From: Vincent Pit Date: Tue, 1 Jun 2010 16:20:35 +0000 (+0200) Subject: Improve the thread destructor trick X-Git-Tag: rt62800~15 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=daea523653756bb45d89c7b17bbc6ac70f37019d;p=perl%2Fmodules%2Fautovivification.git Improve the thread destructor trick It's currently only used before 5.10.1, so it wasn't really broken by the recent changes to blead. But the new technique is cleaner and easier to maintain. --- diff --git a/MANIFEST b/MANIFEST index 28df70a..639db05 100644 --- a/MANIFEST +++ b/MANIFEST @@ -6,6 +6,7 @@ README autovivification.xs lib/autovivification.pm ptable.h +reap.h samples/hash2array.pl t/00-load.t t/20-hash.t diff --git a/autovivification.xs b/autovivification.xs index b56a21a..f342214 100644 --- a/autovivification.xs +++ b/autovivification.xs @@ -159,21 +159,12 @@ STATIC void a_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { ptable_hints_store(ud->tbl, ent->key, h2); } -STATIC void a_thread_cleanup(pTHX_ void *); +#include "reap.h" STATIC void a_thread_cleanup(pTHX_ void *ud) { - int *level = ud; + dMY_CXT; - if (*level) { - *level = 0; - LEAVE; - SAVEDESTRUCTOR_X(a_thread_cleanup, level); - ENTER; - } else { - dMY_CXT; - PerlMemShared_free(level); - ptable_hints_free(MY_CXT.tbl); - } + ptable_hints_free(MY_CXT.tbl); } #endif /* A_THREADSAFE */ @@ -1124,7 +1115,6 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; - int *level; PPCODE: { my_cxt_t ud; @@ -1138,13 +1128,7 @@ PPCODE: MY_CXT.tbl = t; MY_CXT.owner = aTHX; } - { - level = PerlMemShared_malloc(sizeof *level); - *level = 1; - LEAVEn("sub"); - SAVEDESTRUCTOR_X(a_thread_cleanup, level); - ENTERn("sub"); - } + reap(3, a_thread_cleanup, NULL); XSRETURN(0); #endif diff --git a/reap.h b/reap.h new file mode 100644 index 0000000..9073899 --- /dev/null +++ b/reap.h @@ -0,0 +1,81 @@ +/* This file is part of the autovivification Perl module. + * See http://search.cpan.org/dist/autovivification/ */ + +/* This header provides a specialized version of Scope::Upper::reap that can be + * called directly from XS. + * See http://search.cpan.org/dist/Scope-Upper/ for details. */ + +#ifndef REAP_H +#define REAP_H 1 + +#define REAP_DESTRUCTOR_SIZE 3 + +typedef struct { + I32 depth; + I32 *origin; + void (*cb)(pTHX_ void *); + void *ud; + char *dummy; +} reap_ud; + +STATIC void reap_pop(pTHX_ void *); + +STATIC void reap_pop(pTHX_ void *ud_) { + reap_ud *ud = ud_; + I32 depth, *origin, mark, base; + + depth = ud->depth; + origin = ud->origin; + mark = origin[depth]; + base = origin[depth - 1]; + + if (base < mark) { + PL_savestack_ix = mark; + leave_scope(base); + } + PL_savestack_ix = base; + + if ((ud->depth = --depth) > 0) { + SAVEDESTRUCTOR_X(reap_pop, ud); + } else { + void (*cb)(pTHX_ void *) = ud->cb; + void *cb_ud = ud->ud; + + PerlMemShared_free(ud->origin); + PerlMemShared_free(ud); + + SAVEDESTRUCTOR_X(cb, cb_ud); + } +} + +STATIC void reap(pTHX_ I32 depth, void (*cb)(pTHX_ void *), void *cb_ud) { +#define reap(D, CB, UD) reap(aTHX_ (D), (CB), (UD)) + reap_ud *ud; + I32 i; + + if (depth > PL_scopestack_ix) + depth = PL_scopestack_ix; + + ud = PerlMemShared_malloc(sizeof *ud); + ud->depth = depth; + ud->origin = PerlMemShared_malloc((depth + 1) * sizeof *ud->origin); + ud->cb = cb; + ud->ud = cb_ud; + ud->dummy = NULL; + + for (i = depth; i >= 1; --i) { + I32 j = PL_scopestack_ix - i; + ud->origin[depth - i] = PL_scopestack[j]; + PL_scopestack[j] += REAP_DESTRUCTOR_SIZE; + } + ud->origin[depth] = PL_savestack_ix; + + while (PL_savestack_ix + REAP_DESTRUCTOR_SIZE + <= PL_scopestack[PL_scopestack_ix - 1]) { + save_pptr(&ud->dummy); + } + + SAVEDESTRUCTOR_X(reap_pop, ud); +} + +#endif /* REAP_H */