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, 124 insertions, 48 deletions

diff --git a/util.c b/util.c
index 9c0df21793..2c897a4776 100644
--- a/util.c
+++ b/util.c
@@ -82,7 +82,7 @@ Perl_safesysmalloc(pTHX_ MEM_SIZE size)
 #endif /* HAS_64K_LIMIT */
 #ifdef DEBUGGING
     if ((long)size < 0)
-	croak("panic: malloc");
+	Perl_croak(aTHX_ "panic: malloc");
 #endif
     ptr = PerlMem_malloc(size?size:1);	/* malloc(0) is NASTY on our system */
 #if !(defined(I286) || defined(atarist))
@@ -128,7 +128,7 @@ Perl_safesysrealloc(pTHX_ Malloc_t where,MEM_SIZE size)
 	return safesysmalloc(size);
 #ifdef DEBUGGING
     if ((long)size < 0)
-	croak("panic: realloc");
+	Perl_croak(aTHX_ "panic: realloc");
 #endif
     ptr = PerlMem_realloc(where,size);
 
@@ -188,7 +188,7 @@ Perl_safesyscalloc(pTHX_ MEM_SIZE count, MEM_SIZE size)
 #endif /* HAS_64K_LIMIT */
 #ifdef DEBUGGING
     if ((long)size < 0 || (long)count < 0)
-	croak("panic: calloc");
+	Perl_croak(aTHX_ "panic: calloc");
 #endif
     size *= count;
     ptr = PerlMem_malloc(size?size:1);	/* malloc(0) is NASTY on our system */
@@ -297,7 +297,7 @@ Perl_safexcalloc(pTHX_ I32 x,MEM_SIZE count, MEM_SIZE size)
 }
 
 STATIC void
-xstat(pTHX_ int flag)
+S_xstat(pTHX_ int flag)
 {
     register I32 i, j, total = 0;
     I32 subtot[MAXYCOUNT];
@@ -527,7 +527,7 @@ Perl_new_collate(pTHX_ const char *newcoll)
 	  Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
 	  SSize_t mult = fb - fa;
 	  if (mult < 1)
-	      croak("strxfrm() gets absurd");
+	      Perl_croak(aTHX_ "strxfrm() gets absurd");
 	  PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
 	  PL_collxfrm_mult = mult;
 	}
@@ -1307,10 +1307,10 @@ Perl_savepvn(pTHX_ const char *sv, register I32 len)
     return newaddr;
 }
 
-/* the SV for form() and mess() is not kept in an arena */
+/* the SV for Perl_form() and mess() is not kept in an arena */
 
 STATIC SV *
-mess_alloc(pTHX)
+S_mess_alloc(pTHX)
 {
     dTHR;
     SV *sv;
@@ -1332,6 +1332,20 @@ mess_alloc(pTHX)
     return sv;
 }
 
+#ifdef PERL_IMPLICIT_CONTEXT
+char *
+Perl_form_nocontext(const char* pat, ...)
+{
+    dTHX;
+    SV *sv = mess_alloc();
+    va_list args;
+    va_start(args, pat);
+    sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+    va_end(args);
+    return SvPVX(sv);
+}
+#endif
+
 char *
 Perl_form(pTHX_ const char* pat, ...)
 {
@@ -1353,12 +1367,12 @@ Perl_mess(pTHX_ const char *pat, va_list *args)
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
 	dTHR;
 	if (PL_curcop->cop_line)
-	    sv_catpvf(sv, " at %_ line %ld",
+	    Perl_sv_catpvf(aTHX_ sv, " at %_ line %ld",
 		      GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
 	if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
 	    bool line_mode = (RsSIMPLE(PL_rs) &&
 			      SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
-	    sv_catpvf(sv, ", <%s> %s %ld",
+	    Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %ld",
 		      PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
 		      line_mode ? "line" : "chunk", 
 		      (long)IoLINES(GvIOp(PL_last_in_gv)));
@@ -1368,11 +1382,10 @@ Perl_mess(pTHX_ const char *pat, va_list *args)
     return sv;
 }
 
-OP *
-Perl_die(pTHX_ const char* pat, ...)
+static OP *
+do_die(pTHX_ const char* pat, va_list *args)
 {
     dTHR;
-    va_list args;
     char *message;
     int was_in_eval = PL_in_eval;
     HV *stash;
@@ -1385,21 +1398,19 @@ Perl_die(pTHX_ const char* pat, ...)
 			  "%p: die: curstack = %p, mainstack = %p\n",
 			  thr, PL_curstack, PL_mainstack));
 
-    va_start(args, pat);
     if (pat) {
-	msv = mess(pat, &args);
+	msv = mess(pat, args);
 	message = SvPV(msv,msglen);
     }
     else {
 	message = Nullch;
     }
-    va_end(args);
 
     DEBUG_S(PerlIO_printf(PerlIO_stderr(),
 			  "%p: die: message = %s\ndiehook = %p\n",
 			  thr, message, PL_diehook));
     if (PL_diehook) {
-	/* sv_2cv might call croak() */
+	/* sv_2cv might call Perl_croak() */
 	SV *olddiehook = PL_diehook;
 	ENTER;
 	SAVESPTR(PL_diehook);
@@ -1439,11 +1450,35 @@ Perl_die(pTHX_ const char* pat, ...)
     return PL_restartop;
 }
 
-void
-Perl_croak(pTHX_ const char* pat, ...)
+#ifdef PERL_IMPLICIT_CONTEXT
+OP *
+Perl_die_nocontext(const char* pat, ...)
 {
-    dTHR;
+    dTHX;
+    OP *o;
     va_list args;
+    va_start(args, pat);
+    o = do_die(aTHX_ pat, &args);
+    va_end(args);
+    return o;
+}
+#endif
+
+OP *
+Perl_die(pTHX_ const char* pat, ...)
+{
+    OP *o;
+    va_list args;
+    va_start(args, pat);
+    o = do_die(aTHX_ pat, &args);
+    va_end(args);
+    return o;
+}
+
+STATIC void
+S_do_croak(pTHX_ const char* pat, va_list *args)
+{
+    dTHR;
     char *message;
     HV *stash;
     GV *gv;
@@ -1451,13 +1486,11 @@ Perl_croak(pTHX_ const char* pat, ...)
     SV *msv;
     STRLEN msglen;
 
-    va_start(args, pat);
-    msv = mess(pat, &args);
+    msv = mess(pat, args);
     message = SvPV(msv,msglen);
-    va_end(args);
     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
     if (PL_diehook) {
-	/* sv_2cv might call croak() */
+	/* sv_2cv might call Perl_croak() */
 	SV *olddiehook = PL_diehook;
 	ENTER;
 	SAVESPTR(PL_diehook);
@@ -1500,10 +1533,32 @@ Perl_croak(pTHX_ const char* pat, ...)
     my_failure_exit();
 }
 
+#ifdef PERL_IMPLICIT_CONTEXT
 void
-Perl_warn(pTHX_ const char* pat,...)
+Perl_croak_nocontext(const char *pat, ...)
 {
+    dTHX;
     va_list args;
+    va_start(args, pat);
+    do_croak(pat, &args);
+    /* NOTREACHED */
+    va_end(args);
+}
+#endif /* PERL_IMPLICIT_CONTEXT */
+
+void
+Perl_croak(pTHX_ const char *pat, ...)
+{
+    va_list args;
+    va_start(args, pat);
+    do_croak(pat, &args);
+    /* NOTREACHED */
+    va_end(args);
+}
+
+STATIC void
+S_do_warn(pTHX_ const char* pat, va_list *args)
+{
     char *message;
     HV *stash;
     GV *gv;
@@ -1511,13 +1566,11 @@ Perl_warn(pTHX_ const char* pat,...)
     SV *msv;
     STRLEN msglen;
 
-    va_start(args, pat);
-    msv = mess(pat, &args);
+    msv = mess(pat, args);
     message = SvPV(msv, msglen);
-    va_end(args);
 
     if (PL_warnhook) {
-	/* sv_2cv might call warn() */
+	/* sv_2cv might call Perl_warn() */
 	dTHR;
 	SV *oldwarnhook = PL_warnhook;
 	ENTER;
@@ -1556,6 +1609,27 @@ Perl_warn(pTHX_ const char* pat,...)
     (void)PerlIO_flush(PerlIO_stderr());
 }
 
+#ifdef PERL_IMPLICIT_CONTEXT
+void
+Perl_warn_nocontext(const char *pat, ...)
+{
+    dTHX;
+    va_list args;
+    va_start(args, pat);
+    do_warn(pat, &args);
+    va_end(args);
+}
+#endif /* PERL_IMPLICIT_CONTEXT */
+
+void
+Perl_warn(pTHX_ const char *pat, ...)
+{
+    va_list args;
+    va_start(args, pat);
+    do_warn(pat, &args);
+    va_end(args);
+}
+
 void
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
@@ -1578,7 +1652,7 @@ Perl_warner(pTHX_ U32  err, const char* pat,...)
         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
 #endif /* USE_THREADS */
         if (PL_diehook) {
-            /* sv_2cv might call croak() */
+            /* sv_2cv might call Perl_croak() */
             SV *olddiehook = PL_diehook;
             ENTER;
             SAVESPTR(PL_diehook);
@@ -1613,7 +1687,7 @@ Perl_warner(pTHX_ U32  err, const char* pat,...)
     }
     else {
         if (PL_warnhook) {
-            /* sv_2cv might call warn() */
+            /* sv_2cv might call Perl_warn() */
             dTHR;
             SV *oldwarnhook = PL_warnhook;
             ENTER;
@@ -1925,7 +1999,7 @@ Perl_my_htonl(pTHX_ long l)
     return u.result;
 #else
 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
-    croak("Unknown BYTEORDER\n");
+    Perl_croak(aTHX_ "Unknown BYTEORDER\n");
 #else
     register I32 o;
     register I32 s;
@@ -1954,7 +2028,7 @@ Perl_my_ntohl(pTHX_ long l)
     return u.l;
 #else
 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
-    croak("Unknown BYTEORDER\n");
+    Perl_croak(aTHX_ "Unknown BYTEORDER\n");
 #else
     register I32 o;
     register I32 s;
@@ -2064,7 +2138,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 		PerlLIO_close(pp[1]);
 	    }
 	    if (!doexec)
-		croak("Can't fork");
+		Perl_croak(aTHX_ "Can't fork");
 	    return Nullfp;
 	}
 	sleep(5);
@@ -2139,7 +2213,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 	}
 	if (n) {			/* Error */
 	    if (n != sizeof(int))
-		croak("panic: kid popen errno read");
+		Perl_croak(aTHX_ "panic: kid popen errno read");
 	    PerlLIO_close(pp[0]);
 	    errno = errkid;		/* Propagate errno from kid */
 	    return Nullfp;
@@ -2422,7 +2496,7 @@ Perl_wait4pid(pTHX_ int pid, int *statusp, int flags)
     {
 	I32 result;
 	if (flags)
-	    croak("Can't do waitpid with flags");
+	    Perl_croak(aTHX_ "Can't do waitpid with flags");
 	else {
 	    while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
 		pidgone(result,*statusp);
@@ -2613,7 +2687,7 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
     while (len && *s >= '0' && *s <= '1') {
       register UV n = retval << 1;
       if (!overflowed && (n >> 1) != retval) {
-          warn("Integer overflow in binary number");
+          Perl_warn(aTHX_ "Integer overflow in binary number");
           overflowed = TRUE;
       }
       retval = n | (*s++ - '0');
@@ -2622,7 +2696,7 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
     if (len && (*s >= '2' && *s <= '9')) {
       dTHR;
       if (ckWARN(WARN_UNSAFE))
-          warner(WARN_UNSAFE, "Illegal binary digit '%c' ignored", *s);
+          Perl_warner(aTHX_ WARN_UNSAFE, "Illegal binary digit '%c' ignored", *s);
     }
     *retlen = s - start;
     return retval;
@@ -2637,7 +2711,7 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
     while (len && *s >= '0' && *s <= '7') {
 	register UV n = retval << 3;
 	if (!overflowed && (n >> 3) != retval) {
-	    warn("Integer overflow in octal number");
+	    Perl_warn(aTHX_ "Integer overflow in octal number");
 	    overflowed = TRUE;
 	}
 	retval = n | (*s++ - '0');
@@ -2646,7 +2720,7 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
     if (len && (*s == '8' || *s == '9')) {
 	dTHR;
 	if (ckWARN(WARN_OCTAL))
-	    warner(WARN_OCTAL, "Illegal octal digit '%c' ignored", *s);
+	    Perl_warner(aTHX_ WARN_OCTAL, "Illegal octal digit '%c' ignored", *s);
     }
     *retlen = s - start;
     return retval;
@@ -2670,13 +2744,13 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
 		dTHR;
 		--s;
 		if (ckWARN(WARN_UNSAFE))
-		    warner(WARN_UNSAFE,"Illegal hex digit '%c' ignored", *s);
+		    Perl_warner(aTHX_ WARN_UNSAFE,"Illegal hex digit '%c' ignored", *s);
 		break;
 	    }
 	}
 	n = retval << 4;
 	if (!overflowed && (n >> 4) != retval) {
-	    warn("Integer overflow in hex number");
+	    Perl_warn(aTHX_ "Integer overflow in hex number");
 	    overflowed = TRUE;
 	}
 	retval = n | ((tmp - PL_hexdigit) & 15);
@@ -2885,7 +2959,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f
 	    seen_dot = 1;			/* Disable message. */
 	if (!xfound) {
 	    if (flags & 1) {			/* do or die? */
-	        croak("Can't %s %s%s%s",
+	        Perl_croak(aTHX_ "Can't %s %s%s%s",
 		      (xfailed ? "execute" : "find"),
 		      (xfailed ? xfailed : scriptname),
 		      (xfailed ? "" : " on PATH"),
@@ -2963,7 +3037,7 @@ Perl_cond_wait(pTHX_ perl_cond *cp)
     perl_cond cond;
 
     if (thr->i.next_run == thr)
-	croak("panic: perl_cond_wait called by last runnable thread");
+	Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
     
     New(666, cond, 1, struct perl_wait_queue);
     cond->thread = thr;
@@ -2983,7 +3057,7 @@ Perl_getTHR(pTHX)
     pthread_addr_t t;
 
     if (pthread_getspecific(PL_thr_key, &t))
-	croak("panic: pthread_getspecific");
+	Perl_croak(aTHX_ "panic: pthread_getspecific");
     return (struct perl_thread *) t;
 }
 #endif
@@ -3036,7 +3110,9 @@ Perl_condpair_magic(pTHX_ SV *sv)
 struct perl_thread *
 Perl_new_struct_thread(pTHX_ struct perl_thread *t)
 {
+#ifndef PERL_IMPLICIT_CONTEXT
     struct perl_thread *thr;
+#endif
     SV *sv;
     SV **svp;
     I32 i;
@@ -3058,10 +3134,10 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
     Zero(thr, 1, struct perl_thread);
 #endif
 
-    PL_protect = FUNC_NAME_TO_PTR(default_protect);
+    PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect);
 
     thr->oursv = sv;
-    init_stacks(ARGS);
+    init_stacks();
 
     PL_curcop = &PL_compiling;
     thr->cvcache = newHV();
@@ -3090,8 +3166,8 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
 
     PL_statname = NEWSV(66,0);
     PL_maxscream = -1;
-    PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
-    PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
+    PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
+    PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
     PL_regindent = 0;
     PL_reginterp_cnt = 0;
     PL_lastscream = Nullsv;