This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Nearly-working threads re-structuring. Do not integrate,
authorNick Ing-Simmons <nik@tiuk.ti.com>
Sat, 19 Jan 2002 22:17:07 +0000 (22:17 +0000)
committerNick Ing-Simmons <nik@tiuk.ti.com>
Sat, 19 Jan 2002 22:17:07 +0000 (22:17 +0000)
submit-ing to get to Win32, and as "off site" backup.

p4raw-id: //depot/perlio@14352

25 files changed:
MANIFEST
Makefile.SH
Makefile.micro
embed.fnc
embed.h
embedvar.h
ext/threads/shared/shared.xs
ext/threads/threads.h [deleted file]
ext/threads/threads.pm
ext/threads/threads.xs
ext/threads/typemap [new file with mode: 0644]
global.sym
intrpvar.h
mg.c
mg.h
perl.h
perlapi.h
perlvars.h
pp.c
proto.h
sharedsv.c [deleted file]
sharedsv.h [deleted file]
sv.c
sv.h
util.c

index 68a0e5f..bb99801 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2046,8 +2046,6 @@ regnodes.h                        Description of nodes of RE engine
 run.c                          The interpreter loop
 scope.c                                Scope entry and exit code
 scope.h                                Scope entry and exit header
-sharedsv.c                     ithreads-shared scalar values code
-sharedsv.h                     ithreads-shared scalar values header
 sv.c                           Scalar value code
 sv.h                           Scalar value header
 t/base/cond.t                  See if conditionals work
index f86b17b..9405eeb 100644 (file)
@@ -288,19 +288,19 @@ h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h
 h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
 h3 = opcode.h patchlevel.h perl.h perlapi.h perly.h pp.h proto.h regcomp.h
 h4 = regexp.h scope.h sv.h unixish.h util.h iperlsys.h thread.h
-h5 = utf8.h warnings.h sharedsv.h
+h5 = utf8.h warnings.h
 h = $(h1) $(h2) $(h3) $(h4) $(h5)
 
 c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c
 c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c
 c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c xsutils.c
-c4 = globals.c perlio.c perlapi.c numeric.c locale.c pp_pack.c pp_sort.c sharedsv.c
+c4 = globals.c perlio.c perlapi.c numeric.c locale.c pp_pack.c pp_sort.c
 
 c = $(c1) $(c2) $(c3) $(c4) miniperlmain.c perlmain.c
 
 obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT)
 obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
-obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT) sharedsv$(OBJ_EXT)
+obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT)
 
 obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
 
index 0e3ddbb..11f2cc2 100644 (file)
@@ -1,7 +1,7 @@
 CC = cc
 LD = $(CC)
 DEFINES = -DPERL_CORE -DPERL_MICRO
-OPTIMIZE = 
+OPTIMIZE =
 CFLAGS = $(DEFINES) $(OPTIMIZE)
 LIBS = -lm
 _O = .o
@@ -16,8 +16,7 @@ O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \
        uregcomp$(_O) uregexec$(_O) urun$(_O) \
        uscope$(_O) usv$(_O) utaint$(_O) utoke$(_O) \
        unumeric$(_O) ulocale$(_O) \
-       uuniversal$(_O) uutf8$(_O) uutil$(_O) uperlapi$(_O) \
-       usharedsv$(_O)
+       uuniversal$(_O) uutf8$(_O) uutil$(_O) uperlapi$(_O)
 
 microperl:     $(O)
        $(LD) -o $@ $(O) $(LIBS)
@@ -138,6 +137,4 @@ uutil$(_O): $(HE) util.c
 uperlapi$(_O): $(HE) perlapi.c perlapi.h
        $(CC) -c -o $@ $(CFLAGS) perlapi.c
 
-usharedsv$(_O):        $(HE) sharedsv.c sharedsv.h
-       $(CC) -c -o $@ $(CFLAGS) sharedsv.c
 
index f76805e..ae73fd1 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -943,6 +943,9 @@ Ap  |void   |sys_intern_init
 Ap |char * |custom_op_name|OP* op
 Ap |char * |custom_op_desc|OP* op
 
+Adp    |void   |sv_nosharing   |SV *
+Adp    |void   |sv_nolocking   |SV *
+Adp    |void   |sv_nounlocking |SV *
 
 END_EXTERN_C
 
@@ -1160,17 +1163,6 @@ s        |void   |debprof        |OP *o
 s      |SV*    |save_scalar_at |SV **sptr
 #endif
 
-#if defined(USE_ITHREADS)
-Adp    |void        |sharedsv_init
-Adp    |shared_sv*  |sharedsv_new
-Adp    |shared_sv*  |sharedsv_find          |SV* sv
-Adp    |void        |sharedsv_lock          |shared_sv* ssv
-Adp    |void        |sharedsv_unlock        |shared_sv* ssv
-p      |void        |sharedsv_unlock_scope  |shared_sv* ssv
-Adp    |void        |sharedsv_thrcnt_inc    |shared_sv* ssv
-Adp    |void        |sharedsv_thrcnt_dec    |shared_sv* ssv
-#endif
-
 #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
 s      |IV     |asIV           |SV* sv
 s      |UV     |asUV           |SV* sv
diff --git a/embed.h b/embed.h
index a2fbb67..5f8b3ad 100644 (file)
--- a/embed.h
+++ b/embed.h
 #endif
 #define custom_op_name         Perl_custom_op_name
 #define custom_op_desc         Perl_custom_op_desc
+#define sv_nosharing           Perl_sv_nosharing
+#define sv_nolocking           Perl_sv_nolocking
+#define sv_nounlocking         Perl_sv_nounlocking
 #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
 #define avhv_index_sv          S_avhv_index_sv
 #define avhv_index             S_avhv_index
 #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
 #define save_scalar_at         S_save_scalar_at
 #endif
-#if defined(USE_ITHREADS)
-#define sharedsv_init          Perl_sharedsv_init
-#define sharedsv_new           Perl_sharedsv_new
-#define sharedsv_find          Perl_sharedsv_find
-#define sharedsv_lock          Perl_sharedsv_lock
-#define sharedsv_unlock                Perl_sharedsv_unlock
-#define sharedsv_unlock_scope  Perl_sharedsv_unlock_scope
-#define sharedsv_thrcnt_inc    Perl_sharedsv_thrcnt_inc
-#define sharedsv_thrcnt_dec    Perl_sharedsv_thrcnt_dec
-#endif
 #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
 #define asIV                   S_asIV
 #define asUV                   S_asUV
 #endif
 #define custom_op_name(a)      Perl_custom_op_name(aTHX_ a)
 #define custom_op_desc(a)      Perl_custom_op_desc(aTHX_ a)
+#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)
 #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)
 #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
 #define save_scalar_at(a)      S_save_scalar_at(aTHX_ a)
 #endif
-#if defined(USE_ITHREADS)
-#define sharedsv_init()                Perl_sharedsv_init(aTHX)
-#define sharedsv_new()         Perl_sharedsv_new(aTHX)
-#define sharedsv_find(a)       Perl_sharedsv_find(aTHX_ a)
-#define sharedsv_lock(a)       Perl_sharedsv_lock(aTHX_ a)
-#define sharedsv_unlock(a)     Perl_sharedsv_unlock(aTHX_ a)
-#define sharedsv_unlock_scope(a)       Perl_sharedsv_unlock_scope(aTHX_ a)
-#define sharedsv_thrcnt_inc(a) Perl_sharedsv_thrcnt_inc(aTHX_ a)
-#define sharedsv_thrcnt_dec(a) Perl_sharedsv_thrcnt_dec(aTHX_ a)
-#endif
 #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
 #define asIV(a)                        S_asIV(aTHX_ a)
 #define asUV(a)                        S_asUV(aTHX_ a)
index c6eb5fa..1557c65 100644 (file)
 #define PL_curinterp           (PL_Vars.Gcurinterp)
 #define PL_do_undump           (PL_Vars.Gdo_undump)
 #define PL_hexdigit            (PL_Vars.Ghexdigit)
+#define PL_lockhook            (PL_Vars.Glockhook)
 #define PL_malloc_mutex                (PL_Vars.Gmalloc_mutex)
 #define PL_op_mutex            (PL_Vars.Gop_mutex)
 #define PL_patleave            (PL_Vars.Gpatleave)
 #define PL_runops_dbg          (PL_Vars.Grunops_dbg)
 #define PL_runops_std          (PL_Vars.Grunops_std)
-#define PL_sharedsv_space      (PL_Vars.Gsharedsv_space)
-#define PL_sharedsv_space_mutex        (PL_Vars.Gsharedsv_space_mutex)
+#define PL_sharehook           (PL_Vars.Gsharehook)
 #define PL_thr_key             (PL_Vars.Gthr_key)
+#define PL_unlockhook          (PL_Vars.Gunlockhook)
 
 #else /* !PERL_GLOBAL_STRUCT */
 
 #define PL_Gcurinterp          PL_curinterp
 #define PL_Gdo_undump          PL_do_undump
 #define PL_Ghexdigit           PL_hexdigit
+#define PL_Glockhook           PL_lockhook
 #define PL_Gmalloc_mutex       PL_malloc_mutex
 #define PL_Gop_mutex           PL_op_mutex
 #define PL_Gpatleave           PL_patleave
 #define PL_Grunops_dbg         PL_runops_dbg
 #define PL_Grunops_std         PL_runops_std
-#define PL_Gsharedsv_space     PL_sharedsv_space
-#define PL_Gsharedsv_space_mutex       PL_sharedsv_space_mutex
+#define PL_Gsharehook          PL_sharehook
 #define PL_Gthr_key            PL_thr_key
+#define PL_Gunlockhook         PL_unlockhook
 
 #endif /* PERL_GLOBAL_STRUCT */
 
index cf655cb..e21bbe9 100644 (file)
+/*    sharedsv.c
+ *
+ *    Copyright (c) 2001, Larry Wall
+ *
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
+ *
+ */
 
+/*
+* Contributed by Arthur Bergman arthur@contiller.se
+*
+* "Hand any two wizards a piece of rope and they would instinctively pull in
+* opposite directions."
+*                         --Sourcery
+*
+*/
+
+#define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 
+PerlInterpreter        *PL_sharedsv_space;             /* The shared sv space */
+perl_mutex      PL_sharedsv_space_mutex;       /* Mutex protecting the shared sv space */
+
+typedef struct {
+    SV                 *sv;             /* The actual SV */
+    perl_mutex          mutex;          /* Our mutex */
+    perl_cond           cond;           /* Our condition variable */
+    perl_cond           user_cond;      /* For user-level conditions */
+    IV                  locks;          /* Number of locks held */
+    PerlInterpreter    *owner;          /* Who owns the lock? */
+    U16                 index;          /* Update index */
+} shared_sv;
+
+#define SHAREDSvGET(a)      (a->sv)
+#define SHAREDSvLOCK(a)     Perl_sharedsv_lock(aTHX_ a)
+#define SHAREDSvUNLOCK(a)   Perl_sharedsv_unlock(aTHX_ a)
+
+#define SHAREDSvEDIT(a)     STMT_START {                                \
+                                MUTEX_LOCK(&PL_sharedsv_space_mutex);   \
+                                SHAREDSvLOCK((a));                      \
+                                PERL_SET_CONTEXT(PL_sharedsv_space);    \
+                            } STMT_END
+
+#define SHAREDSvRELEASE(a)  STMT_START {                                \
+                                PERL_SET_CONTEXT((a)->owner);           \
+                                SHAREDSvUNLOCK((a));                    \
+                                MUTEX_UNLOCK(&PL_sharedsv_space_mutex); \
+                            } STMT_END
+
+extern void    Perl_sharedsv_init(pTHX);
+extern shared_sv*      Perl_sharedsv_new(pTHX);
+extern shared_sv*      Perl_sharedsv_find(pTHX_ SV* sv);
+extern void    Perl_sharedsv_lock(pTHX_ shared_sv* ssv);
+extern void    Perl_sharedsv_unlock(pTHX_ shared_sv* ssv);
+extern void    Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv);
+extern void    Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv);
+extern void    Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv);
+
+/*
+  Shared SV
+
+  Shared SV is a structure for keeping the backend storage
+  of shared svs.
+
+*/
+
+/*
+
+ =head1 Shared SV Functions
+
+ =for apidoc sharedsv_init 
+
+Saves a space for keeping SVs wider than an interpreter,
+currently only stores a pointer to the first interpreter.
+
+ =cut
+
+*/
+
+void
+Perl_sharedsv_init(pTHX)
+{
+  PerlInterpreter* old_context = PERL_GET_CONTEXT;
+  PL_sharedsv_space = perl_alloc();
+  perl_construct(PL_sharedsv_space);
+  PERL_SET_CONTEXT(old_context);
+  MUTEX_INIT(&PL_sharedsv_space_mutex);
+}
+
+/*
+ =for apidoc sharedsv_new
+
+Allocates a new shared sv struct, you must yourself create the SV/AV/HV.
+ =cut
+*/
+
+shared_sv *
+Perl_sharedsv_new(pTHX)
+{
+    shared_sv* ssv;
+    New(2555,ssv,1,shared_sv);
+    MUTEX_INIT(&ssv->mutex);
+    COND_INIT(&ssv->cond);
+    COND_INIT(&ssv->user_cond);
+    ssv->owner = 0;
+    ssv->locks = 0;
+    ssv->index = 0;
+    return ssv;
+}
+
+
+/*
+ =for apidoc sharedsv_find
+
+Tries to find if a given SV has a shared backend, either by
+looking at magic, or by checking if it is tied again threads::shared.
+
+ =cut
+*/
+
+shared_sv *
+Perl_sharedsv_find(pTHX_ SV* sv)
+{
+  /* does all it can to find a shared_sv struct, returns NULL otherwise */
+    shared_sv* ssv = NULL;
+    switch (SvTYPE(sv)) {
+        case SVt_PVMG:
+        case SVt_PVAV:
+        case SVt_PVHV: {
+            MAGIC* mg = mg_find(sv, PERL_MAGIC_ext);
+            if(mg) {
+               if(strcmp(mg->mg_ptr,"threads::shared"))
+                    break;
+                ssv = INT2PTR(shared_sv *, SvIV(mg->mg_obj));
+               break;
+             }
+       
+            mg = mg_find(sv,PERL_MAGIC_tied);
+             if(mg) {
+                 SV* obj = SvTIED_obj(sv,mg);
+                if(sv_derived_from(obj, "threads::shared"))
+                     ssv = INT2PTR(shared_sv *, SvIV(SvRV(obj)));
+                 break;
+             }
+       }
+    }
+    return ssv;
+}
+
+/*
+ =for apidoc sharedsv_lock
+
+Recursive locks on a sharedsv.
+Locks are dynamically scoped at the level of the first lock.
+ =cut
+*/
+void
+Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
+{
+    if(!ssv)
+        return;
+    MUTEX_LOCK(&ssv->mutex);
+    if(ssv->owner && ssv->owner == my_perl) {
+        ssv->locks++;
+       MUTEX_UNLOCK(&ssv->mutex);
+        return;
+    }
+    while(ssv->owner)
+      COND_WAIT(&ssv->cond,&ssv->mutex);
+    ssv->locks++;
+    ssv->owner = my_perl;
+    if(ssv->locks == 1)
+        SAVEDESTRUCTOR_X(Perl_sharedsv_unlock_scope,ssv);
+    MUTEX_UNLOCK(&ssv->mutex);
+}
+
+/*
+ =for apidoc sharedsv_unlock
+
+Recursively unlocks a shared sv.
+
+ =cut
+*/
+
+void
+Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
+{
+    MUTEX_LOCK(&ssv->mutex);
+    if(ssv->owner != my_perl) {
+        Perl_croak(aTHX_ "panic: Perl_sharedsv_unlock unlocking mutex that we don't own");
+        MUTEX_UNLOCK(&ssv->mutex);
+        return;
+    }
+
+    if(--ssv->locks == 0) {
+        ssv->owner = NULL;
+       COND_SIGNAL(&ssv->cond);
+    }
+    MUTEX_UNLOCK(&ssv->mutex);
+ }
+
+void
+Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv)
+{
+    MUTEX_LOCK(&ssv->mutex);
+    if(ssv->owner != my_perl) {
+        MUTEX_UNLOCK(&ssv->mutex);
+        return;
+    }
+    ssv->locks = 0;
+    ssv->owner = NULL;
+    COND_SIGNAL(&ssv->cond);
+    MUTEX_UNLOCK(&ssv->mutex);
+}
+
+/*
+ =for apidoc sharedsv_thrcnt_inc
+
+Increments the threadcount of a sharedsv.
+ =cut
+*/
+void
+Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv)
+{
+  SHAREDSvLOCK(ssv);
+  SvREFCNT_inc(ssv->sv);
+  SHAREDSvUNLOCK(ssv);
+}
+
+/*
+ =for apidoc sharedsv_thrcnt_dec
+
+Decrements the threadcount of a shared sv. When a threads frontend is freed
+this function should be called.
+
+ =cut
+*/
+
+void
+Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv)
+{
+    SV* sv;
+    SHAREDSvLOCK(ssv);
+    sv = SHAREDSvGET(ssv);
+    if (SvREFCNT(sv) == 1) {
+        switch (SvTYPE(sv)) {
+        case SVt_RV:
+            if (SvROK(sv))
+            Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(SvRV(sv))));
+            break;
+        case SVt_PVAV: {
+            SV **src_ary  = AvARRAY((AV *)sv);
+            SSize_t items = AvFILLp((AV *)sv) + 1;
+
+            while (items-- > 0) {
+            if(SvTYPE(*src_ary))
+                Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(*src_ary)));
+                src_ary++;
+            }
+            break;
+        }
+        case SVt_PVHV: {
+            HE *entry;
+            (void)hv_iterinit((HV *)sv);
+            while ((entry = hv_iternext((HV *)sv)))
+                Perl_sharedsv_thrcnt_dec(
+                    aTHX_ INT2PTR(shared_sv *, SvIV(hv_iterval((HV *)sv, entry)))
+                );
+            break;
+        }
+        }
+    }
+    Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(ssv));
+    SHAREDSvUNLOCK(ssv);
+}
+
+
 MGVTBL svtable;
 
-SV* shared_sv_attach_sv (SV* sv, shared_sv* shared) {
+SV* Perl_shared_sv_attach_sv (pTHX_ SV* sv, shared_sv* shared) {
     HV* shared_hv = get_hv("threads::shared::shared", FALSE);
     SV* id = newSViv(PTR2IV(shared));
     STRLEN length = sv_len(id);
@@ -99,7 +374,7 @@ int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) {
         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
         if(!target) {
             sv_setsv(sv,SHAREDSvGET(shared));
-            SHAREDSvUNLOCK(shared);            
+            SHAREDSvUNLOCK(shared);
             Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar");
         }
         SHAREDSvEDIT(shared);
@@ -120,7 +395,7 @@ int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) {
 
 int shared_sv_destroy_mg (pTHX_ SV* sv, MAGIC *mg) {
     shared_sv* shared = INT2PTR(shared_sv*, SvIV(mg->mg_obj));
-    if(!shared) 
+    if(!shared)
         return 0;
     {
        HV* shared_hv = get_hv("threads::shared::shared", FALSE);
@@ -167,7 +442,7 @@ _thrcnt(ref)
         RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared)));
         SHAREDSvUNLOCK(shared);
        OUTPUT:
-        RETVAL   
+        RETVAL
 
 
 void
@@ -178,7 +453,7 @@ thrcnt_inc(ref,perl)
        shared_sv* shared;
        PerlInterpreter* origperl = INT2PTR(PerlInterpreter*, SvIV(perl));
        PerlInterpreter* oldperl = PERL_GET_CONTEXT;
-        if(SvROK(ref)) 
+        if(SvROK(ref))
             ref = SvRV(ref);
         shared = Perl_sharedsv_find(aTHX, ref);
         if(!shared)
@@ -196,7 +471,7 @@ _thrcnt_dec(ref)
            croak("thrcnt can only be used on shared values");
        Perl_sharedsv_thrcnt_dec(aTHX_ shared);
 
-void 
+void
 unlock_enabled(ref)
        SV* ref
        PROTOTYPE: \[$@%]
@@ -296,7 +571,7 @@ new(class, value)
 
 MODULE = threads::shared               PACKAGE = threads::shared::av
 
-SV* 
+SV*
 new(class, value)
        SV* class
        SV* value
@@ -315,7 +590,7 @@ STORE(self, index, value)
         SV* self
        SV* index
         SV* value
-        CODE:    
+        CODE:
         shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
         shared_sv* slot;
         SV* aentry;
@@ -370,7 +645,7 @@ FETCH(self, index)
                slot = INT2PTR(shared_sv*, SvIV(aentry));
                if(SvROK(SHAREDSvGET(slot))) {
                     shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
-                    retval = shared_sv_attach_sv(NULL,target);
+                    retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
                } else {
                     retval = newSVsv(SHAREDSvGET(slot));
                }
@@ -453,7 +728,7 @@ POP(self)
            slot = INT2PTR(shared_sv*, SvIV(retval));
            if(SvROK(SHAREDSvGET(slot))) {
                 shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
-                retval = shared_sv_attach_sv(NULL,target);
+                retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
            } else {
                 retval = newSVsv(SHAREDSvGET(slot));
             }
@@ -482,7 +757,7 @@ SHIFT(self)
            slot = INT2PTR(shared_sv*, SvIV(retval));
             if(SvROK(SHAREDSvGET(slot))) {
                  shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
-                 retval = shared_sv_attach_sv(NULL,target);
+                 retval = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
             } else {
                  retval = newSVsv(SHAREDSvGET(slot));
             }
@@ -584,14 +859,14 @@ DELETE(self,index)
                slot = INT2PTR(shared_sv*, SvIV(tmp));
                 if(SvROK(SHAREDSvGET(slot))) {
                    shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
-                   RETVAL = shared_sv_attach_sv(NULL,target);
+                   RETVAL = Perl_shared_sv_attach_sv(aTHX_ NULL,target);
                 } else {
                    RETVAL = newSVsv(SHAREDSvGET(slot));
                 }
-                Perl_sharedsv_thrcnt_dec(aTHX_ slot);               
+                Perl_sharedsv_thrcnt_dec(aTHX_ slot);
            } else {
                 RETVAL = &PL_sv_undef;
-           }       
+           }   
        } else {
            RETVAL = &PL_sv_undef;
        }       
@@ -609,7 +884,7 @@ SPLICE(self, offset, length, ...)
        
 MODULE = threads::shared               PACKAGE = threads::shared::hv
 
-SV* 
+SV*
 new(class, value)
        SV* class
        SV* value
@@ -689,7 +964,7 @@ FETCH(self, key)
                 slot = INT2PTR(shared_sv*, SvIV(hentry));
                if(SvROK(SHAREDSvGET(slot))) {
                    shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
-                   retval = shared_sv_attach_sv(NULL, target);
+                   retval = Perl_shared_sv_attach_sv(aTHX_ NULL, target);
                } else {
                    retval = newSVsv(SHAREDSvGET(slot));
                }
@@ -802,7 +1077,7 @@ DELETE(self, key)
                slot = INT2PTR(shared_sv*, SvIV(tmp));
                if(SvROK(SHAREDSvGET(slot))) {
                    shared_sv* target = INT2PTR(shared_sv*, SvIV(SvRV(SHAREDSvGET(slot))));
-                   RETVAL = shared_sv_attach_sv(NULL, target);
+                   RETVAL = Perl_shared_sv_attach_sv(aTHX_ NULL, target);
                } else {
                    RETVAL = newSVsv(SHAREDSvGET(slot));
                }
@@ -813,3 +1088,8 @@ DELETE(self, key)
         SHAREDSvUNLOCK(shared);
         OUTPUT:
         RETVAL
+
+BOOT:
+{
+     Perl_sharedsv_init(aTHX);
+}
diff --git a/ext/threads/threads.h b/ext/threads/threads.h
deleted file mode 100755 (executable)
index 72a4872..0000000
+++ /dev/null
@@ -1,99 +0,0 @@
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#include <stdio.h>
-#include <stdlib.h>
-
-#ifdef WIN32
-#include <windows.h>
-#include <win32thread.h>
-#define PERL_THREAD_DETACH(t) 
-#define PERL_THREAD_SETSPECIFIC(k,v) TlsSetValue(k,v)
-#define PERL_THREAD_GETSPECIFIC(k,v) v = TlsGetValue(k)
-#define PERL_THREAD_ALLOC_SPECIFIC(k) \
-STMT_START {\
-  if((k = TlsAlloc()) == TLS_OUT_OF_INDEXES) {\
-    PerlIO_printf(PerlIO_stderr(),"panic threads.h: TlsAlloc");\
-    exit(1);\
-  }\
-} STMT_END
-#else
-#include <pthread.h>
-#include <thread.h>
-
-#define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
-#ifdef OLD_PTHREADS_API
-#define PERL_THREAD_DETACH(t) pthread_detach(&(t))
-#define PERL_THREAD_GETSPECIFIC(k,v) pthread_getspecific(k,&v)
-#define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
-  if(pthread_keycreate(&(k),0)) {\
-    PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
-    exit(1);\
-  }\
-} STMT_END
-#else
-#define PERL_THREAD_DETACH(t) pthread_detach((t))
-#define PERL_THREAD_GETSPECIFIC(k,v) v = pthread_getspecific(k)
-#define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
-  if(pthread_key_create(&(k),0)) {\
-    PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
-    exit(1);\
-  }\
-} STMT_END
-#endif
-#endif
-
-typedef struct {
-  PerlInterpreter *interp;    /* The threads interpreter */
-  I32 tid;              /* Our thread */
-  perl_mutex mutex;            /* our mutex */
-  I32 count;                   /* how many threads have a reference to us */
-  signed char detached;                /* are we detached ? */
-  SV* init_function;
-  SV* params;
-#ifdef WIN32
-  DWORD        thr;
-  HANDLE handle;
-#else
-  pthread_t thr;
-#endif
-} ithread;
-
-
-
-static perl_mutex create_mutex;  /* protects the creation of threads ??? */
-
-
-
-I32 tid_counter = 1;
-shared_sv* threads;
-
-perl_key self_key;
-
-
-
-
-/* internal functions */
-#ifdef WIN32
-THREAD_RET_TYPE Perl_thread_run(LPVOID arg);
-#else
-void* Perl_thread_run(void * arg);
-#endif
-void Perl_thread_destruct(ithread* thread);
-
-/* Perl mapped functions to iThread:: */
-SV* Perl_thread_create(char* class, SV* function_to_call, SV* params);
-I32 Perl_thread_tid (SV* obj);
-void Perl_thread_join(SV* obj);
-void Perl_thread_detach(SV* obj);
-SV* Perl_thread_self (char* class);
-
-
-
-
-
-
-
-
-
index 444ec5b..7a5a274 100755 (executable)
@@ -4,7 +4,7 @@ use 5.7.2;
 use strict;
 use warnings;
 
-use overload 
+use overload
     '==' => \&equal,
     'fallback' => 1;
 
@@ -41,6 +41,9 @@ $threads::threads = 1;
 
 bootstrap threads $VERSION;
 
+# why document 'new' then use 'create' in the tests!
+*create = \&new;
+
 # Preloaded methods go here.
 
 1;
@@ -146,9 +149,9 @@ Arthur Bergman E<lt>arthur at contiller.seE<gt>
 
 threads is released under the same license as Perl.
 
-Thanks to 
+Thanks to
 
-Richard Soderberg E<lt>rs at crystalflame.netE<gt> 
+Richard Soderberg E<lt>rs at crystalflame.netE<gt>
 Helping me out tons, trying to find reasons for races and other weird bugs!
 
 Simon Cozens E<lt>simon at brecon.co.ukE<gt>
index 6f58de9..1b89e2c 100755 (executable)
-#include "threads.h"
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef WIN32
+#include <windows.h>
+#include <win32thread.h>
+#define PERL_THREAD_SETSPECIFIC(k,v) TlsSetValue(k,v)
+#define PERL_THREAD_GETSPECIFIC(k,v) v = TlsGetValue(k)
+#define PERL_THREAD_ALLOC_SPECIFIC(k) \
+STMT_START {\
+  if((k = TlsAlloc()) == TLS_OUT_OF_INDEXES) {\
+    PerlIO_printf(PerlIO_stderr(),"panic threads.h: TlsAlloc");\
+    exit(1);\
+  }\
+} STMT_END
+#else
+#include <pthread.h>
+#include <thread.h>
+
+#define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
+#ifdef OLD_PTHREADS_API
+#define PERL_THREAD_DETACH(t) pthread_detach(&(t))
+#define PERL_THREAD_GETSPECIFIC(k,v) pthread_getspecific(k,&v)
+#define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
+  if(pthread_keycreate(&(k),0)) {\
+    PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
+    exit(1);\
+  }\
+} STMT_END
+#else
+#define PERL_THREAD_DETACH(t) pthread_detach((t))
+#define PERL_THREAD_GETSPECIFIC(k,v) v = pthread_getspecific(k)
+#define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
+  if(pthread_key_create(&(k),0)) {\
+    PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
+    exit(1);\
+  }\
+} STMT_END
+#endif
+#endif
+
+typedef struct ithread_s {
+    struct ithread_s *next;    /* next thread in the list */
+    struct ithread_s *prev;    /* prev thread in the list */
+    PerlInterpreter *interp;   /* The threads interpreter */
+    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 ? */
+    SV* init_function;          /* Code to run */
+    SV* params;                 /* args to pass function */
+#ifdef WIN32
+       DWORD   thr;            /* OS's idea if thread id */
+       HANDLE handle;          /* OS's waitable handle */
+#else
+       pthread_t thr;          /* OS's handle for the thread */
+#endif
+} ithread;
+
+ithread *threads;
+
+/* Macros to supply the aTHX_ in an embed.h like manner */
+#define ithread_join(thread)           Perl_ithread_join(aTHX_ thread)
+#define ithread_DESTROY(thread)                Perl_ithread_DESTROY(aTHX_ thread)
+#define ithread_CLONE(thread)          Perl_ithread_CLONE(aTHX_ thread)
+#define ithread_detach(thread)         Perl_ithread_detach(aTHX_ thread)
+#define ithread_tid(thread)            ((thread)->tid)
+
+static perl_mutex create_mutex;  /* protects the creation of threads ??? */
+
+I32 tid_counter = 0;
+
+perl_key self_key;
+
+/*
+ *  Clear up after thread is done with
+ */
+void
+Perl_ithread_destruct (pTHX_ ithread* thread)
+{
+       MUTEX_LOCK(&thread->mutex);
+       Perl_warn(aTHX_ "destruct %d with count=%d",thread->tid,thread->count);
+       if (thread->count != 0) {
+               MUTEX_UNLOCK(&thread->mutex);
+               return; 
+       }
+       MUTEX_UNLOCK(&thread->mutex);
+       MUTEX_LOCK(&create_mutex);
+       /* Remove from circular list of threads */
+       if (thread->next == thread) {
+           /* last one should never get here ? */
+           threads = NULL;
+        }
+       else {
+           thread->next->prev = thread->prev->next;
+           thread->prev->next = thread->next->prev;
+           if (threads == thread) {
+               threads = thread->next;
+           }
+       }
+       MUTEX_UNLOCK(&create_mutex);
+       /* Thread is now disowned */
+       if (thread->interp) {
+           dTHXa(thread->interp);
+           PERL_SET_CONTEXT(thread->interp);
+           perl_destruct(thread->interp);
+           perl_free(thread->interp);
+           thread->interp = NULL;
+       }
+       PERL_SET_CONTEXT(aTHX);
+}
+
+
+/* MAGIC (in mg.h sense) hooks */
+
+int
+ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
+{
+    ithread *thread = (ithread *) mg->mg_ptr;
+    SvIVX(sv) = PTR2IV(thread);
+    SvIOK_on(sv);
+    return 0;
+}
+
+int
+ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
+{
+    ithread *thread = (ithread *) mg->mg_ptr;
+    MUTEX_LOCK(&thread->mutex);
+    Perl_warn(aTHX_ "Unmagic %d with count=%d",thread->tid,thread->count);
+    thread->count--;
+    MUTEX_UNLOCK(&thread->mutex);
+    /* This is safe as it re-checks count */
+    Perl_ithread_destruct(aTHX_ thread);
+    return 0;
+}
+
+int
+ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
+{
+    ithread *thread = (ithread *) mg->mg_ptr;
+    MUTEX_LOCK(&thread->mutex);
+    Perl_warn(aTHX_ "DUP %d with count=%d",thread->tid,thread->count);
+    thread->count++;
+    MUTEX_UNLOCK(&thread->mutex);
+    return 0;
+}
+
+MGVTBL ithread_vtbl = {
+ ithread_mg_get,       /* get */
+ 0,                    /* set */
+ 0,                    /* len */
+ 0,                    /* clear */
+ ithread_mg_free,      /* free */
+ 0,                    /* copy */
+ ithread_mg_dup                /* dup */
+};
+
 
 /*
  *     Starts executing the thread. Needs to clean up memory a tad better.
+ *      Passed as the C level function to run in the new thread
  */
 
 #ifdef WIN32
-THREAD_RET_TYPE Perl_thread_run(LPVOID arg) {
+THREAD_RET_TYPE
+Perl_ithread_run(LPVOID arg) {
 #else
-void* Perl_thread_run(void * arg) {
+void*
+Perl_ithread_run(void * arg) {
 #endif
        ithread* thread = (ithread*) arg;
-       SV* thread_tid_ptr;
-       SV* thread_ptr;
        dTHXa(thread->interp);
        PERL_SET_CONTEXT(thread->interp);
+       PERL_THREAD_SETSPECIFIC(self_key,thread);
 
+#if 0
+       /* Far from clear messing with ->thr child-side is a good idea */
+       MUTEX_LOCK(&thread->mutex);
 #ifdef WIN32
        thread->thr = GetCurrentThreadId();
 #else
        thread->thr = pthread_self();
 #endif
+       MUTEX_UNLOCK(&thread->mutex);
+#endif
 
-       SHAREDSvLOCK(threads);
-       SHAREDSvEDIT(threads);
-       PERL_THREAD_SETSPECIFIC(self_key,INT2PTR(void*,thread->tid));
-       thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, thread->tid);  
-       thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
-       hv_store_ent((HV*)SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
-       SvREFCNT_dec(thread_tid_ptr);
-       SHAREDSvRELEASE(threads);
-       SHAREDSvUNLOCK(threads);
        PL_perl_destruct_level = 2;
 
        {
-
-               AV* params;
-               I32 len;
+               AV* params = (AV*) SvRV(thread->params);
+               I32 len = av_len(params)+1;
                int i;
                dSP;
-               params = (AV*) SvRV(thread->params);
-               len = av_len(params);
                ENTER;
                SAVETMPS;
                PUSHMARK(SP);
-               if(len > -1) {
-                       for(i = 0; i < len + 1; i++) {
-                               XPUSHs(av_shift(params));
-                       }       
+               for(i = 0; i < len; i++) {
+                   XPUSHs(av_shift(params));
                }
                PUTBACK;
-               call_sv(thread->init_function, G_DISCARD);
+               call_sv(thread->init_function, G_DISCARD|G_EVAL);
+               SPAGAIN;
                FREETMPS;
                LEAVE;
-
-
+               SvREFCNT_dec(thread->params);
+               SvREFCNT_dec(thread->init_function);
        }
 
-       MUTEX_LOCK(&thread->mutex);
        PerlIO_flush((PerlIO*)NULL);
-       perl_destruct(thread->interp);  
-       perl_free(thread->interp);
-       if(thread->detached == 1) {
+       MUTEX_LOCK(&thread->mutex);
+       Perl_warn(aTHX_ "finished %d with count=%d",thread->tid,thread->count);
+       if (thread->detached == 1) {
                MUTEX_UNLOCK(&thread->mutex);
-               Perl_thread_destruct(thread);
+               Perl_ithread_destruct(aTHX_ thread);
        } else {
                MUTEX_UNLOCK(&thread->mutex);
        }
@@ -71,46 +223,84 @@ void* Perl_thread_run(void * arg) {
 #else
        return 0;
 #endif
+}
+
+SV *
+ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
+{
+    SV *sv;
+    MAGIC *mg;
+    if (inc) {
+       MUTEX_LOCK(&thread->mutex);
+       thread->count++;
+       Perl_warn(aTHX_ "SV for %d with count=%d",thread->tid,thread->count);
+       MUTEX_UNLOCK(&thread->mutex);
+    }
+    if (!obj)
+     obj = newSV(0);
+    sv = newSVrv(obj,classname);
+    sv_setiv(sv,PTR2IV(thread));
+    mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
+    mg->mg_flags |= MGf_DUP;
+    SvREADONLY_on(sv);
+    return obj;
+}
 
+ithread *
+SV_to_ithread(pTHX_ SV *sv)
+{
+    ithread *thread;
+    if (SvROK(sv))
+     {
+      thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
+     }
+    else
+     {
+      PERL_THREAD_GETSPECIFIC(self_key,thread);
+     }
+    return thread;
 }
 
 /*
- * iThread->create();
+ * iThread->create(); ( aka iThread->new() )
+ * Called in context of parent thread
  */
 
-SV* Perl_thread_create(char* class, SV* init_function, SV* params) {
-       ithread* thread = malloc(sizeof(ithread));
-       SV*      obj_ref;
-       SV*      obj;
-       SV*             temp_store;
-       PerlInterpreter *current_perl;
-       CLONE_PARAMS clone_param;
-
-       MUTEX_LOCK(&create_mutex);  
-       obj_ref = newSViv(0);
-       obj = newSVrv(obj_ref, class);
-       sv_setiv(obj, PTR2IV(thread));
-       SvREADONLY_on(obj);
-       PerlIO_flush((PerlIO*)NULL);
-       current_perl = PERL_GET_CONTEXT;        
-
+SV *
+Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
+{
+       ithread*        thread;
+       CLONE_PARAMS    clone_param;
+
+       MUTEX_LOCK(&create_mutex);
+       thread = PerlMemShared_malloc(sizeof(ithread));
+       Zero(thread,1,ithread);
+       thread->next = threads;
+       thread->prev = threads->prev;
+       thread->prev->next = thread;
+       /* Set count to 1 immediately in case thread exits before
+        * we return to caller !
+        */
+       thread->count = 1;
+       MUTEX_INIT(&thread->mutex);
+       thread->tid = tid_counter++;
+       thread->detached = 0;
 
+       /* "Clone" our interpreter into the thread's interpreter
+        * This gives thread access to "static data" and code.
+        */
 
-       temp_store = Perl_get_sv(current_perl, "threads::origthread", TRUE | GV_ADDMULTI);
-       sv_setiv(temp_store,PTR2IV(current_perl));
-       temp_store = NULL;      
+       PerlIO_flush((PerlIO*)NULL);
 
-       
 #ifdef WIN32
-       thread->interp = perl_clone(current_perl, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
+       thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
 #else
-       thread->interp = perl_clone(current_perl, CLONEf_KEEP_PTR_TABLE);
+       thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
 #endif
-       
 
        clone_param.flags = 0;  
        thread->init_function = Perl_sv_dup(thread->interp, init_function, &clone_param);
-       if(SvREFCNT(thread->init_function) == 0) {
+       if (SvREFCNT(thread->init_function) == 0) {
            SvREFCNT_inc(thread->init_function);
        }       
 
@@ -120,25 +310,15 @@ SV* Perl_thread_create(char* class, SV* init_function, SV* params) {
        ptr_table_free(PL_ptr_table);
        PL_ptr_table = NULL;
        
+       PERL_SET_CONTEXT(aTHX);
 
-
-
-       PERL_SET_CONTEXT(current_perl);
-
-
-       /* let's init the thread */
-
-       MUTEX_INIT(&thread->mutex);
-       thread->tid = tid_counter++;
-       thread->detached = 0;
-       thread->count = 1;
+       /* Start the thread */
 
 #ifdef WIN32
 
-       thread->handle = CreateThread(NULL, 0, Perl_thread_run,
+       thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
                        (LPVOID)thread, 0, &thread->thr);
 
-
 #else
        {
          static pthread_attr_t attr;
@@ -158,243 +338,165 @@ SV* Perl_thread_create(char* class, SV* init_function, SV* params) {
 #  endif
 
 #ifdef OLD_PTHREADS_API
-         pthread_create( &thread->thr, attr, Perl_thread_run, (void *)thread);
+         pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
 #else
-         pthread_create( &thread->thr, &attr, Perl_thread_run, (void *)thread);
+         pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
 #endif
        }
 #endif
        MUTEX_UNLOCK(&create_mutex);    
+       return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
+}
 
-       return obj_ref;
+SV*
+Perl_ithread_self (pTHX_ SV *obj, char* Class)
+{
+    ithread *thread;
+    PERL_THREAD_GETSPECIFIC(self_key,thread);
+    return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
 }
 
 /*
- * returns the id of the thread
+ * joins the thread this code needs to take the returnvalue from the
+ * call_sv and send it back
  */
-I32 Perl_thread_tid (SV* obj) {
-       ithread* thread;
-       if(!SvROK(obj)) {
-               obj = Perl_thread_self(SvPV_nolen(obj));
-               thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
-               SvREFCNT_dec(obj);
-       } else {
-               thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
-       }
-       return thread->tid;
-}
 
-SV* Perl_thread_self (char* class) {
-       dTHX;
-       SV*      obj_ref;
-       SV*      obj;
-       SV*     thread_tid_ptr;
-       SV*     thread_ptr;
-       HE*     thread_entry;
-       void*   id;
-       PERL_THREAD_GETSPECIFIC(self_key,id);
-       SHAREDSvLOCK(threads);
-       SHAREDSvEDIT(threads);
-       
-       thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(id));   
-
-       thread_entry = Perl_hv_fetch_ent(PL_sharedsv_space,
-                                        (HV*) SHAREDSvGET(threads),
-                                        thread_tid_ptr, 0,0);
-       thread_ptr = HeVAL(thread_entry);
-       SvREFCNT_dec(thread_tid_ptr);   
-       SHAREDSvRELEASE(threads);
-       SHAREDSvUNLOCK(threads);
-
-       obj_ref = newSViv(0);
-       obj = newSVrv(obj_ref, class);
-       sv_setsv(obj, thread_ptr);
-       SvREADONLY_on(obj);
-       return obj_ref;
+void
+Perl_ithread_CLONE(pTHX_ SV *obj)
+{
+ if (SvROK(obj))
+  {
+   ithread *thread = SV_to_ithread(aTHX_ obj);
+  }
+ else
+  {
+   Perl_warn(aTHX_ "CLONE %_",obj);
+  }
 }
 
-/*
- * joins the thread this code needs to take the returnvalue from the
- * call_sv and send it back */
-
-void Perl_thread_join(SV* obj) {
-       ithread* thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
+void
+Perl_ithread_join(pTHX_ SV *obj)
+{
+    ithread *thread = SV_to_ithread(aTHX_ obj);
+    MUTEX_LOCK(&thread->mutex);
+    Perl_warn(aTHX_ "joining %d with count=%d",thread->tid,thread->count);
+    if (!thread->detached) {
 #ifdef WIN32
        DWORD waitcode;
-       waitcode = WaitForSingleObject(thread->handle, INFINITE);
 #else
        void *retval;
-       pthread_join(thread->thr,&retval);
 #endif
-}
-
-/* detaches a thread
- * needs to better clean up memory */
-
-void Perl_thread_detach(SV* obj) {
-       ithread* thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
-       MUTEX_LOCK(&thread->mutex);
-       thread->detached = 1;
-       PERL_THREAD_DETACH(thread->thr);
        MUTEX_UNLOCK(&thread->mutex);
-}
-
-void Perl_thread_DESTROY (SV* obj) {
-       ithread* thread = INT2PTR(ithread*, SvIV(SvRV(obj)));
-       
+#ifdef WIN32
+       waitcode = WaitForSingleObject(thread->handle, INFINITE);
+#else
+       pthread_join(thread->thr,&retval);
+#endif
+       Perl_warn(aTHX_ "joined %d with count=%d",thread->tid,thread->count);
+       /* We have finished with it */
        MUTEX_LOCK(&thread->mutex);
-       thread->count--;
+       thread->detached = 2;
        MUTEX_UNLOCK(&thread->mutex);
-       Perl_thread_destruct(thread);
-}
-
-void Perl_thread_destruct (ithread* thread) {
-       return;
-       MUTEX_LOCK(&thread->mutex);
-       if(thread->count != 0) {
-               MUTEX_UNLOCK(&thread->mutex);
-               return; 
-       }
+       sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
+    }
+    else {
        MUTEX_UNLOCK(&thread->mutex);
-       /* it is safe noone is holding a ref to this */
-       /*printf("proper destruction!\n");*/
+       Perl_croak(aTHX_ "Cannot join a detached thread");
+    }
 }
 
-MODULE = threads               PACKAGE = threads               
-BOOT:
-       Perl_sharedsv_init(aTHX);
-       PERL_THREAD_ALLOC_SPECIFIC(self_key);
-       PL_perl_destruct_level = 2;
-       threads = Perl_sharedsv_new(aTHX);
-       SHAREDSvEDIT(threads);
-       SHAREDSvGET(threads) = (SV *)newHV();
-       SHAREDSvRELEASE(threads);
-       {
-           
-       
-           SV* temp = get_sv("threads::sharedsv_space", TRUE | GV_ADDMULTI);
-           SV* temp2 = newSViv(PTR2IV(PL_sharedsv_space));
-           sv_setsv( temp , temp2 );
-       }
-       {
-               ithread* thread = malloc(sizeof(ithread));
-               SV* thread_tid_ptr;
-               SV* thread_ptr;
-               MUTEX_INIT(&thread->mutex);
-               thread->tid = 0;
+void
+Perl_ithread_detach(pTHX_ ithread *thread)
+{
+    MUTEX_LOCK(&thread->mutex);
+    if (!thread->detached) {
+       thread->detached = 1;
 #ifdef WIN32
-               thread->thr = GetCurrentThreadId();
+       CloseHandle(thread->handle);
+       thread->handle = 0;
 #else
-               thread->thr = pthread_self();
+       PERL_THREAD_DETACH(thread->thr);
 #endif
-               SHAREDSvEDIT(threads);
-               PERL_THREAD_ALLOC_SPECIFIC(self_key);
-               PERL_THREAD_SETSPECIFIC(self_key,0);
-               thread_tid_ptr = Perl_newSVuv(PL_sharedsv_space, 0);
-               thread_ptr = Perl_newSVuv(PL_sharedsv_space, PTR2UV(thread));
-               hv_store_ent((HV*) SHAREDSvGET(threads), thread_tid_ptr, thread_ptr,0);
-               SvREFCNT_dec(thread_tid_ptr);
-               SHAREDSvRELEASE(threads);
-       }
-       MUTEX_INIT(&create_mutex);
-
-PROTOTYPES: DISABLE
+    }
+    MUTEX_UNLOCK(&thread->mutex);
+}
 
-SV *
-create (class, function_to_call, ...)
-        char *  class
-        SV *    function_to_call
-               CODE:
-                       AV* params = newAV();
-                       if(items > 2) {
-                               int i;
-                               for(i = 2; i < items ; i++) {
-                                       av_push(params, ST(i));
-                               }
-                       }
-                       RETVAL = Perl_thread_create(class, function_to_call, newRV_noinc((SV*) params));
-                       OUTPUT:
-                       RETVAL
 
-SV *
-new (class, function_to_call, ...)
-        char *  class
-        SV *    function_to_call
-               CODE:
-                       AV* params = newAV();
-                       if(items > 2) {
-                               int i;
-                               for(i = 2; i < items ; i++) {
-                                       av_push(params, ST(i));
-                               }
-                       }
-                       RETVAL = Perl_thread_create(class, function_to_call, newRV_noinc((SV*) params));
-                       OUTPUT:
-                       RETVAL
+void
+Perl_ithread_DESTROY(pTHX_ SV *sv)
+{
+    ithread *thread = SV_to_ithread(aTHX_ sv);
+    Perl_warn(aTHX_ "DESTROY %d with count=%d",thread->tid,thread->count);
+    sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
+}
 
+MODULE = threads               PACKAGE = threads       PREFIX = ithread_
+PROTOTYPES: DISABLE
 
+void
+ithread_new (classname, function_to_call, ...)
+char * classname
+SV *   function_to_call
+CODE:
+{
+    AV* params = newAV();
+    if (items > 2) {
+       int i;
+       for(i = 2; i < items ; i++) {
+           av_push(params, ST(i));
+       }
+    }
+    ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
+    XSRETURN(1);
+}
 
-SV *
-self (class)
-               char* class
-       CODE:
-               RETVAL = Perl_thread_self(class);
-       OUTPUT:
-               RETVAL
+void
+ithread_self(char *classname)
+CODE:
+{
+       ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
+       XSRETURN(1);
+}
 
 int
-tid (obj)      
-               SV *    obj;
-       CODE:
-               RETVAL = Perl_thread_tid(obj);
-       OUTPUT:
-       RETVAL
+ithread_tid(ithread *thread)
 
 void
-join (obj)
-        SV *    obj
-        PREINIT:
-        I32* temp;
-        PPCODE:
-        temp = PL_markstack_ptr++;
-        Perl_thread_join(obj);
-        if (PL_markstack_ptr != temp) {
-          /* truly void, because dXSARGS not invoked */
-          PL_markstack_ptr = temp;
-          XSRETURN_EMPTY; /* return empty stack */
-        }
-        /* must have used dXSARGS; list context implied */
-        return; /* assume stack size is correct */
+ithread_join(SV *obj)
 
 void
-detach (obj)
-        SV *    obj
-        PREINIT:
-        I32* temp;
-        PPCODE:
-        temp = PL_markstack_ptr++;
-        Perl_thread_detach(obj);
-        if (PL_markstack_ptr != temp) {
-          /* truly void, because dXSARGS not invoked */
-          PL_markstack_ptr = temp;
-          XSRETURN_EMPTY; /* return empty stack */
-        }
-        /* must have used dXSARGS; list context implied */
-        return; /* assume stack size is correct */
+ithread_detach(ithread *thread)
 
 void
-DESTROY (obj)
-        SV *    obj
-        PREINIT:
-        I32* temp;
-        PPCODE:
-        temp = PL_markstack_ptr++;
-        Perl_thread_DESTROY(obj);
-        if (PL_markstack_ptr != temp) {
-          /* truly void, because dXSARGS not invoked */
-          PL_markstack_ptr = temp;
-          XSRETURN_EMPTY; /* return empty stack */
-        }
-        /* must have used dXSARGS; list context implied */
-        return; /* assume stack size is correct */
+ithread_DESTROY(SV *thread)
+
+void
+ithread_CLONE(SV *sv)
+
+BOOT:
+{
+       ithread* thread;
+       PERL_THREAD_ALLOC_SPECIFIC(self_key);
+       MUTEX_INIT(&create_mutex);
+       MUTEX_LOCK(&create_mutex);
+       thread  = PerlMemShared_malloc(sizeof(ithread));
+       Zero(thread,1,ithread);
+       PL_perl_destruct_level = 2;
+       MUTEX_INIT(&thread->mutex);
+       threads = thread;
+       thread->next = thread;
+        thread->prev = thread;
+       thread->interp = aTHX;
+       thread->count  = 1;  /* imortal */
+       thread->tid = tid_counter++;
+       thread->detached = 1;
+#ifdef WIN32
+       thread->thr = GetCurrentThreadId();
+#else
+       thread->thr = pthread_self();
+#endif
+       PERL_THREAD_SETSPECIFIC(self_key,thread);
+       MUTEX_UNLOCK(&create_mutex);
+}
+
 
diff --git a/ext/threads/typemap b/ext/threads/typemap
new file mode 100644 (file)
index 0000000..269d412
--- /dev/null
@@ -0,0 +1,9 @@
+ithread *      T_ITHREAD
+
+INPUT
+T_ITHREAD
+       $var = SV_to_ithread(aTHX_ $arg)
+
+OUTPUT
+T_ITHREAD
+       ithread_to_SV(aTHX_ $arg, $var, classname, TRUE);
index e64508b..df840d9 100644 (file)
@@ -594,13 +594,9 @@ Perl_sys_intern_clear
 Perl_sys_intern_init
 Perl_custom_op_name
 Perl_custom_op_desc
-Perl_sharedsv_init
-Perl_sharedsv_new
-Perl_sharedsv_find
-Perl_sharedsv_lock
-Perl_sharedsv_unlock
-Perl_sharedsv_thrcnt_inc
-Perl_sharedsv_thrcnt_dec
+Perl_sv_nosharing
+Perl_sv_nolocking
+Perl_sv_nounlocking
 Perl_sv_setsv_flags
 Perl_sv_catpvn_flags
 Perl_sv_catsv_flags
index 0000596..dccbdb6 100644 (file)
@@ -490,9 +490,6 @@ PERLVAR(Iregex_padav,   AV*)                /* All regex objects */
 PERLVAR(Ireentrant_buffer, REBUF*)     /* here we store the _r buffers */
 #endif
 
-PERLVAR(sharedsv_space,                PerlInterpreter*)
-PERLVAR(sharedsv_space_mutex,  perl_mutex)
-
 #endif
 
 PERLVAR(Isavebegin,     bool)  /* save BEGINs for compiler     */
diff --git a/mg.c b/mg.c
index c7ebca3..3602643 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -319,7 +319,11 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
     int count = 0;
     MAGIC* mg;
     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
-       if (isUPPER(mg->mg_type)) {
+       MGVTBL* vtbl = mg->mg_virtual;
+       if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
+           count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
+       }
+       else if (isUPPER(mg->mg_type)) {
            sv_magic(nsv,
                     mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
                     (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
diff --git a/mg.h b/mg.h
index 0048803..566ced7 100644 (file)
--- a/mg.h
+++ b/mg.h
@@ -16,6 +16,9 @@ struct mgvtbl {
     U32                (CPERLscope(*svt_len))  (pTHX_ SV *sv, MAGIC* mg);
     int                (CPERLscope(*svt_clear))(pTHX_ SV *sv, MAGIC* mg);
     int                (CPERLscope(*svt_free)) (pTHX_ SV *sv, MAGIC* mg);
+    int                (CPERLscope(*svt_copy)) (pTHX_ SV *sv, MAGIC* mg,
+                                       SV *nsv, const char *name, int namlen);
+    int                (CPERLscope(*svt_dup))  (pTHX_ MAGIC *mg, CLONE_PARAMS *param);
 };
 #endif
 
@@ -33,6 +36,8 @@ struct magic {
 #define MGf_TAINTEDDIR 1
 #define MGf_REFCOUNTED 2
 #define MGf_GSKIP      4
+#define MGf_COPY       8
+#define MGf_DUP        16
 
 #define MGf_MINMATCH   1
 
diff --git a/perl.h b/perl.h
index 11cac10..e2b3419 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2149,7 +2149,6 @@ typedef I32 (*filter_t) (pTHX_ int, SV *, int);
 #include "scope.h"
 #include "warnings.h"
 #include "utf8.h"
-#include "sharedsv.h"
 
 /* Current curly descriptor */
 typedef struct curcur CURCUR;
@@ -2514,7 +2513,9 @@ Gid_t getegid (void);
 #define PERL_MAGIC_nkeys         'k' /* scalar(keys()) lvalue */
 #define PERL_MAGIC_dbfile        'L' /* Debugger %_<filename */
 #define PERL_MAGIC_dbline        'l' /* Debugger %_<filename element */
-#define PERL_MAGIC_mutex         'm' /* ??? */
+#define PERL_MAGIC_mutex         'm' /* for lock op */
+#define PERL_MAGIC_shared        'N' /* Shared between threads */
+#define PERL_MAGIC_shared_scalar  'n' /* Shared between threads */
 #define PERL_MAGIC_collxfrm      'o' /* Locale transformation */
 #define PERL_MAGIC_tied                  'P' /* Tied array or hash */
 #define PERL_MAGIC_tiedelem      'p' /* Tied array or hash element */
@@ -2524,6 +2525,7 @@ Gid_t getegid (void);
 #define PERL_MAGIC_sigelem       's' /* %SIG hash element */
 #define PERL_MAGIC_taint         't' /* Taintedness */
 #define PERL_MAGIC_uvar                  'U' /* Available for use by extensions */
+#define PERL_MAGIC_uvar_elem     'u' /* Reserved for use by extensions */
 #define PERL_MAGIC_vec           'v' /* vec() lvalue */
 #define PERL_MAGIC_substr        'x' /* substr() lvalue */
 #define PERL_MAGIC_defelem       'y' /* Shadow "foreach" iterator variable /
@@ -2531,7 +2533,7 @@ Gid_t getegid (void);
 #define PERL_MAGIC_glob                  '*' /* GV (typeglob) */
 #define PERL_MAGIC_arylen        '#' /* Array length ($#ary) */
 #define PERL_MAGIC_pos           '.' /* pos() lvalue */
-#define PERL_MAGIC_backref       '<' /* ??? */
+#define PERL_MAGIC_backref       '<' /* for weak ref data */
 #define PERL_MAGIC_ext           '~' /* Available for use by extensions */
 
 
@@ -2762,6 +2764,7 @@ typedef Sighandler_t Sigsave_t;
 
 
 typedef int (CPERLscope(*runops_proc_t)) (pTHX);
+typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv);
 typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX);
 
 /* _ (for $_) must be first in the following list (DEFSV requires it) */
@@ -3325,7 +3328,7 @@ START_EXTERN_C
 
 #ifdef DOINIT
 
-EXT MGVTBL PL_vtbl_sv =        {MEMBER_TO_FPTR(Perl_magic_get),
+EXT MGVTBL PL_vtbl_sv =                {MEMBER_TO_FPTR(Perl_magic_get),
                                MEMBER_TO_FPTR(Perl_magic_set),
                                        MEMBER_TO_FPTR(Perl_magic_len),
                                                0,      0};
@@ -3344,10 +3347,12 @@ EXT MGVTBL PL_vtbl_sigelem =    {MEMBER_TO_FPTR(Perl_magic_getsig),
                                        0,      MEMBER_TO_FPTR(Perl_magic_clearsig),
                                                        0};
 #endif
-EXT MGVTBL PL_vtbl_pack =      {0,     0,      MEMBER_TO_FPTR(Perl_magic_sizepack),    MEMBER_TO_FPTR(Perl_magic_wipepack),
+EXT MGVTBL PL_vtbl_pack =      {0,     0,      
+                               MEMBER_TO_FPTR(Perl_magic_sizepack),    
+                               MEMBER_TO_FPTR(Perl_magic_wipepack),
                                                        0};
 EXT MGVTBL PL_vtbl_packelem =  {MEMBER_TO_FPTR(Perl_magic_getpack),
-                               MEMBER_TO_FPTR(Perl_magic_setpack),
+                                       MEMBER_TO_FPTR(Perl_magic_setpack),
                                        0,      MEMBER_TO_FPTR(Perl_magic_clearpack),
                                                        0};
 EXT MGVTBL PL_vtbl_dbline =    {0,     MEMBER_TO_FPTR(Perl_magic_setdbline),
@@ -3368,12 +3373,14 @@ EXT MGVTBL PL_vtbl_mglob =      {0,     MEMBER_TO_FPTR(Perl_magic_setmglob),
 EXT MGVTBL PL_vtbl_nkeys =     {MEMBER_TO_FPTR(Perl_magic_getnkeys),
                                MEMBER_TO_FPTR(Perl_magic_setnkeys),
                                        0,      0,      0};
-EXT MGVTBL PL_vtbl_taint =     {MEMBER_TO_FPTR(Perl_magic_gettaint),MEMBER_TO_FPTR(Perl_magic_settaint),
+EXT MGVTBL PL_vtbl_taint =     {MEMBER_TO_FPTR(Perl_magic_gettaint),
+                                       MEMBER_TO_FPTR(Perl_magic_settaint),
                                        0,      0,      0};
-EXT MGVTBL PL_vtbl_substr =    {MEMBER_TO_FPTR(Perl_magic_getsubstr), MEMBER_TO_FPTR(Perl_magic_setsubstr),
+EXT MGVTBL PL_vtbl_substr =    {MEMBER_TO_FPTR(Perl_magic_getsubstr),
+                                       MEMBER_TO_FPTR(Perl_magic_setsubstr),
                                        0,      0,      0};
 EXT MGVTBL PL_vtbl_vec =       {MEMBER_TO_FPTR(Perl_magic_getvec),
-                               MEMBER_TO_FPTR(Perl_magic_setvec),
+                                       MEMBER_TO_FPTR(Perl_magic_setvec),
                                        0,      0,      0};
 EXT MGVTBL PL_vtbl_pos =       {MEMBER_TO_FPTR(Perl_magic_getpos),
                                MEMBER_TO_FPTR(Perl_magic_setpos),
@@ -3386,9 +3393,11 @@ EXT MGVTBL PL_vtbl_uvar =        {MEMBER_TO_FPTR(Perl_magic_getuvar),
                                MEMBER_TO_FPTR(Perl_magic_setuvar),
                                        0,      0,      0};
 #ifdef USE_5005THREADS
-EXT MGVTBL PL_vtbl_mutex =     {0,     0,      0,      0,      MEMBER_TO_FPTR(Perl_magic_mutexfree)};
+EXT MGVTBL PL_vtbl_mutex =     {0,     0,      0,      0,      
+                                       MEMBER_TO_FPTR(Perl_magic_mutexfree)};
 #endif /* USE_5005THREADS */
-EXT MGVTBL PL_vtbl_defelem = {MEMBER_TO_FPTR(Perl_magic_getdefelem),MEMBER_TO_FPTR(Perl_magic_setdefelem),
+EXT MGVTBL PL_vtbl_defelem = {MEMBER_TO_FPTR(Perl_magic_getdefelem),
+                                       MEMBER_TO_FPTR(Perl_magic_setdefelem),
                                        0,      0,      0};
 
 EXT MGVTBL PL_vtbl_regexp = {0,0,0,0, MEMBER_TO_FPTR(Perl_magic_freeregexp)};
index 76eb92f..82761a4 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -941,6 +941,8 @@ END_EXTERN_C
 #define PL_do_undump           (*Perl_Gdo_undump_ptr(NULL))
 #undef  PL_hexdigit
 #define PL_hexdigit            (*Perl_Ghexdigit_ptr(NULL))
+#undef  PL_lockhook
+#define PL_lockhook            (*Perl_Glockhook_ptr(NULL))
 #undef  PL_malloc_mutex
 #define PL_malloc_mutex                (*Perl_Gmalloc_mutex_ptr(NULL))
 #undef  PL_op_mutex
@@ -951,12 +953,12 @@ END_EXTERN_C
 #define PL_runops_dbg          (*Perl_Grunops_dbg_ptr(NULL))
 #undef  PL_runops_std
 #define PL_runops_std          (*Perl_Grunops_std_ptr(NULL))
-#undef  PL_sharedsv_space
-#define PL_sharedsv_space      (*Perl_Gsharedsv_space_ptr(NULL))
-#undef  PL_sharedsv_space_mutex
-#define PL_sharedsv_space_mutex        (*Perl_Gsharedsv_space_mutex_ptr(NULL))
+#undef  PL_sharehook
+#define PL_sharehook           (*Perl_Gsharehook_ptr(NULL))
 #undef  PL_thr_key
 #define PL_thr_key             (*Perl_Gthr_key_ptr(NULL))
+#undef  PL_unlockhook
+#define PL_unlockhook          (*Perl_Gunlockhook_ptr(NULL))
 
 #endif /* !PERL_CORE */
 #endif /* MULTIPLICITY */
index 606f7a5..8cff165 100644 (file)
@@ -37,11 +37,14 @@ PERLVAR(Gmalloc_mutex,      perl_mutex)     /* Mutex for malloc */
 
 #if defined(USE_ITHREADS)
 PERLVAR(Gop_mutex,     perl_mutex)     /* Mutex for op refcounting */
-PERLVAR(Gsharedsv_space, PerlInterpreter*) /* The shared sv space */
-PERLVAR(Gsharedsv_space_mutex, perl_mutex) /* Mutex protecting the shared sv space */
 #endif
 
 /* Force inclusion of both runops options */
 PERLVARI(Grunops_std,  runops_proc_t,  MEMBER_TO_FPTR(Perl_runops_standard))
 PERLVARI(Grunops_dbg,  runops_proc_t,  MEMBER_TO_FPTR(Perl_runops_debug))
 
+/* Hooks to shared SVs and locks. */
+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))
+
diff --git a/pp.c b/pp.c
index 0d7f75b..ef0c75e 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -1006,7 +1006,7 @@ PP(pp_divide)
 {
     dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
     /* Only try to do UV divide first
-       if ((SLOPPYDIVIDE is true) or 
+       if ((SLOPPYDIVIDE is true) or
            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
             to preserve))
        The assumption is that it is better to use floating point divide
@@ -2702,7 +2702,7 @@ PP(pp_int)
 #   if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
 #       ifdef HAS_MODFL_POW32_BUG
 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
-                { 
+                {
                     NV offset = Perl_modf(value, &value);
                     (void)Perl_modf(offset, &offset);
                     value += offset;
@@ -3134,7 +3134,7 @@ PP(pp_ord)
     }
 
     XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
-    
+
     RETURN;
 }
 
@@ -3183,7 +3183,7 @@ PP(pp_crypt)
          * If not possible, croak.
          * Yes, we made this up.  */
          SV* tsv = sv_2mortal(newSVsv(left));
-        
+       
         SvUTF8_on(tsv);
         if (!sv_utf8_downgrade(tsv, FALSE))
              Perl_croak(aTHX_ "Wide character in crypt");
@@ -4541,14 +4541,7 @@ PP(pp_lock)
     dSP;
     dTOPss;
     SV *retsv = sv;
-#ifdef USE_5005THREADS
-    sv_lock(sv);
-#endif /* USE_5005THREADS */
-#ifdef USE_ITHREADS
-    shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
-    if(ssv)
-        Perl_sharedsv_lock(aTHX_ ssv);
-#endif /* USE_ITHREADS */
+    SvLOCK(sv);
     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
        || SvTYPE(retsv) == SVt_PVCV) {
        retsv = refto(retsv);
diff --git a/proto.h b/proto.h
index b93bb2c..f2f8fe0 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -980,6 +980,9 @@ PERL_CALLCONV void  Perl_sys_intern_init(pTHX);
 PERL_CALLCONV char *   Perl_custom_op_name(pTHX_ OP* op);
 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 *);
 
 END_EXTERN_C
 
@@ -1189,17 +1192,6 @@ STATIC void      S_debprof(pTHX_ OP *o);
 STATIC SV*     S_save_scalar_at(pTHX_ SV **sptr);
 #endif
 
-#if defined(USE_ITHREADS)
-PERL_CALLCONV void     Perl_sharedsv_init(pTHX);
-PERL_CALLCONV shared_sv*       Perl_sharedsv_new(pTHX);
-PERL_CALLCONV shared_sv*       Perl_sharedsv_find(pTHX_ SV* sv);
-PERL_CALLCONV void     Perl_sharedsv_lock(pTHX_ shared_sv* ssv);
-PERL_CALLCONV void     Perl_sharedsv_unlock(pTHX_ shared_sv* ssv);
-PERL_CALLCONV void     Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv);
-PERL_CALLCONV void     Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv);
-PERL_CALLCONV void     Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv);
-#endif
-
 #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
 STATIC IV      S_asIV(pTHX_ SV* sv);
 STATIC UV      S_asUV(pTHX_ SV* sv);
diff --git a/sharedsv.c b/sharedsv.c
deleted file mode 100644 (file)
index f0cba10..0000000
+++ /dev/null
@@ -1,244 +0,0 @@
-/*    sharedsv.c
- *
- *    Copyright (c) 2001, Larry Wall
- *
- *    You may distribute under the terms of either the GNU General Public
- *    License or the Artistic License, as specified in the README file.
- *
- */
-
-/*
-* Contributed by Arthur Bergman arthur@contiller.se
-*
-* "Hand any two wizards a piece of rope and they would instinctively pull in
-* opposite directions."
-*                         --Sourcery
-*
-*/
-
-#include "EXTERN.h"
-#define PERL_IN_SHAREDSV_C
-#include "perl.h"
-
-#ifdef USE_ITHREADS
-
-
-
-/*
-  Shared SV
-
-  Shared SV is a structure for keeping the backend storage
-  of shared svs.
-
- */
-
-/*
-=head1 Shared SV Functions
-
-=for apidoc sharedsv_init
-
-Saves a space for keeping SVs wider than an interpreter,
-currently only stores a pointer to the first interpreter.
-
-=cut
-*/
-
-void
-Perl_sharedsv_init(pTHX)
-{
-  PerlInterpreter* old_context = PERL_GET_CONTEXT;
-  PL_sharedsv_space = perl_alloc();
-  perl_construct(PL_sharedsv_space);
-  PERL_SET_CONTEXT(old_context);
-  MUTEX_INIT(&PL_sharedsv_space_mutex);
-}
-
-/*
-=for apidoc sharedsv_new
-
-Allocates a new shared sv struct, you must yourself create the SV/AV/HV.
-=cut
-*/
-
-shared_sv *
-Perl_sharedsv_new(pTHX)
-{
-    shared_sv* ssv;
-    New(2555,ssv,1,shared_sv);
-    MUTEX_INIT(&ssv->mutex);
-    COND_INIT(&ssv->cond);
-    COND_INIT(&ssv->user_cond);
-    ssv->owner = 0;
-    ssv->locks = 0;
-    ssv->index = 0;
-    return ssv;
-}
-
-
-/*
-=for apidoc sharedsv_find
-
-Tries to find if a given SV has a shared backend, either by
-looking at magic, or by checking if it is tied again threads::shared.
-
-=cut
-*/
-
-shared_sv *
-Perl_sharedsv_find(pTHX_ SV* sv)
-{
-  /* does all it can to find a shared_sv struct, returns NULL otherwise */
-    shared_sv* ssv = NULL; 
-    switch (SvTYPE(sv)) {
-        case SVt_PVMG:
-        case SVt_PVAV:
-        case SVt_PVHV: {
-            MAGIC* mg = mg_find(sv, PERL_MAGIC_ext);
-            if(mg) {
-               if(strcmp(mg->mg_ptr,"threads::shared"))
-                    break;
-                ssv = INT2PTR(shared_sv *, SvIV(mg->mg_obj));
-               break;
-             }
-           
-            mg = mg_find(sv,PERL_MAGIC_tied);
-             if(mg) {
-                 SV* obj = SvTIED_obj(sv,mg);
-                if(sv_derived_from(obj, "threads::shared"))
-                     ssv = INT2PTR(shared_sv *, SvIV(SvRV(obj)));
-                 break;
-             }
-       }
-    }            
-    return ssv;
-}
-
-/*
-=for apidoc sharedsv_lock
-
-Recursive locks on a sharedsv.
-Locks are dynamically scoped at the level of the first lock.
-=cut
-*/
-void
-Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
-{
-    if(!ssv)
-        return;
-    MUTEX_LOCK(&ssv->mutex);
-    if(ssv->owner && ssv->owner == my_perl) {
-        ssv->locks++;
-       MUTEX_UNLOCK(&ssv->mutex);
-        return;
-    }
-    while(ssv->owner) 
-      COND_WAIT(&ssv->cond,&ssv->mutex);
-    ssv->locks++;
-    ssv->owner = my_perl;
-    if(ssv->locks == 1)
-        SAVEDESTRUCTOR_X(Perl_sharedsv_unlock_scope,ssv);
-    MUTEX_UNLOCK(&ssv->mutex);
-}
-
-/*
-=for apidoc sharedsv_unlock
-
-Recursively unlocks a shared sv.
-
-=cut
-*/
-
-void
-Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
-{
-    MUTEX_LOCK(&ssv->mutex);
-    if(ssv->owner != my_perl) {
-        Perl_croak(aTHX_ "panic: Perl_sharedsv_unlock unlocking mutex that we don't own");
-        MUTEX_UNLOCK(&ssv->mutex); 
-        return;
-    } 
-
-    if(--ssv->locks == 0) {
-        ssv->owner = NULL;
-       COND_SIGNAL(&ssv->cond);
-    }
-    MUTEX_UNLOCK(&ssv->mutex);
- }
-
-void
-Perl_sharedsv_unlock_scope(pTHX_ shared_sv* ssv)
-{
-    MUTEX_LOCK(&ssv->mutex);
-    if(ssv->owner != my_perl) {
-        MUTEX_UNLOCK(&ssv->mutex);
-        return;
-    }
-    ssv->locks = 0;
-    ssv->owner = NULL;
-    COND_SIGNAL(&ssv->cond);
-    MUTEX_UNLOCK(&ssv->mutex);
-}
-
-/*
-=for apidoc sharedsv_thrcnt_inc
-
-Increments the threadcount of a sharedsv.
-=cut
-*/
-void
-Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv)
-{
-  SHAREDSvLOCK(ssv);
-  SvREFCNT_inc(ssv->sv);
-  SHAREDSvUNLOCK(ssv);
-}
-
-/*
-=for apidoc sharedsv_thrcnt_dec
-
-Decrements the threadcount of a shared sv. When a threads frontend is freed
-this function should be called.
-
-=cut
-*/
-
-void
-Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv)
-{
-    SV* sv;
-    SHAREDSvLOCK(ssv);
-    sv = SHAREDSvGET(ssv);
-    if (SvREFCNT(sv) == 1) {
-        switch (SvTYPE(sv)) {
-        case SVt_RV:
-            if (SvROK(sv))
-            Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(SvRV(sv))));
-            break;
-        case SVt_PVAV: {
-            SV **src_ary  = AvARRAY((AV *)sv);
-            SSize_t items = AvFILLp((AV *)sv) + 1;
-
-            while (items-- > 0) {
-            if(SvTYPE(*src_ary))
-                Perl_sharedsv_thrcnt_dec(aTHX_ INT2PTR(shared_sv *, SvIV(*src_ary)));
-                src_ary++;
-            }
-            break;
-        }
-        case SVt_PVHV: {
-            HE *entry;
-            (void)hv_iterinit((HV *)sv);
-            while ((entry = hv_iternext((HV *)sv)))
-                Perl_sharedsv_thrcnt_dec(
-                    aTHX_ INT2PTR(shared_sv *, SvIV(hv_iterval((HV *)sv, entry)))
-                );
-            break;
-        }
-        }
-    }
-    Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(ssv));
-    SHAREDSvUNLOCK(ssv);
-}
-
-#endif /* USE_ITHREADS */
-
diff --git a/sharedsv.h b/sharedsv.h
deleted file mode 100644 (file)
index f82804d..0000000
+++ /dev/null
@@ -1,29 +0,0 @@
-#ifdef USE_ITHREADS
-
-typedef struct {
-    SV                 *sv;             /* The actual SV */
-    perl_mutex          mutex;          /* Our mutex */
-    perl_cond           cond;           /* Our condition variable */
-    perl_cond           user_cond;      /* For user-level conditions */
-    IV                  locks;          /* Number of locks held */
-    PerlInterpreter    *owner;          /* Who owns the lock? */
-    U16                 index;          /* Update index */
-} shared_sv;
-
-#define SHAREDSvGET(a)      (a->sv)
-#define SHAREDSvLOCK(a)     Perl_sharedsv_lock(aTHX_ a)
-#define SHAREDSvUNLOCK(a)   Perl_sharedsv_unlock(aTHX_ a)
-
-#define SHAREDSvEDIT(a)     STMT_START {                                \
-                                MUTEX_LOCK(&PL_sharedsv_space_mutex);   \
-                                SHAREDSvLOCK((a));                      \
-                                PERL_SET_CONTEXT(PL_sharedsv_space);    \
-                            } STMT_END
-
-#define SHAREDSvRELEASE(a)  STMT_START {                                \
-                                PERL_SET_CONTEXT((a)->owner);           \
-                                SHAREDSvUNLOCK((a));                    \
-                                MUTEX_UNLOCK(&PL_sharedsv_space_mutex); \
-                            } STMT_END
-
-#endif /* USE_ITHREADS */
diff --git a/sv.c b/sv.c
index 2fbabb0..89633b5 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4418,17 +4418,16 @@ Perl_newSV(pTHX_ STRLEN len)
 /*
 =for apidoc sv_magicext
 
-Adds magic to an SV, upgrading it if necessary. Applies the 
+Adds magic to an SV, upgrading it if necessary. Applies the
 supplied vtable and returns pointer to the magic added.
 
 Note that sv_magicext will allow things that sv_magic will not.
-In particular you can add magic to SvREADONLY SVs and and more than 
+In particular you can add magic to SvREADONLY SVs and and more than
 one instance of the same 'how'
 
 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
-(if C<name> is NULL then namelen bytes are allocated and Zero()-ed),
-if C<namelen> is zero then C<name> is stored as-is and - as another special 
-case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain 
+if C<namelen> is zero then C<name> is stored as-is and - as another special
+case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
 an C<SV*> and has its REFCNT incremented
 
 (This is now used as a subroutine by sv_magic.)
@@ -4440,7 +4439,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
                 const char* name, I32 namlen)
 {
     MAGIC* mg;
-    
+
     if (SvTYPE(sv) < SVt_PVMG) {
        (void)SvUPGRADE(sv, SVt_PVMG);
     }
@@ -4473,11 +4472,11 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
            mg->mg_ptr = savepvn(name, namlen);
        else if (namlen == HEf_SVKEY)
            mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
-       else 
+       else
            mg->mg_ptr = (char *) name;
     }
     mg->mg_virtual = vtable;
-    
+
     mg_magical(sv);
     if (SvGMAGICAL(sv))
        SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
@@ -4495,7 +4494,7 @@ then adds a new magic item of type C<how> to the head of the magic list.
 
 void
 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
-{ 
+{
     MAGIC* mg;
     MGVTBL *vtable = 0;
 
@@ -4512,15 +4511,15 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     }
     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
        if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
-           /* sv_magic() refuses to add a magic of the same 'how' as an 
-              existing one 
+           /* sv_magic() refuses to add a magic of the same 'how' as an
+              existing one
             */
            if (how == PERL_MAGIC_taint)
                mg->mg_len |= 1;
            return;
        }
     }
-        
+
     switch (how) {
     case PERL_MAGIC_sv:
        vtable = &PL_vtbl_sv;
@@ -4632,10 +4631,10 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     default:
        Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
     }
-    
+
     /* Rest of work is done else where */
     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
-    
+
     switch (how) {
     case PERL_MAGIC_taint:
        mg->mg_len = 1;
@@ -8702,7 +8701,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
        nmg->mg_len     = mg->mg_len;
        nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
        if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
-           if (mg->mg_len >= 0) {
+           if (mg->mg_len > 0) {
                nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
                if (mg->mg_type == PERL_MAGIC_overload_table &&
                        AMT_AMAGIC((AMT*)mg->mg_ptr))
@@ -8718,6 +8717,9 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
            else if (mg->mg_len == HEf_SVKEY)
                nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
        }
+       if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
+           CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
+       }
        mgprev = nmg;
     }
     return mgret;
@@ -8938,9 +8940,9 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
     else if (SvPVX(sstr)) {
        /* Has something there */
        if (SvLEN(sstr)) {
-           /* Normal PV - clone whole allocated space */ 
+           /* Normal PV - clone whole allocated space */
            SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
-       }  
+       }
        else {
            /* Special case - not normally malloced for some reason */
            if (SvREADONLY(sstr) && SvFAKE(sstr)) {
@@ -10494,3 +10496,4 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
      return SvPVX(sv);
 }
 
+
diff --git a/sv.h b/sv.h
index 7c07988..8414124 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1167,6 +1167,18 @@ Like C<SvSetSV>, but does any set magic required afterwards.
 =for apidoc Am|void|SvSetMagicSV_nosteal|SV* dsv|SV* ssv
 Like C<SvSetMagicSV>, but does any set magic required afterwards.
 
+=for apidoc Am|void|SvSHARE|SV* sv
+Arranges for sv to be shared between threads if a suitable module
+has been loaded.
+
+=for apidoc Am|void|SvLOCK|SV* sv
+Arranges for a mutual exclusion lock to be obtained on sv if a suitable module
+has been loaded.
+
+=for apidoc Am|void|SvUNLOCK|SV* sv
+Releases a mutual exclusion lock on sv if a suitable module
+has been loaded.
+
 =head1 SV Manipulation Functions
 
 =for apidoc Am|char *|SvGROW|SV* sv|STRLEN len
@@ -1178,6 +1190,10 @@ Returns a pointer to the character buffer.
 =cut
 */
 
+#define SvSHARE(sv) CALL_FPTR(PL_sharehook)(aTHX_ sv)
+#define SvLOCK(sv) CALL_FPTR(PL_lockhook)(aTHX_ sv)
+#define SvUNLOCK(sv) CALL_FPTR(PL_unlockhook)(aTHX_ sv)
+
 #define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
 #define SvSETMAGIC(x) STMT_START { if (SvSMAGICAL(x)) mg_set(x); } STMT_END
 
diff --git a/util.c b/util.c
index a816cb9..46b9ac1 100644 (file)
--- a/util.c
+++ b/util.c
@@ -4273,3 +4273,52 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 }
 #endif
 
+/*
+
+=for apidoc sv_nosharing
+
+Dummy routine which "shares" an SV when there is no sharing module present.
+Exists to avoid test for a NULL function pointer and because it could potentially warn under
+some level of strict-ness.
+
+=cut
+*/
+
+void
+Perl_sv_nosharing(pTHX_ SV *sv)
+{
+}
+
+/*
+=for apidoc sv_nolocking
+
+Dummy routine which "locks" an SV when there is no locking module present.
+Exists to avoid test for a NULL function pointer and because it could potentially warn under
+some level of strict-ness.
+
+=cut
+*/
+
+void
+Perl_sv_nolocking(pTHX_ SV *sv)
+{
+}
+
+
+/*
+=for apidoc sv_nounlocking
+
+Dummy routine which "unlocks" an SV when there is no locking module present.
+Exists to avoid test for a NULL function pointer and because it could potentially warn under
+some level of strict-ness.
+
+=cut
+*/
+
+void
+Perl_sv_nounlocking(pTHX_ SV *sv)
+{
+}
+
+
+