From: Vincent Pit <vince@profvince.com>
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/?p=perl%2Fmodules%2Fautovivification.git;a=commitdiff_plain;h=daea523653756bb45d89c7b17bbc6ac70f37019d

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 */