Fix segfaults when mainthread exits with other threads running:
Nick Ing-Simmons [Wed, 3 Apr 2002 13:15:30 +0000 (13:15 +0000)]
 - track number of running threads
 - if main thread calls perl_destruct() with other threads running
   skip most of cleanup (with a warning).

p4raw-id: //depot/perlio@15698

embed.fnc
embed.h
embedvar.h
ext/threads/threads.xs
global.sym
perl.c
perl.h
perlapi.h
perlvars.h
pod/perlapi.pod
proto.h

index 9ecf123..36a58b3 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -957,6 +957,7 @@ Ap |char * |custom_op_desc|OP* op
 Adp    |void   |sv_nosharing   |SV *
 Adp    |void   |sv_nolocking   |SV *
 Adp    |void   |sv_nounlocking |SV *
+Adp    |int    |nothreadhook
 
 END_EXTERN_C
 
diff --git a/embed.h b/embed.h
index 8dd9b60..6d0049f 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define sv_nosharing           Perl_sv_nosharing
 #define sv_nolocking           Perl_sv_nolocking
 #define sv_nounlocking         Perl_sv_nounlocking
+#define nothreadhook           Perl_nothreadhook
 #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
 #define avhv_index_sv          S_avhv_index_sv
 #define avhv_index             S_avhv_index
 #define sv_nosharing(a)                Perl_sv_nosharing(aTHX_ a)
 #define sv_nolocking(a)                Perl_sv_nolocking(aTHX_ a)
 #define sv_nounlocking(a)      Perl_sv_nounlocking(aTHX_ a)
+#define nothreadhook()         Perl_nothreadhook(aTHX)
 #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
 #define avhv_index_sv(a)       S_avhv_index_sv(aTHX_ a)
 #define avhv_index(a,b,c)      S_avhv_index(aTHX_ a,b,c)
index 8eccfa2..3799178 100644 (file)
 #define PL_runops_std          (PL_Vars.Grunops_std)
 #define PL_sharehook           (PL_Vars.Gsharehook)
 #define PL_thr_key             (PL_Vars.Gthr_key)
+#define PL_threadhook          (PL_Vars.Gthreadhook)
 #define PL_unlockhook          (PL_Vars.Gunlockhook)
 
 #else /* !PERL_GLOBAL_STRUCT */
 #define PL_Grunops_std         PL_runops_std
 #define PL_Gsharehook          PL_sharehook
 #define PL_Gthr_key            PL_thr_key
+#define PL_Gthreadhook         PL_threadhook
 #define PL_Gunlockhook         PL_unlockhook
 
 #endif /* PERL_GLOBAL_STRUCT */
index 006e552..393867e 100755 (executable)
@@ -41,6 +41,12 @@ STMT_START {\
 #endif
 #endif
 
+/* Values for 'state' member */
+#define PERL_ITHR_JOINABLE             0
+#define PERL_ITHR_DETACHED             1
+#define PERL_ITHR_FINISHED             4
+#define PERL_ITHR_JOINED               2
+
 typedef struct ithread_s {
     struct ithread_s *next;    /* next thread in the list */
     struct ithread_s *prev;    /* prev thread in the list */
@@ -48,7 +54,7 @@ typedef struct ithread_s {
     I32 tid;                   /* threads module's thread id */
     perl_mutex mutex;          /* mutex for updating things in this struct */
     I32 count;                 /* how many SVs have a reference to us */
-    signed char detached;      /* are we detached ? */
+    signed char state;         /* are we detached ? */
     int gimme;                 /* Context of create */
     SV* init_function;          /* Code to run */
     SV* params;                 /* args to pass function */
@@ -72,6 +78,7 @@ ithread *threads;
 static perl_mutex create_destruct_mutex;  /* protects the creation and destruction of threads*/
 
 I32 tid_counter = 0;
+I32 known_threads = 0;
 I32 active_threads = 0;
 perl_key self_key;
 
@@ -79,9 +86,12 @@ perl_key self_key;
  *  Clear up after thread is done with
  */
 void
-Perl_ithread_destruct (pTHX_ ithread* thread)
+Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
 {
        MUTEX_LOCK(&thread->mutex);
+       if (!thread->next) {
+           Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
+       }
        if (thread->count != 0) {
                MUTEX_UNLOCK(&thread->mutex);
                return;
@@ -98,14 +108,17 @@ Perl_ithread_destruct (pTHX_ ithread* thread)
            if (threads == thread) {
                threads = thread->next;
            }
+           thread->next = NULL;
+           thread->prev = NULL;
        }
-       active_threads--;
-       MUTEX_UNLOCK(&create_destruct_mutex);
-       /* Thread is now disowned */
+       known_threads--;
+       assert( known_threads >= 0 );
 #if 0
-        Perl_warn(aTHX_ "destruct %d @ %p by %p",
-                 thread->tid,thread->interp,aTHX);
+        Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
+                 thread->tid,thread->interp,aTHX, known_threads);
 #endif
+       MUTEX_UNLOCK(&create_destruct_mutex);
+       /* Thread is now disowned */
        if (thread->interp) {
            dTHXa(thread->interp);
            PERL_SET_CONTEXT(thread->interp);
@@ -117,6 +130,41 @@ Perl_ithread_destruct (pTHX_ ithread* thread)
        MUTEX_UNLOCK(&thread->mutex);
 }
 
+int
+Perl_ithread_hook(pTHX)
+{
+    int veto_cleanup = 0;
+    MUTEX_LOCK(&create_destruct_mutex);
+    if (aTHX == PL_curinterp && active_threads != 1) {
+       Perl_warn(aTHX_ "Cleanup skipped %d active threads", active_threads);
+       veto_cleanup = 1;
+    }
+    MUTEX_UNLOCK(&create_destruct_mutex);
+    return veto_cleanup;
+}
+
+void
+Perl_ithread_detach(pTHX_ ithread *thread)
+{
+    MUTEX_LOCK(&thread->mutex);
+    if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
+       thread->state |= PERL_ITHR_DETACHED;
+#ifdef WIN32
+       CloseHandle(thread->handle);
+       thread->handle = 0;
+#else
+       PERL_THREAD_DETACH(thread->thr);
+#endif
+    }
+    if ((thread->state & PERL_ITHR_FINISHED) &&
+        (thread->state & PERL_ITHR_DETACHED)) {
+       MUTEX_UNLOCK(&thread->mutex);
+       Perl_ithread_destruct(aTHX_ thread, "detach");
+    }
+    else {
+       MUTEX_UNLOCK(&thread->mutex);
+    }
+}
 
 /* MAGIC (in mg.h sense) hooks */
 
@@ -135,9 +183,16 @@ ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
     ithread *thread = (ithread *) mg->mg_ptr;
     MUTEX_LOCK(&thread->mutex);
     thread->count--;
-    MUTEX_UNLOCK(&thread->mutex);
-    /* This is safe as it re-checks count */
-    Perl_ithread_destruct(aTHX_ thread);
+    if (thread->count == 0) {
+       if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
+           Perl_warn(aTHX_ "Implicit detach");
+       }
+       MUTEX_UNLOCK(&thread->mutex);
+       Perl_ithread_detach(aTHX_ thread);
+    }
+    else {
+       MUTEX_UNLOCK(&thread->mutex);
+    }
     return 0;
 }
 
@@ -220,16 +275,21 @@ Perl_ithread_run(void * arg) {
        }
 
        PerlIO_flush((PerlIO*)NULL);
+       MUTEX_LOCK(&create_destruct_mutex);
+       active_threads--;
+       assert( active_threads >= 0 );
+       MUTEX_UNLOCK(&create_destruct_mutex);
        MUTEX_LOCK(&thread->mutex);
-       if (thread->detached & 1) {
+       thread->state |= PERL_ITHR_FINISHED;
+
+       if (thread->state & PERL_ITHR_DETACHED) {
                MUTEX_UNLOCK(&thread->mutex);
                SvREFCNT_dec(thread->params);
                thread->params = Nullsv;
-               Perl_ithread_destruct(aTHX_ thread);
+               Perl_ithread_destruct(aTHX_ thread, "detached finish");
        } else {
-               thread->detached |= 4;
-               MUTEX_UNLOCK(&thread->mutex);
-       }
+               MUTEX_UNLOCK(&thread->mutex);
+       }
 #ifdef WIN32
        return (DWORD)0;
 #else
@@ -296,7 +356,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
        MUTEX_INIT(&thread->mutex);
        thread->tid = tid_counter++;
        thread->gimme = GIMME_V;
-       thread->detached = (thread->gimme == G_VOID) ? 1 : 0;
+       thread->state = (thread->gimme == G_VOID) ? 1 : 0;
 
        /* "Clone" our interpreter into the thread's interpreter
         * This gives thread access to "static data" and code.
@@ -317,7 +377,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
        {
            dTHXa(thread->interp);
             /* Here we remove END blocks since they should only run
-              in the thread they are created 
+              in the thread they are created
             */
             SvREFCNT_dec(PL_endav);
             PL_endav = newAV();
@@ -368,6 +428,7 @@ Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* param
 #endif
        }
 #endif
+       known_threads++;
        active_threads++;
        MUTEX_UNLOCK(&create_destruct_mutex);
        return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
@@ -399,16 +460,16 @@ Perl_ithread_CLONE(pTHX_ SV *obj)
   }
 }
 
-AV* 
+AV*
 Perl_ithread_join(pTHX_ SV *obj)
 {
     ithread *thread = SV_to_ithread(aTHX_ obj);
     MUTEX_LOCK(&thread->mutex);
-    if (thread->detached & 1) {
+    if (thread->state & PERL_ITHR_DETACHED) {
        MUTEX_UNLOCK(&thread->mutex);
        Perl_croak(aTHX_ "Cannot join a detached thread");
     }
-    else if (thread->detached & 2) {
+    else if (thread->state & PERL_ITHR_JOINED) {
        MUTEX_UNLOCK(&thread->mutex);
        Perl_croak(aTHX_ "Thread already joined");
     }
@@ -427,8 +488,9 @@ Perl_ithread_join(pTHX_ SV *obj)
 #endif
        MUTEX_LOCK(&thread->mutex);
        
+       /* sv_dup over the args */
        {
-         AV* params = (AV*) SvRV(thread->params);        
+         AV* params = (AV*) SvRV(thread->params);      
          CLONE_PARAMS clone_params;
          clone_params.stashes = newAV();
          PL_ptr_table = ptr_table_new();
@@ -439,35 +501,17 @@ Perl_ithread_join(pTHX_ SV *obj)
          PL_ptr_table = NULL;
 
        }
-       /* sv_dup over the args */
        /* We have finished with it */
-       thread->detached |= 2;
+       thread->state |= PERL_ITHR_JOINED;
        MUTEX_UNLOCK(&thread->mutex);
        sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
-       Perl_ithread_destruct(aTHX_ thread);
+       Perl_ithread_destruct(aTHX_ thread, "joined");
        return retparam;
     }
     return (AV*)NULL;
 }
 
 void
-Perl_ithread_detach(pTHX_ ithread *thread)
-{
-    MUTEX_LOCK(&thread->mutex);
-    if (!thread->detached) {
-       thread->detached = 1;
-#ifdef WIN32
-       CloseHandle(thread->handle);
-       thread->handle = 0;
-#else
-       PERL_THREAD_DETACH(thread->thr);
-#endif
-    }
-    MUTEX_UNLOCK(&thread->mutex);
-}
-
-
-void
 Perl_ithread_DESTROY(pTHX_ SV *sv)
 {
     ithread *thread = SV_to_ithread(aTHX_ sv);
@@ -534,6 +578,7 @@ BOOT:
        PERL_THREAD_ALLOC_SPECIFIC(self_key);
        MUTEX_INIT(&create_destruct_mutex);
        MUTEX_LOCK(&create_destruct_mutex);
+       PL_threadhook = &Perl_ithread_hook;
        thread  = PerlMemShared_malloc(sizeof(ithread));
        Zero(thread,1,ithread);
        PL_perl_destruct_level = 2;
@@ -544,13 +589,15 @@ BOOT:
        thread->interp = aTHX;
        thread->count  = 1;  /* imortal */
        thread->tid = tid_counter++;
+       known_threads++;
        active_threads++;
-       thread->detached = 1;
+       thread->state = 1;
 #ifdef WIN32
        thread->thr = GetCurrentThreadId();
 #else
        thread->thr = pthread_self();
 #endif
+
        PERL_THREAD_SETSPECIFIC(self_key,thread);
        MUTEX_UNLOCK(&create_destruct_mutex);
 }
index f86942e..3eb8d34 100644 (file)
@@ -608,6 +608,7 @@ Perl_custom_op_desc
 Perl_sv_nosharing
 Perl_sv_nolocking
 Perl_sv_nounlocking
+Perl_nothreadhook
 Perl_sv_setsv_flags
 Perl_sv_catpvn_flags
 Perl_sv_catsv_flags
diff --git a/perl.c b/perl.c
index ca21f18..bc69454 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -294,6 +294,21 @@ perl_construct(pTHXx)
 }
 
 /*
+=for apidoc nothreadhook
+
+Stub that provides thread hook for perl_destruct when there are
+no threads.
+
+=cut
+*/
+
+int
+Perl_nothreadhook(pTHXx)
+{
+    return 0;
+}
+
+/*
 =for apidoc perl_destruct
 
 Shuts down a Perl interpreter.  See L<perlembed>.
@@ -410,6 +425,11 @@ perl_destruct(pTHXx)
     LEAVE;
     FREETMPS;
 
+    if (CALL_FPTR(PL_threadhook)(aTHX)) {
+        /* Threads hook has vetoed further cleanup */
+        return STATUS_NATIVE_EXPORT;;
+    }
+
     /* We must account for everything.  */
 
     /* Destroy the main CV and syntax tree */
@@ -2776,8 +2796,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 
 
         /* This strips off Perl comments which might interfere with
-           the C pre-processor, including #!.  #line directives are 
-           deliberately stripped to avoid confusion with Perl's version 
+           the C pre-processor, including #!.  #line directives are
+           deliberately stripped to avoid confusion with Perl's version
            of #line.  FWP played some golf with it so it will fit
            into VMS's 255 character buffer.
         */
@@ -2788,7 +2808,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 
         Perl_sv_setpvf(aTHX_ cmd, "\
 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
-                       perl, quote, code, quote, scriptname, cpp, 
+                       perl, quote, code, quote, scriptname, cpp,
                        cpp_discard_flag, sv, CPPMINUS);
 
        PL_doextract = FALSE;
@@ -2812,8 +2832,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
        }
 #       endif /* IAMSUID */
 
-        DEBUG_P(PerlIO_printf(Perl_debug_log, 
-                              "PL_preprocess: cmd=\"%s\"\n", 
+        DEBUG_P(PerlIO_printf(Perl_debug_log,
+                              "PL_preprocess: cmd=\"%s\"\n",
                               SvPVX(cmd)));
 
        PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
@@ -2840,8 +2860,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
                 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
             {
                 /* try again */
-                PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, 
-                                         BIN_EXP, (int)PERL_REVISION, 
+                PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
+                                         BIN_EXP, (int)PERL_REVISION,
                                          (int)PERL_VERSION,
                                          (int)PERL_SUBVERSION), PL_origargv);
                 Perl_croak(aTHX_ "Can't do setuid\n");
diff --git a/perl.h b/perl.h
index f499e7b..958ecb4 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2797,6 +2797,7 @@ typedef Sighandler_t Sigsave_t;
 
 typedef int (CPERLscope(*runops_proc_t)) (pTHX);
 typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv);
+typedef int  (CPERLscope(*thrhook_proc_t)) (pTHX);
 typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX);
 
 /* _ (for $_) must be first in the following list (DEFSV requires it) */
index 5070d1d..24f790a 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -968,6 +968,8 @@ END_EXTERN_C
 #define PL_sharehook           (*Perl_Gsharehook_ptr(NULL))
 #undef  PL_thr_key
 #define PL_thr_key             (*Perl_Gthr_key_ptr(NULL))
+#undef  PL_threadhook
+#define PL_threadhook          (*Perl_Gthreadhook_ptr(NULL))
 #undef  PL_unlockhook
 #define PL_unlockhook          (*Perl_Gunlockhook_ptr(NULL))
 
index 5195679..b841719 100644 (file)
@@ -56,4 +56,5 @@ PERLVARI(Grunops_dbg, runops_proc_t,  MEMBER_TO_FPTR(Perl_runops_debug))
 PERLVARI(Gsharehook,   share_proc_t,   MEMBER_TO_FPTR(Perl_sv_nosharing))
 PERLVARI(Glockhook,    share_proc_t,   MEMBER_TO_FPTR(Perl_sv_nolocking))
 PERLVARI(Gunlockhook,  share_proc_t,   MEMBER_TO_FPTR(Perl_sv_nounlocking))
+PERLVARI(Gthreadhook,  thrhook_proc_t, MEMBER_TO_FPTR(Perl_nothreadhook))
 
index ad0d6d8..94f26eb 100644 (file)
@@ -576,6 +576,16 @@ method, similar to C<use Foo::Bar VERSION LIST>.
 =for hackers
 Found in file op.c
 
+=item nothreadhook
+
+Stub that provides thread hook for perl_destruct when there are
+no threads.
+
+       int     nothreadhook()
+
+=for hackers
+Found in file perl.c
+
 =item perl_alloc
 
 Allocates a new Perl interpreter.  See L<perlembed>.
diff --git a/proto.h b/proto.h
index d3137e6..7b41013 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1004,6 +1004,7 @@ PERL_CALLCONV char *      Perl_custom_op_desc(pTHX_ OP* op);
 PERL_CALLCONV void     Perl_sv_nosharing(pTHX_ SV *);
 PERL_CALLCONV void     Perl_sv_nolocking(pTHX_ SV *);
 PERL_CALLCONV void     Perl_sv_nounlocking(pTHX_ SV *);
+PERL_CALLCONV int      Perl_nothreadhook(pTHX);
 
 END_EXTERN_C