# endif
#endif
+#ifdef DEBUGGING
+# define I_ASSERT(C) assert(C)
+#else
+# define I_ASSERT(C)
+#endif
+
#ifndef I_WORKAROUND_REQUIRE_PROPAGATION
# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1)
#endif
# define MY_CXT_CLONE NOOP
#endif
+#if I_THREADSAFE
+/* We must use preexistent global mutexes or we will never be able to destroy
+ * them. */
+# if I_HAS_PERL(5, 9, 3)
+# define I_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex)
+# define I_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex)
+# else
+# define I_LOADED_LOCK OP_REFCNT_LOCK
+# define I_LOADED_UNLOCK OP_REFCNT_UNLOCK
+# endif
+#else
+# define I_LOADED_LOCK NOOP
+# define I_LOADED_UNLOCK NOOP
+#endif
+
#if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
-# define I_CHECK_MUTEX_LOCK OP_CHECK_MUTEX_LOCK
-# define I_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK
+# define I_CHECK_LOCK OP_CHECK_MUTEX_LOCK
+# define I_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK
+#elif I_HAS_PERL(5, 9, 3)
+# define I_CHECK_LOCK OP_REFCNT_LOCK
+# define I_CHECK_UNLOCK OP_REFCNT_UNLOCK
#else
-# define I_CHECK_MUTEX_LOCK OP_REFCNT_LOCK
-# define I_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK
+/* Before perl 5.9.3, indirect_ck_*() calls are already protected by the
+ * I_LOADED mutex, which falls back to the OP_REFCNT mutex. Make sure we don't
+ * lock it twice. */
+# define I_CHECK_LOCK NOOP
+# define I_CHECK_UNLOCK NOOP
#endif
typedef OP *(*indirect_ck_t)(pTHX_ OP *);
static void indirect_ck_replace(pTHX_ OPCODE type, indirect_ck_t new_ck, indirect_ck_t *old_ck_p) {
#define indirect_ck_replace(T, NC, OCP) indirect_ck_replace(aTHX_ (T), (NC), (OCP))
- I_CHECK_MUTEX_LOCK;
+ I_CHECK_LOCK;
if (!*old_ck_p) {
*old_ck_p = PL_check[type];
PL_check[type] = new_ck;
}
- I_CHECK_MUTEX_UNLOCK;
+ I_CHECK_UNLOCK;
}
#endif
static void indirect_ck_restore(pTHX_ OPCODE type, indirect_ck_t *old_ck_p) {
#define indirect_ck_restore(T, OCP) indirect_ck_restore(aTHX_ (T), (OCP))
- I_CHECK_MUTEX_LOCK;
+ I_CHECK_LOCK;
if (*old_ck_p) {
PL_check[type] = *old_ck_p;
*old_ck_p = 0;
}
- I_CHECK_MUTEX_UNLOCK;
+ I_CHECK_UNLOCK;
}
/* --- Helpers ------------------------------------------------------------- */
/* ... Check if the module is loaded ....................................... */
-static U32 indirect_loaded = 0;
+static I32 indirect_loaded = 0;
#if I_THREADSAFE
#define PTABLE_NAME ptable_loaded
-#define PTABLE_VAL_FREE(V) NOOP
+#define PTABLE_NEED_DELETE 1
+#define PTABLE_NEED_WALK 0
#include "ptable.h"
static ptable *indirect_loaded_cxts = NULL;
-/* We must use preexistent global mutexes or we will never be able to destroy
- * them. */
-#if I_HAS_PERL(5, 9, 3)
-# define I_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex)
-# define I_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex)
-#else
-# define I_LOADED_LOCK OP_REFCNT_LOCK
-# define I_LOADED_UNLOCK OP_REFCNT_UNLOCK
-#endif
-
static int indirect_is_loaded(pTHX_ void *cxt) {
#define indirect_is_loaded(C) indirect_is_loaded(aTHX_ (C))
int res = 0;
int global_setup = 0;
if (indirect_loaded <= 0) {
- assert(!indirect_loaded_cxts);
+ I_ASSERT(indirect_loaded == 0);
+ I_ASSERT(!indirect_loaded_cxts);
indirect_loaded_cxts = ptable_new();
global_setup = 1;
}
++indirect_loaded;
- assert(indirect_loaded_cxts);
+ I_ASSERT(indirect_loaded_cxts);
ptable_loaded_store(indirect_loaded_cxts, cxt, cxt);
return global_setup;
int global_teardown = 0;
if (indirect_loaded > 1) {
- assert(indirect_loaded_cxts);
+ I_ASSERT(indirect_loaded_cxts);
ptable_loaded_delete(indirect_loaded_cxts, cxt);
--indirect_loaded;
} else if (indirect_loaded_cxts) {
+ I_ASSERT(indirect_loaded == 1);
ptable_loaded_free(indirect_loaded_cxts);
indirect_loaded_cxts = NULL;
indirect_loaded = 0;
#else
-#define I_LOADED_LOCK NOOP
-#define I_LOADED_UNLOCK NOOP
-
#define indirect_is_loaded(C) (indirect_loaded > 0)
#define indirect_set_loaded_locked(C) ((indirect_loaded++ <= 0) ? 1 : 0)
#define indirect_clear_loaded_locked(C) ((--indirect_loaded <= 0) ? 1 : 0)
#define PTABLE_NAME ptable_hints
#define PTABLE_VAL_FREE(V) I_HINT_FREE(V)
+#define PTABLE_NEED_DELETE 0
+#define PTABLE_NEED_WALK 1
#define pPTBL pTHX
#define pPTBL_ pTHX_
#define PTABLE_NAME ptable
#define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); }
+#define PTABLE_NEED_DELETE 1
+#define PTABLE_NEED_WALK 0
#define pPTBL pTHX
#define pPTBL_ pTHX_
ptable_hints_store(ud->tbl, ent->key, h2);
}
-static void indirect_thread_cleanup(pTHX_ void *ud) {
- int global_teardown;
- dMY_CXT;
-
- global_teardown = indirect_clear_loaded_locked(&MY_CXT);
- assert(!global_teardown);
-
- SvREFCNT_dec(MY_CXT.global_code);
- MY_CXT.global_code = NULL;
-
- ptable_free(MY_CXT.map);
- MY_CXT.map = NULL;
-
- ptable_hints_free(MY_CXT.tbl);
- MY_CXT.tbl = NULL;
-}
-
-static int indirect_endav_free(pTHX_ SV *sv, MAGIC *mg) {
- SAVEDESTRUCTOR_X(indirect_thread_cleanup, NULL);
-
- return 0;
-}
-
-static MGVTBL indirect_endav_vtbl = {
- 0,
- 0,
- 0,
- 0,
- indirect_endav_free
-#if MGf_COPY
- , 0
-#endif
-#if MGf_DUP
- , 0
-#endif
-#if MGf_LOCAL
- , 0
-#endif
-};
-
#endif /* I_THREADSAFE */
#if I_WORKAROUND_REQUIRE_PROPAGATION
+
static IV indirect_require_tag(pTHX) {
#define indirect_require_tag() indirect_require_tag(aTHX)
const CV *cv, *outside;
return PTR2IV(cv);
}
+
#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
static SV *indirect_tag(pTHX_ SV *value) {
ptable_delete(MY_CXT.map, o);
}
+/* --- Safe version of call_sv() ------------------------------------------- */
+
+static I32 indirect_call_sv(pTHX_ SV *sv, I32 flags) {
+#define indirect_call_sv(S, F) indirect_call_sv(aTHX_ (S), (F))
+ I32 ret, cxix;
+ PERL_CONTEXT saved_cx;
+ SV *saved_errsv = NULL;
+
+ if (SvTRUE(ERRSV)) {
+ if (IN_PERL_COMPILETIME && PL_errors)
+ sv_catsv(PL_errors, ERRSV);
+ else
+ saved_errsv = newSVsv(ERRSV);
+ SvCUR_set(ERRSV, 0);
+ }
+
+ cxix = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX);
+ /* The last popped context will be reused by call_sv(), but our callers may
+ * still need its previous value. Back it up so that it isn't clobbered. */
+ saved_cx = cxstack[cxix];
+
+ ret = call_sv(sv, flags | G_EVAL);
+
+ cxstack[cxix] = saved_cx;
+
+ if (SvTRUE(ERRSV)) {
+ /* Discard the old ERRSV, and reuse the variable to temporarily store the
+ * new one. */
+ if (saved_errsv)
+ sv_setsv(saved_errsv, ERRSV);
+ else
+ saved_errsv = newSVsv(ERRSV);
+ SvCUR_set(ERRSV, 0);
+ /* Immediately flush all errors. */
+ if (IN_PERL_COMPILETIME) {
+#if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
+ if (PL_parser)
+ ++PL_parser->error_count;
+#elif defined(PL_error_count)
+ ++PL_error_count;
+#else
+ ++PL_Ierror_count;
+#endif
+ if (PL_errors) {
+ sv_setsv(ERRSV, PL_errors);
+ SvCUR_set(PL_errors, 0);
+ }
+ }
+ sv_catsv(ERRSV, saved_errsv);
+ SvREFCNT_dec(saved_errsv);
+ croak(NULL);
+ } else if (saved_errsv) {
+ /* If IN_PERL_COMPILETIME && PL_errors, then the old ERRSV has already been
+ * added to PL_errors. Otherwise, just restore it to ERRSV, as if no eval
+ * block has ever been executed. */
+ sv_setsv(ERRSV, saved_errsv);
+ SvREFCNT_dec(saved_errsv);
+ }
+
+ return ret;
+}
+
/* --- Check functions ----------------------------------------------------- */
static int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) {
mPUSHu(moi->line);
PUTBACK;
- call_sv(code, G_VOID);
+ indirect_call_sv(code, G_VOID);
PUTBACK;
static void indirect_teardown(pTHX_ void *interp) {
dMY_CXT;
-#if I_MULTIPLICITY
- if (aTHX != interp)
- return;
-#endif
-
I_LOADED_LOCK;
if (indirect_clear_loaded_locked(&MY_CXT)) {
I_LOADED_UNLOCK;
+ SvREFCNT_dec(MY_CXT.global_code);
+ MY_CXT.global_code = NULL;
+
ptable_free(MY_CXT.map);
MY_CXT.map = NULL;
indirect_ck_replace(OP_LINESEQ, indirect_ck_scope, &indirect_old_ck_lineseq);
indirect_ck_replace(OP_METHOD, indirect_ck_method,
- &indirect_old_ck_method);
+ &indirect_old_ck_method);
indirect_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named,
- &indirect_old_ck_method_named);
+ &indirect_old_ck_method_named);
indirect_ck_replace(OP_ENTERSUB, indirect_ck_entersub,
- &indirect_old_ck_entersub);
+ &indirect_old_ck_entersub);
}
I_LOADED_UNLOCK;
MY_CXT.global_code = NULL;
}
-#if I_MULTIPLICITY
- call_atexit(indirect_teardown, aTHX);
-#else
call_atexit(indirect_teardown, NULL);
-#endif
return;
}
PREINIT:
ptable *t;
SV *global_code_dup;
- GV *gv;
PPCODE:
{
indirect_ptable_clone_ud ud;
int global_setup;
I_LOADED_LOCK;
global_setup = indirect_set_loaded_locked(&MY_CXT);
- assert(!global_setup);
+ I_ASSERT(!global_setup);
I_LOADED_UNLOCK;
}
}
- gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV);
- if (gv) {
- CV *cv = GvCV(gv);
- if (!PL_endav)
- PL_endav = newAV();
- SvREFCNT_inc(cv);
- if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv))
- SvREFCNT_dec(cv);
- sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &indirect_endav_vtbl, NULL, 0);
- }
XSRETURN(0);
-void
-_THREAD_CLEANUP(...)
-PROTOTYPE: DISABLE
-PPCODE:
- indirect_thread_cleanup(aTHX_ NULL);
- XSRETURN(0);
-
-#endif
+#endif /* I_THREADSAFE */
SV *
_tag(SV *value)