Affix
view release on metacpan or search on metacpan
lib/Affix.c view on Meta::CPAN
sv_setsv(sv, &PL_sv_undef);
return;
}
// Calculate length (like wcslen)
size_t wlen = 0;
while (wstr[wlen])
wlen++;
// Pre-allocate SV buffer.
// Worst case UTF-8 expansion: 1 wchar (4 bytes) -> 4 UTF-8 bytes.
// +1 for null terminator.
SvPVCLEAR(sv);
char * d = SvGROW(sv, (wlen * sizeof(wchar_t)) + 1);
wchar_t * s = wstr;
while (*s) {
UV uv = (UV)*s++;
// Handle Windows Surrogate Pairs (UTF-16LE)
if (sizeof(wchar_t) == 2 && uv >= 0xD800 && uv <= 0xDBFF) {
if (*s >= 0xDC00 && *s <= 0xDFFF) {
UV low = (UV)*s++;
uv = ((uv - 0xD800) << 10) + (low - 0xDC00) + 0x10000;
}
}
d = (char *)uvchr_to_utf8((U8 *)d, uv);
}
*d = 0;
// Set Perl SV properties
SvCUR_set(sv, d - SvPVX(sv));
SvPOK_on(sv);
SvUTF8_on(sv);
}
// Direct marshalling experiment
void Affix_trigger_backend(pTHX_ CV * cv) {
// Backend optimization is not yet thread-clone friendly in this patch.
// For now, assume it works or isn't used in the threading test.
dSP;
dAXMARK;
dXSTARG;
Affix_Backend * backend = (Affix_Backend *)CvXSUBANY(cv).any_ptr;
if (UNLIKELY((SP - MARK) != backend->num_args))
croak("Wrong number of arguments to affixed function. Expected %" UVuf ", got %" UVuf,
(UV)backend->num_args,
(UV)(SP - MARK));
size_t ret_size = infix_type_get_size(backend->ret_type);
void * ret_buffer;
if (ret_size <= 2048)
ret_buffer = alloca(ret_size);
else {
Newxz(ret_buffer, ret_size, char);
SAVEFREEPV(ret_buffer);
}
SV ** perl_stack_frame = &ST(0);
backend->cif(ret_buffer, (void **)perl_stack_frame);
switch (backend->ret_opcode) {
case OP_RET_VOID:
sv_setsv(TARG, &PL_sv_undef);
break;
case OP_RET_BOOL:
sv_setbool(TARG, *(bool *)ret_buffer);
break;
case OP_RET_SINT8:
sv_setiv(TARG, *(int8_t *)ret_buffer);
break;
case OP_RET_UINT8:
sv_setuv(TARG, *(uint8_t *)ret_buffer);
break;
case OP_RET_SINT16:
sv_setiv(TARG, *(int16_t *)ret_buffer);
break;
case OP_RET_UINT16:
sv_setuv(TARG, *(uint16_t *)ret_buffer);
break;
case OP_RET_SINT32:
sv_setiv(TARG, *(int32_t *)ret_buffer);
break;
case OP_RET_UINT32:
sv_setuv(TARG, *(uint32_t *)ret_buffer);
break;
case OP_RET_SINT64:
sv_setiv(TARG, *(int64_t *)ret_buffer);
break;
case OP_RET_UINT64:
sv_setuv(TARG, *(uint64_t *)ret_buffer);
break;
case OP_RET_FLOAT:
sv_setnv(TARG, (double)*(float *)ret_buffer);
break;
case OP_RET_DOUBLE:
sv_setnv(TARG, *(double *)ret_buffer);
break;
case OP_RET_PTR_CHAR:
{
char * p = *(char **)ret_buffer;
if (p)
sv_setpv(TARG, p);
else
sv_setsv(TARG, &PL_sv_undef);
break;
}
case OP_RET_PTR_WCHAR:
pull_pointer_as_pin(aTHX_ nullptr, TARG, backend->ret_type, ret_buffer, backend->ret_readonly);
break;
case OP_RET_SV:
{
SV * s = *(SV **)ret_buffer;
if (s)
sv_setsv(TARG, s);
else
sv_setsv(TARG, &PL_sv_undef);
break;
}
case OP_RET_CUSTOM:
lib/Affix.c view on Meta::CPAN
const char * start = str;
while ((p = strstr(p, "SV"))) {
// Check boundaries: Ensure we match whole word "SV"
// Start boundary: Beginning of string OR prev char is not alnum/_/@
bool start_ok = (p == start) || (!isALNUM((unsigned char)*(p - 1)) && *(p - 1) != '_' && *(p - 1) != '@');
// End boundary: End of string OR next char is not alnum/_
bool end_ok = (p[2] == '\0') || (!isALNUM((unsigned char)p[2]) && p[2] != '_');
if (start_ok && end_ok) {
// Append everything before this match
sv_catpvn(modified, start, p - start);
// Append the named type reference
sv_catpvs(modified, "@SV");
// Advance past "SV"
p += 2;
start = p;
}
else // Not a standalone "SV", skip this occurrence
p++;
}
// Append remainder
sv_catpv(modified, start);
// only return modified string if we actually changed something
if (SvCUR(modified) > strlen(str))
return SvPV_nolen(modified);
}
return str;
}
int64_t affix_perl_shim_sv_to_sint64(pTHX_ void * sv_raw) { return SvIVX((SV *)sv_raw); }
double affix_perl_shim_sv_to_double(pTHX_ void * sv_raw) { return SvNVX((SV *)sv_raw); }
const char * affix_perl_shim_sv_to_string(pTHX_ void * sv_raw) { return SvPV_nolen((SV *)sv_raw); }
void * affix_perl_shim_sv_to_pointer(pTHX_ void * sv_raw) {
SV * sv = (SV *)sv_raw;
if (!SvOK(sv) || !SvROK(sv))
return nullptr;
return INT2PTR(void *, SvIV(SvRV(sv)));
}
void * affix_perl_shim_newSViv(pTHX_ int64_t value) { return newSViv(value); }
void * affix_perl_shim_newSVnv(pTHX_ double value) { return newSVnv(value); }
void * affix_perl_shim_newSVpv(pTHX_ const char * value) { return newSVpv(value, 0); }
void _pin_sv(pTHX_ SV * sv,
const infix_type * type,
void * pointer,
bool managed,
SV * owner_sv,
size_t bit_offset,
size_t bit_width);
static void push_union(pTHX_ Affix * affix, const infix_type * type, SV * sv, void * p);
#define DEFINE_PUSH_PRIMITIVE_EXECUTOR(name, c_type, sv_accessor) \
static void plan_step_push_##name(pTHX_ Affix * affix, \
Affix_Plan_Step * step, \
SV ** perl_stack_frame, \
void * args_buffer, \
void ** c_args, \
void * ret_buffer) { \
PERL_UNUSED_VAR(affix); \
PERL_UNUSED_VAR(ret_buffer); \
SV * sv = perl_stack_frame[step->data.index]; \
void * c_arg_ptr = (char *)args_buffer + step->data.c_arg_offset; \
*(c_type *)c_arg_ptr = (c_type)sv_accessor(sv); \
c_args[step->data.index] = c_arg_ptr; \
}
#define DEFINE_IV_PUSH_HANDLER(name, c_type) \
static void push_handler_##name(pTHX_ Affix * affix, SV * sv, void * c_ptr) { \
PERL_UNUSED_VAR(affix); \
c_type val; \
U32 flags = SvFLAGS(sv); \
if (flags & SVf_IOK) { \
if (flags & SVf_IVisUV) \
val = (c_type)SvUVX(sv); \
else \
val = (c_type)SvIVX(sv); \
} \
else { \
dTHX; \
val = (c_type)SvIV(sv); \
} \
memcpy(c_ptr, &val, sizeof val); \
return; \
}
#define DEFINE_UV_PUSH_HANDLER(name, c_type) \
static void push_handler_##name(pTHX_ Affix * affix, SV * sv, void * c_ptr) { \
PERL_UNUSED_VAR(affix); \
c_type val; \
U32 flags = SvFLAGS(sv); \
if (flags & SVf_IOK) { \
if (flags & SVf_IVisUV) \
val = (c_type)SvUVX(sv); \
else \
val = (c_type)SvIVX(sv); \
} \
else { \
dTHX; \
val = (c_type)SvUV(sv); \
} \
memcpy(c_ptr, &val, sizeof val); \
return; \
}
#define DEFINE_NV_PUSH_HANDLER(name, c_type) \
static void push_handler_##name(pTHX_ Affix * affix, SV * sv, void * c_ptr) { \
PERL_UNUSED_VAR(affix); \
c_type val; \
U32 flags = SvFLAGS(sv); \
if (LIKELY(flags & SVf_NOK)) \
val = SvNVX(sv); \
else if (flags & SVf_IOK) { \
if (flags & SVf_IVisUV) \
val = (c_type)SvUVX(sv); \
else \
val = (c_type)SvIVX(sv); \
} \
else { \
dTHX; \
val = SvNV(sv); \
} \
lib/Affix.c view on Meta::CPAN
if (pointee->category == INFIX_TYPE_PRIMITIVE) {
if (pointee->meta.primitive_id == INFIX_PRIMITIVE_SINT8 ||
pointee->meta.primitive_id == INFIX_PRIMITIVE_UINT8) {
return OP_RET_PTR_CHAR;
}
#if defined(INFIX_OS_WINDOWS)
if (infix_type_get_size(pointee) == sizeof(wchar_t))
return OP_RET_PTR_WCHAR;
#endif
}
return OP_RET_PTR;
}
if (type->category == INFIX_TYPE_STRUCT) {
if (is_perl_sv_type(type))
croak("Type 'SV' cannot be returned by value. Use 'Pointer[SV]' instead.");
}
return OP_RET_CUSTOM;
}
DEFINE_IV_PUSH_HANDLER(sint8, int8_t)
DEFINE_UV_PUSH_HANDLER(uint8, uint8_t)
DEFINE_IV_PUSH_HANDLER(sint16, int16_t)
DEFINE_UV_PUSH_HANDLER(uint16, uint16_t)
DEFINE_IV_PUSH_HANDLER(sint32, int32_t)
DEFINE_UV_PUSH_HANDLER(uint32, uint32_t)
DEFINE_IV_PUSH_HANDLER(sint64, int64_t)
DEFINE_UV_PUSH_HANDLER(uint64, uint64_t)
#ifdef __SIZEOF_INT128__
DEFINE_I128_PUSH_HANDLER(sint128)
DEFINE_U128_PUSH_HANDLER(uint128)
#endif
static void push_handler_float16(pTHX_ Affix * affix, SV * sv, void * c_ptr) {
PERL_UNUSED_VAR(affix);
infix_float16_t val = float_to_half((float)SvNV(sv));
memcpy(c_ptr, &val, sizeof val);
}
DEFINE_NV_PUSH_HANDLER(float, float);
DEFINE_NV_PUSH_HANDLER(double, double);
DEFINE_NV_PUSH_HANDLER(long_double, long double);
static void push_handler_bool(pTHX_ Affix * affix, SV * perl_sv, void * c_ptr) {
PERL_UNUSED_VAR(affix);
bool val = SvTRUE(perl_sv);
memcpy(c_ptr, &val, sizeof val);
}
DEFINE_PUSH_PRIMITIVE_EXECUTOR(bool, bool, SvTRUE)
DEFINE_PUSH_PRIMITIVE_EXECUTOR(sint8, int8_t, SvIV)
DEFINE_PUSH_PRIMITIVE_EXECUTOR(uint8, uint8_t, SvUV)
DEFINE_PUSH_PRIMITIVE_EXECUTOR(sint16, int16_t, SvIV)
DEFINE_PUSH_PRIMITIVE_EXECUTOR(uint16, uint16_t, SvUV)
DEFINE_PUSH_PRIMITIVE_EXECUTOR(sint32, int32_t, SvIV)
DEFINE_PUSH_PRIMITIVE_EXECUTOR(uint32, uint32_t, SvUV)
DEFINE_PUSH_PRIMITIVE_EXECUTOR(sint64, int64_t, SvIV)
DEFINE_PUSH_PRIMITIVE_EXECUTOR(uint64, uint64_t, SvUV)
static void plan_step_push_float16(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
SV * sv = perl_stack_frame[step->data.index];
infix_float16_t h = float_to_half((float)SvNV(sv));
void * p = (char *)args_buffer + step->data.c_arg_offset;
*(infix_float16_t *)p = h;
c_args[step->data.index] = p;
}
DEFINE_PUSH_PRIMITIVE_EXECUTOR(float, float, SvNV)
DEFINE_PUSH_PRIMITIVE_EXECUTOR(double, double, SvNV)
DEFINE_PUSH_PRIMITIVE_EXECUTOR(long_double, long double, SvNV)
#if !defined(INFIX_COMPILER_MSVC)
static void plan_step_push_sint128(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
SV * sv = perl_stack_frame[step->data.index];
void * ptr = (char *)args_buffer + step->data.c_arg_offset;
sv_to_int128_safe(sv, ptr);
c_args[step->data.index] = ptr;
}
static void plan_step_push_uint128(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
SV * sv = perl_stack_frame[step->data.index];
void * ptr = (char *)args_buffer + step->data.c_arg_offset;
sv_to_uint128_safe(sv, ptr);
c_args[step->data.index] = ptr;
}
#endif
static const Affix_Step_Executor primitive_executors[] = {
[INFIX_PRIMITIVE_BOOL] = plan_step_push_bool,
[INFIX_PRIMITIVE_SINT8] = plan_step_push_sint8,
[INFIX_PRIMITIVE_UINT8] = plan_step_push_uint8,
[INFIX_PRIMITIVE_SINT16] = plan_step_push_sint16,
[INFIX_PRIMITIVE_UINT16] = plan_step_push_uint16,
[INFIX_PRIMITIVE_SINT32] = plan_step_push_sint32,
[INFIX_PRIMITIVE_UINT32] = plan_step_push_uint32,
[INFIX_PRIMITIVE_SINT64] = plan_step_push_sint64,
[INFIX_PRIMITIVE_UINT64] = plan_step_push_uint64,
[INFIX_PRIMITIVE_FLOAT16] = plan_step_push_float16,
[INFIX_PRIMITIVE_FLOAT] = plan_step_push_float,
[INFIX_PRIMITIVE_DOUBLE] = plan_step_push_double,
[INFIX_PRIMITIVE_LONG_DOUBLE] = plan_step_push_long_double,
#if !defined(INFIX_COMPILER_MSVC)
[INFIX_PRIMITIVE_SINT128] = plan_step_push_sint128,
[INFIX_PRIMITIVE_UINT128] = plan_step_push_uint128,
#endif
};
static const Affix_Push_Handler primitive_push_handlers[] = {
[INFIX_PRIMITIVE_BOOL] = push_handler_bool,
[INFIX_PRIMITIVE_SINT8] = push_handler_sint8,
[INFIX_PRIMITIVE_UINT8] = push_handler_uint8,
[INFIX_PRIMITIVE_SINT16] = push_handler_sint16,
[INFIX_PRIMITIVE_UINT16] = push_handler_uint16,
[INFIX_PRIMITIVE_SINT32] = push_handler_sint32,
[INFIX_PRIMITIVE_UINT32] = push_handler_uint32,
[INFIX_PRIMITIVE_SINT64] = push_handler_sint64,
[INFIX_PRIMITIVE_UINT64] = push_handler_uint64,
[INFIX_PRIMITIVE_FLOAT16] = push_handler_float16,
[INFIX_PRIMITIVE_FLOAT] = push_handler_float,
[INFIX_PRIMITIVE_DOUBLE] = push_handler_double,
[INFIX_PRIMITIVE_LONG_DOUBLE] = push_handler_long_double,
#ifdef __SIZEOF_INT128__
[INFIX_PRIMITIVE_SINT128] = push_handler_sint128,
[INFIX_PRIMITIVE_UINT128] = push_handler_uint128,
#endif
};
static void plan_step_push_pointer(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(ret_buffer);
const infix_type * type = step->data.type;
SV * sv = perl_stack_frame[step->data.index];
void * c_arg_ptr = (char *)args_buffer + step->data.c_arg_offset;
c_args[step->data.index] = c_arg_ptr;
void * addr = get_address_v2(aTHX_ sv);
if (addr) {
*(void **)c_arg_ptr = addr;
return;
}
const infix_type * pointee_type = type->meta.pointer_info.pointee_type;
if (pointee_type == nullptr)
croak("Internal error in push_pointer: pointee_type is nullptr");
if (!SvOK(sv)) {
if (!SvREADONLY(sv)) {
size_t size = infix_type_get_size(pointee_type);
size_t align = infix_type_get_alignment(pointee_type);
if (size == 0) {
size = sizeof(void *);
align = _Alignof(void *);
}
void * temp_slot = infix_arena_alloc(affix->call_args_arena, size, align > 0 ? align : 1);
memset(temp_slot, 0, size);
*(void **)c_arg_ptr = temp_slot;
return;
}
*(void **)c_arg_ptr = nullptr;
return;
}
if (SvIOK(sv)) { // Treat integer value as a raw memory address
*(void **)c_arg_ptr = INT2PTR(void *, SvUV(sv));
return;
}
const char * type_name = infix_type_get_name(type);
if (!type_name && type->category == INFIX_TYPE_NAMED_REFERENCE)
type_name = type->meta.named_reference.name;
if ((type_name &&
(strEQ(type_name, "Buffer") || strEQ(type_name, "@Buffer") || strEQ(type_name, "SockAddr") ||
strEQ(type_name, "@SockAddr") || strEQ(type_name, "StringList") || strEQ(type_name, "@StringList"))) ||
(is_string_list_type(aTHX_ type) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)) {
sv2ptr(aTHX_ affix, sv, c_arg_ptr, type);
return;
}
const char * pointee_name = infix_type_get_name(pointee_type);
if (!pointee_name && pointee_type->category == INFIX_TYPE_NAMED_REFERENCE)
pointee_name = pointee_type->meta.named_reference.name;
if (pointee_name &&
(strEQ(pointee_name, "File") || strEQ(pointee_name, "@File") || strEQ(pointee_name, "PerlIO") ||
strEQ(pointee_name, "@PerlIO"))) {
sv2ptr(aTHX_ affix, sv, c_arg_ptr, type);
return;
}
if (pointee_type->category == INFIX_TYPE_REVERSE_TRAMPOLINE &&
lib/Affix.c view on Meta::CPAN
}
}
}
if (SvTYPE(rv) == SVt_PVAV) {
AV * av = (AV *)rv;
size_t len = av_len(av) + 1;
size_t element_size = infix_type_get_size(pointee_type);
if (element_size > 0 && len > SIZE_MAX / element_size)
croak("Array size overflow: %zu elements * %zu bytes", len, element_size);
size_t total_size = len * element_size;
char * c_array = (char *)infix_arena_alloc(affix->call_args_arena, total_size, _Alignof(void *));
if (!c_array)
croak("Failed to allocate from arena for array marshalling");
memset(c_array, 0, total_size);
for (size_t i = 0; i < len; ++i) {
SV ** elem_sv_ptr = av_fetch(av, i, 0);
if (elem_sv_ptr)
sv2ptr(aTHX_ affix, *elem_sv_ptr, c_array + (i * element_size), pointee_type);
}
*(void **)c_arg_ptr = c_array;
return;
}
const infix_type * copy_type = (pointee_type->category == INFIX_TYPE_VOID)
? (SvIOK(rv) ? infix_type_create_primitive(INFIX_PRIMITIVE_SINT64)
: SvNOK(rv) ? infix_type_create_primitive(INFIX_PRIMITIVE_DOUBLE)
: SvPOK(rv) ? (*(void **)c_arg_ptr = SvPV_nolen(rv), (infix_type *)nullptr)
: (croak("Cannot pass reference to this type of scalar for a 'void*' parameter"),
(infix_type *)nullptr))
: pointee_type;
if (!copy_type)
return;
void * dest_c_ptr = infix_arena_alloc(
affix->call_args_arena, infix_type_get_size(copy_type), infix_type_get_alignment(copy_type));
SV * sv_to_marshal = (SvTYPE(rv) == SVt_PVHV) ? sv : rv;
sv2ptr(aTHX_ affix, sv_to_marshal, dest_c_ptr, copy_type);
*(void **)c_arg_ptr = dest_c_ptr;
return;
}
if (SvPOK(sv)) {
bool is_char_ptr = (pointee_type->category == INFIX_TYPE_PRIMITIVE &&
(pointee_type->meta.primitive_id == INFIX_PRIMITIVE_SINT8 ||
pointee_type->meta.primitive_id == INFIX_PRIMITIVE_UINT8));
bool is_void_ptr = (pointee_type->category == INFIX_TYPE_VOID);
if (is_char_ptr || is_void_ptr) {
*(const char **)c_arg_ptr = SvPV_nolen(sv);
return;
}
}
sv_dump(sv);
char signature_buf[256];
if (infix_type_print(signature_buf, sizeof(signature_buf), (infix_type *)type, INFIX_DIALECT_SIGNATURE) !=
INFIX_SUCCESS) {
strncpy(signature_buf, "[error printing type]", sizeof(signature_buf) - 1);
signature_buf[sizeof(signature_buf) - 1] = '\0';
}
croak("Don't know how to handle this type of scalar as a pointer argument yet: %s", signature_buf);
}
static void plan_step_push_struct(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(ret_buffer);
const infix_type * type = step->data.type;
SV * sv = perl_stack_frame[step->data.index];
void * c_arg_ptr = (char *)args_buffer + step->data.c_arg_offset;
c_args[step->data.index] = c_arg_ptr;
push_struct(aTHX_ affix, type, sv, c_arg_ptr);
}
static void plan_step_push_union(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(ret_buffer);
const infix_type * type = step->data.type;
SV * sv = perl_stack_frame[step->data.index];
void * c_arg_ptr = (char *)args_buffer + step->data.c_arg_offset;
c_args[step->data.index] = c_arg_ptr;
push_union(aTHX_ affix, type, sv, c_arg_ptr);
}
static void plan_step_push_array(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(ret_buffer);
const infix_type * type = step->data.type;
SV * sv = perl_stack_frame[step->data.index];
// args_buffer slot is sizeof(void*) because we substituted Pointer for Array in the JIT
void * c_arg_ptr = (char *)args_buffer + step->data.c_arg_offset;
c_args[step->data.index] = c_arg_ptr;
// Handle nullptr/Undef
if (!SvOK(sv)) {
*(void **)c_arg_ptr = nullptr;
return;
}
const infix_type * element_type = type->meta.array_info.element_type;
size_t element_size = infix_type_get_size(element_type);
if (SvPOK(sv) && element_type->category == INFIX_TYPE_PRIMITIVE && element_size == 1) {
STRLEN len;
const char * s = SvPV(sv, len);
size_t fixed_len = type->meta.array_info.num_elements;
size_t alloc_len = (fixed_len > 0) ? fixed_len : len + 1; // +1 for null if dynamic
void * temp_array = infix_arena_alloc(affix->call_args_arena, alloc_len, 1);
if (!temp_array)
croak("Failed to allocate memory for array argument");
memset(temp_array, 0, alloc_len);
// Copy what fits
size_t copy_len = (len < alloc_len) ? len : alloc_len;
memcpy(temp_array, s, copy_len);
if (element_type->meta.primitive_id == INFIX_PRIMITIVE_SINT8 && len >= alloc_len && alloc_len > 0)
((char *)temp_array)[alloc_len - 1] = '\0';
*(void **)c_arg_ptr = temp_array;
return;
}
if (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV)
croak("Expected an ARRAY reference or String for array marshalling");
AV * av = (AV *)SvRV(sv);
size_t input_len = av_len(av) + 1;
size_t fixed_len = type->meta.array_info.num_elements;
size_t alloc_len = (fixed_len > 0 && fixed_len > input_len) ? fixed_len : input_len;
if (element_size > 0 && alloc_len > SIZE_MAX / element_size)
croak("Array size overflow: %zu elements * %zu bytes", alloc_len, element_size);
size_t total_size = alloc_len * element_size;
// Allocate transient memory in the args_arena
void * temp_array = infix_arena_alloc(
affix->call_args_arena, total_size > 0 ? total_size : 1, infix_type_get_alignment(element_type));
if (!temp_array)
croak("Failed to allocate memory for array argument");
memset(temp_array, 0, total_size); // Zero-fill (important for padding fixed arrays)
for (size_t i = 0; i < input_len; ++i) { // Copy data
SV ** elem_sv_ptr = av_fetch(av, i, 0);
if (elem_sv_ptr) {
void * elem_ptr = (char *)temp_array + (i * element_size);
sv2ptr(aTHX_ affix, *elem_sv_ptr, elem_ptr, element_type);
}
}
// Write the POINTER to the argument slot
*(void **)c_arg_ptr = temp_array;
}
static void plan_step_push_enum(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(ret_buffer);
const infix_type * type = step->data.type;
SV * sv = perl_stack_frame[step->data.index];
void * c_arg_ptr = (char *)args_buffer + step->data.c_arg_offset;
c_args[step->data.index] = c_arg_ptr;
sv2ptr(aTHX_ affix, sv, c_arg_ptr, type);
}
static void plan_step_push_complex(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(ret_buffer);
const infix_type * type = step->data.type;
SV * sv = perl_stack_frame[step->data.index];
void * c_arg_ptr = (char *)args_buffer + step->data.c_arg_offset;
c_args[step->data.index] = c_arg_ptr;
if (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV)
croak("Expected an ARRAY reference with two numbers for complex type marshalling");
AV * av = (AV *)SvRV(sv);
if (av_len(av) != 1)
croak("Expected exactly two elements (real, imaginary) for complex type");
const infix_type * base_type = type->meta.complex_info.base_type;
size_t base_size = infix_type_get_size(base_type);
SV ** real_sv_ptr = av_fetch(av, 0, 0);
SV ** imag_sv_ptr = av_fetch(av, 1, 0);
if (!real_sv_ptr || !imag_sv_ptr)
croak("Failed to fetch real or imaginary part from array for complex type");
sv2ptr(aTHX_ affix, *real_sv_ptr, c_arg_ptr, base_type);
sv2ptr(aTHX_ affix, *imag_sv_ptr, (char *)c_arg_ptr + base_size, base_type);
}
static void plan_step_push_vector(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(ret_buffer);
const infix_type * type = step->data.type;
SV * sv = perl_stack_frame[step->data.index];
void * c_arg_ptr = (char *)args_buffer + step->data.c_arg_offset;
c_args[step->data.index] = c_arg_ptr;
// If it's a string, assume it's a packed buffer (e.g. pack 'f4')
// and copy it directly. This is much faster than iterating an AV.
if (SvPOK(sv)) {
STRLEN len;
const char * buf = SvPV(sv, len);
size_t expected_size = infix_type_get_size(type);
if (len >= expected_size) {
memcpy(c_arg_ptr, buf, expected_size);
return;
}
// If string is too short, fall through to AV check or error
}
if (!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV)
croak("Expected an ARRAY reference or Packed String for vector marshalling");
AV * av = (AV *)SvRV(sv);
size_t num_elements = av_len(av) + 1;
size_t c_vector_len = type->meta.vector_info.num_elements;
if (num_elements != c_vector_len)
croak("Perl array has %lu elements, but C vector type requires %lu.",
(unsigned long)num_elements,
(unsigned long)c_vector_len);
const infix_type * element_type = type->meta.vector_info.element_type;
size_t element_size = infix_type_get_size(element_type);
for (size_t i = 0; i < num_elements; ++i) {
SV ** element_sv_ptr = av_fetch(av, i, 0);
if (element_sv_ptr) {
void * element_ptr = (char *)c_arg_ptr + (i * element_size);
sv2ptr(aTHX_ affix, *element_sv_ptr, element_ptr, element_type);
}
}
}
static void plan_step_push_sv(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(affix);
PERL_UNUSED_VAR(ret_buffer);
SV * sv = perl_stack_frame[step->data.index];
void * c_arg_ptr = (char *)args_buffer + step->data.c_arg_offset;
c_args[step->data.index] = c_arg_ptr;
*(void **)c_arg_ptr = sv;
}
static void plan_step_push_callback(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(ret_buffer);
const infix_type * type = step->data.type;
SV * sv = perl_stack_frame[step->data.index];
void * c_arg_ptr = (char *)args_buffer + step->data.c_arg_offset;
c_args[step->data.index] = c_arg_ptr;
push_reverse_trampoline(aTHX_ affix, type, sv, c_arg_ptr);
}
static void plan_step_call_c_function(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(step);
PERL_UNUSED_VAR(perl_stack_frame);
PERL_UNUSED_VAR(args_buffer);
affix->cif(ret_buffer, c_args);
}
static void plan_step_pull_return_value(pTHX_ Affix * affix,
Affix_Plan_Step * step,
SV ** perl_stack_frame,
void * args_buffer,
void ** c_args,
void * ret_buffer) {
PERL_UNUSED_VAR(perl_stack_frame);
PERL_UNUSED_VAR(args_buffer);
PERL_UNUSED_VAR(c_args);
step->data.pull_handler(aTHX_ affix, affix->return_sv, step->data.type, ret_buffer, affix->ret_readonly);
}
Affix_Step_Executor get_plan_step_executor(const infix_type * type) {
switch (type->category) {
case INFIX_TYPE_PRIMITIVE:
return primitive_executors[type->meta.primitive_id];
case INFIX_TYPE_POINTER:
{
if (is_perl_sv_type(type))
return plan_step_push_sv;
return plan_step_push_pointer;
}
case INFIX_TYPE_STRUCT:
{
if (is_perl_sv_type(type))
return plan_step_push_sv;
return plan_step_push_struct;
}
case INFIX_TYPE_UNION:
return plan_step_push_union;
case INFIX_TYPE_ARRAY:
return plan_step_push_array;
case INFIX_TYPE_REVERSE_TRAMPOLINE:
return plan_step_push_callback;
case INFIX_TYPE_ENUM:
return plan_step_push_enum;
case INFIX_TYPE_COMPLEX:
return plan_step_push_complex;
case INFIX_TYPE_VECTOR:
return plan_step_push_vector;
default:
return nullptr;
}
}
static void writeback_primitive(pTHX_ Affix * affix, const OutParamInfo * info, SV * perl_sv, void * c_arg_ptr) {
void * actual_data_ptr = *(void **)c_arg_ptr;
if (!actual_data_ptr)
return;
if (SvTYPE(perl_sv) == SVt_PVAV) {
AV * av = (AV *)perl_sv;
size_t count = av_len(av) + 1;
size_t elem_size = infix_type_get_size(info->pointee_type);
for (size_t i = 0; i < count; ++i) {
void * elem_ptr = (char *)actual_data_ptr + (i * elem_size);
SV ** sv_ptr = av_fetch(av, i, 0);
if (sv_ptr && *sv_ptr)
ptr2sv(aTHX_ affix, elem_ptr, *sv_ptr, info->pointee_type, false);
else {
SV * val = newSV(0);
ptr2sv(aTHX_ affix, elem_ptr, val, info->pointee_type, false);
if (!av_store(av, i, val))
SvREFCNT_dec(val);
}
}
return;
lib/Affix.c view on Meta::CPAN
av_extend(av, num_elements);
Affix_Pull h = get_pull_handler(aTHX_ element_type);
if (!h)
croak("Cannot convert C vector element type to Perl SV");
for (size_t i = 0; i < num_elements; ++i) {
void * element_ptr = (char *)p + (i * element_size);
SV ** existing_sv_ptr = av_fetch(av, i, 0);
SV * element_sv = existing_sv_ptr ? *existing_sv_ptr : newSV(0);
h(aTHX_ affix, element_sv, element_type, element_ptr, readonly);
if (!existing_sv_ptr) {
if (!av_store(av, i, element_sv))
SvREFCNT_dec(element_sv);
}
}
}
static void pull_pointer_as_string(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
void * c_ptr = *(void **)p;
if (c_ptr == nullptr)
sv_setsv(sv, &PL_sv_undef);
else
sv_setpv(sv, (const char *)c_ptr);
}
static void pull_pointer_as_struct(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
void * c_ptr = *(void **)p;
if (c_ptr == nullptr)
sv_setsv(sv, &PL_sv_undef);
else {
const infix_type * pointee_type = type->meta.pointer_info.pointee_type;
pull_struct(aTHX_ affix, sv, pointee_type, c_ptr, readonly);
}
}
#if 0
static void pull_struct_as_live(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
void * c_ptr = *(void **)p;
if (c_ptr == nullptr) {
sv_setsv(sv, &PL_sv_undef);
return;
}
const infix_type * pointee_type = type->meta.pointer_info.pointee_type;
HV * hv = newHV();
SV * rv = newRV_noinc(MUTABLE_SV(hv));
//~ sv_bless(rv, gv_stashpv("Affix::Live", GV_ADD));
_populate_hv_from_c_struct(aTHX_ affix, hv, pointee_type, c_ptr, true, nullptr, readonly);
sv_setsv(sv, rv);
SvREFCNT_dec(rv);
}
#endif
static void pull_pointer_as_array(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
void * c_ptr = *(void **)p;
if (c_ptr == nullptr)
sv_setsv(sv, &PL_sv_undef);
else {
const infix_type * pointee_type = type->meta.pointer_info.pointee_type;
pull_array(aTHX_ affix, sv, pointee_type, c_ptr, readonly);
}
}
void pull_pointer_as_pin(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
/* p is the address of the pointer variable in the C stack frame */
void * c_ptr = *(void **)p;
if (c_ptr == nullptr) {
sv_setsv(sv, &PL_sv_undef);
return;
}
const infix_type * pointee = _unwrap_pin_type(type);
const infix_type * res_pointee = resolve_type(aTHX_ pointee);
infix_type_category cat = infix_type_get_category(res_pointee);
if (cat == INFIX_TYPE_STRUCT || cat == INFIX_TYPE_UNION || cat == INFIX_TYPE_ARRAY || cat == INFIX_TYPE_VECTOR) {
/* Return HashRef or ArrayRef for complex types */
SV * rv = bind_aggregate(aTHX_ c_ptr, pointee, NULL, readonly);
sv_setsv(sv, rv);
SvREFCNT_dec(rv);
}
else {
/* FOR PRIMITIVES: Return a SCALAR REFERENCE to a magical scalar.
This allows the user to use $$p_a to read the value. */
SV * magic_scalar = newSV(0);
bind_placeholder(aTHX_ magic_scalar, c_ptr, pointee, 0, 0, true, NULL, NULL, readonly, true);
SV * rv = newRV_noinc(magic_scalar);
sv_setsv(sv, rv);
SvREFCNT_dec(rv);
}
}
static void pull_sv(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
void * c_ptr = *(void **)p;
if (c_ptr == nullptr)
sv_setsv(sv, &PL_sv_undef);
else
sv_setsv(sv, (SV *)c_ptr);
}
static void pull_file(pTHX_ Affix * affix, SV * sv, const infix_type * type, void * p, bool readonly) {
PERL_UNUSED_VAR(affix);
PERL_UNUSED_VAR(type);
FILE * fp = *(FILE **)p;
if (!fp) {
sv_setsv(sv, &PL_sv_undef);
return;
}
// Duplicate FD to avoid double-close issues
int fd =
#ifdef _WIN32
_fileno
#else
fileno
#endif
(fp);
if (fd < 0) {
sv_setsv(sv, &PL_sv_undef);
return;
}
int new_fd = PerlLIO_dup(fd);
if (new_fd < 0) {
( run in 1.085 second using v1.01-cache-2.11-cpan-2e0ccfb7a10 )