view release on metacpan or  search on metacpan

xs/doubly/doubly.c  view on Meta::CPAN

    }
}

static void doubly_init(pTHX) {
#ifdef USE_ITHREADS
    if (!doubly_mutex_initialized) {
        MUTEX_INIT(&doubly_mutex);
        doubly_mutex_initialized = 1;
    }
#endif
    if (!doubly_initialized) {
        g_lists_size = 16;
        Newxz(g_lists, g_lists_size, DoublyListMeta);
        g_nodes_size = 64;
        Newxz(g_nodes, g_nodes_size, DoublyNodeSlot);
        g_free_nodes_size = 16;
        Newxz(g_free_nodes, g_free_nodes_size, IV);
        g_free_lists_size = 16;
        Newxz(g_free_lists, g_free_lists_size, IV);
        doubly_initialized = 1;
    }
}

/* ============================================
   Node Management
   ============================================ */

/* Allocate a new node slot, returns index */
static IV alloc_node(pTHX) {
    IV idx;

    /* Check free list first */
    if (g_free_nodes_count > 0) {
        idx = g_free_nodes[--g_free_nodes_count];
    } else {
        ensure_nodes_capacity(g_nodes_count);
        idx = g_nodes_count++;
    }

    /* Initialize node */
    g_nodes[idx].data = NULL;
    g_nodes[idx].prev_idx = -1;
    g_nodes[idx].next_idx = -1;
    g_nodes[idx].list_idx = -1;
    g_nodes[idx].node_id = g_next_node_id++;
#ifdef USE_ITHREADS
    g_nodes[idx].data_interp = NULL;
#endif

    return idx;
}

/* Free a node slot (add to free list) */
static void free_node(pTHX_ IV idx) {
    DoublyNodeSlot* node;

    if (idx < 0 || idx >= g_nodes_count) return;

    node = &g_nodes[idx];

    /* Decrement SV refcount if not during global destruction
     * and only if we're in the interpreter that owns the SV */
    if (node->data && !PL_dirty) {
#ifdef USE_ITHREADS
        /* Only free if this interpreter owns the SV */
        if (node->data_interp == PERL_GET_THX) {
            SvREFCNT_dec(node->data);
        }
        /* Note: if we're not the owner, we "leak" this SV intentionally.
         * The owning interpreter will clean it up during its destruction. */
#else
        SvREFCNT_dec(node->data);
#endif
    }
    node->data = NULL;
    node->prev_idx = -1;
    node->next_idx = -1;
    node->list_idx = -1;
    node->node_id = 0;
#ifdef USE_ITHREADS
    node->data_interp = NULL;
#endif

    /* Add to free list */
    if (g_free_nodes_count >= g_free_nodes_size) {
        g_free_nodes_size *= 2;
        Renew(g_free_nodes, g_free_nodes_size, IV);
    }
    g_free_nodes[g_free_nodes_count++] = idx;
}

/* Create a node with data */
static IV create_node(pTHX_ SV* data, IV list_idx) {
    IV idx = alloc_node(aTHX);
    DoublyNodeSlot* node = &g_nodes[idx];

    if (data && SvOK(data)) {
        node->data = newSVsv(data);  /* Copy the SV */
    } else {
        node->data = newSV(0);  /* Create empty SV for undef */
    }
    node->list_idx = list_idx;
#ifdef USE_ITHREADS
    node->data_interp = PERL_GET_THX;  /* Track which interpreter owns this SV */
#endif

    return idx;
}

/* ============================================
   List Management
   ============================================ */

/* Allocate a new list, returns index */
static IV alloc_list(pTHX) {
    IV idx;

    /* Check free list first */
    if (g_free_lists_count > 0) {
        idx = g_free_lists[--g_free_lists_count];
    } else {

xs/doubly/doubly.c  view on Meta::CPAN

            if (!found) {
                /* Re-find node by ID since list may have changed during callback */
                node_idx = find_node_by_id(list, current_node_id);
                if (node_idx >= 0) {
                    node = get_node(node_idx);
                    if (node) {
                        node_idx = node->next_idx;
                        pos++;
                    } else {
                        break;
                    }
                } else {
                    /* Node was removed during callback */
                    break;
                }
            }
        }
    }
    DOUBLY_UNLOCK();

    if (found) {
        list_insert_at_pos(aTHX_ list_idx, pos, data);
    } else {
        list_add(aTHX_ list_idx, data);
    }

    /* Return $self for chaining - no refcount increment needed */
    XSRETURN(1);
}

static XS(xs_destroy) {
    dXSARGS;
    HV* hash;
    SV** id_sv;
    IV list_idx;

    if (items < 1) croak("Usage: doubly::destroy(self)");

    hash = (HV*)SvRV(ST(0));
    id_sv = hv_fetch(hash, "_id", 3, 0);
    list_idx = id_sv ? SvIV(*id_sv) : -1;

    list_destroy(aTHX_ list_idx);
    XSRETURN_EMPTY;
}

static XS(xs_DESTROY) {
    dXSARGS;
    HV* hash;
    SV** id_sv;
    IV list_idx;
#ifdef USE_ITHREADS
    SV** owner_tid_sv;
    UV owner_tid;
    UV my_tid;
#endif

    PERL_UNUSED_VAR(items);

    /* Skip cleanup during global destruction */
    if (PL_dirty) {
        XSRETURN_EMPTY;
    }

    hash = (HV*)SvRV(ST(0));
    id_sv = hv_fetch(hash, "_id", 3, 0);
    list_idx = id_sv ? SvIV(*id_sv) : -1;

#ifdef USE_ITHREADS
    owner_tid_sv = hv_fetch(hash, "_owner_tid", 10, 0);
    owner_tid = owner_tid_sv ? SvUV(*owner_tid_sv) : 0;
    my_tid = PTR2UV(PERL_GET_THX);

    /* Always decrement refcount - list_decref handles SV ownership internally.
     * This prevents memory leaks from cloned objects that never get cleaned up. */
    list_decref(aTHX_ list_idx);
    (void)owner_tid; /* Suppress unused variable warning */
    (void)my_tid;
#else
    list_decref(aTHX_ list_idx);
#endif
    XSRETURN_EMPTY;
}

static XS(xs_CLONE_SKIP) {
    dXSARGS;
    PERL_UNUSED_VAR(items);
    /* Return 1 - do NOT clone doubly objects to new threads.
     * Each thread must create its own lists. Sharing lists across
     * threads is not supported. */
    XSRETURN_IV(1);
}

/* ============================================
   Boot
   ============================================ */

XS_EXTERNAL(boot_doubly) {
    dXSBOOTARGSXSAPIVERCHK;
    CV *method_cv;
    SV *ckobj;
    PERL_UNUSED_VAR(items);

    doubly_init(aTHX);

    /* Register custom OPs */
    XopENTRY_set(&doubly_data_get_xop, xop_name, "doubly_data_get");
    XopENTRY_set(&doubly_data_get_xop, xop_desc, "doubly data getter");
    Perl_custom_op_register(aTHX_ pp_doubly_data_get, &doubly_data_get_xop);

    XopENTRY_set(&doubly_data_set_xop, xop_name, "doubly_data_set");
    XopENTRY_set(&doubly_data_set_xop, xop_desc, "doubly data setter");
    Perl_custom_op_register(aTHX_ pp_doubly_data_set, &doubly_data_set_xop);

    XopENTRY_set(&doubly_length_xop, xop_name, "doubly_length");
    XopENTRY_set(&doubly_length_xop, xop_desc, "doubly length");
    Perl_custom_op_register(aTHX_ pp_doubly_length, &doubly_length_xop);

    XopENTRY_set(&doubly_next_xop, xop_name, "doubly_next");
    XopENTRY_set(&doubly_next_xop, xop_desc, "doubly next");