initial stub implementation of implicit thread/this

pointer	argument; builds/tests on Solaris, win32
hasn't been fixed up yet; proto.h, global.sym and
static function decls are now generated from a common
database in proto.pl; some inconsistently named
perl_foo() things are now Perl_foo(), compatibility
#defines provided; perl_foo() (lowercase 'p') reserved
for functions that take an explicit context argument;
next step: generate #define foo(a,b) Perl_foo(aTHX_ a,b)

p4raw-id: //depot/perl@3522

1 files changed, 65 insertions, 132 deletions

diff --git a/perl.c b/perl.c
index 7fad9f043f..87aa87082e 100644
--- a/perl.c
+++ b/perl.c
@@ -12,6 +12,7 @@
  */
 
 #include "EXTERN.h"
+#define PERL_IN_PERL_C
 #include "perl.h"
 
 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
@@ -43,41 +44,8 @@ char *getenv (char *); /* Usually in <stdlib.h> */
 #endif
 
 #ifdef PERL_OBJECT
-static I32 read_e_script (CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen);
-#else
-static void find_beginning (void);
-static void forbid_setid (char *);
-static void incpush (char *, int);
-static void init_interp (void);
-static void init_ids (void);
-static void init_debugger (void);
-static void init_lexer (void);
-static void init_main_stash (void);
-static void *perl_parse_body (va_list args);
-static void *perl_run_body (va_list args);
-static void *perl_call_body (va_list args);
-static void perl_call_xbody (OP *myop, int is_eval);
-static void *call_list_body (va_list args);
-#ifdef USE_THREADS
-static struct perl_thread * init_main_thread (void);
-#endif /* USE_THREADS */
-static void init_perllib (void);
-static void init_postdump_symbols (int, char **, char **);
-static void init_predump_symbols (void);
-static void my_exit_jump (void) __attribute__((noreturn));
-static void nuke_stacks (void);
-static void open_script (char *, bool, SV *, int *fd);
-static void usage (char *);
-#ifdef IAMSUID
-static int  fd_on_nosuid_fs (int);
-#endif
-static void validate_suid (char *, char*, int);
-static I32 read_e_script (int idx, SV *buf_sv, int maxlen);
-#endif
-
-#ifdef PERL_OBJECT
 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
-					     IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
+		     IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
 {
     CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
     if(pPerl != NULL)
@@ -87,7 +55,7 @@ CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
 }
 #else
 PerlInterpreter *
-perl_alloc(void)
+perl_alloc(pTHX)
 {
     PerlInterpreter *sv_interp;
 
@@ -98,11 +66,7 @@ perl_alloc(void)
 #endif /* PERL_OBJECT */
 
 void
-#ifdef PERL_OBJECT
-perl_construct(void)
-#else
 perl_construct(register PerlInterpreter *sv_interp)
-#endif
 {
 #ifdef USE_THREADS
     int i;
@@ -240,11 +204,7 @@ perl_construct(register PerlInterpreter *sv_interp)
 }
 
 void
-#ifdef PERL_OBJECT
-perl_destruct(void)
-#else
 perl_destruct(register PerlInterpreter *sv_interp)
-#endif
 {
     dTHR;
     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
@@ -602,11 +562,7 @@ perl_destruct(register PerlInterpreter *sv_interp)
 }
 
 void
-#ifdef PERL_OBJECT
-perl_free(void)
-#else
 perl_free(PerlInterpreter *sv_interp)
-#endif
 {
 #ifdef PERL_OBJECT
 	Safefree(this);
@@ -618,11 +574,7 @@ perl_free(PerlInterpreter *sv_interp)
 }
 
 void
-#ifdef PERL_OBJECT
-perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
-#else
-perl_atexit(void (*fn) (void *), void *ptr)
-#endif
+Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
 {
     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
     PL_exitlist[PL_exitlistlen].fn = fn;
@@ -630,18 +582,8 @@ perl_atexit(void (*fn) (void *), void *ptr)
     ++PL_exitlistlen;
 }
 
-#ifdef PERL_OBJECT
-    typedef void (*xs_init_t)(CPerlObj*);
-#else
-    typedef void (*xs_init_t)(void);
-#endif
-
 int
-#ifdef PERL_OBJECT
-perl_parse(xs_init_t xsinit, int argc, char **argv, char **env)
-#else
-perl_parse(PerlInterpreter *sv_interp, xs_init_t xsinit, int argc, char **argv, char **env)
-#endif
+perl_parse(PerlInterpreter *sv_interp, XSINIT_t xsinit, int argc, char **argv, char **env)
 {
     dTHR;
     I32 oldscope;
@@ -696,7 +638,7 @@ setuid perl scripts securely.\n");
     oldscope = PL_scopestack_ix;
     PL_dowarn = G_WARN_OFF;
 
-    CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_parse_body), env, xsinit);
+    CALLPROTECT(&ret, FUNC_NAME_TO_PTR(parse_body), env, xsinit);
     switch (ret) {
     case 0:
 	return 0;
@@ -720,7 +662,7 @@ setuid perl scripts securely.\n");
 }
 
 STATIC void *
-perl_parse_body(va_list args)
+parse_body(pTHX_ va_list args)
 {
     dTHR;
     int argc = PL_origargc;
@@ -734,7 +676,7 @@ perl_parse_body(va_list args)
     register SV *sv;
     register char *s;
 
-    xs_init_t xsinit = va_arg(args, xs_init_t);
+    XSINIT_t xsinit = va_arg(args, XSINIT_t);
 
     sv_setpvn(PL_linestr,"",0);
     sv = newSVpvn("",0);		/* first used for -I flags */
@@ -1032,7 +974,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
     /* now that script is parsed, we can modify record separator */
     SvREFCNT_dec(PL_rs);
     PL_rs = SvREFCNT_inc(PL_nrs);
-    sv_setsv(perl_get_sv("/", TRUE), PL_rs);
+    sv_setsv(get_sv("/", TRUE), PL_rs);
     if (PL_do_undump)
 	my_unexec();
 
@@ -1053,11 +995,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 }
 
 int
-#ifdef PERL_OBJECT
-perl_run(void)
-#else
 perl_run(PerlInterpreter *sv_interp)
-#endif
 {
     dTHR;
     I32 oldscope;
@@ -1071,7 +1009,7 @@ perl_run(PerlInterpreter *sv_interp)
     oldscope = PL_scopestack_ix;
 
  redo_body:
-    CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_run_body), oldscope);
+    CALLPROTECT(&ret, FUNC_NAME_TO_PTR(run_body), oldscope);
     switch (ret) {
     case 1:
 	cxstack_ix = -1;		/* start context stack again */
@@ -1104,7 +1042,7 @@ perl_run(PerlInterpreter *sv_interp)
 }
 
 STATIC void *
-perl_run_body(va_list args)
+run_body(pTHX_ va_list args)
 {
     dTHR;
     I32 oldscope = va_arg(args, I32);
@@ -1145,7 +1083,7 @@ perl_run_body(va_list args)
 }
 
 SV*
-perl_get_sv(const char *name, I32 create)
+Perl_get_sv(pTHX_ const char *name, I32 create)
 {
     GV *gv;
 #ifdef USE_THREADS
@@ -1164,7 +1102,7 @@ perl_get_sv(const char *name, I32 create)
 }
 
 AV*
-perl_get_av(const char *name, I32 create)
+Perl_get_av(pTHX_ const char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
     if (create)
@@ -1175,7 +1113,7 @@ perl_get_av(const char *name, I32 create)
 }
 
 HV*
-perl_get_hv(const char *name, I32 create)
+Perl_get_hv(pTHX_ const char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
     if (create)
@@ -1186,7 +1124,7 @@ perl_get_hv(const char *name, I32 create)
 }
 
 CV*
-perl_get_cv(const char *name, I32 create)
+Perl_get_cv(pTHX_ const char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
     /* XXX unsafe for threads if eval_owner isn't held */
@@ -1206,7 +1144,7 @@ perl_get_cv(const char *name, I32 create)
 /* Be sure to refetch the stack pointer after calling these routines. */
 
 I32
-perl_call_argv(const char *sub_name, I32 flags, register char **argv)
+Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
               
           		/* See G_* flags in cop.h */
                      	/* null terminated arg list */
@@ -1221,19 +1159,19 @@ perl_call_argv(const char *sub_name, I32 flags, register char **argv)
 	}
 	PUTBACK;
     }
-    return perl_call_pv(sub_name, flags);
+    return call_pv(sub_name, flags);
 }
 
 I32
-perl_call_pv(const char *sub_name, I32 flags)
+Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
               		/* name of the subroutine */
           		/* See G_* flags in cop.h */
 {
-    return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
+    return call_sv((SV*)get_cv(sub_name, TRUE), flags);
 }
 
 I32
-perl_call_method(const char *methname, I32 flags)
+Perl_call_method(pTHX_ const char *methname, I32 flags)
                		/* name of the subroutine */
           		/* See G_* flags in cop.h */
 {
@@ -1246,12 +1184,12 @@ perl_call_method(const char *methname, I32 flags)
     pp_method(ARGS);
 	if(PL_op == &myop)
 		PL_op = Nullop;
-    return perl_call_sv(*PL_stack_sp--, flags);
+    return call_sv(*PL_stack_sp--, flags);
 }
 
 /* May be called with any of a CV, a GV, or an SV containing the name. */
 I32
-perl_call_sv(SV *sv, I32 flags)
+Perl_call_sv(pTHX_ SV *sv, I32 flags)
        
           		/* See G_* flags in cop.h */
 {
@@ -1295,7 +1233,7 @@ perl_call_sv(SV *sv, I32 flags)
 
     if (!(flags & G_EVAL)) {
 	CATCH_SET(TRUE);
-	perl_call_xbody((OP*)&myop, FALSE);
+	call_xbody((OP*)&myop, FALSE);
 	retval = PL_stack_sp - (PL_stack_base + oldmark);
 	CATCH_SET(FALSE);
     }
@@ -1324,7 +1262,7 @@ perl_call_sv(SV *sv, I32 flags)
 	PL_markstack_ptr++;
 
   redo_body:
-	CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_call_body), (OP*)&myop, FALSE);
+	CALLPROTECT(&ret, FUNC_NAME_TO_PTR(call_body), (OP*)&myop, FALSE);
 	switch (ret) {
 	case 0:
 	    retval = PL_stack_sp - (PL_stack_base + oldmark);
@@ -1384,17 +1322,17 @@ perl_call_sv(SV *sv, I32 flags)
 }
 
 STATIC void *
-perl_call_body(va_list args)
+call_body(pTHX_ va_list args)
 {
     OP *myop = va_arg(args, OP*);
     int is_eval = va_arg(args, int);
 
-    perl_call_xbody(myop, is_eval);
+    call_xbody(myop, is_eval);
     return NULL;
 }
 
 STATIC void
-perl_call_xbody(OP *myop, int is_eval)
+call_xbody(pTHX_ OP *myop, int is_eval)
 {
     dTHR;
 
@@ -1411,7 +1349,7 @@ perl_call_xbody(OP *myop, int is_eval)
 /* Eval a string. The G_EVAL flag is always assumed. */
 
 I32
-perl_eval_sv(SV *sv, I32 flags)
+Perl_eval_sv(pTHX_ SV *sv, I32 flags)
        
           		/* See G_* flags in cop.h */
 {
@@ -1446,7 +1384,7 @@ perl_eval_sv(SV *sv, I32 flags)
 	myop.op_flags |= OPf_SPECIAL;
 
  redo_body:
-    CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_call_body), (OP*)&myop, TRUE);
+    CALLPROTECT(&ret, FUNC_NAME_TO_PTR(call_body), (OP*)&myop, TRUE);
     switch (ret) {
     case 0:
 	retval = PL_stack_sp - (PL_stack_base + oldmark);
@@ -1491,13 +1429,13 @@ perl_eval_sv(SV *sv, I32 flags)
 }
 
 SV*
-perl_eval_pv(const char *p, I32 croak_on_error)
+Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
 {
     dSP;
     SV* sv = newSVpv(p, 0);
 
     PUSHMARK(SP);
-    perl_eval_sv(sv, G_SCALAR);
+    eval_sv(sv, G_SCALAR);
     SvREFCNT_dec(sv);
 
     SPAGAIN;
@@ -1515,7 +1453,7 @@ perl_eval_pv(const char *p, I32 croak_on_error)
 /* Require a module. */
 
 void
-perl_require_pv(const char *pv)
+Perl_require_pv(pTHX_ const char *pv)
 {
     SV* sv;
     dSP;
@@ -1525,13 +1463,13 @@ perl_require_pv(const char *pv)
     sv_setpv(sv, "require '");
     sv_catpv(sv, pv);
     sv_catpv(sv, "'");
-    perl_eval_sv(sv, G_DISCARD);
+    eval_sv(sv, G_DISCARD);
     SPAGAIN;
     POPSTACK;
 }
 
 void
-magicname(char *sym, char *name, I32 namlen)
+Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
 {
     register GV *gv;
 
@@ -1540,8 +1478,7 @@ magicname(char *sym, char *name, I32 namlen)
 }
 
 STATIC void
-usage(char *name)		/* XXX move this out into a module ? */
-           
+usage(pTHX_ char *name)		/* XXX move this out into a module ? */
 {
     /* This message really ought to be max 23 lines.
      * Removed -h because the user already knows that opton. Others? */
@@ -1583,7 +1520,7 @@ NULL
 /* This routine handles any switches that can be given during run */
 
 char *
-moreswitches(char *s)
+Perl_moreswitches(pTHX_ char *s)
 {
     I32 numlen;
     U32 rschar;
@@ -1873,7 +1810,7 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
 
 void
-my_unexec(void)
+Perl_my_unexec(pTHX)
 {
 #ifdef UNEXEC
     SV*    prog;
@@ -1901,7 +1838,7 @@ my_unexec(void)
 
 /* initialize curinterp */
 STATIC void
-init_interp(void)
+init_interp(pTHX)
 {
 
 #ifdef PERL_OBJECT		/* XXX kludge */
@@ -1968,7 +1905,7 @@ init_interp(void)
 }
 
 STATIC void
-init_main_stash(void)
+init_main_stash(pTHX)
 {
     dTHR;
     GV *gv;
@@ -2007,11 +1944,11 @@ init_main_stash(void)
     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
     /* We must init $/ before switches are processed. */
-    sv_setpvn(perl_get_sv("/", TRUE), "\n", 1);
+    sv_setpvn(get_sv("/", TRUE), "\n", 1);
 }
 
 STATIC void
-open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
+open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 {
     dTHR;
     register char *s;
@@ -2174,8 +2111,8 @@ sed %s -e \"/^[^#]/b\" \
  * here so that metaconfig picks them up. */
 
 #ifdef IAMSUID
-static int
-fd_on_nosuid_fs(int fd)
+STATIC int
+fd_on_nosuid_fs(pTHX_ int fd)
 {
     int on_nosuid  = 0;
     int check_okay = 0;
@@ -2238,7 +2175,7 @@ fd_on_nosuid_fs(int fd)
 #endif /* IAMSUID */
 
 STATIC void
-validate_suid(char *validarg, char *scriptname, int fdscript)
+validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
 {
     int which;
 
@@ -2483,7 +2420,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 }
 
 STATIC void
-find_beginning(void)
+find_beginning(pTHX)
 {
     register char *s, *s2;
 
@@ -2513,7 +2450,7 @@ find_beginning(void)
 
 
 STATIC void
-init_ids(void)
+init_ids(pTHX)
 {
     PL_uid = (int)PerlProc_getuid();
     PL_euid = (int)PerlProc_geteuid();
@@ -2527,7 +2464,7 @@ init_ids(void)
 }
 
 STATIC void
-forbid_setid(char *s)
+forbid_setid(pTHX_ char *s)
 {
     if (PL_euid != PL_uid)
         croak("No %s allowed while running setuid", s);
@@ -2536,7 +2473,7 @@ forbid_setid(char *s)
 }
 
 STATIC void
-init_debugger(void)
+init_debugger(pTHX)
 {
     dTHR;
     PL_curstash = PL_debstash;
@@ -2561,7 +2498,7 @@ init_debugger(void)
 #endif
 
 void
-init_stacks(ARGSproto)
+Perl_init_stacks(pTHX_ ARGSproto)
 {
     /* start with 128-item stack and 8K cxstack */
     PL_curstackinfo = new_stackinfo(REASONABLE(128),
@@ -2601,7 +2538,7 @@ init_stacks(ARGSproto)
 #undef REASONABLE
 
 STATIC void
-nuke_stacks(void)
+nuke_stacks(pTHX)
 {
     dTHR;
     while (PL_curstackinfo->si_next)
@@ -2629,7 +2566,7 @@ static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
 #endif
 
 STATIC void
-init_lexer(void)
+init_lexer(pTHX)
 {
 #ifdef PERL_OBJECT
 	PerlIO *tmpfp;
@@ -2642,13 +2579,13 @@ init_lexer(void)
 }
 
 STATIC void
-init_predump_symbols(void)
+init_predump_symbols(pTHX)
 {
     dTHR;
     GV *tmpgv;
     GV *othergv;
 
-    sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
+    sv_setpvn(get_sv("\"", TRUE), " ", 1);
     PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
     GvMULTI_on(PL_stdingv);
     IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
@@ -2678,7 +2615,7 @@ init_predump_symbols(void)
 }
 
 STATIC void
-init_postdump_symbols(register int argc, register char **argv, register char **env)
+init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
 {
     dTHR;
     char *s;
@@ -2766,7 +2703,7 @@ init_postdump_symbols(register int argc, register char **argv, register char **e
 }
 
 STATIC void
-init_perllib(void)
+init_perllib(pTHX)
 {
     char *s;
     if (!PL_tainting) {
@@ -2837,7 +2774,7 @@ init_perllib(void)
 #endif 
 
 STATIC void
-incpush(char *p, int addsubdirs)
+incpush(pTHX_ char *p, int addsubdirs)
 {
     SV *subdir = Nullsv;
 
@@ -2925,7 +2862,7 @@ incpush(char *p, int addsubdirs)
 
 #ifdef USE_THREADS
 STATIC struct perl_thread *
-init_main_thread()
+init_main_thread(pTHX)
 {
     struct perl_thread *thr;
     XPV *xpv;
@@ -2996,7 +2933,7 @@ init_main_thread()
 #endif /* USE_THREADS */
 
 void
-call_list(I32 oldscope, AV *paramList)
+Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 {
     dTHR;
     SV *atsv = ERRSV;
@@ -3059,18 +2996,18 @@ call_list(I32 oldscope, AV *paramList)
 }
 
 STATIC void *
-call_list_body(va_list args)
+call_list_body(pTHX_ va_list args)
 {
     dTHR;
     CV *cv = va_arg(args, CV*);
 
     PUSHMARK(PL_stack_sp);
-    perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
+    call_sv((SV*)cv, G_EVAL|G_DISCARD);
     return NULL;
 }
 
 void
-my_exit(U32 status)
+Perl_my_exit(pTHX_ U32 status)
 {
     dTHR;
 
@@ -3091,7 +3028,7 @@ my_exit(U32 status)
 }
 
 void
-my_failure_exit(void)
+Perl_my_failure_exit(pTHX)
 {
 #ifdef VMS
     if (vaxc$errno & 1) {
@@ -3120,7 +3057,7 @@ my_failure_exit(void)
 }
 
 STATIC void
-my_exit_jump(void)
+my_exit_jump(pTHX)
 {
     dTHR;
     register PERL_CONTEXT *cx;
@@ -3149,12 +3086,8 @@ my_exit_jump(void)
 
 #include "XSUB.h"
 
-static I32
-#ifdef PERL_OBJECT
-read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
-#else
-read_e_script(int idx, SV *buf_sv, int maxlen)
-#endif
+STATIC I32
+read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
 {
     char *p, *nl;
     p  = SvPVX(PL_e_script);