diff options
| -rw-r--r-- | MANIFEST | 2 | ||||
| -rw-r--r-- | Makefile.SH | 6 | ||||
| -rw-r--r-- | Makefile.micro | 7 | ||||
| -rw-r--r-- | embed.fnc | 14 | ||||
| -rw-r--r-- | embed.h | 26 | ||||
| -rw-r--r-- | embedvar.h | 10 | ||||
| -rw-r--r-- | ext/threads/shared/shared.xs | 314 | ||||
| -rwxr-xr-x | ext/threads/threads.h | 99 | ||||
| -rwxr-xr-x | ext/threads/threads.pm | 9 | ||||
| -rwxr-xr-x | ext/threads/threads.xs | 638 | ||||
| -rw-r--r-- | ext/threads/typemap | 9 | ||||
| -rw-r--r-- | global.sym | 10 | ||||
| -rw-r--r-- | intrpvar.h | 3 | ||||
| -rw-r--r-- | mg.c | 6 | ||||
| -rw-r--r-- | mg.h | 5 | ||||
| -rw-r--r-- | perl.h | 31 | ||||
| -rw-r--r-- | perlapi.h | 10 | ||||
| -rw-r--r-- | perlvars.h | 7 | ||||
| -rw-r--r-- | pp.c | 17 | ||||
| -rw-r--r-- | proto.h | 14 | ||||
| -rw-r--r-- | sharedsv.c | 244 | ||||
| -rw-r--r-- | sharedsv.h | 29 | ||||
| -rw-r--r-- | sv.c | 37 | ||||
| -rw-r--r-- | sv.h | 16 | ||||
| -rw-r--r-- | util.c | 49 |
25 files changed, 839 insertions, 773 deletions
@@ -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 diff --git a/Makefile.SH b/Makefile.SH index f86b17bf6b..9405eeb505 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -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) diff --git a/Makefile.micro b/Makefile.micro index 0e3ddbb632..11f2cc2fda 100644 --- a/Makefile.micro +++ b/Makefile.micro @@ -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 @@ -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 @@ -881,6 +881,9 @@ #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 @@ -1071,16 +1074,6 @@ #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 @@ -2426,6 +2419,9 @@ #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) @@ -2615,16 +2611,6 @@ #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) diff --git a/embedvar.h b/embedvar.h index c6eb5fa7ae..1557c657d3 100644 --- a/embedvar.h +++ b/embedvar.h @@ -1350,14 +1350,15 @@ #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 */ @@ -1366,14 +1367,15 @@ #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 */ diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index cf655cbc58..e21bbe964c 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -1,11 +1,286 @@ +/* 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 index 72a4872485..0000000000 --- a/ext/threads/threads.h +++ /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); - - - - - - - - - diff --git a/ext/threads/threads.pm b/ext/threads/threads.pm index 444ec5b67c..7a5a2740bb 100755 --- a/ext/threads/threads.pm +++ b/ext/threads/threads.pm @@ -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> diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs index 6f58de9681..1b89e2cc14 100755 --- a/ext/threads/threads.xs +++ b/ext/threads/threads.xs @@ -1,68 +1,220 @@ -#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 index 0000000000..269d412ae6 --- /dev/null +++ b/ext/threads/typemap @@ -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); diff --git a/global.sym b/global.sym index e64508b793..df840d92d3 100644 --- a/global.sym +++ b/global.sym @@ -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 diff --git a/intrpvar.h b/intrpvar.h index 00005963b5..dccbdb65b6 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -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 */ @@ -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) @@ -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 @@ -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)}; @@ -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 */ diff --git a/perlvars.h b/perlvars.h index 606f7a5243..8cff1657dc 100644 --- a/perlvars.h +++ b/perlvars.h @@ -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)) + @@ -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); @@ -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 index f0cba10d98..0000000000 --- a/sharedsv.c +++ /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 index f82804dba4..0000000000 --- a/sharedsv.h +++ /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 */ @@ -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); } + @@ -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 @@ -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) +{ +} + + + |