#define invert Perl_invert
#define io_close Perl_io_close
#define jmaybe Perl_jmaybe
-#define key_create Perl_key_create
-#define key_destroy Perl_key_destroy
#define keyword Perl_keyword
#define know_next Perl_know_next
#define last_lop Perl_last_lop
goto finishoff;
}
+ CATCH_SET(TRUE);
+
/* Now duplicate most of perl_call_sv but with a few twists */
op = (OP*)&myop;
Zero(op, 1, LOGOP);
/* removed for debug */
SvREFCNT_dec(curstack);
#endif
- SvREFCNT_dec(cvcache);
+ SvREFCNT_dec(thr->cvcache);
SvREFCNT_dec(thr->magicals);
SvREFCNT_dec(thr->specific);
Safefree(markstack);
Safefree(retstack);
Safefree(cxstack);
Safefree(tmps_stack);
+ Safefree(ofs);
MUTEX_LOCK(&thr->mutex);
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
savethread = thr;
thr = new_struct_thread(thr);
- init_stacks(ARGS);
SPAGAIN;
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
"%p: newthread, tid is %u, preparing stack\n",
#endif
if (err) {
/* Thread creation failed--clean up */
- SvREFCNT_dec(cvcache);
+ SvREFCNT_dec(thr->cvcache);
remove_thread(thr);
MUTEX_DESTROY(&thr->mutex);
for (i = 0; i <= AvFILL(initargs); i++)
croak("panic: sigprocmask");
#endif
sv = newSViv(thr->tid);
- sv_magic(sv, oursv, '~', 0, 0);
+ sv_magic(sv, thr->oursv, '~', 0, 0);
SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
return sv_bless(newRV_noinc(sv), gv_stashpv(class, TRUE));
}
SV *sv;
PPCODE:
sv = newSViv(thr->tid);
- sv_magic(sv, oursv, '~', 0, 0);
+ sv_magic(sv, thr->oursv, '~', 0, 0);
SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv), gv_stashpv(class, TRUE))));
do {
SV *sv = (SV*)SvRV(*svp);
sv_setiv(sv, t->tid);
- SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->Toursv);
+ SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->oursv);
SvMAGIC(sv)->mg_flags |= MGf_REFCOUNTED;
SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
t = t->next;
in_my_stash
inc_amg
io_close
-key_create
-key_destroy
know_next
last_lop
last_lop_op
filled = 1;
}
#endif
- amt.table[i]= cv ? (CV*)SvREFCNT_inc(cv) : 0;
+ amt.table[i]=(CV*)SvREFCNT_inc(cv);
}
if (filled) {
AMT_AMAGIC_on(&amt);
warn("Variable \"%s\" will not stay shared", name);
}
}
- av_store(comppad, newoff, oldsv ? SvREFCNT_inc(oldsv) : 0);
+ av_store(comppad, newoff, SvREFCNT_inc(oldsv));
return newoff;
}
}
static void init_debugger _((void));
static void init_lexer _((void));
static void init_main_stash _((void));
+#ifdef USE_THREADS
+static struct thread * init_main_thread _((void));
+#endif /* USE_THREADS */
static void init_perllib _((void));
static void init_postdump_symbols _((int, char **, char **));
static void init_predump_symbols _((void));
MUTEX_INIT(&threads_mutex);
COND_INIT(&nthreads_cond);
- thr = new_struct_thread(0);
+ thr = init_main_thread();
#endif /* USE_THREADS */
linestr = NEWSV(65,80);
SvREFCNT_dec(subdir);
}
+#ifdef USE_THREADS
+static struct thread *
+init_main_thread()
+{
+ struct thread *thr;
+ XPV *xpv;
+
+ Newz(53, thr, 1, struct thread);
+ curcop = &compiling;
+ thr->cvcache = newHV();
+ thr->magicals = newAV();
+ thr->specific = newAV();
+ thr->flags = THRf_R_JOINABLE;
+ MUTEX_INIT(&thr->mutex);
+ /* Handcraft thrsv similarly to mess_sv */
+ New(53, thrsv, 1, SV);
+ Newz(53, xpv, 1, XPV);
+ SvFLAGS(thrsv) = SVt_PV;
+ SvANY(thrsv) = (void*)xpv;
+ SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
+ SvPVX(thrsv) = (char*)thr;
+ SvCUR_set(thrsv, sizeof(thr));
+ SvLEN_set(thrsv, sizeof(thr));
+ *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
+ thr->oursv = thrsv;
+ curcop = &compiling;
+ chopset = " \n-";
+
+ MUTEX_LOCK(&threads_mutex);
+ nthreads++;
+ thr->tid = 0;
+ thr->next = thr;
+ thr->prev = thr;
+ MUTEX_UNLOCK(&threads_mutex);
+
+#ifdef HAVE_THREAD_INTERN
+ init_thread_intern(thr);
+#else
+ thr->self = pthread_self();
+#endif /* HAVE_THREAD_INTERN */
+ SET_THR(thr);
+
+ /*
+ * These must come after the SET_THR because sv_setpvn does
+ * SvTAINT and the taint fields require dTHR.
+ */
+ toptarget = NEWSV(0,0);
+ sv_upgrade(toptarget, SVt_PVFM);
+ sv_setpvn(toptarget, "", 0);
+ bodytarget = NEWSV(0,0);
+ sv_upgrade(bodytarget, SVt_PVFM);
+ sv_setpvn(bodytarget, "", 0);
+ formtarget = bodytarget;
+ return thr;
+}
+#endif /* USE_THREADS */
+
void
call_list(oldscope, list)
I32 oldscope;
CvPADLIST(compcv) = comppadlist;
if (saveop->op_type != OP_REQUIRE)
- CvOUTSIDE(compcv) = caller ? (CV*)SvREFCNT_inc(caller) : 0;
+ CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
SAVEFREESV(compcv);
* (3) instead of (2) so we'd have to clone. Would the fact
* that we released the mutex more quickly make up for this?
*/
- svp = hv_fetch(cvcache, (char *)cv, sizeof(cv), FALSE);
+ svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE);
if (svp) {
/* We already have a clone to use */
MUTEX_UNLOCK(CvMUTEXP(cv));
*/
clonecv = cv_clone(cv);
SvREFCNT_dec(cv); /* finished with this */
- hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
+ hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
CvOWNER(clonecv) = thr;
cv = clonecv;
SvREFCNT_inc(cv);
OP* invert _((OP* cmd));
OP* jmaybe _((OP* arg));
I32 keyword _((char* d, I32 len));
-PADOFFSET key_create _((void));
-void key_destroy _((PADOFFSET key));
void leave_scope _((I32 base));
void lex_end _((void));
void lex_start _((SV* line));
#define SvREFCNT(sv) (sv)->sv_refcnt
#ifdef __GNUC__
-# define SvREFCNT_inc(sv) ({SV *nsv = (SV*)(sv); ++SvREFCNT(nsv); nsv;})
+# define SvREFCNT_inc(sv) ({SV* nsv=(SV*)(sv); if(nsv) ++SvREFCNT(nsv); nsv;})
#else
# if defined(CRIPPLED_CC) || defined(USE_THREADS)
-# define SvREFCNT_inc(sv) sv_newref((SV*)sv)
+# define SvREFCNT_inc(sv) sv_newref((SV*)sv)
# else
-# define SvREFCNT_inc(sv) ((Sv = (SV*)(sv)), ++SvREFCNT(Sv), (SV*)Sv)
+# define SvREFCNT_inc(sv) ((Sv=(SV*)(sv)), (Sv && ++SvREFCNT(Sv)), (SV*)Sv)
# endif
#endif
/* XXX Sort stuff, firstgv, secongv and so on? */
- SV * Toursv;
- HV * Tcvcache;
+ SV * oursv;
+ HV * cvcache;
perl_thread self; /* Underlying thread object */
U32 flags;
AV * magicals; /* Per-thread magicals */
#ifdef ADD_THREAD_INTERN
struct thread_intern i; /* Platform-dependent internals */
#endif
- char trailing_nul; /* For the sake of thrsv, t->Toursv */
+ char trailing_nul; /* For the sake of thrsv and oursv */
};
typedef struct thread *Thread;
#undef dirty
#undef localizing
-#define oursv (thr->Toursv)
#define stack_base (thr->Tstack_base)
#define stack_sp (thr->Tstack_sp)
#define stack_max (thr->Tstack_max)
#define top_env (thr->Ttop_env)
#define runlevel (thr->Trunlevel)
-#define cvcache (thr->Tcvcache)
#else
/* USE_THREADS is not defined */
#define MUTEX_LOCK(m)
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(compcv) = comppadlist;
- CvOUTSIDE(compcv) = outsidecv ? (CV*)SvREFCNT_inc(outsidecv) : 0;
+ CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
#ifdef USE_THREADS
CvOWNER(compcv) = 0;
New(666, CvMUTEXP(compcv), 1, perl_mutex);
GV *gv;
CV *cv;
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "die: curstack = %p, mainstack= %p\n",
- curstack, mainstack));/*debug*/
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "%p: die: curstack = %p, mainstack = %p\n",
+ thr, curstack, mainstack));
/* We have to switch back to mainstack or die_where may try to pop
* the eval block from the wrong stack if die is being called from a
* signal handler. - dkindred@cs.cmu.edu */
message = mess(pat, &args);
va_end(args);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "die: message = %s\ndiehook = %p\n",
- message, diehook));/*debug*/
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "%p: die: message = %s\ndiehook = %p\n",
+ thr, message, diehook));
if (diehook) {
/* sv_2cv might call croak() */
SV *olddiehook = diehook;
restartop = die_where(message);
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
- "die: restartop = %p, was_in_eval = %d, oldrunlevel = %d\n",
- restartop, was_in_eval, oldrunlevel));/*debug*/
+ "%p: die: restartop = %p, was_in_eval = %d, oldrunlevel = %d\n",
+ thr, restartop, was_in_eval, oldrunlevel));
if ((!restartop && was_in_eval) || oldrunlevel > 1)
JMPENV_JUMP(3);
return restartop;
}
/*
- * Make a new perl thread structure using t as a prototype. If t is NULL
- * then this is the initial main thread and we have to bootstrap carefully.
- * Some of the fields for the new thread are copied from the prototype
- * thread, t, so t should not be running in perl at the time this function
- * is called. The usual case, where t is the thread calling new_struct_thread,
- * clearly satisfies this constraint.
+ * Make a new perl thread structure using t as a prototype. Some of the
+ * fields for the new thread are copied from the prototype thread, t,
+ * so t should not be running in perl at the time this function is
+ * called. The use by ext/Thread/Thread.xs in core perl (where t is the
+ * thread calling new_struct_thread) clearly satisfies this constraint.
*/
struct thread *
new_struct_thread(t)
struct thread *t;
{
struct thread *thr;
- XPV *xpv;
SV *sv;
+ SV **svp;
+ I32 i;
+
+ sv = newSVpv("", 0);
+ SvGROW(sv, sizeof(struct thread) + 1);
+ SvCUR_set(sv, sizeof(struct thread));
+ thr = (Thread) SvPVX(sv);
+ /* Zero(thr, 1, struct thread); */
+
+ /* debug */
+ memset(thr, 0xab, sizeof(struct thread));
+ markstack = 0;
+ scopestack = 0;
+ savestack = 0;
+ retstack = 0;
+ dirty = 0;
+ localizing = 0;
+ /* end debug */
+
+ thr->oursv = sv;
+ init_stacks(thr);
- Newz(53, thr, 1, struct thread);
- cvcache = newHV();
curcop = &compiling;
+ thr->cvcache = newHV();
thr->magicals = newAV();
thr->specific = newAV();
thr->flags = THRf_R_JOINABLE;
MUTEX_INIT(&thr->mutex);
- if (t) {
- oursv = newSVpv("", 0);
- SvGROW(oursv, sizeof(struct thread) + 1);
- SvCUR_set(oursv, sizeof(struct thread));
- thr = (struct thread *) SvPVX(sv);
- } else {
- /* Handcraft thrsv similarly to mess_sv */
- New(53, thrsv, 1, SV);
- Newz(53, xpv, 1, XPV);
- SvFLAGS(thrsv) = SVt_PV;
- SvANY(thrsv) = (void*)xpv;
- SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
- SvPVX(thrsv) = (char*)thr;
- SvCUR_set(thrsv, sizeof(thr));
- SvLEN_set(thrsv, sizeof(thr));
- *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
- oursv = thrsv;
- }
- if (t) {
- curcop = t->Tcurcop; /* XXX As good a guess as any? */
- defstash = t->Tdefstash; /* XXX maybe these should */
- curstash = t->Tcurstash; /* always be set to main? */
- /* top_env? */
- /* runlevel */
- tainted = t->Ttainted;
- curpm = t->Tcurpm; /* XXX No PMOP ref count */
- nrs = newSVsv(t->Tnrs);
- rs = newSVsv(t->Trs);
- last_in_gv = (GV*)SvREFCNT_inc(t->Tlast_in_gv);
- ofslen = t->Tofslen;
- ofs = savepvn(t->Tofs, ofslen);
- defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
- chopset = t->Tchopset;
- formtarget = newSVsv(t->Tformtarget);
- bodytarget = newSVsv(t->Tbodytarget);
- toptarget = newSVsv(t->Ttoptarget);
- } else {
- curcop = &compiling;
- chopset = " \n-";
- }
+
+ curcop = t->Tcurcop; /* XXX As good a guess as any? */
+ defstash = t->Tdefstash; /* XXX maybe these should */
+ curstash = t->Tcurstash; /* always be set to main? */
+ /* top_env needs to be non-zero. The particular value doesn't matter */
+ top_env = t->Ttop_env;
+ runlevel = 1; /* XXX should be safe ? */
+ in_eval = FALSE;
+ restartop = 0;
+
+ tainted = t->Ttainted;
+ curpm = t->Tcurpm; /* XXX No PMOP ref count */
+ nrs = newSVsv(t->Tnrs);
+ rs = newSVsv(t->Trs);
+ last_in_gv = (GV*)SvREFCNT_inc(t->Tlast_in_gv);
+ ofslen = t->Tofslen;
+ ofs = savepvn(t->Tofs, ofslen);
+ defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
+ chopset = t->Tchopset;
+ formtarget = newSVsv(t->Tformtarget);
+ bodytarget = newSVsv(t->Tbodytarget);
+ toptarget = newSVsv(t->Ttoptarget);
+
+ /* Initialise all per-thread magicals that the template thread used */
+ svp = AvARRAY(t->magicals);
+ for (i = 0; i <= AvFILL(t->magicals); i++, svp++) {
+ if (*svp && *svp != &sv_undef) {
+ SV *sv = newSVsv(*svp);
+ av_store(thr->magicals, i, sv);
+ sv_magic(sv, 0, 0, &per_thread_magicals[i], 1);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "new_struct_thread: copied magical %d\n",i));
+ }
+ }
+
MUTEX_LOCK(&threads_mutex);
nthreads++;
- thr->tid = threadnum++;
- if (t) {
- thr->next = t->next;
- thr->prev = t;
- t->next = thr;
- thr->next->prev = thr;
- } else {
- thr->next = thr;
- thr->prev = thr;
- }
+ thr->tid = ++threadnum;
+ thr->next = t->next;
+ thr->prev = t;
+ t->next = thr;
+ thr->next->prev = thr;
MUTEX_UNLOCK(&threads_mutex);
#ifdef HAVE_THREAD_INTERN
#else
thr->self = pthread_self();
#endif /* HAVE_THREAD_INTERN */
- SET_THR(thr);
- if (!t) {
- /*
- * These must come after the SET_THR because sv_setpvn does
- * SvTAINT and the taint fields require dTHR.
- */
- toptarget = NEWSV(0,0);
- sv_upgrade(toptarget, SVt_PVFM);
- sv_setpvn(toptarget, "", 0);
- bodytarget = NEWSV(0,0);
- sv_upgrade(bodytarget, SVt_PVFM);
- sv_setpvn(bodytarget, "", 0);
- formtarget = bodytarget;
- }
return thr;
}
#endif /* USE_THREADS */
projects / platform / upstream / perl.git / commitdiff