more complete support for implicit thread/interpreter pointer,

enabled via -DPERL_IMPLICIT_CONTEXT (all changes are noops
without that enabled):
  - USE_THREADS now enables PERL_IMPLICIT_CONTEXT, so dTHR
    is a noop; tests pass on Solaris; should be faster now!
  - MULTIPLICITY has been tested with and without
    PERL_IMPLICIT_CONTEXT on Solaris
  - improved function database now merged with embed.pl
  - everything except the varargs functions have foo(a,b,c) macros
    to provide compatibility
  - varargs functions default to compatibility variants that
    get the context pointer using dTHX
  - there should be almost no source compatibility issues as a
    result of all this
  - dl_foo.xs changes other than dl_dlopen.xs untested
  - still needs documentation, fixups for win32 etc
Next step: migrate most non-mutex variables from perlvars.h
to intrpvar.h

p4raw-id: //depot/perl@3524

1 files changed, 57 insertions, 57 deletions

diff --git a/pp_hot.c b/pp_hot.c
index 36a33ff04d..b652a63b49 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -35,7 +35,7 @@
 
 #ifdef USE_THREADS
 STATIC void
-unset_cvowner(pTHX_ void *cvarg)
+S_unset_cvowner(pTHX_ void *cvarg)
 {
     register CV* cv = (CV *) cvarg;
 #ifdef DEBUGGING
@@ -212,7 +212,7 @@ PP(pp_readline)
 	    dSP;
 	    XPUSHs((SV*)PL_last_in_gv);
 	    PUTBACK;
-	    pp_rv2gv(ARGS);
+	    pp_rv2gv();
 	    PL_last_in_gv = (GV*)(*PL_stack_sp--);
 	}
     }
@@ -233,7 +233,7 @@ PP(pp_preinc)
 {
     djSP;
     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
-	croak(PL_no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
     	SvIVX(TOPs) != IV_MAX)
     {
@@ -351,7 +351,7 @@ PP(pp_print)
 	if (ckWARN(WARN_UNOPENED)) {
 	    SV* sv = sv_newmortal();
             gv_fullname3(sv, gv, Nullch);
-            warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
+            Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
         }
 
 	SETERRNO(EBADF,RMS$_IFI);
@@ -362,10 +362,10 @@ PP(pp_print)
 	    SV* sv = sv_newmortal();
             gv_fullname3(sv, gv, Nullch);
 	    if (IoIFP(io))
-		warner(WARN_IO, "Filehandle %s opened only for input", 
+		Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for input", 
 				SvPV(sv,n_a));
 	    else if (ckWARN(WARN_CLOSED))
-		warner(WARN_CLOSED, "print on closed filehandle %s", 
+		Perl_warner(aTHX_ WARN_CLOSED, "print on closed filehandle %s", 
 				SvPV(sv,n_a));
 	}
 	SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
@@ -426,7 +426,7 @@ PP(pp_rv2av)
 
 	av = (AV*)SvRV(sv);
 	if (SvTYPE(av) != SVt_PVAV)
-	    DIE("Not an ARRAY reference");
+	    DIE(aTHX_ "Not an ARRAY reference");
 	if (PL_op->op_flags & OPf_REF) {
 	    SETs((SV*)av);
 	    RETURN;
@@ -455,9 +455,9 @@ PP(pp_rv2av)
 		if (!SvOK(sv)) {
 		    if (PL_op->op_flags & OPf_REF ||
 		      PL_op->op_private & HINT_STRICT_REFS)
-			DIE(PL_no_usym, "an ARRAY");
+			DIE(aTHX_ PL_no_usym, "an ARRAY");
 		    if (ckWARN(WARN_UNINITIALIZED))
-			warner(WARN_UNINITIALIZED, PL_warn_uninit);
+			Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
 		    if (GIMME == G_ARRAY) {
 			(void)POPs;
 			RETURN;
@@ -474,7 +474,7 @@ PP(pp_rv2av)
 		}
 		else {
 		    if (PL_op->op_private & HINT_STRICT_REFS)
-			DIE(PL_no_symref, sym, "an ARRAY");
+			DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
 		    gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
 		}
 	    }
@@ -526,7 +526,7 @@ PP(pp_rv2hv)
 
 	hv = (HV*)SvRV(sv);
 	if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
-	    DIE("Not a HASH reference");
+	    DIE(aTHX_ "Not a HASH reference");
 	if (PL_op->op_flags & OPf_REF) {
 	    SETs((SV*)hv);
 	    RETURN;
@@ -555,9 +555,9 @@ PP(pp_rv2hv)
 		if (!SvOK(sv)) {
 		    if (PL_op->op_flags & OPf_REF ||
 		      PL_op->op_private & HINT_STRICT_REFS)
-			DIE(PL_no_usym, "a HASH");
+			DIE(aTHX_ PL_no_usym, "a HASH");
 		    if (ckWARN(WARN_UNINITIALIZED))
-			warner(WARN_UNINITIALIZED, PL_warn_uninit);
+			Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
 		    if (GIMME == G_ARRAY) {
 			SP--;
 			RETURN;
@@ -574,7 +574,7 @@ PP(pp_rv2hv)
 		}
 		else {
 		    if (PL_op->op_private & HINT_STRICT_REFS)
-			DIE(PL_no_symref, sym, "a HASH");
+			DIE(aTHX_ PL_no_symref, sym, "a HASH");
 		    gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
 		}
 	    }
@@ -593,14 +593,14 @@ PP(pp_rv2hv)
 
     if (GIMME == G_ARRAY) { /* array wanted */
 	*PL_stack_sp = (SV*)hv;
-	return do_kv(ARGS);
+	return do_kv();
     }
     else {
 	dTARGET;
 	if (SvTYPE(hv) == SVt_PVAV)
 	    hv = avhv_keys((AV*)hv);
 	if (HvFILL(hv))
-	    sv_setpvf(TARG, "%ld/%ld",
+	    Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
 		      (long)HvFILL(hv), (long)HvMAX(hv) + 1);
 	else
 	    sv_setiv(TARG, 0);
@@ -711,9 +711,9 @@ PP(pp_aassign)
 				SvROK(*relem) &&
 				( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 				  SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
-				warner(WARN_UNSAFE, "Reference found where even-sized list expected");
+				Perl_warner(aTHX_ WARN_UNSAFE, "Reference found where even-sized list expected");
 			    else
-				warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
+				Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
 			}
 			tmpstr = NEWSV(29,0);
 			didstore = hv_store_ent(hash,*relem,tmpstr,0);
@@ -767,7 +767,7 @@ PP(pp_aassign)
 #    endif /* HAS_SETEUID */
 	    if (PL_delaymagic & DM_UID) {
 		if (PL_uid != PL_euid)
-		    DIE("No setreuid available");
+		    DIE(aTHX_ "No setreuid available");
 		(void)PerlProc_setuid(PL_uid);
 	    }
 #  endif /* HAS_SETREUID */
@@ -796,7 +796,7 @@ PP(pp_aassign)
 #    endif /* HAS_SETEGID */
 	    if (PL_delaymagic & DM_GID) {
 		if (PL_gid != PL_egid)
-		    DIE("No setregid available");
+		    DIE(aTHX_ "No setregid available");
 		(void)PerlProc_setgid(PL_gid);
 	    }
 #  endif /* HAS_SETREGID */
@@ -869,7 +869,7 @@ PP(pp_match)
     s = SvPV(TARG, len);
     strend = s + len;
     if (!s)
-	DIE("panic: do_match");
+	DIE(aTHX_ "panic: do_match");
     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
 		 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
     TAINT_NOT;
@@ -998,7 +998,7 @@ play_it_again:
 	    rx->float_substr = Nullsv;
 	}
     }
-    if (CALLREGEXEC(rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
+    if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
     {
 	PL_curpm = pm;
 	if (pm->op_pmflags & PMf_ONCE)
@@ -1305,10 +1305,10 @@ Perl_do_readline(pTHX)
     if (!fp) {
 	if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
 	    if (type == OP_GLOB)
-		warner(WARN_CLOSED, "glob failed (can't start child: %s)",
+		Perl_warner(aTHX_ WARN_CLOSED, "glob failed (can't start child: %s)",
 		       Strerror(errno));
 	    else
-		warner(WARN_CLOSED, "Read on closed filehandle <%s>",
+		Perl_warner(aTHX_ WARN_CLOSED, "Read on closed filehandle <%s>",
 		       GvENAME(PL_last_in_gv));
 	}
 	if (gimme == G_SCALAR) {
@@ -1357,7 +1357,7 @@ Perl_do_readline(pTHX)
 	    }
 	    else if (type == OP_GLOB) {
 		if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) {
-		    warner(WARN_CLOSED,
+		    Perl_warner(aTHX_ WARN_CLOSED,
 			   "glob failed (child exited with status %d%s)",
 			   STATUS_CURRENT >> 8,
 			   (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
@@ -1454,7 +1454,7 @@ PP(pp_helem)
     }
     else if (SvTYPE(hv) == SVt_PVAV) {
 	if (PL_op->op_private & OPpLVAL_INTRO)
-	    DIE("Can't localize pseudo-hash element");
+	    DIE(aTHX_ "Can't localize pseudo-hash element");
 	svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
     }
     else {
@@ -1466,7 +1466,7 @@ PP(pp_helem)
 	    SV* key2;
 	    if (!defer) {
 		STRLEN n_a;
-		DIE(PL_no_helem, SvPV(keysv, n_a));
+		DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
 	    }
 	    lv = sv_newmortal();
 	    sv_upgrade(lv, SVt_PVLV);
@@ -1566,7 +1566,7 @@ PP(pp_iter)
     EXTEND(SP, 1);
     cx = &cxstack[cxstack_ix];
     if (CxTYPE(cx) != CXt_LOOP)
-	DIE("panic: pp_iter");
+	DIE(aTHX_ "panic: pp_iter");
 
     av = cx->blk_loop.iterary;
     if (SvTYPE(av) != SVt_PVAV) {
@@ -1696,7 +1696,7 @@ PP(pp_subst)
     if (SvREADONLY(TARG)
 	|| (SvTYPE(TARG) > SVt_PVLV
 	    && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
-	croak(PL_no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
     PUTBACK;
 
     s = SvPV(TARG, len);
@@ -1710,7 +1710,7 @@ PP(pp_subst)
 
   force_it:
     if (!pm || !s)
-	DIE("panic: do_subst");
+	DIE(aTHX_ "panic: do_subst");
 
     strend = s + len;
     maxiters = 2*(strend - s) + 10;	/* We can match twice at each 
@@ -1784,7 +1784,7 @@ PP(pp_subst)
     /* can do inplace substitution? */
     if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
 	&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
-	if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
+	if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
 	    SPAGAIN;
 	    PUSHs(&PL_sv_no);
 	    LEAVE_SCOPE(oldsave);
@@ -1842,7 +1842,7 @@ PP(pp_subst)
 	else {
 	    do {
 		if (iters++ > maxiters)
-		    DIE("Substitution loop");
+		    DIE(aTHX_ "Substitution loop");
 		rxtainted |= RX_MATCH_TAINTED(rx);
 		m = rx->startp[0] + orig;
 		/*SUPPRESS 560*/
@@ -1856,7 +1856,7 @@ PP(pp_subst)
 		    d += clen;
 		}
 		s = rx->endp[0] + orig;
-	    } while (CALLREGEXEC(rx, s, strend, orig, s == m,
+	    } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
 				 Nullsv, NULL, REXEC_NOT_FIRST)); /* don't match same null twice */
 	    if (s != d) {
 		i = strend - s;
@@ -1879,7 +1879,7 @@ PP(pp_subst)
 	RETURN;
     }
 
-    if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
+    if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
 	if (force_on_match) {
 	    force_on_match = 0;
 	    s = SvPV_force(TARG, len);
@@ -1898,7 +1898,7 @@ PP(pp_subst)
 	r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
 	do {
 	    if (iters++ > maxiters)
-		DIE("Substitution loop");
+		DIE(aTHX_ "Substitution loop");
 	    rxtainted |= RX_MATCH_TAINTED(rx);
 	    if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 		m = s;
@@ -1914,7 +1914,7 @@ PP(pp_subst)
 		sv_catpvn(dstr, c, clen);
 	    if (once)
 		break;
-	} while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, r_flags));
+	} while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags));
 	sv_catpvn(dstr, s, strend - s);
 
 	(void)SvOOK_off(TARG);
@@ -2041,7 +2041,7 @@ PP(pp_leavesub)
 }
 
 STATIC CV *
-get_db_sub(pTHX_ SV **svp, CV *cv)
+S_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
     dTHR;
     SV *dbsv = GvSV(PL_DBsub);
@@ -2087,7 +2087,7 @@ PP(pp_entersub)
     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
 
     if (!sv)
-	DIE("Not a CODE reference");
+	DIE(aTHX_ "Not a CODE reference");
     switch (SvTYPE(sv)) {
     default:
 	if (!SvROK(sv)) {
@@ -2106,9 +2106,9 @@ PP(pp_entersub)
 	    else
 		sym = SvPV(sv, n_a);
 	    if (!sym)
-		DIE(PL_no_usym, "a subroutine");
+		DIE(aTHX_ PL_no_usym, "a subroutine");
 	    if (PL_op->op_private & HINT_STRICT_REFS)
-		DIE(PL_no_symref, sym, "a subroutine");
+		DIE(aTHX_ PL_no_symref, sym, "a subroutine");
 	    cv = get_cv(sym, TRUE);
 	    break;
 	}
@@ -2122,7 +2122,7 @@ PP(pp_entersub)
 	/* FALL THROUGH */
     case SVt_PVHV:
     case SVt_PVAV:
-	DIE("Not a CODE reference");
+	DIE(aTHX_ "Not a CODE reference");
     case SVt_PVCV:
 	cv = (CV*)sv;
 	break;
@@ -2147,7 +2147,7 @@ PP(pp_entersub)
 
 	/* anonymous or undef'd function leaves us no recourse */
 	if (CvANON(cv) || !(gv = CvGV(cv)))
-	    DIE("Undefined subroutine called");
+	    DIE(aTHX_ "Undefined subroutine called");
 
 	/* autoloaded stub? */
 	if (cv != GvCV(gv)) {
@@ -2165,11 +2165,11 @@ try_autoload:
 	    else {
 		sub_name = sv_newmortal();
 		gv_efullname3(sub_name, gv, Nullch);
-		DIE("Undefined subroutine &%s called", SvPVX(sub_name));
+		DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
 	    }
 	}
 	if (!cv)
-	    DIE("Not a CODE reference");
+	    DIE(aTHX_ "Not a CODE reference");
 	goto retry;
     }
 
@@ -2177,7 +2177,7 @@ try_autoload:
     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
 	cv = get_db_sub(&sv, cv);
 	if (!cv)
-	    DIE("No DBsub routine");
+	    DIE(aTHX_ "No DBsub routine");
     }
 
 #ifdef USE_THREADS
@@ -2200,7 +2200,7 @@ try_autoload:
 		    || !(sv = AvARRAY(av)[0]))
 		{
 		    MUTEX_UNLOCK(CvMUTEXP(cv));
-		    croak("no argument for locked method call");
+		    Perl_croak(aTHX_ "no argument for locked method call");
 		}
 	    }
 	    if (SvROK(sv))
@@ -2226,7 +2226,7 @@ try_autoload:
 	    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
 				  thr, sv);)
 	    MUTEX_UNLOCK(MgMUTEXP(mg));
-	    save_destructor(unlock_condpair, sv);
+	    save_destructor(Perl_unlock_condpair, sv);
 	}
 	MUTEX_LOCK(CvMUTEXP(cv));
     }
@@ -2271,7 +2271,7 @@ try_autoload:
 	    CvOWNER(cv) = thr;
 	    SvREFCNT_inc(cv);
 	    if (CvDEPTH(cv) == 0)
-		SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
+		SAVEDESTRUCTOR(S_unset_cvowner, (void*) cv);
 	}
 	else {
 	    /* (2) => grab ownership of cv. (3) => make clone */
@@ -2308,7 +2308,7 @@ try_autoload:
 	    DEBUG_S(if (CvDEPTH(cv) != 0)
 			PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
 				      CvDEPTH(cv)););
-	    SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
+	    SAVEDESTRUCTOR(S_unset_cvowner, (void*) cv);
 	}
     }
 #endif /* USE_THREADS */
@@ -2366,7 +2366,7 @@ try_autoload:
 		PL_curcopdb = NULL;
 	    }
 	    /* Do we need to open block here? XXXX */
-	    (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
+	    (void)(*CvXSUB(cv))(aTHX_ cv);
 
 	    /* Enforce some sanity in scalar context. */
 	    if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
@@ -2515,11 +2515,11 @@ void
 Perl_sub_crush_depth(pTHX_ CV *cv)
 {
     if (CvANON(cv))
-	warner(WARN_RECURSION, "Deep recursion on anonymous subroutine");
+	Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
     else {
 	SV* tmpstr = sv_newmortal();
 	gv_efullname3(tmpstr, CvGV(cv), Nullch);
-	warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"", 
+	Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"", 
 		SvPVX(tmpstr));
     }
 }
@@ -2543,7 +2543,7 @@ PP(pp_aelem)
 	if (!svp || *svp == &PL_sv_undef) {
 	    SV* lv;
 	    if (!defer)
-		DIE(PL_no_aelem, elem);
+		DIE(aTHX_ PL_no_aelem, elem);
 	    lv = sv_newmortal();
 	    sv_upgrade(lv, SVt_PVLV);
 	    LvTYPE(lv) = 'y';
@@ -2573,7 +2573,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 	mg_get(sv);
     if (!SvOK(sv)) {
 	if (SvREADONLY(sv))
-	    croak(PL_no_modify);
+	    Perl_croak(aTHX_ PL_no_modify);
 	if (SvTYPE(sv) < SVt_RV)
 	    sv_upgrade(sv, SVt_RV);
 	else if (SvTYPE(sv) >= SVt_PV) {
@@ -2638,7 +2638,7 @@ PP(pp_method)
 		    : !isIDFIRST(*packname)
 		))
 	    {
-		DIE("Can't call method \"%s\" %s", name,
+		DIE(aTHX_ "Can't call method \"%s\" %s", name,
 		    SvOK(sv)? "without a package or object reference"
 			    : "on an undefined value");
 	    }
@@ -2649,7 +2649,7 @@ PP(pp_method)
     }
 
     if (!ob || !SvOBJECT(ob))
-	DIE("Can't call method \"%s\" on unblessed reference", name);
+	DIE(aTHX_ "Can't call method \"%s\" on unblessed reference", name);
 
     stash = SvSTASH(ob);
 
@@ -2674,7 +2674,7 @@ PP(pp_method)
 	    packname = name;
 	    packlen = sep - name;
 	}
-	DIE("Can't locate object method \"%s\" via package \"%.*s\"",
+	DIE(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"",
 	    leaf, (int)packlen, packname);
     }
     SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);