From: Nick Ing-Simmons Date: Fri, 7 Nov 1997 01:37:28 +0000 (+0000) Subject: Raw integrate of latest perl X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e77eedc24c0252a902559034f2aa207f216529cc;p=p5sagit%2Fp5-mst-13.2.git Raw integrate of latest perl p4raw-id: //depot/ansiperl@208 --- e77eedc24c0252a902559034f2aa207f216529cc diff --cc ext/Thread/Thread.xs index 6e7f4b7,9c0325e..d132394 --- a/ext/Thread/Thread.xs +++ b/ext/Thread/Thread.xs @@@ -218,38 -209,8 +223,25 @@@ newthread (SV *startsv, AV *initargs, c #endif savethread = thr; - sv = newSVpv("", 0); - SvGROW(sv, sizeof(struct thread) + 1); - SvCUR_set(sv, sizeof(struct thread)); - thr = (Thread) SvPVX(sv); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: newthread(%s) = %p)\n", - savethread, SvPEEK(startsv), thr)); - oursv = sv; - /* If we don't zero these foostack pointers, init_stacks won't init them */ - markstack = 0; - scopestack = 0; - savestack = 0; - retstack = 0; - init_stacks(ARGS); - curcop = savethread->Tcurcop; /* XXX As good a guess as any? */ + thr = new_struct_thread(thr); SPAGAIN; + defstash = savethread->Tdefstash; /* XXX maybe these should */ + curstash = savethread->Tcurstash; /* always be set to main? */ + /* top_env? */ + /* runlevel */ + cvcache = newHV(); + thr->flags = THRf_R_JOINABLE; + MUTEX_INIT(&thr->mutex); + thr->tid = ++threadnum; + /* Insert new thread into the circular linked list and bump nthreads */ + MUTEX_LOCK(&threads_mutex); + thr->next = savethread->next; + thr->prev = savethread; + savethread->next = thr; + thr->next->prev = thr; + nthreads++; + MUTEX_UNLOCK(&threads_mutex); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: newthread, tid is %u, preparing stack\n", savethread, thr->tid)); @@@ -292,19 -253,14 +284,19 @@@ 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)); + return sv_bless(newRV_noinc(sv), gv_stashpv(Class, TRUE)); +#else + croak("No threads in this perl"); + return &sv_undef; +#endif } +static Signal_t handle_thread_signal _((int sig)); + static Signal_t -handle_thread_signal(sig) -int sig; +handle_thread_signal(int sig) { char c = (char) sig; write(sig_pipe[0], &c, 1); @@@ -393,22 -345,18 +385,22 @@@ voi flags(t) Thread t PPCODE: +#ifdef USE_THREADS PUSHs(sv_2mortal(newSViv(t->flags))); +#endif void -self(class) - char * class +self(Class) + char * Class PREINIT: SV *sv; - PPCODE: + PPCODE: +#ifdef USE_THREADS 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)))); + PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv), gv_stashpv(Class, TRUE)))); +#endif U32 tid(t) diff --cc op.c index a0309de,e91bea9..513a650 --- a/op.c +++ b/op.c @@@ -495,6 -511,45 +495,44 @@@ pad_reset(void pad_reset_pending = FALSE; } + #ifdef USE_THREADS + /* find_thread_magical is not reentrant */ + PADOFFSET -find_thread_magical(name) -char *name; ++find_thread_magical(char *name) + { + dTHR; + char *p; + PADOFFSET key; + SV **svp; + /* We currently only handle single character magicals */ + p = strchr(per_thread_magicals, *name); + if (!p) + return NOT_IN_PAD; + key = p - per_thread_magicals; + svp = av_fetch(thr->magicals, key, FALSE); + if (!svp) { + SV *sv = NEWSV(0, 0); + av_store(thr->magicals, key, sv); + /* + * Some magic variables used to be automagically initialised + * in gv_fetchpv. Those which are now per-thread magicals get + * initialised here instead. + */ + switch (*name) { + case ';': + sv_setpv(sv, "\034"); + break; + } + sv_magic(sv, 0, 0, name, 1); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "find_thread_magical: new SV %p for $%s%c\n", + sv, (*name < 32) ? "^" : "", + (*name < 32) ? toCTRL(*name) : *name)); + } + return key; + } + #endif /* USE_THREADS */ + /* Destructor */ void @@@ -1528,13 -1635,18 +1581,17 @@@ localize(OP *o, I32 lex } OP * -jmaybe(o) -OP *o; +jmaybe(OP *o) { if (o->op_type == OP_LIST) { - o = convert(OP_JOIN, 0, - prepend_elem(OP_LIST, - newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), - o)); + OP *o2; + #ifdef USE_THREADS + o2 = newOP(OP_SPECIFIC, 0); + o2->op_targ = find_thread_magical(";"); + #else + o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), + #endif /* USE_THREADS */ + o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } return o; } @@@ -3390,23 -3615,11 +3462,8 @@@ newSUB(I32 floor, OP *o, OP *proto, OP return cv; } - #ifdef DEPRECATED - CV * - newXSUB(name, ix, subaddr, filename) - char *name; - I32 ix; - I32 (*subaddr)(); - char *filename; - { - CV* cv = newXS(name, (void(*)())subaddr, filename); - CvOLDSTYLE_on(cv); - CvXSUBANY(cv).any_i32 = ix; - return cv; - } - #endif - -V * -newXS(name, subaddr, filename) -char *name; -void (*subaddr) _((CV*)); -char *filename; +CV * - newXS(char *name, void (*subaddr) (CV *), char *filename) ++newXS(char *name, void (*subaddr) _((CV *)), char *filename) { dTHR; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); diff --cc perl.c index aff14f4,fff0450..cca10d3 --- a/perl.c +++ b/perl.c @@@ -979,8 -971,11 +956,11 @@@ print \" \\@INC:\\n @INC\\n\";") /* now that script is parsed, we can modify record separator */ SvREFCNT_dec(rs); rs = SvREFCNT_inc(nrs); + #ifdef USE_THREADS + sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs); + #else sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs); -#endif /* USE_THREADS */ + if (do_undump) my_unexec(); @@@ -2522,7 -2544,11 +2502,10 @@@ init_predump_symbols(void GV *tmpgv; GV *othergv; + #ifdef USE_THREADS + sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1); + #else sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); -#endif /* USE_THREADS */ stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(stdingv); @@@ -2796,8 -2828,67 +2779,65 @@@ incpush(char *p, int addsubdirs 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; -AV* list; +call_list(I32 oldscope, AV *list) { dTHR; line_t oldline = curcop->cop_line; diff --cc pp.c index 3234be3,866ddb0..86dd10f --- a/pp.c +++ b/pp.c @@@ -4296,4 -4296,20 +4296,20 @@@ PP(pp_lock RETURN; } - + PP(pp_specific) + { + #ifdef USE_THREADS - dSP; ++ djSP; + SV **svp = av_fetch(thr->magicals, op->op_targ, FALSE); + if (!svp) + croak("panic: pp_specific"); + EXTEND(sp, 1); + if (op->op_private & OPpLVAL_INTRO) + PUSHs(save_svref(svp)); + else + PUSHs(*svp); + #else + DIE("tried to access thread-specific data in non-threaded perl"); + #endif /* USE_THREADS */ + RETURN; + } diff --cc pp_ctl.c index 3dfc22e,915ee6c..ee60c41 --- a/pp_ctl.c +++ b/pp_ctl.c @@@ -1106,24 -1117,9 +1106,9 @@@ PP(pp_orassign RETURNOP(cLOGOP->op_other); } - #ifdef DEPRECATED - PP(pp_entersubr) - { - djSP; - SV** mark = (stack_base + *markstack_ptr + 1); - SV* cv = *mark; - while (mark < sp) { /* emulate old interface */ - *mark = mark[1]; - mark++; - } - *sp = cv; - return pp_entersub(ARGS); - } - #endif - PP(pp_caller) { - dSP; + djSP; register I32 cxix = dopoptosub(cxstack_ix); register CONTEXT *cx; I32 dbcxix; diff --cc sv.h index 7a283a6,916dc17..c888d8f --- a/sv.h +++ b/sv.h @@@ -70,16 -70,19 +70,19 @@@ struct io #define SvANY(sv) (sv)->sv_any #define SvFLAGS(sv) (sv)->sv_flags -#define SvREFCNT(sv) (sv)->sv_refcnt - #define SvREFCNT(sv) (sv)->sv_refcnt - #ifdef CRIPPLED_CC - #define SvREFCNT_inc(sv) sv_newref((SV*)sv) - #define SvREFCNT_dec(sv) sv_free((SV*)sv) + #ifdef __GNUC__ + # define SvREFCNT_inc(sv) ({SV* nsv=(SV*)(sv); if(nsv) ++SvREFCNT(nsv); nsv;}) #else - #define SvREFCNT_inc(sv) ((Sv = (SV*)(sv)), \ - (Sv && ++SvREFCNT(Sv)), (SV*)Sv) + # if defined(CRIPPLED_CC) || defined(USE_THREADS) + # define SvREFCNT_inc(sv) sv_newref((SV*)sv) + # else + # define SvREFCNT_inc(sv) ((Sv=(SV*)(sv)), (Sv && ++SvREFCNT(Sv)), (SV*)Sv) + # endif + #endif + #define SvREFCNT_dec(sv) sv_free((SV*)sv) +#endif #define SVTYPEMASK 0xff #define SvTYPE(sv) ((sv)->sv_flags & SVTYPEMASK) diff --cc t/TEST index cae8103,cae8103..1bda4ef --- a/t/TEST +++ b/t/TEST @@@ -7,24 -7,24 +7,39 @@@ $| = 1; --if ($#ARGV >= 0 && $ARGV[0] eq '-v') { ++if ($ARGV[0] eq '-v') { $verbose = 1; shift; } chdir 't' if -f 't/TEST'; --die "You need to run \"make test\" first to set things up.\n" ++die "You need to run \"make test\" first to set things up.\n" unless -e 'perl' or -e 'perl.exe'; $ENV{EMXSHELL} = 'sh'; # For OS/2 --if ($#ARGV == -1) { -- @ARGV = split(/[ \n]/, -- `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); ++if ($ARGV[0] eq '') { ++ push( @ARGV, `dir/s/b base` ); ++ push( @ARGV, `dir/s/b comp` ); ++ push( @ARGV, `dir/s/b cmd` ); ++ push( @ARGV, `dir/s/b io` ); ++ push( @ARGV, `dir/s/b op` ); ++ push( @ARGV, `dir/s/b pragma` ); ++ push( @ARGV, `dir/s/b lib` ); ++ ++ grep( chomp, @ARGV ); ++ @ARGV = grep( /\.t$/, @ARGV ); ++ grep( s/.*t\\//, @ARGV ); ++# @ARGV = split(/[ \n]/, ++# `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`); ++} else { ++ ++@ARGV = map(glob($_),@ARGV); ++ } --if ($^O eq 'os2' || $^O eq 'qnx') { ++if ($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'qnx' || 1) { $sharpbang = 0; } else { @@@ -41,8 -41,8 +56,6 @@@ $bad = 0; $good = 0; $total = @ARGV; --$files = 0; --$totmax = 0; while ($test = shift) { if ($test =~ /^$/) { next; @@@ -51,12 -51,12 +64,11 @@@ chop($te); print "$te" . '.' x (18 - length($te)); if ($sharpbang) { -- -x $test || (print "isn't executable.\n"); -- open(RESULTS,"./$test |") || (print "can't run.\n"); ++ open(results,"./$test |") || (print "can't run.\n"); } else { -- open(SCRIPT,"$test") || die "Can't run $test.\n"; -- $_ =