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 28df70afd12ccf99eaa1c76e673ab810f45e4b53..639db05f068e43b0e1a2b5741b014b48e46d5cdb 100644 (file)
--- 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 b56a21a36bc28e80719d3144c8f9874698b16191..f342214c495663c1979a2d5cdfb644eb321cc3c1 100644 (file)
--- 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 (file)
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 */