X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=c5589284fc5b3257ee0fa3da40ec3de4ef171efc;hb=0fb65259707f0db2eda122e573c417865fc91435;hp=5b0685d97502efdab9caa4a15d4c958615757ccf;hpb=c827e4d5a2951be50c2bffc478035891b8ceb8c5;p=perl%2Fmodules%2FScope-Upper.git

diff --git a/Upper.xs b/Upper.xs
index 5b0685d..c558928 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -729,16 +729,23 @@ static void su_save_gvcv(pTHX_ GV *gv) {
 /* --- Actions ------------------------------------------------------------- */
 
 typedef struct {
- I32 depth;
- I32 pad;
+ U8   type;
+ U8   private;
+ U8   pad;
+ /* spare */
+ I32  depth;
  I32 *origin;
- void (*handler)(pTHX_ void *);
 } su_ud_common;
 
-#define SU_UD_DEPTH(U)   (((su_ud_common *) (U))->depth)
+#define SU_UD_TYPE(U)    (((su_ud_common *) (U))->type)
+#define SU_UD_PRIVATE(U) (((su_ud_common *) (U))->private)
 #define SU_UD_PAD(U)     (((su_ud_common *) (U))->pad)
+#define SU_UD_DEPTH(U)   (((su_ud_common *) (U))->depth)
 #define SU_UD_ORIGIN(U)  (((su_ud_common *) (U))->origin)
-#define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler)
+
+#define SU_UD_TYPE_REAP     0
+#define SU_UD_TYPE_LOCALIZE 1
+#define SU_UD_TYPE_UID      2
 
 #define SU_UD_FREE(U) STMT_START { \
  if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \
@@ -797,17 +804,6 @@ static void su_call(pTHX_ void *ud_) {
  SU_UD_FREE(ud);
 }
 
-static void su_reap(pTHX_ void *ud) {
-#define su_reap(U) su_reap(aTHX_ (U))
- SU_D({
-  PerlIO_printf(Perl_debug_log,
-                "%p: === reap\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
-                 ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
- });
-
- SAVEDESTRUCTOR_X(su_call, ud);
-}
-
 /* ... Localize & localize array/hash element .............................. */
 
 typedef struct {
@@ -815,7 +811,6 @@ typedef struct {
  SV    *sv;
  SV    *val;
  SV    *elem;
- svtype type;
 } su_ud_localize;
 
 #define SU_UD_LOCALIZE_FREE(U) STMT_START { \
@@ -898,10 +893,11 @@ static I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *el
  }
  /* When deref is set, val isn't NULL */
 
+ SU_UD_PRIVATE(ud) = t;
+
  ud->sv   = sv;
  ud->val  = val ? newSVsv(deref ? SvRV(val) : val) : NULL;
  ud->elem = SvREFCNT_inc(elem);
- ud->type = t;
 
  return size;
 }
@@ -912,7 +908,7 @@ static void su_localize(pTHX_ void *ud_) {
  SV *sv   = ud->sv;
  SV *val  = ud->val;
  SV *elem = ud->elem;
- svtype t = ud->type;
+ svtype t = SU_UD_PRIVATE(ud);
  GV *gv;
 
  if (SvTYPE(sv) >= SVt_PVGV) {
@@ -973,12 +969,54 @@ done:
 
 /* --- Pop a context back -------------------------------------------------- */
 
-#if SU_DEBUG && defined(DEBUGGING)
+#ifdef DEBUGGING
 # define SU_CXNAME(C) PL_block_type[CxTYPE(C)]
 #else
-# define SU_CXNAME(C) "XXX"
+# if SU_HAS_PERL(5, 11, 0)
+static const char *su_block_type[] = {
+ "NULL",
+ "WHEN",
+ "BLOCK",
+ "GIVEN",
+ "LOOP_FOR",
+ "LOOP_PLAIN",
+ "LOOP_LAZYSV",
+ "LOOP_LAZYIV",
+ "SUB",
+ "FORMAT",
+ "EVAL",
+ "SUBST"
+};
+# elif SU_HAS_PERL(5, 9, 3)
+static const char *su_block_type[] = {
+ "NULL",
+ "SUB",
+ "EVAL",
+ "WHEN",
+ "SUBST",
+ "BLOCK",
+ "FORMAT",
+ "GIVEN",
+ "LOOP_FOR",
+ "LOOP_PLAIN",
+ "LOOP_LAZYSV",
+ "LOOP_LAZYIV"
+};
+# else
+static const char *su_block_type[] = {
+ "NULL",
+ "SUB",
+ "EVAL",
+ "LOOP",
+ "SUBST",
+ "BLOCK"
+};
+# endif
+# define SU_CXNAME(C) su_block_type[CxTYPE(C)]
 #endif
 
+static void su_uid_bump(pTHX_ void *ud_);
+
 static void su_pop(pTHX_ void *ud) {
 #define su_pop(U) su_pop(aTHX_ (U))
  I32 depth, base, mark, *origin;
@@ -1027,9 +1065,9 @@ static void su_pop(pTHX_ void *ud) {
  SU_UD_DEPTH(ud) = --depth;
 
  if (depth > 0) {
-  I32 pad;
+  U8 pad;
 
-  if ((pad = SU_UD_PAD(ud))) {
+  if ((pad = SU_UD_PAD(ud)) > 0) {
    dMY_CXT;
    do {
     SU_D(PerlIO_printf(Perl_debug_log,
@@ -1044,7 +1082,23 @@ static void su_pop(pTHX_ void *ud) {
            ud,                       depth, PL_scopestack_ix, PL_savestack_ix));
   SAVEDESTRUCTOR_X(su_pop, ud);
  } else {
-  SU_UD_HANDLER(ud)(aTHX_ ud);
+  switch (SU_UD_TYPE(ud)) {
+   case SU_UD_TYPE_REAP: {
+    SU_D({
+     PerlIO_printf(Perl_debug_log,
+                "%p: === reap\n%p: depth=%2d scope_ix=%2d save_ix=%2d\n",
+                 ud, ud, SU_UD_DEPTH(ud), PL_scopestack_ix, PL_savestack_ix);
+    });
+    SAVEDESTRUCTOR_X(su_call, ud);
+    break;
+   }
+   case SU_UD_TYPE_LOCALIZE:
+    su_localize(ud);
+    break;
+   case SU_UD_TYPE_UID:
+    su_uid_bump(aTHX_ ud);
+    break;
+  }
  }
 
  SU_D(PerlIO_printf(Perl_debug_log,
@@ -1056,7 +1110,8 @@ static void su_pop(pTHX_ void *ud) {
 
 static I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
 #define su_init(U, C, S) su_init(aTHX_ (U), (C), (S))
- I32 i, depth = 1, pad, offset, *origin;
+ I32 i, depth, offset, base, *origin;
+ U8 pad;
 
  SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix));
 
@@ -1073,41 +1128,23 @@ static I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
  SU_D(PerlIO_printf(Perl_debug_log, "%p: size=%d pad=%d offset=%d\n",
                                      ud,    size,   pad,   offset));
 
- for (i = cxstack_ix; i > cxix; --i) {
-  PERL_CONTEXT *cx = cxstack + i;
-  switch (CxTYPE(cx)) {
-#if SU_HAS_PERL(5, 11, 0)
-   case CXt_LOOP_FOR:
-   case CXt_LOOP_PLAIN:
-   case CXt_LOOP_LAZYSV:
-   case CXt_LOOP_LAZYIV:
-#else
-   case CXt_LOOP:
-#endif
-    SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is loop\n", ud, i));
-    depth += 2;
-    break;
-   default:
-    SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is other\n", ud, i));
-    depth++;
-    break;
-  }
- }
+ depth = PL_scopestack_ix - cxstack[cxix].blk_oldscopesp;
  SU_D(PerlIO_printf(Perl_debug_log, "%p: going down to depth %d\n", ud, depth));
 
  Newx(origin, depth + 1, I32);
- origin[0] = PL_scopestack[PL_scopestack_ix - depth];
- PL_scopestack[PL_scopestack_ix - depth] += size;
- for (i = depth - 1; i >= 1; --i) {
-  I32 j = PL_scopestack_ix - i;
-  origin[depth - i] = PL_scopestack[j];
+ base = PL_scopestack_ix - depth;
+ origin[0] = PL_scopestack[base];
+ PL_scopestack[base] += size;
+ for (i = 1; i < depth; ++i) {
+  I32 j = i + base;
+  origin[i] = PL_scopestack[j];
   PL_scopestack[j] += offset;
  }
  origin[depth] = PL_savestack_ix;
 
- SU_UD_ORIGIN(ud) = origin;
- SU_UD_DEPTH(ud)  = depth;
  SU_UD_PAD(ud)    = pad;
+ SU_UD_DEPTH(ud)  = depth;
+ SU_UD_ORIGIN(ud) = origin;
 
  /* Make sure the first destructor fires by pushing enough fake slots on the
   * stack. */
@@ -1220,12 +1257,12 @@ static void su_yield(pTHX_ void *ud_) {
 #if SU_HAS_PERL(5, 10, 0)
    if (cxix > 0) {
     PERL_CONTEXT *prev = cx - 1;
-    U8 type = CxTYPE(prev);
-    if ((type == CXt_GIVEN || type == CXt_WHEN)
+    U8       prev_type = CxTYPE(prev);
+    if ((prev_type == CXt_GIVEN || prev_type == CXt_WHEN)
         && (prev->blk_oldcop == cx->blk_oldcop)) {
      cxix--;
      cx = prev;
-     if (type == CXt_GIVEN)
+     if (prev_type == CXt_GIVEN)
       goto cxt_given;
      else
       goto cxt_when;
@@ -1997,7 +2034,7 @@ static SV *su_uid_get(pTHX_ I32 cxix) {
 
   Newx(ud, 1, su_ud_reap);
   SU_UD_ORIGIN(ud)  = NULL;
-  SU_UD_HANDLER(ud) = su_uid_bump;
+  SU_UD_TYPE(ud)    = SU_UD_TYPE_UID;
   ud->cb = (SV *) uid;
   su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
  }
@@ -2221,7 +2258,7 @@ static I32 su_context_gimme(pTHX_ I32 cxix) {
 
 /* --- Global setup/teardown ----------------------------------------------- */
 
-static U32 su_initialized = 0;
+static VOL U32 su_initialized = 0;
 
 static void su_global_teardown(pTHX_ void *root) {
  if (!su_initialized)
@@ -2826,8 +2863,8 @@ CODE:
  SU_GET_CONTEXT(1, 1, su_context_skip_db(cxstack_ix));
  cxix = su_context_normalize_down(cxix);
  Newx(ud, 1, su_ud_reap);
- SU_UD_ORIGIN(ud)  = NULL;
- SU_UD_HANDLER(ud) = su_reap;
+ SU_UD_ORIGIN(ud) = NULL;
+ SU_UD_TYPE(ud)   = SU_UD_TYPE_REAP;
  ud->cb = newSVsv(hook);
  su_init(ud, cxix, SU_SAVE_DESTRUCTOR_SIZE);
 
@@ -2842,8 +2879,8 @@ CODE:
  SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix));
  cxix = su_context_normalize_down(cxix);
  Newx(ud, 1, su_ud_localize);
- SU_UD_ORIGIN(ud)  = NULL;
- SU_UD_HANDLER(ud) = su_localize;
+ SU_UD_ORIGIN(ud) = NULL;
+ SU_UD_TYPE(ud)   = SU_UD_TYPE_LOCALIZE;
  size = su_ud_localize_init(ud, sv, val, NULL);
  su_init(ud, cxix, size);
 
@@ -2860,10 +2897,10 @@ CODE:
  SU_GET_CONTEXT(3, 3, su_context_skip_db(cxstack_ix));
  cxix = su_context_normalize_down(cxix);
  Newx(ud, 1, su_ud_localize);
- SU_UD_ORIGIN(ud)  = NULL;
- SU_UD_HANDLER(ud) = su_localize;
+ SU_UD_ORIGIN(ud) = NULL;
+ SU_UD_TYPE(ud)   = SU_UD_TYPE_LOCALIZE;
  size = su_ud_localize_init(ud, sv, val, elem);
- if (ud->type != SVt_PVAV && ud->type != SVt_PVHV) {
+ if (SU_UD_PRIVATE(ud) != SVt_PVAV && SU_UD_PRIVATE(ud) != SVt_PVHV) {
   SU_UD_LOCALIZE_FREE(ud);
   croak("Can't localize an element of something that isn't an array or a hash");
  }
@@ -2880,8 +2917,8 @@ CODE:
  SU_GET_CONTEXT(2, 2, su_context_skip_db(cxstack_ix));
  cxix = su_context_normalize_down(cxix);
  Newx(ud, 1, su_ud_localize);
- SU_UD_ORIGIN(ud)  = NULL;
- SU_UD_HANDLER(ud) = su_localize;
+ SU_UD_ORIGIN(ud) = NULL;
+ SU_UD_TYPE(ud)   = SU_UD_TYPE_LOCALIZE;
  size = su_ud_localize_init(ud, sv, NULL, elem);
  su_init(ud, cxix, size);