# 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 PTABLE_VAL_FREE(V) \
- { indirect_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); }
+#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_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
-
- return h->code;
-}
-
-#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);
- }
+#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
- return newSVuv(tag);
+ return I_HINT_CODE(h);
}
-#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) {
#define indirect_hint() indirect_hint(aTHX)
SV *hint;
+
+ if (IN_PERL_RUNTIME)
+ return NULL;
+
#if I_HAS_PERL(5, 9, 5)
hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
NULL,
0,
indirect_hash);
#else
- SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__,
+ {
+ SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__,
indirect_hash);
- if (!val)
- return 0;
- hint = *val;
+ if (!val)
+ return 0;
+ hint = *val;
+ }
#endif
return indirect_detag(hint);
}
oi->size = 0;
}
- s = SvPV_const(sv, len);
+ if (sv) {
+ s = SvPV_const(sv, len);
+ } else {
+ s = "{";
+ len = 1;
+ }
+
if (len > oi->size) {
Safefree(oi->buf);
Newx(oi->buf, len, char);
oi->size = len;
}
Copy(s, oi->buf, len, char);
+
oi->len = len;
oi->pos = src;
oi->line = line;
return o;
}
+/* ... ck_scope ............................................................ */
+
+STATIC OP *(*indirect_old_ck_scope) (pTHX_ OP *) = 0;
+STATIC OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
+
+STATIC OP *indirect_ck_scope(pTHX_ OP *o) {
+ OP *(*old_ck)(pTHX_ OP *) = 0;
+
+ switch (o->op_type) {
+ case OP_SCOPE: old_ck = indirect_old_ck_scope; break;
+ case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break;
+ }
+ o = CALL_FPTR(old_ck)(aTHX_ o);
+
+ if (indirect_hint()) {
+ indirect_map_store(o, PL_oldbufptr, NULL, CopLINE(&PL_compiling));
+ return o;
+ }
+
+ 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 ........................................................... */
STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
case OP_CONST:
case OP_RV2SV:
case OP_PADSV:
+ case OP_SCOPE:
+ case OP_LEAVE:
break;
default:
goto done;
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_RV2SV] = MEMBER_TO_FPTR(indirect_ck_rv2sv);
indirect_old_ck_padany = PL_check[OP_PADANY];
PL_check[OP_PADANY] = MEMBER_TO_FPTR(indirect_ck_padany);
+ indirect_old_ck_scope = PL_check[OP_SCOPE];
+ 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_method = PL_check[OP_METHOD];
PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_ck_method);
indirect_old_ck_entersub = PL_check[OP_ENTERSUB];
projects / perl / modules / indirect.git / blobdiff