#include "perl.h"
#include "XSUB.h"
+#define __PACKAGE__ "indirect"
+#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
+
+/* --- Compatibility wrappers ---------------------------------------------- */
+
+#ifndef NOOP
+# define NOOP
+#endif
+
+#ifndef dNOOP
+# define dNOOP
+#endif
+
#ifndef SvPV_const
# define SvPV_const SvPV
#endif
# define HvNAMELEN_get(H) strlen(HvNAME_get(H))
#endif
+#ifndef SvIS_FREED
+# define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK)
+#endif
+
#define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
#if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
# endif
#endif
-/* ... Hints ............................................................... */
+/* ... Thread safety and multiplicity ...................................... */
+
+#ifndef I_MULTIPLICITY
+# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
+# define I_MULTIPLICITY 1
+# else
+# define I_MULTIPLICITY 0
+# endif
+#endif
+#if I_MULTIPLICITY && !defined(tTHX)
+# define tTHX PerlInterpreter*
+#endif
+
+#if I_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
+# define I_THREADSAFE 1
+# ifndef MY_CXT_CLONE
+# define MY_CXT_CLONE \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
+ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+# endif
+#else
+# define I_THREADSAFE 0
+# undef dMY_CXT
+# define dMY_CXT dNOOP
+# undef MY_CXT
+# define MY_CXT indirect_globaldata
+# undef START_MY_CXT
+# define START_MY_CXT STATIC my_cxt_t MY_CXT;
+# undef MY_CXT_INIT
+# define MY_CXT_INIT NOOP
+# undef MY_CXT_CLONE
+# define MY_CXT_CLONE NOOP
+#endif
+
+/* --- Helpers ------------------------------------------------------------- */
+
+/* ... Pointer table ....................................................... */
+
+#define PTABLE_NAME ptable
+#define PTABLE_VAL_FREE(V) if ((V) && !SvIS_FREED((SV *) (V))) SvREFCNT_dec(V)
+
+#define pPTBL pTHX
+#define pPTBL_ pTHX_
+#define aPTBL aTHX
+#define aPTBL_ aTHX_
+
+#include "ptable.h"
+
+#define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
+#define ptable_clear(T) ptable_clear(aTHX_ (T))
+#define ptable_free(T) ptable_free(aTHX_ (T))
+
+/* ... Thread-safe hints ................................................... */
+
+#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
+
+#if I_THREADSAFE
+
+typedef struct {
+ ptable *tbl;
+ ptable *map;
+ tTHX owner;
+ const char *linestr;
+} my_cxt_t;
+
+#else
+
+typedef struct {
+ ptable *map;
+ const char *linestr;
+} my_cxt_t;
+
+#endif /* I_THREADSAFE */
+
+START_MY_CXT
+
+#if I_THREADSAFE
+
+STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
+ my_cxt_t *ud = ud_;
+ SV *val = ent->val;
+
+ if (ud->owner != aTHX) {
+ CLONE_PARAMS param;
+ AV *stashes = (SvTYPE(val) == SVt_PVHV && HvNAME_get(val)) ? newAV() : NULL;
+ param.stashes = stashes;
+ param.flags = 0;
+ param.proto_perl = ud->owner;
+ val = sv_dup(val, ¶m);
+ if (stashes) {
+ av_undef(stashes);
+ SvREFCNT_dec(stashes);
+ }
+ }
+
+ ptable_store(ud->tbl, ent->key, val);
+ SvREFCNT_inc(val);
+}
+
+STATIC void indirect_thread_cleanup(pTHX_ void *);
+
+STATIC void indirect_thread_cleanup(pTHX_ void *ud) {
+ int *level = ud;
+ SV *id;
+
+ if (*level) {
+ *level = 0;
+ LEAVE;
+ SAVEDESTRUCTOR_X(indirect_thread_cleanup, level);
+ ENTER;
+ } else {
+ dMY_CXT;
+ PerlMemShared_free(level);
+ ptable_free(MY_CXT.map);
+ ptable_free(MY_CXT.tbl);
+ }
+}
+
+STATIC SV *indirect_tag(pTHX_ SV *value) {
+#define indirect_tag(V) indirect_tag(aTHX_ (V))
+ dMY_CXT;
+
+ value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL;
+ /* 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_store(MY_CXT.tbl, value, value);
+ SvREFCNT_inc(value);
+
+ return newSVuv(PTR2UV(value));
+}
+
+STATIC SV *indirect_detag(pTHX_ const SV *hint) {
+#define indirect_detag(H) indirect_detag(aTHX_ (H))
+ void *tag;
+ SV *value;
+
+ if (!hint || !SvOK(hint) || !SvIOK(hint))
+ croak("Wrong hint");
+
+ tag = INT2PTR(void *, SvIVX(hint));
+ {
+ dMY_CXT;
+ value = ptable_fetch(MY_CXT.tbl, tag);
+ }
+
+ return value;
+}
+
+#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) INT2PTR(SV *, SvUVX(H))
+
+#endif /* I_THREADSAFE */
STATIC U32 indirect_hash = 0;
-STATIC IV indirect_hint(pTHX) {
+STATIC SV *indirect_hint(pTHX) {
#define indirect_hint() indirect_hint(aTHX)
SV *id;
#if I_HAS_PERL(5, 10, 0)
id = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
NULL,
- "indirect", 8,
+ __PACKAGE__, __PACKAGE_LEN__,
0,
indirect_hash);
#else
- SV **val = hv_fetch(GvHV(PL_hintgv), "indirect", 8, indirect_hash);
+ SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__,
+ indirect_hash);
if (!val)
return 0;
id = *val;
#endif
- return (id && SvOK(id) && SvIOK(id)) ? SvIV(id) : 0;
+ return (id && SvOK(id)) ? id : NULL;
}
/* ... op -> source position ............................................... */
-STATIC HV *indirect_map = NULL;
-STATIC const char *indirect_linestr = NULL;
-
-/* We need (CHAR_BIT * sizeof(UV)) / 4 + 1 chars, but it's just better to take
- * a power of two */
-#define OP2STR_BUF char buf[(CHAR_BIT * sizeof(UV)) / 2]
-#define OP2STR(O) (sprintf(buf, "%"UVxf, PTR2UV(O)))
-
STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) {
#define indirect_map_store(O, S, N) indirect_map_store(aTHX_ (O), (S), (N))
- OP2STR_BUF;
- const char *pl_linestr;
+ dMY_CXT;
SV *val;
/* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q)
* still be alive somewhere. */
if (!PL_lex_inwhat) {
- pl_linestr = SvPVX_const(PL_linestr);
- if (indirect_linestr != pl_linestr) {
- hv_clear(indirect_map);
- indirect_linestr = pl_linestr;
+ const char *pl_linestr = SvPVX_const(PL_linestr);
+ if (MY_CXT.linestr != pl_linestr) {
+ ptable_clear(MY_CXT.map);
+ MY_CXT.linestr = pl_linestr;
}
}
SvUVX(val) = PTR2UV(src);
SvIOK_on(val);
SvIsUV_on(val);
- if (!hv_store(indirect_map, buf, OP2STR(o), val, 0)) SvREFCNT_dec(val);
+
+ ptable_store(MY_CXT.map, o, val);
}
STATIC const char *indirect_map_fetch(pTHX_ const OP *o, SV ** const name) {
#define indirect_map_fetch(O, S) indirect_map_fetch(aTHX_ (O), (S))
- OP2STR_BUF;
- SV **val;
+ dMY_CXT;
+ SV *val;
- if (indirect_linestr != SvPVX_const(PL_linestr))
+ if (MY_CXT.linestr != SvPVX_const(PL_linestr))
return NULL;
- val = hv_fetch(indirect_map, buf, OP2STR(o), 0);
+ val = ptable_fetch(MY_CXT.map, o);
if (!val) {
*name = NULL;
return NULL;
}
- *name = *val;
- return INT2PTR(const char *, SvUVX(*val));
-}
-
-STATIC void indirect_map_delete(pTHX_ const OP *o) {
-#define indirect_map_delete(O) indirect_map_delete(aTHX_ (O))
- OP2STR_BUF;
-
- hv_delete(indirect_map, buf, OP2STR(o), G_DISCARD);
-}
-
-STATIC void indirect_map_clean_kids(pTHX_ const OP *o) {
-#define indirect_map_clean_kids(O) indirect_map_clean_kids(aTHX_ (O))
- if (o->op_flags & OPf_KIDS) {
- const OP *kid = cUNOPo->op_first;
- for (; kid; kid = kid->op_sibling) {
- indirect_map_clean_kids(kid);
- indirect_map_delete(kid);
- }
- }
+ *name = val;
+ return INT2PTR(const char *, SvUVX(val));
}
-STATIC void indirect_map_clean(pTHX_ const OP *o) {
-#define indirect_map_clean(O) indirect_map_clean(aTHX_ (O))
- indirect_map_clean_kids(o);
- indirect_map_delete(o);
-}
+/* --- Check functions ----------------------------------------------------- */
STATIC const char *indirect_find(pTHX_ SV *sv, const char *s) {
#define indirect_find(N, S) indirect_find(aTHX_ (N), (S))
SV *sv;
const char *name = NULL, *s;
STRLEN len;
- OPCODE type = op->op_type;
+ OPCODE type = (OPCODE) op->op_type;
switch (type) {
case OP_GV:
/* ... ck_entersub ......................................................... */
-STATIC const char indirect_msg[] = "Indirect call of method \"%s\" on object \"%s\"";
-
STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
- LISTOP *op;
- OP *om, *oo;
- IV hint = indirect_hint();
+ SV *hint = indirect_hint();
o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o);
if (hint) {
- const char *pm, *po;
- SV *svm, *svo;
- oo = o;
+ const char *mpos, *opos;
+ SV *mnamesv, *onamesv;
+ OP *mop, *oop;
+ LISTOP *lop;
+
+ oop = o;
do {
- op = (LISTOP *) oo;
- if (!op->op_flags & OPf_KIDS)
+ lop = (LISTOP *) oop;
+ if (!(lop->op_flags & OPf_KIDS))
goto done;
- oo = op->op_first;
- } while (oo->op_type != OP_PUSHMARK);
- oo = oo->op_sibling;
- om = op->op_last;
- if (om->op_type == OP_METHOD)
- om = cUNOPx(om)->op_first;
- else if (om->op_type != OP_METHOD_NAMED)
+ oop = lop->op_first;
+ } while (oop->op_type != OP_PUSHMARK);
+ oop = oop->op_sibling;
+ mop = lop->op_last;
+
+ if (mop->op_type == OP_METHOD)
+ mop = cUNOPx(mop)->op_first;
+ else if (mop->op_type != OP_METHOD_NAMED)
goto done;
- pm = indirect_map_fetch(om, &svm);
- po = indirect_map_fetch(oo, &svo);
- if (pm && po && pm < po) {
- const char *psvm = SvPV_nolen_const(svm), *psvo = SvPV_nolen_const(svo);
- if (hint == 2)
- croak(indirect_msg, psvm, psvo);
- else
- warn(indirect_msg, psvm, psvo);
+
+ mpos = indirect_map_fetch(mop, &mnamesv);
+ if (!mpos)
+ goto done;
+
+ opos = indirect_map_fetch(oop, &onamesv);
+ if (!opos)
+ goto done;
+
+ if (mpos < opos) {
+ SV *code = indirect_detag(hint);
+
+ if (hint) {
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ EXTEND(SP, 2);
+ PUSHs(onamesv);
+ PUSHs(mnamesv);
+ PUTBACK;
+
+ call_sv(code, G_VOID);
+
+ PUTBACK;
+
+ FREETMPS;
+ LEAVE;
+ }
}
-done:
- indirect_map_clean(o);
}
+done:
return o;
}
MODULE = indirect PACKAGE = indirect
-PROTOTYPES: DISABLE
+PROTOTYPES: ENABLE
BOOT:
{
if (!indirect_initialized++) {
- PERL_HASH(indirect_hash, "indirect", 8);
- indirect_map = newHV();
+ HV *stash;
+
+ MY_CXT_INIT;
+ MY_CXT.map = ptable_new();
+ MY_CXT.linestr = NULL;
+#if I_THREADSAFE
+ MY_CXT.tbl = ptable_new();
+ MY_CXT.owner = aTHX;
+#endif
+
+ PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
+
indirect_old_ck_const = PL_check[OP_CONST];
PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_ck_const);
indirect_old_ck_rv2sv = PL_check[OP_RV2SV];
PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_ck_method);
indirect_old_ck_entersub = PL_check[OP_ENTERSUB];
PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_ck_entersub);
+
+ stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
+ newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE));
}
}
+
+#if I_THREADSAFE
+
+void
+CLONE(...)
+PROTOTYPE: DISABLE
+PREINIT:
+ ptable *t;
+ int *level;
+CODE:
+ {
+ my_cxt_t ud;
+ dMY_CXT;
+ ud.tbl = t = ptable_new();
+ ud.owner = MY_CXT.owner;
+ ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud);
+ }
+ {
+ MY_CXT_CLONE;
+ MY_CXT.map = ptable_new();
+ MY_CXT.linestr = NULL;
+ MY_CXT.tbl = t;
+ MY_CXT.owner = aTHX;
+ }
+ {
+ level = PerlMemShared_malloc(sizeof *level);
+ *level = 1;
+ LEAVE;
+ SAVEDESTRUCTOR_X(indirect_thread_cleanup, level);
+ ENTER;
+ }
+
+#endif
+
+SV *
+_tag(SV *value)
+PROTOTYPE: $
+CODE:
+ RETVAL = indirect_tag(value);
+OUTPUT:
+ RETVAL
projects / perl / modules / indirect.git / blobdiff