Only remap the hint through the pointer table for threaded perls

Also use the hint pointer as the unique identifier for the %^H entry, so
that the pragma no longer leaks when you specify the same hook (i.e. a
reference to the same sub) in two different require scopes.

diff --git a/MANIFEST b/MANIFEST
index f8c8cf3e21372da624dca6c50ba70859f2e4eabe..3d8ae87a2e38dac33c053f14efdceeae63bb8faa 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -27,3 +27,5 @@ t/95-portability-files.t
 t/99-kwalitee.t
 t/lib/Lexical/Types/TestRequired1.pm
 t/lib/Lexical/Types/TestRequired2.pm
+t/lib/Lexical/Types/TestRequired3X.pm
+t/lib/Lexical/Types/TestRequired3Y.pm

diff --git a/Types.xs b/Types.xs
index 46aa91628eec598ce7bbf3f1e95e8147138b5078..ff9e398f6242d625c40706a095161c8b37cb354e 100644 (file)
--- a/Types.xs
+++ b/Types.xs
@@ -35,8 +35,8 @@
 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
 #endif
 
-#ifndef SvIS_FREED
-# define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK)
+#ifndef SvREFCNT_inc_simple_NN
+# define SvREFCNT_inc_simple_NN SvREFCNT_inc
 #endif
 
 /* ... Thread safety and multiplicity ...................................... */
@@ -87,19 +87,39 @@
 
 /* ... Thread-safe hints ................................................... */
 
-/* If any of those is true, we need to store the hint in a global table. */
-
-#if LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION
+#if LT_WORKAROUND_REQUIRE_PROPAGATION
 
 typedef struct {
  SV *code;
-#if LT_WORKAROUND_REQUIRE_PROPAGATION
  UV  requires;
-#endif
 } lt_hint_t;
 
+#define LT_HINT_STRUCT 1
+
+#define LT_HINT_CODE(H) ((H)->code)
+
+#define LT_HINT_FREE(H) { \
+ lt_hint_t *h = (H);      \
+ SvREFCNT_dec(h->code);   \
+ PerlMemShared_free(h);   \
+}
+
+#else  /*  LT_WORKAROUND_REQUIRE_PROPAGATION */
+
+typedef SV lt_hint_t;
+
+#define LT_HINT_STRUCT 0
+
+#define LT_HINT_CODE(H) (H)
+
+#define LT_HINT_FREE(H) SvREFCNT_dec(H);
+
+#endif /* !LT_WORKAROUND_REQUIRE_PROPAGATION */
+
+#if LT_THREADSAFE
+
 #define PTABLE_NAME        ptable_hints
-#define PTABLE_VAL_FREE(V) { lt_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); }
+#define PTABLE_VAL_FREE(V) LT_HINT_FREE(V)
 
 #define pPTBL  pTHX
 #define pPTBL_ pTHX_
@@ -111,17 +131,15 @@ typedef struct {
 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
 
-#endif /* LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION */
+#endif /* LT_THREADSAFE */
 
 /* ... Global data ......................................................... */
 
 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 
 typedef struct {
-#if LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION
- ptable *tbl; /* It really is a ptable_hints */
-#endif
 #if LT_THREADSAFE
+ ptable *tbl; /* It really is a ptable_hints */
  tTHX    owner;
 #endif
  SV     *default_meth;
@@ -160,15 +178,28 @@ STATIC SV *lt_clone(pTHX_ SV *sv, tTHX owner) {
 STATIC void lt_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) {
  my_cxt_t  *ud  = ud_;
  lt_hint_t *h1 = ent->val;
- lt_hint_t *h2 = PerlMemShared_malloc(sizeof *h2);
+ lt_hint_t *h2;
 
- *h2 = *h1;
+ if (ud->owner == aTHX)
+  return;
 
- if (ud->owner != aTHX)
-  h2->code = lt_clone(h1->code, ud->owner);
+#if LT_HINT_STRUCT
 
- ptable_hints_store(ud->tbl, ent->key, h2);
+ h2           = PerlMemShared_malloc(sizeof *h2);
+ h2->code     = lt_clone(h1->code, ud->owner);
  SvREFCNT_inc(h2->code);
+#if LT_WORKAROUND_REQUIRE_PROPAGATION
+ h2->requires = h1->requires;
+#endif
+
+#else /*   LT_HINT_STRUCT */
+
+ h2 = lt_clone(h1, ud->owner);
+ SvREFCNT_inc(h2);
+
+#endif /* !LT_HINT_STRUCT */
+
+ ptable_hints_store(ud->tbl, ent->key, h2);
 }
 
 STATIC void lt_thread_cleanup(pTHX_ void *);
@@ -192,22 +223,28 @@ STATIC void lt_thread_cleanup(pTHX_ void *ud) {
 
 /* ... Hint tags ........................................................... */
 
-#if LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION
-
 STATIC SV *lt_tag(pTHX_ SV *value) {
 #define lt_tag(V) lt_tag(aTHX_ (V))
  lt_hint_t *h;
+ SV *code = NULL;
  dMY_CXT;
 
- value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL;
+ if (SvROK(value)) {
+  value = SvRV(value);
+  if (SvTYPE(value) >= SVt_PVCV) {
+   code = value;
+   SvREFCNT_inc_simple_NN(code);
+  }
+ }
 
+#if LT_HINT_STRUCT
  h = PerlMemShared_malloc(sizeof *h);
- h->code = SvREFCNT_inc(value);
+ h->code = code;
 
 #if LT_WORKAROUND_REQUIRE_PROPAGATION
  {
   const PERL_SI *si;
-  UV             requires = 0;
+  I32            requires = 0;
 
   for (si = PL_curstackinfo; si; si = si->si_prev) {
    I32 cxix;
@@ -222,14 +259,20 @@ STATIC SV *lt_tag(pTHX_ SV *value) {
 
   h->requires = requires;
  }
-#endif
+#endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
+
+#else  /*  LT_HINT_STRUCT */
+ h = code;
+#endif /* !LT_HINT_STRUCT */
 
+#if LT_THREADSAFE
  /* We only need for the key to be an unique tag for looking up the value later.
   * Allocated memory provides convenient unique identifiers, so that's why we
-  * use the value pointer as the key itself. */
- ptable_hints_store(MY_CXT.tbl, value, h);
+  * use the hint as the key itself. */
+ ptable_hints_store(MY_CXT.tbl, h, h);
+#endif /* LT_THREADSAFE */
 
- return newSVuv(PTR2UV(value));
+ return newSViv(PTR2IV(h));
 }
 
 STATIC SV *lt_detag(pTHX_ const SV *hint) {
@@ -237,15 +280,18 @@ STATIC SV *lt_detag(pTHX_ const SV *hint) {
  lt_hint_t *h;
  dMY_CXT;
 
- if (!(hint && SvOK(hint) && SvIOK(hint)))
+ if (!(hint && SvIOK(hint)))
   return NULL;
 
- h = ptable_fetch(MY_CXT.tbl, INT2PTR(void *, SvUVX(hint)));
+ h = INT2PTR(lt_hint_t *, SvIVX(hint));
+#if LT_THREADSAFE
+ h = ptable_fetch(MY_CXT.tbl, h);
+#endif /* LT_THREADSAFE */
 
 #if LT_WORKAROUND_REQUIRE_PROPAGATION
  {
   const PERL_SI *si;
-  UV             requires = 0;
+  I32            requires = 0;
 
   for (si = PL_curstackinfo; si; si = si->si_prev) {
    I32 cxix;
@@ -259,30 +305,11 @@ STATIC SV *lt_detag(pTHX_ const SV *hint) {
    }
   }
  }
-#endif
+#endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
 
- return h->code;
+ return LT_HINT_CODE(h);
 }
 
-#else
-
-STATIC SV *lt_tag(pTHX_ SV *value) {
-#define lt_tag(V) lt_tag(aTHX_ (V))
- UV tag = 0;
-
- if (SvOK(value) && SvROK(value)) {
-  value = SvRV(value);
-  SvREFCNT_inc(value);
-  tag = PTR2UV(value);
- }
-
- return newSVuv(tag);
-}
-
-#define lt_detag(H) (((H) && SvOK(H)) ? INT2PTR(SV *, SvUVX(H)) : NULL)
-
-#endif /* LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION */
-
 STATIC U32 lt_hash = 0;
 
 STATIC SV *lt_hint(pTHX) {
@@ -633,10 +660,8 @@ BOOT:
   HV *stash;
 
   MY_CXT_INIT;
-#if LT_THREADSAFE || LT_WORKAROUND_REQUIRE_PROPAGATION
-  MY_CXT.tbl            = ptable_new();
-#endif
 #if LT_THREADSAFE
+  MY_CXT.tbl            = ptable_new();
   MY_CXT.owner          = aTHX;
 #endif
   MY_CXT.pp_padsv_saved = 0;

diff --git a/t/16-scope.t b/t/16-scope.t
index 712bec2c81da136294d55297ea353c77bf301bd4..6d78ec1a3615529457de06dc92f0a6664d0e7d34 100644 (file)
--- a/t/16-scope.t
+++ b/t/16-scope.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => (1 + 2) + (1 + 4);
+use Test::More tests => (1 + 2) + (1 + 4) + (3 + 3);
 
 sub Int::TYPEDSCALAR { join ':', (caller 0)[1, 2] }
 
@@ -20,3 +20,28 @@ use lib 't/lib';
  eval 'use Lexical::Types; use Lexical::Types::TestRequired2';
  is $@, '', 'second require test didn\'t croak prematurely';
 }
+
+{
+ my (@decls, @w);
+ sub cb3 { push @decls, $_[0]; @_ }
+ {
+  no strict 'refs';
+  *{"Int3$_\::TYPEDSCALAR"} = \&Int::TYPEDSCALAR for qw/X Y Z/;
+ }
+ local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
+ eval <<' TESTREQUIRED3';
+  {
+   package Lexical::Types::TestRequired3Z;
+   use Lexical::Types as => \&main::cb3;
+   use Lexical::Types::TestRequired3X;
+   use Lexical::Types::TestRequired3Y;
+   my Int3Z $z;
+   ::is($z, __FILE__.':6', 'pragma in use at the end');
+  }
+ TESTREQUIRED3
+ @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if $] <= 5.008003;
+ is         $@,     '',  'third require test didn\'t croak prematurely';
+ is_deeply \@w,     [ ], 'third require test didn\'t warn';
+ is_deeply \@decls, [ map "Int3$_", qw/X Z/ ],
+                         'third require test propagated in the right scopes';
+}

diff --git a/t/lib/Lexical/Types/TestRequired3X.pm b/t/lib/Lexical/Types/TestRequired3X.pm
new file mode 100644 (file)
index 0000000..d327679
--- /dev/null
+++ b/t/lib/Lexical/Types/TestRequired3X.pm
@@ -0,0 +1,9 @@
+package Lexical::Types::TestRequired3X;
+
+use Lexical::Types as => \&main::cb3;
+
+my Int3X $x;
+Test::More::is($x, __FILE__.':'.(__LINE__-1),
+                                            'pragma in use after double setup');
+
+1;

diff --git a/t/lib/Lexical/Types/TestRequired3Y.pm b/t/lib/Lexical/Types/TestRequired3Y.pm
new file mode 100644 (file)
index 0000000..67214f2
--- /dev/null
+++ b/t/lib/Lexical/Types/TestRequired3Y.pm
@@ -0,0 +1,6 @@
+package Lexical::Types::TestRequired3Y;
+
+my Int3Y $y;
+Test::More::is($y, undef, 'pragma not in use in require after double setup');
+
+1;