# define SvPVX_const SvPVX
#endif
+#ifndef SvREFCNT_inc_simple_NN
+# define SvREFCNT_inc_simple_NN SvREFCNT_inc
+#endif
+
#ifndef sv_catpvn_nomg
# define sv_catpvn_nomg sv_catpvn
#endif
/* ... Thread-safe hints ................................................... */
-/* If any of those are true, we need to store the hint in a global table. */
-
-#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
+#if I_WORKAROUND_REQUIRE_PROPAGATION
typedef struct {
SV *code;
-#if I_WORKAROUND_REQUIRE_PROPAGATION
I32 requires;
-#endif
} indirect_hint_t;
-#define PTABLE_NAME ptable_hints
+#define I_HINT_STRUCT 1
+
+#define I_HINT_CODE(H) ((H)->code)
+
+#define I_HINT_FREE(H) { \
+ indirect_hint_t *h = (H); \
+ SvREFCNT_dec(h->code); \
+ PerlMemShared_free(h); \
+}
+
+#else /* I_WORKAROUND_REQUIRE_PROPAGATION */
+
+typedef SV indirect_hint_t;
+
+#define I_HINT_STRUCT 0
+
+#define I_HINT_CODE(H) (H)
+
+#define I_HINT_FREE(H) SvREFCNT_dec(H);
+
+#endif /* !I_WORKAROUND_REQUIRE_PROPAGATION */
+
+#if I_THREADSAFE
-#define PTABLE_VAL_FREE(V) \
- { indirect_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); }
+#define PTABLE_NAME ptable_hints
+#define PTABLE_VAL_FREE(V) I_HINT_FREE(V)
#define pPTBL pTHX
#define pPTBL_ pTHX_
#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 /* I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION */
+#endif /* I_THREADSAFE */
/* Define the op->str ptable here because we need to be able to clean it during
* thread cleanup. */
#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
typedef struct {
-#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
+#if I_THREADSAFE
ptable *tbl; /* It really is a ptable_hints */
+ tTHX owner;
#endif
ptable *map;
const char *linestr;
-#if I_THREADSAFE
- tTHX owner;
-#endif
} my_cxt_t;
START_MY_CXT
STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
my_cxt_t *ud = ud_;
indirect_hint_t *h1 = ent->val;
- indirect_hint_t *h2 = PerlMemShared_malloc(sizeof *h2);
+ indirect_hint_t *h2;
- *h2 = *h1;
+ if (ud->owner == aTHX)
+ return;
- if (ud->owner != aTHX)
- h2->code = indirect_clone(h1->code, ud->owner);
+#if I_HINT_STRUCT
- ptable_hints_store(ud->tbl, ent->key, h2);
+ h2 = PerlMemShared_malloc(sizeof *h2);
+ h2->code = indirect_clone(h1->code, ud->owner);
SvREFCNT_inc(h2->code);
+#if I_WORKAROUND_REQUIRE_PROPAGATION
+ h2->requires = h1->requires;
+#endif
+
+#else /* I_HINT_STRUCT */
+
+ h2 = indirect_clone(h1, ud->owner);
+ SvREFCNT_inc(h2);
+
+#endif /* !I_HINT_STRUCT */
+
+ ptable_hints_store(ud->tbl, ent->key, h2);
}
STATIC void indirect_thread_cleanup(pTHX_ void *);
#endif /* I_THREADSAFE */
-#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
-
STATIC SV *indirect_tag(pTHX_ SV *value) {
#define indirect_tag(V) indirect_tag(aTHX_ (V))
indirect_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;
+ if (CvANON(code) && !CvCLONED(code))
+ CvCLONE_on(code);
+ SvREFCNT_inc_simple_NN(code);
+ }
+ }
+#if I_HINT_STRUCT
h = PerlMemShared_malloc(sizeof *h);
- h->code = SvREFCNT_inc(value);
+ h->code = code;
#if I_WORKAROUND_REQUIRE_PROPAGATION
{
h->requires = requires;
}
-#endif
+#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
+
+#else /* I_HINT_STRUCT */
+ h = code;
+#endif /* !I_HINT_STRUCT */
+#if I_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 /* I_THREADSAFE */
- return newSVuv(PTR2UV(value));
+ return newSViv(PTR2IV(h));
}
STATIC SV *indirect_detag(pTHX_ const SV *hint) {
indirect_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(indirect_hint_t *, SvIVX(hint));
+#if I_THREADSAFE
+ h = ptable_fetch(MY_CXT.tbl, h);
+#endif /* I_THREADSAFE */
#if I_WORKAROUND_REQUIRE_PROPAGATION
{
}
}
}
-#endif
+#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
- return h->code;
+ return I_HINT_CODE(h);
}
-#else
-
-STATIC SV *indirect_tag(pTHX_ SV *value) {
-#define indirect_tag(V) indirect_tag(aTHX_ (V))
- UV tag = 0;
-
- if (SvOK(value) && SvROK(value)) {
- value = SvRV(value);
- SvREFCNT_inc(value);
- tag = PTR2UV(value);
- }
-
- return newSVuv(tag);
-}
-
-#define indirect_detag(H) (((H) && SvOK(H)) ? INT2PTR(SV *, SvUVX(H)) : NULL)
-
-#endif /* I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION */
-
STATIC U32 indirect_hash = 0;
STATIC SV *indirect_hint(pTHX) {
return o;
}
-/* ... ck_leave ............................................................ */
-
-STATIC OP *(*indirect_old_ck_leave)(pTHX_ OP *) = 0;
-
-STATIC OP *indirect_ck_leave(pTHX_ OP *o) {
- o = CALL_FPTR(indirect_old_ck_leave)(aTHX_ o);
-
- /* Cleanup relevant entries in case ck_method catches them later. */
- indirect_map_delete(o);
- return o;
-}
+/* We don't need to clean the map entries for leave ops because they can only
+ * be created by mutating from a lineseq. */
/* ... ck_method ........................................................... */
HV *stash;
MY_CXT_INIT;
- MY_CXT.map = ptable_new();
- MY_CXT.linestr = NULL;
-#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
- MY_CXT.tbl = ptable_new();
-#endif
#if I_THREADSAFE
+ MY_CXT.tbl = ptable_new();
MY_CXT.owner = aTHX;
#endif
+ MY_CXT.map = ptable_new();
+ MY_CXT.linestr = NULL;
PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
PL_check[OP_SCOPE] = MEMBER_TO_FPTR(indirect_ck_scope);
indirect_old_ck_lineseq = PL_check[OP_LINESEQ];
PL_check[OP_LINESEQ] = MEMBER_TO_FPTR(indirect_ck_scope);
- indirect_old_ck_leave = PL_check[OP_LEAVE];
- PL_check[OP_LEAVE] = MEMBER_TO_FPTR(indirect_ck_leave);
indirect_old_ck_method = PL_check[OP_METHOD];
PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_ck_method);
projects / perl / modules / indirect.git / blobdiff