summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--MANIFEST2
-rw-r--r--Makefile.SH6
-rw-r--r--Makefile.micro7
-rw-r--r--embed.fnc14
-rw-r--r--embed.h26
-rw-r--r--embedvar.h10
-rw-r--r--ext/threads/shared/shared.xs314
-rwxr-xr-xext/threads/threads.h99
-rwxr-xr-xext/threads/threads.pm9
-rwxr-xr-xext/threads/threads.xs638
-rw-r--r--ext/threads/typemap9
-rw-r--r--global.sym10
-rw-r--r--intrpvar.h3
-rw-r--r--mg.c6
-rw-r--r--mg.h5
-rw-r--r--perl.h31
-rw-r--r--perlapi.h10
-rw-r--r--perlvars.h7
-rw-r--r--pp.c17
-rw-r--r--proto.h14
-rw-r--r--sharedsv.c244
-rw-r--r--sharedsv.h29
-rw-r--r--sv.c37
-rw-r--r--sv.h16
-rw-r--r--util.c49
25 files changed, 839 insertions, 773 deletions
diff --git a/MANIFEST b/MANIFEST
index 68a0e5f50b..bb99801629 100644
--- 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
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
diff --git a/embed.fnc b/embed.fnc
index f76805ea66..ae73fd1941 100644
--- 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 a2fbb67052..5f8b3ada2b 100644
--- a/embed.h
+++ b/embed.h
@@ -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 */
diff --git a/mg.c b/mg.c
index c7ebca3817..36026431d5 100644
--- 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 0048803440..566ced70fc 100644
--- 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 11cac10a00..e2b3419fcd 100644
--- 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)};
diff --git a/perlapi.h b/perlapi.h
index 76eb92f2c5..82761a4618 100644
--- 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 */
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))
+
diff --git a/pp.c b/pp.c
index 0d7f75bbd3..ef0c75e9d5 100644
--- 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 b93bb2c525..f2f8fe00fb 100644
--- 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
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 */
diff --git a/sv.c b/sv.c
index 2fbabb0214..89633b5de9 100644
--- 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 7c07988518..8414124add 100644
--- 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 a816cb99ba..46b9ac1e2e 100644
--- 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)
+{
+}
+
+
+