view release on metacpan or  search on metacpan

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

    }
    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;
        }

        AV * av = newAV();
        Affix_Pin_2_Point_Oh am = {.ptr = ptr, .type = type, .arena = arena, .readonly = readonly};
        sv_magicext((SV *)av, owner, PERL_MAGIC_ext, &vtbl_array, (char *)&am, sizeof(Affix_Pin_2_Point_Oh));

        for (size_t i = 0; i < n; i++) {
            SV * el = newSV(0);
            void * child_ptr = ptr ? ((char *)ptr + (i * step)) : nullptr;
            // Borrow the external lifeline (see struct branch above): referencing the
            // parent AV here creates an uncollectable refcount cycle.
            bind_placeholder(aTHX_ el, child_ptr, el_type, 0, 0, false, owner, nullptr, readonly, false);
            av_push(av, el);
        }
        return newRV_noinc((SV *)av);
    }
    return newSV(0);
}

/**
 * @brief Recursively constructs a Perl tree (Hash/Array) mapping to a C aggregate.
 * @param ptr Pointer to the raw C memory.
 * @param type The aggregate (struct/union/array) type.
 * @param owner The "root" SV that owns the C memory (lifeline).
 * @return A new reference to the constructed Perl aggregate.
 */
SV * bind_aggregate(pTHX_ void * ptr, const infix_type * type, SV * owner, bool readonly) {
    return _bind_aggregate_internal(aTHX_ ptr, type, owner, nullptr, false, readonly);
}

/**
 * @brief Public Strategy: Used by cast() to handle anonymous type lifecycle.
 */
SV * bind_aggregate_anon(pTHX_ void * ptr, const infix_type * type, SV * owner, infix_arena_t * arena, bool readonly) {
    return _bind_aggregate_internal(aTHX_ ptr, type, owner, arena, false, readonly);
}

/**
 * @brief Registers multiple types into the global Infix Type Registry.
 * @param defs The Infix type definition string.
 */
void define_types(pTHX_ const char * defs) {
    dMY_CXT;
    if (infix_register_types(MY_CXT.registry, defs) != INFIX_SUCCESS)
        croak("Parse Error");
}

/**
 * @brief Returns the layout size of a type by name.
 * @param name Type name or AST signature.
 * @return Size in bytes.
 */
IV sizeof_type(pTHX_ const char * name) {
    dMY_CXT;
    const infix_type * t = infix_registry_lookup_type(MY_CXT.registry, name);
    if (!t) {
        infix_arena_t * ta;
        infix_type * tt;
        if (infix_type_from_signature(&tt, &ta, name, MY_CXT.registry) == INFIX_SUCCESS) {
            size_t s = tt->size;
            infix_arena_destroy(ta);
            return s;
        }
    }
    return t ? t->size : 0;
}

/**
 * @brief Returns the byte offset of a member in a struct/union.
 * @param type_name The aggregate type name.
 * @param member_name The member field name.