submit-ing to get to Win32, and as "off site" backup.
p4raw-id: //depot/perlio@14352
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
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)
CC = cc
LD = $(CC)
DEFINES = -DPERL_CORE -DPERL_MICRO
-OPTIMIZE =
+OPTIMIZE =
CFLAGS = $(DEFINES) $(OPTIMIZE)
LIBS = -lm
_O = .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)
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
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
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
#endif
#define custom_op_name Perl_custom_op_name
#define custom_op_desc Perl_custom_op_desc
+#define sv_nosharing Perl_sv_nosharing
+#define sv_nolocking Perl_sv_nolocking
+#define sv_nounlocking Perl_sv_nounlocking
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
#define avhv_index_sv S_avhv_index_sv
#define avhv_index S_avhv_index
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#define save_scalar_at S_save_scalar_at
#endif
-#if defined(USE_ITHREADS)
-#define sharedsv_init Perl_sharedsv_init
-#define sharedsv_new Perl_sharedsv_new
-#define sharedsv_find Perl_sharedsv_find
-#define sharedsv_lock Perl_sharedsv_lock
-#define sharedsv_unlock Perl_sharedsv_unlock
-#define sharedsv_unlock_scope Perl_sharedsv_unlock_scope
-#define sharedsv_thrcnt_inc Perl_sharedsv_thrcnt_inc
-#define sharedsv_thrcnt_dec Perl_sharedsv_thrcnt_dec
-#endif
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
#define asIV S_asIV
#define asUV S_asUV
#endif
#define custom_op_name(a) Perl_custom_op_name(aTHX_ a)
#define custom_op_desc(a) Perl_custom_op_desc(aTHX_ a)
+#define sv_nosharing(a) Perl_sv_nosharing(aTHX_ a)
+#define sv_nolocking(a) Perl_sv_nolocking(aTHX_ a)
+#define sv_nounlocking(a) Perl_sv_nounlocking(aTHX_ a)
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
#define avhv_index_sv(a) S_avhv_index_sv(aTHX_ a)
#define avhv_index(a,b,c) S_avhv_index(aTHX_ a,b,c)
#if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
#define save_scalar_at(a) S_save_scalar_at(aTHX_ a)
#endif
-#if defined(USE_ITHREADS)
-#define sharedsv_init() Perl_sharedsv_init(aTHX)
-#define sharedsv_new() Perl_sharedsv_new(aTHX)
-#define sharedsv_find(a) Perl_sharedsv_find(aTHX_ a)
-#define sharedsv_lock(a) Perl_sharedsv_lock(aTHX_ a)
-#define sharedsv_unlock(a) Perl_sharedsv_unlock(aTHX_ a)
-#define sharedsv_unlock_scope(a) Perl_sharedsv_unlock_scope(aTHX_ a)
-#define sharedsv_thrcnt_inc(a) Perl_sharedsv_thrcnt_inc(aTHX_ a)
-#define sharedsv_thrcnt_dec(a) Perl_sharedsv_thrcnt_dec(aTHX_ a)
-#endif
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
#define asIV(a) S_asIV(aTHX_ a)
#define asUV(a) S_asUV(aTHX_ a)
#define PL_curinterp (PL_Vars.Gcurinterp)
#define PL_do_undump (PL_Vars.Gdo_undump)
#define PL_hexdigit (PL_Vars.Ghexdigit)
+#define PL_lockhook (PL_Vars.Glockhook)
#define PL_malloc_mutex (PL_Vars.Gmalloc_mutex)
#define PL_op_mutex (PL_Vars.Gop_mutex)
#define PL_patleave (PL_Vars.Gpatleave)
#define PL_runops_dbg (PL_Vars.Grunops_dbg)
#define PL_runops_std (PL_Vars.Grunops_std)
-#define PL_sharedsv_space (PL_Vars.Gsharedsv_space)
-#define PL_sharedsv_space_mutex (PL_Vars.Gsharedsv_space_mutex)
+#define PL_sharehook (PL_Vars.Gsharehook)
#define PL_thr_key (PL_Vars.Gthr_key)
+#define PL_unlockhook (PL_Vars.Gunlockhook)
#else /* !PERL_GLOBAL_STRUCT */
#define PL_Gcurinterp PL_curinterp
#define PL_Gdo_undump PL_do_undump
#define PL_Ghexdigit PL_hexdigit
+#define PL_Glockhook PL_lockhook
#define PL_Gmalloc_mutex PL_malloc_mutex
#define PL_Gop_mutex PL_op_mutex
#define PL_Gpatleave PL_patleave
#define PL_Grunops_dbg PL_runops_dbg
#define PL_Grunops_std PL_runops_std
-#define PL_Gsharedsv_space PL_sharedsv_space
-#define PL_Gsharedsv_space_mutex PL_sharedsv_space_mutex
+#define PL_Gsharehook PL_sharehook
#define PL_Gthr_key PL_thr_key
+#define PL_Gunlockhook PL_unlockhook
#endif /* PERL_GLOBAL_STRUCT */
+/* 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);
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);
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);
RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared)));
SHAREDSvUNLOCK(shared);
OUTPUT:
- RETVAL
+ RETVAL
void
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)
croak("thrcnt can only be used on shared values");
Perl_sharedsv_thrcnt_dec(aTHX_ shared);
-void
+void
unlock_enabled(ref)
SV* ref
PROTOTYPE: \[$@%]
MODULE = threads::shared PACKAGE = threads::shared::av
-SV*
+SV*
new(class, value)
SV* class
SV* value
SV* self
SV* index
SV* value
- CODE:
+ CODE:
shared_sv* shared = INT2PTR(shared_sv*, SvIV(SvRV(self)));
shared_sv* slot;
SV* aentry;
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));
}
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));
}
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));
}
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;
}
MODULE = threads::shared PACKAGE = threads::shared::hv
-SV*
+SV*
new(class, value)
SV* class
SV* value
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));
}
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));
}
SHAREDSvUNLOCK(shared);
OUTPUT:
RETVAL
+
+BOOT:
+{
+ Perl_sharedsv_init(aTHX);
+}
+++ /dev/null
-
-#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);
-
-
-
-
-
-
-
-
-
use strict;
use warnings;
-use overload
+use overload
'==' => \&equal,
'fallback' => 1;
bootstrap threads $VERSION;
+# why document 'new' then use 'create' in the tests!
+*create = \&new;
+
# Preloaded methods go here.
1;
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>
-#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);
}
#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);
}
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;
# 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);
+}
+
--- /dev/null
+ithread * T_ITHREAD
+
+INPUT
+T_ITHREAD
+ $var = SV_to_ithread(aTHX_ $arg)
+
+OUTPUT
+T_ITHREAD
+ ithread_to_SV(aTHX_ $arg, $var, classname, TRUE);
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
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 */
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)
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
#define MGf_TAINTEDDIR 1
#define MGf_REFCOUNTED 2
#define MGf_GSKIP 4
+#define MGf_COPY 8
+#define MGf_DUP 16
#define MGf_MINMATCH 1
#include "scope.h"
#include "warnings.h"
#include "utf8.h"
-#include "sharedsv.h"
/* Current curly descriptor */
typedef struct curcur CURCUR;
#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 */
#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 /
#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 */
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) */
#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};
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),
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),
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)};
#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
#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 */
#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))
+
{
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
# 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;
}
XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
-
+
RETURN;
}
* 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");
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);
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
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);
+++ /dev/null
-/* 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 */
-
+++ /dev/null
-#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 */
/*
=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.)
const char* name, I32 namlen)
{
MAGIC* mg;
-
+
if (SvTYPE(sv) < SVt_PVMG) {
(void)SvUPGRADE(sv, SVt_PVMG);
}
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);
void
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
-{
+{
MAGIC* mg;
MGVTBL *vtable = 0;
}
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;
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;
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))
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;
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)) {
return SvPVX(sv);
}
+
=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
=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
}
#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)
+{
+}
+
+
+
projects / p5sagit/p5-mst-13.2.git / commitdiff