More fixups for thrperl integration.
[p5sagit/p5-mst-13.2.git] / perl.c
diff --git a/perl.c b/perl.c
index fd99e75..242535a 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -72,10 +72,12 @@ static void init_main_stash _((void));
 static void init_perllib _((void));
 static void init_postdump_symbols _((int, char **, char **));
 static void init_predump_symbols _((void));
-static void init_stacks _((void));
 static void my_exit_jump _((void)) __attribute__((noreturn));
 static void nuke_stacks _((void));
 static void open_script _((char *, bool, SV *));
+#ifdef USE_THREADS
+static void thread_destruct _((void *));
+#endif /* USE_THREADS */
 static void usage _((char *));
 static void validate_suid _((char *, char*));
 
@@ -95,6 +97,10 @@ void
 perl_construct( sv_interp )
 register PerlInterpreter *sv_interp;
 {
+#ifdef USE_THREADS
+    struct thread *thr;
+#endif /* USE_THREADS */
+    
     if (!(curinterp = sv_interp))
        return;
 
@@ -102,6 +108,21 @@ register PerlInterpreter *sv_interp;
     Zero(sv_interp, 1, PerlInterpreter);
 #endif
 
+#ifdef USE_THREADS
+#ifdef NEED_PTHREAD_INIT
+    pthread_init();
+#endif /* NEED_PTHREAD_INIT */
+    New(53, thr, 1, struct thread);
+    self = pthread_self();
+    if (pthread_key_create(&thr_key, thread_destruct))
+       croak("panic: pthread_key_create");
+    if (pthread_setspecific(thr_key, (void *) thr))
+       croak("panic: pthread_setspecific");
+    nthreads = 1;
+    cvcache = newHV();
+    thrflags = 0;
+#endif /* USE_THREADS */
+
     /* Init the real globals? */
     if (!linestr) {
        linestr = NEWSV(65,80);
@@ -122,6 +143,12 @@ register PerlInterpreter *sv_interp;
        nrs = newSVpv("\n", 1);
        rs = SvREFCNT_inc(nrs);
 
+       MUTEX_INIT(&malloc_mutex);
+       MUTEX_INIT(&sv_mutex);
+       MUTEX_INIT(&eval_mutex);
+       MUTEX_INIT(&nthreads_mutex);
+       COND_INIT(&nthreads_cond);
+
        pidstatus = newHV();
 
 #ifdef MSDOS
@@ -169,14 +196,42 @@ register PerlInterpreter *sv_interp;
 
     fdpid = newAV();   /* for remembering popen pids by fd */
 
-    init_stacks();
+    init_stacks(ARGS);
+    DEBUG( {
+       New(51,debname,128,char);
+       New(52,debdelim,128,char);
+    } )
+
     ENTER;
 }
 
+#ifdef USE_THREADS
+void
+thread_destruct(arg)
+void *arg;
+{
+    struct thread *thr = (struct thread *) arg;
+    /*
+     * Decrement the global thread count and signal anyone listening.
+     * The only official thread listening is the original thread while
+     * in perl_destruct. It waits until it's the only thread and then
+     * performs END blocks and other process clean-ups.
+     */
+    DEBUG_L(fprintf(stderr, "thread_destruct: 0x%lx\n", (unsigned long) thr));
+
+    Safefree(thr);
+    MUTEX_LOCK(&nthreads_mutex);
+    nthreads--;
+    COND_BROADCAST(&nthreads_cond);
+    MUTEX_UNLOCK(&nthreads_mutex);
+}    
+#endif /* USE_THREADS */
+
 void
 perl_destruct(sv_interp)
 register PerlInterpreter *sv_interp;
 {
+    dTHR;
     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
     I32 last_sv_count;
     HV *hv;
@@ -184,6 +239,22 @@ register PerlInterpreter *sv_interp;
     if (!(curinterp = sv_interp))
        return;
 
+#ifdef USE_THREADS
+    /* Wait until all user-created threads go away */
+    MUTEX_LOCK(&nthreads_mutex);
+    while (nthreads > 1)
+    {
+       DEBUG_L(fprintf(stderr, "perl_destruct: waiting for %d threads\n",
+                       nthreads - 1));
+       COND_WAIT(&nthreads_cond, &nthreads_mutex);
+    }
+    /* At this point, we're the last thread */
+    MUTEX_UNLOCK(&nthreads_mutex);
+    DEBUG_L(fprintf(stderr, "perl_destruct: armageddon has arrived\n"));
+    MUTEX_DESTROY(&nthreads_mutex);
+    COND_DESTROY(&nthreads_cond);
+#endif /* USE_THREADS */
+
     destruct_level = perl_destruct_level;
 #ifdef DEBUGGING
     {
@@ -431,6 +502,11 @@ register PerlInterpreter *sv_interp;
     hints = 0;         /* Reset hints. Should hints be per-interpreter ? */
     
     DEBUG_P(debprofdump());
+#ifdef USE_THREADS
+    MUTEX_DESTROY(&sv_mutex);
+    MUTEX_DESTROY(&malloc_mutex);
+    MUTEX_DESTROY(&eval_mutex);
+#endif /* USE_THREADS */
 
     /* As the absolutely last thing, free the non-arena SV for mess() */
 
@@ -461,6 +537,7 @@ int argc;
 char **argv;
 char **env;
 {
+    dTHR;
     register SV *sv;
     register char *s;
     char *scriptname = NULL;
@@ -761,6 +838,15 @@ print \"  \\@INC:\\n    @INC\\n\";");
     comppad_name_fill = 0;
     min_intro_pending = 0;
     padix = 0;
+#ifdef USE_THREADS
+    av_store(comppad_name, 0, newSVpv("@_", 2));
+    curpad[0] = (SV*)newAV();
+    CvOWNER(compcv) = 0;
+    New(666, CvMUTEXP(compcv), 1, pthread_mutex_t);
+    MUTEX_INIT(CvMUTEXP(compcv));
+    New(666, CvCONDP(compcv), 1, pthread_cond_t);
+    COND_INIT(CvCONDP(compcv));
+#endif /* USE_THREADS */
 
     comppadlist = newAV();
     AvREAL_off(comppadlist);
@@ -830,6 +916,7 @@ int
 perl_run(sv_interp)
 PerlInterpreter *sv_interp;
 {
+    dTHR;
     I32 oldscope;
     dJMPENV;
     int ret;
@@ -878,6 +965,10 @@ PerlInterpreter *sv_interp;
     if (!restartop) {
        DEBUG_x(dump_all());
        DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+#ifdef USE_THREADS
+       DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
+                             (unsigned long) thr));
+#endif /* USE_THREADS */       
 
        if (minus_c) {
            PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
@@ -968,6 +1059,7 @@ char *subname;
 I32 flags;             /* See G_* flags in cop.h */
 register char **argv;  /* null terminated arg list */
 {
+    dTHR;
     dSP;
 
     PUSHMARK(sp);
@@ -994,13 +1086,14 @@ perl_call_method(methname, flags)
 char *methname;                /* name of the subroutine */
 I32 flags;             /* See G_* flags in cop.h */
 {
+    dTHR;
     dSP;
     OP myop;
     if (!op)
        op = &myop;
     XPUSHs(sv_2mortal(newSVpv(methname,0)));
     PUTBACK;
-    pp_method();
+    pp_method(ARGS);
     return perl_call_sv(*stack_sp--, flags);
 }
 
@@ -1010,6 +1103,7 @@ perl_call_sv(sv, flags)
 SV* sv;
 I32 flags;             /* See G_* flags in cop.h */
 {
+    dTHR;
     LOGOP myop;                /* fake syntax tree node */
     SV** sp = stack_sp;
     I32 oldmark;
@@ -1108,7 +1202,7 @@ I32 flags;                /* See G_* flags in cop.h */
        CATCH_SET(TRUE);
 
     if (op == (OP*)&myop)
-       op = pp_entersub();
+       op = pp_entersub(ARGS);
     if (op)
        runops();
     retval = stack_sp - (stack_base + oldmark);
@@ -1151,6 +1245,7 @@ perl_eval_sv(sv, flags)
 SV* sv;
 I32 flags;             /* See G_* flags in cop.h */
 {
+    dTHR;
     UNOP myop;         /* fake syntax tree node */
     SV** sp = stack_sp;
     I32 oldmark = sp - stack_base;
@@ -1214,7 +1309,7 @@ I32 flags;                /* See G_* flags in cop.h */
     }
 
     if (op == (OP*)&myop)
-       op = pp_entereval();
+       op = pp_entereval(ARGS);
     if (op)
        runops();
     retval = stack_sp - (stack_base + oldmark);
@@ -1237,6 +1332,7 @@ perl_eval_pv(p, croak_on_error)
 char* p;
 I32 croak_on_error;
 {
+    dTHR;
     dSP;
     SV* sv = newSVpv(p, 0);
 
@@ -1432,30 +1528,31 @@ char *s;
        forbid_setid("-m");     /* XXX ? */
        if (*++s) {
            char *start;
+           SV *sv;
            char *use = "use ";
            /* -M-foo == 'no foo'       */
            if (*s == '-') { use = "no "; ++s; }
-           Sv = newSVpv(use,0);
+           sv = newSVpv(use,0);
            start = s;
            /* We allow -M'Module qw(Foo Bar)'  */
            while(isALNUM(*s) || *s==':') ++s;
            if (*s != '=') {
-               sv_catpv(Sv, start);
+               sv_catpv(sv, start);
                if (*(start-1) == 'm') {
                    if (*s != '\0')
                        croak("Can't use '%c' after -mname", *s);
-                   sv_catpv( Sv, " ()");
+                   sv_catpv( sv, " ()");
                }
            } else {
-               sv_catpvn(Sv, start, s-start);
-               sv_catpv(Sv, " split(/,/,q{");
-               sv_catpv(Sv, ++s);
-               sv_catpv(Sv,    "})");
+               sv_catpvn(sv, start, s-start);
+               sv_catpv(sv, " split(/,/,q{");
+               sv_catpv(sv, ++s);
+               sv_catpv(sv,    "})");
            }
            s += strlen(s);
            if (preambleav == NULL)
                preambleav = newAV();
-           av_push(preambleav, Sv);
+           av_push(preambleav, sv);
        }
        else
            croak("No space allowed after -%c", *(s-1));
@@ -1575,6 +1672,7 @@ my_unexec()
 static void
 init_main_stash()
 {
+    dTHR;
     GV *gv;
 
     /* Note that strtab is a rather special HV.  Assumptions are made
@@ -2147,6 +2245,7 @@ char *s;
 static void
 init_debugger()
 {
+    dTHR;
     curstash = debstash;
     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
     AvREAL_off(dbargs);
@@ -2162,8 +2261,9 @@ init_debugger()
     curstash = defstash;
 }
 
-static void
-init_stacks()
+void
+init_stacks(ARGS)
+dARGS
 {
     curstack = newAV();
     mainstack = curstack;              /* remember in case we switch stacks */
@@ -2182,11 +2282,6 @@ init_stacks()
     tmps_ix = -1;
     tmps_max = 128;
 
-    DEBUG( {
-       New(51,debname,128,char);
-       New(52,debdelim,128,char);
-    } )
-
     /*
      * The following stacks almost certainly should be per-interpreter,
      * but for now they're not.  XXX
@@ -2228,6 +2323,7 @@ init_stacks()
 static void
 nuke_stacks()
 {
+    dTHR;
     Safefree(cxstack);
     Safefree(tmps_stack);
     DEBUG( {
@@ -2250,6 +2346,7 @@ init_lexer()
 static void
 init_predump_symbols()
 {
+    dTHR;
     GV *tmpgv;
     GV *othergv;
 
@@ -2533,6 +2630,7 @@ call_list(oldscope, list)
 I32 oldscope;
 AV* list;
 {
+    dTHR;
     line_t oldline = curcop->cop_line;
     STRLEN len;
     dJMPENV;
@@ -2605,6 +2703,12 @@ void
 my_exit(status)
 U32 status;
 {
+    dTHR;
+
+#ifdef USE_THREADS
+    DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
+                        (unsigned long) thr, (unsigned long) status));
+#endif /* USE_THREADS */
     switch (status) {
     case 0:
        STATUS_ALL_SUCCESS;
@@ -2645,6 +2749,7 @@ my_failure_exit()
 static void
 my_exit_jump()
 {
+    dTHR;
     register CONTEXT *cx;
     I32 gimme;
     SV **newsp;