view release on metacpan or  search on metacpan

lib/Affix/marshal.c  view on Meta::CPAN

                              .bit_width = bit_width,
                              .readonly = readonly,
                              .absolute = absolute,
                              .destructor = nullptr,
                              .destructor_lib_sv = nullptr};

    MGVTBL * v = nullptr;
    int is_wide = 0;

    if (bit_width > 0)
        v = &vtbl_bitfield;
    else if (cat == INFIX_TYPE_ENUM)
        v = &vtbl_enum;
    else if (cat == INFIX_TYPE_PRIMITIVE) {
        if (res->meta.primitive_id == INFIX_PRIMITIVE_SINT128)
            v = &vtbl_sint128;
        else if (res->meta.primitive_id == INFIX_PRIMITIVE_UINT128)
            v = &vtbl_uint128;
        else
            v = get_primitive_vtable(res);
    }
    else if (cat == INFIX_TYPE_POINTER || cat == INFIX_TYPE_REVERSE_TRAMPOLINE)
        v = &vtbl_pointer;
    else if (cat == INFIX_TYPE_VOID)
        v = &vtbl_void;
    else if (is_string_array(aTHX_ type, &is_wide)) {
        if (is_wide) {
            v = &wstring_vtable;
        }
        else {
            /* Resolve the element type to check signedness */
            const infix_type * el = resolve_type(aTHX_ type->meta.array_info.element_type);
            if (el->meta.primitive_id == INFIX_PRIMITIVE_UINT8)
                v = &vtbl_buffer; /* Array[UInt8] -> Binary */
            else
                v = &string_vtable; /* Array[Char] -> String */
        }
    }
    else
        v = &vtbl_lazy_aggregate;

    sv_magicext(sv, owner, PERL_MAGIC_ext, v, (char *)&m, sizeof(Affix_Pin_2_Point_Oh));
    SvMAGICAL_on(sv);
    SvGMAGICAL_on(sv);
    SvSMAGICAL_on(sv);

    /* FIX 3: Never prime a lazy aggregate placeholder; let it vivify on first use. */
    if (prime && v != &vtbl_lazy_aggregate && v != &vtbl_void)
        v->svt_get(aTHX_ sv, mg_find(sv, PERL_MAGIC_ext));
}

#define LAZY_ARRAY_THRESHOLD 100

/**
 * @brief Internal helper to build the actual Perl Hash/Array structure.
 * @param ptr   The raw C memory address (may be nullptr).
 * @param type  The infix_type definition.
 * @param owner The root SV lifeline.
 * @param arena The local arena for anonymous types (if any).
 * @param eager If false, large arrays return a magical scalar placeholder.
 * @param readonly If true, mutations via the resulting aggregate are blocked.
 */
static SV * _bind_aggregate_internal(
    pTHX_ void * ptr, const infix_type * type, SV * owner, infix_arena_t * arena, bool eager, bool readonly) {
    const infix_type * res = resolve_type(aTHX_ type);
    infix_type_category cat = infix_type_get_category(res);

    if (cat == INFIX_TYPE_STRUCT || cat == INFIX_TYPE_UNION) {
        HV * hv = newHV();
        Affix_Pin_2_Point_Oh m = {.ptr = ptr, .type = type, .arena = arena, .readonly = readonly};
        sv_magicext((SV *)hv, owner, PERL_MAGIC_ext, &vtbl_lazy_aggregate, (char *)&m, sizeof(Affix_Pin_2_Point_Oh));

        size_t count = infix_type_get_member_count(res);
        for (size_t i = 0; i < count; i++) {
            const infix_struct_member * m = infix_type_get_member(res, i);
            SV * v = newSV(0);
            /* Propagate nullptr safely so getters don't read from 0x0 + offset */
            void * child_ptr = ptr ? ((char *)ptr + m->offset) : nullptr;
            // Don't read the memory now. Wait until the user accesses the hash key.
            // NOTE: member pins borrow the *external* lifeline (`owner`), never the
            // freshly created parent HV. Referencing the parent here creates a strong
            // reference cycle (HV owns the members, each member's mg_obj owns the HV)
            // that Perl's refcounting cannot collect, leaking the whole pin tree and
            // its arena on every bind/cast.
            bind_placeholder(
                aTHX_ v, child_ptr, m->type, m->bit_offset, m->bit_width, false, owner, NULL, readonly, false);
            hv_store(hv, m->name ? m->name : "", strlen(m->name ? m->name : ""), v, 0);
        }
        return newRV_noinc((SV *)hv);
    }
    else if (cat == INFIX_TYPE_ARRAY || cat == INFIX_TYPE_VECTOR || cat == INFIX_TYPE_COMPLEX) {
        if (is_string_array(aTHX_ type, nullptr)) {
            SV * sv = newSV(0);
            bind_placeholder(aTHX_ sv, ptr, type, 0, 0, true, owner, arena, readonly, false);
            /* WRAP IN REFERENCE to ensure magic persists across assignments */
            return newRV_noinc(sv);
        }

        size_t n, step;
        const infix_type * el_type;
        if (cat == INFIX_TYPE_COMPLEX) {
            n = 2;
            el_type = res->meta.complex_info.base_type;
            step = el_type->size;
        }
        else if (cat == INFIX_TYPE_ARRAY) {
            n = res->meta.array_info.num_elements;
            el_type = res->meta.array_info.element_type;
            step = resolve_type(aTHX_ el_type)->size;
        }
        else {
            n = res->meta.vector_info.num_elements;
            el_type = res->meta.vector_info.element_type;
            step = el_type->size;
        }

        if (!eager && n > LAZY_ARRAY_THRESHOLD) {
            SV * lazy_placeholder = newSV(0);
            bind_placeholder(aTHX_ lazy_placeholder, ptr, type, 0, 0, false, owner, arena, readonly, false);
            return lazy_placeholder;
        }