diff options
| -rwxr-xr-x | Configure | 8 | ||||
| -rw-r--r-- | MANIFEST | 8 | ||||
| -rw-r--r-- | Makefile.SH | 2 | ||||
| -rw-r--r-- | README.threads | 171 | ||||
| -rw-r--r-- | Todo.5.005 | 33 | ||||
| -rw-r--r-- | XSUB.h | 2 | ||||
| -rw-r--r-- | av.c | 287 | ||||
| -rw-r--r--[-rwxr-xr-x] | config_h.SH | 0 | ||||
| -rw-r--r-- | cop.h | 16 | ||||
| -rw-r--r-- | cv.h | 32 | ||||
| -rw-r--r-- | deb.c | 23 | ||||
| -rw-r--r-- | doio.c | 17 | ||||
| -rw-r--r-- | doop.c | 17 | ||||
| -rw-r--r-- | dump.c | 156 | ||||
| -rw-r--r-- | embed.h | 25 | ||||
| -rw-r--r-- | ext/DB_File/DB_File.pm | 8 | ||||
| -rw-r--r-- | ext/DB_File/DB_File.xs | 9 | ||||
| -rw-r--r-- | ext/Opcode/Makefile.PL | 2 | ||||
| -rw-r--r-- | ext/Opcode/Opcode.pm | 8 | ||||
| -rw-r--r-- | ext/Opcode/Opcode.xs | 7 | ||||
| -rw-r--r-- | ext/attrs/Makefile.PL | 7 | ||||
| -rw-r--r-- | ext/attrs/attrs.pm | 55 | ||||
| -rw-r--r-- | ext/attrs/attrs.xs | 60 | ||||
| -rw-r--r-- | global.sym | 24 | ||||
| -rw-r--r-- | gv.c | 17 | ||||
| -rw-r--r-- | hints/dec_osf.sh | 10 | ||||
| -rw-r--r-- | hints/linux.sh | 11 | ||||
| -rw-r--r-- | hints/solaris_2.sh | 12 | ||||
| -rw-r--r-- | hv.c | 16 | ||||
| -rw-r--r-- | interp.sym | 1 | ||||
| -rw-r--r-- | keywords.h | 468 | ||||
| -rwxr-xr-x | keywords.pl | 2 | ||||
| -rw-r--r-- | lib/Class/Fields.pm | 33 | ||||
| -rw-r--r-- | lib/ISA.pm | 20 | ||||
| -rwxr-xr-x[-rw-r--r--] | lib/diagnostics.pm | 0 | ||||
| -rw-r--r--[-rwxr-xr-x] | makeaperl.SH | 0 | ||||
| -rw-r--r-- | malloc.c | 94 | ||||
| -rw-r--r-- | mg.c | 58 | ||||
| -rw-r--r--[-rwxr-xr-x] | minimod.pl | 0 | ||||
| -rw-r--r-- | op.c | 1679 | ||||
| -rw-r--r-- | op.h | 14 | ||||
| -rw-r--r-- | opcode.h | 761 | ||||
| -rwxr-xr-x | opcode.pl | 7 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.c | 186 | ||||
| -rw-r--r-- | perl.h | 95 | ||||
| -rw-r--r--[-rwxr-xr-x] | perl_exp.SH | 0 | ||||
| -rw-r--r-- | perly.c | 233 | ||||
| -rw-r--r-- | perly.y | 5 | ||||
| -rw-r--r--[-rwxr-xr-x] | pod/roffitall | 0 | ||||
| -rw-r--r-- | pp.c | 102 | ||||
| -rw-r--r-- | pp.h | 7 | ||||
| -rw-r--r-- | pp_ctl.c | 118 | ||||
| -rw-r--r-- | pp_hot.c | 228 | ||||
| -rw-r--r-- | pp_sys.c | 19 | ||||
| -rw-r--r-- | proto.h | 75 | ||||
| -rw-r--r-- | regcomp.c | 24 | ||||
| -rw-r--r-- | regexec.c | 4 | ||||
| -rw-r--r-- | run.c | 37 | ||||
| -rw-r--r-- | scope.c | 53 | ||||
| -rw-r--r-- | scope.h | 14 | ||||
| -rw-r--r-- | sv.c | 222 | ||||
| -rw-r--r-- | sv.h | 9 | ||||
| -rwxr-xr-x[-rw-r--r--] | t/comp/cpp.aux | 0 | ||||
| -rw-r--r--[-rwxr-xr-x] | t/harness | 0 | ||||
| -rwxr-xr-x | t/op/do.t | 2 | ||||
| -rw-r--r-- | thread.h | 295 | ||||
| -rw-r--r-- | toke.c | 80 | ||||
| -rw-r--r-- | util.c | 146 | ||||
| -rw-r--r-- | vms/perly_c.vms | 233 | ||||
| -rw-r--r-- | vms/vms.c | 8 | ||||
| -rw-r--r--[-rwxr-xr-x] | writemain.SH | 0 | ||||
| -rwxr-xr-x | x2p/Makefile.SH | 3 |
73 files changed, 4343 insertions, 2037 deletions
@@ -209,6 +209,7 @@ tr='' troff='' uname='' uniq='' +usethreads='' uuname='' vi='' zcat='' @@ -2089,7 +2090,12 @@ case "$archname" in esac rp='What is your architecture name' . ./myread -archname="$ans" +case "$usethreads" in +$define) archname="$ans-thread" + echo "usethreads selected... architecture name is now $archname." >&4 + ;; +*) archname="$ans" ;; +esac myarchname="$tarch" : is AFS running? @@ -23,9 +23,11 @@ README.cygwin32 Notes about Cygwin32 port README.os2 Notes about OS/2 port README.plan9 Notes about Plan9 port README.qnx Notes about QNX port +README.threads Notes about multithreading README.vms Notes about VMS port README.win32 Notes about Win32 port Todo The Wishlist +Todo.5.005 What needs doing before 5.005 release XSUB.h Include file for extension subroutines av.c Array value code av.h Array value header @@ -206,6 +208,9 @@ ext/SDBM_File/typemap SDBM extension interface types ext/Socket/Makefile.PL Socket extension makefile writer ext/Socket/Socket.pm Socket extension Perl module ext/Socket/Socket.xs Socket extension external subroutines +ext/attrs/Makefile.PL attrs extension makefile writer +ext/attrs/attrs.pm attrs extension Perl module +ext/attrs/attrs.xs attrs extension external subroutines ext/util/extliblist Used by extension Makefile.PL to make lib lists ext/util/make_ext Used by Makefile to execute extension Makefiles ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info @@ -320,6 +325,7 @@ lib/CPAN.pm Interface to Comprehensive Perl Archive Network lib/CPAN/FirstTime.pm Utility for creating CPAN config files lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions lib/Carp.pm Error message base class +lib/Class/Fields.pm Set up object field names for pseudo-hash-using classes lib/Class/Struct.pm Declare struct-like datatypes as Perl classes lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm @@ -358,6 +364,7 @@ lib/Getopt/Std.pm Fetch command options (getopt, getopts) lib/I18N/Collate.pm Routines to do strxfrm-based collation lib/IPC/Open2.pm Open a two-ended pipe lib/IPC/Open3.pm Open a three-ended pipe! +lib/ISA.pm Initialise @ISA at compile-time lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package lib/Math/BigInt.pm An arbitrary precision integer arithmetic package lib/Math/Complex.pm A Complex package @@ -768,6 +775,7 @@ t/pragma/subs.t See if subroutine pseudo-importation works t/pragma/warn-1global Tests of global warnings for warning.t t/pragma/warning.t See if warning controls work taint.c Tainting code +thread.h Threading header toke.c The tokener universal.c The default UNIVERSAL package methods unixish.h Defines that are assumed on Unix diff --git a/Makefile.SH b/Makefile.SH index 86fd6ed02e..f2c5260be1 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -183,7 +183,7 @@ addedbyconf = UU $(shextract) $(plextract) pstruct 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 perly.h pp.h proto.h regcomp.h -h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h +h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h thread.h h = $(h1) $(h2) $(h3) $(h4) c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c diff --git a/README.threads b/README.threads new file mode 100644 index 0000000000..4d20243ce7 --- /dev/null +++ b/README.threads @@ -0,0 +1,171 @@ +Building + +If you want to build with multi-threading support and you are +running Linux 2.x (with the LinuxThreads library installed: +that's the linuxthreads and linuxthreads-devel RPMs for RedHat) +or Digital UNIX 4.x or Solaris 2.x for recentish x (2.5 is OK) +then you should be able to use + ./Configure -Dusethreads -Doptimize=-g -ders + make +and ignore the rest of this "Building" section. If it doesn't +work or you are using another platform which you believe supports +POSIX.1c threads then read on. + +Omit the -e from your ./Configure arguments. For example, use + ./Configure -drs +When it offers to let you change config.sh, do so. If you already +have a config.sh then you can edit it and do + ./Configure -S +to propagate the required changes. +In ccflags, insert -DUSE_THREADS (and probably -DDEBUGGING since +that's what I've been building with). Also insert any other +arguments in there that your compiler needs to use POSIX threads. +Change optimize to -g to give you better debugging information. +Include any necessary explicit libraries in libs and change +ldflags if you need any linker flags instead or as well. + +More explicitly, for Linux (when using the standard kernel-threads +based LinuxThreads library): + Add -DUSE_THREADS -D_REENTRANT -DDEBUGGING to ccflags and cppflags + Add -lpthread to libs + Change optimize to -g +For Digital Unix 4.x: + Add -pthread -DUSE_THREADS -DDEBUGGING to ccflags + Add -DUSE_THREADS -DDEBUGGING to cppflags + Add -pthread to ldflags + Change optimize to -g + Add -lpthread -lc_r to lddlflags + For some reason, the extra includes for pthreads make Digital UNIX + complain fatally about the sbrk() delcaration in perl's malloc.c + so use the native malloc as follows: + Change usemymalloc to n + Zap mallocobj and mallocsrc (foo='') + Change d_mymalloc to undef +For Solaris, do the same as for Linux above. + +Now you can do a + make + + +Building the Thread extension + +Build it away from the perl tree in the usual way. Set your PATH +environment variable to have your perl build directory first and +set PERL5LIB to be /your/perl/build/directory/lib (without those, +I had problems where the config information from the ordinary perl +on the system would end up in the Makefile). Then + perl Makefile.PL PERL_SRC=/your/perl/build/directory + make + +Then you can try some of the tests with + perl -Mblib create.t + perl -Mblib join.t + perl -Mblib lock.t + perl -Mblib unsync.t + perl -Mblib unsync2.t + perl -Mblib unsync3.t + perl -Mblib io.t + perl -Mblib queue.t +The io one leaves a thread reading from the keyboard on stdin so +as the ping messages appear you can type lines and see them echoed. + +Try running the main perl test suite too. There are known +failures for po/misc test 45 (tries to do local(@_) but @_ is +now lexical) and some tests involving backticks/system/fork +may or may not work. Under Linux, many tests may appear to fail +when run under the test harness but work fine when invoked +manually. + + +Bugs + +* cond.t hasn't been redone since condition variable changed. + +* FAKE_THREADS should produce a working perl but the Thread +extension won't build with it yet. + +* There's a known memory leak (curstack isn't freed at the end +of each thread because it causes refcount problems that I +haven't tracked down yet) and there are very probably others too. + +* There are still races where bugs show up under contention. + +* Need to document "lock", Thread.pm, Queue.pm, ... + +* Plenty of others + + +Debugging + +Use the -DL command-line option to turn on debugging of the +multi-threading code. Under Linux, that also turns on a quick +hack I did to grab a bit of extra information from segfaults. +If you have a fancier gdb/threads setup than I do then you'll +have to delete the lines in perl.c which say + #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) + DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv);); + #endif + + +Background + +Some old globals (e.g. stack_sp, op) and some old per-interpreter +variables (e.g. tmps_stack, cxstack) move into struct thread. +All fields of struct thread (apart from a few only applicable to +FAKE_THREADS) are of the form Tfoo. For example, stack_sp becomes +the field Tstack_sp of struct thread. For those fields which moved +from original perl, thread.h does + #define foo (thr->Tfoo) +This means that all functions in perl which need to use one of these +fields need an (automatic) variable thr which points at the current +thread's struct thread. For pp_foo functions, it is passed around as +an argument, for other functions they do + dTHR; +which declares and initialises thr from thread-specific data +via pthread_getspecific. If a function fails to compile with an +error about "no such variable thr", it probably just needs a dTHR +at the top. + + +Fake threads + +For FAKE_THREADS, thr is a global variable and perl schedules threads +by altering thr in between appropriate ops. The next and prev fields +of struct thread keep all fake threads on a doubly linked list and +the next_run and prev_run fields keep all runnable threads on a +doubly linked list. Mutexes are stubs for FAKE_THREADS. Condition +variables are implemented as a list of waiting threads. + + +Mutexes and condition variables + +The API is via macros MUTEX_{INIT,LOCK,UNLOCK,DESTROY} and +COND_{INIT,WAIT,SIGNAL,BROADCAST,DESTROY}. For POSIX threads, +perl mutexes and condition variables correspond to POSIX ones. +For FAKE_THREADS, mutexes are stubs and condition variables are +implmented as lists of waiting threads. For FAKE_THREADS, a thread +waits on a condition variable by removing itself from the runnable +list, calling SCHEDULE to change thr to the next appropriate +runnable thread and returning op (i.e. the new threads next op). +This means that fake threads can only block while in PP code. +A PP function which contains a COND_WAIT must be prepared to +handle such restarts and can use the field "private" of struct +thread to record its state. For fake threads, COND_SIGNAL and +COND_BROADCAST work by putting back all the threads on the +condition variables list into the run queue. Note that a mutex +must *not* be held while returning from a PP function. + +Perl locks are a condpair_t structure (a triple of a mutex, a +condtion variable and an owner thread field) attached by 'm' +magic to any SV. pp_lock locks such an object by waiting on the +condition variable until the owner field is zero and then setting +the owner field to its own thread pointer. The lock is recursive +so if the owner field already matches the current thread then +pp_lock returns straight away. If the owner field has to be filled +in then unlock_condpair is queued as an end-of-block destructor and +that function zeroes out the owner field, releasing the lock. + + +Malcolm Beattie +mbeattie@sable.ox.ac.uk +2 October 1997 diff --git a/Todo.5.005 b/Todo.5.005 new file mode 100644 index 0000000000..4bb732ccf9 --- /dev/null +++ b/Todo.5.005 @@ -0,0 +1,33 @@ +Merging + 5.004_02 + 5.004_03 + 5.004_04 + oneperl (THIS pointer) + +Multi-threading + without USE_THREADS, change extern variable for dTHR + sv_mutex initialisation and race + consistent semantics for exit/die in threads + pp_entersub still cloning XSUBs (broken)? + test '~'-magic thread addresses + test new thread state flags, DESTROY etc. + SvREFCNT_dec(curstack) in threadstart() in Thread.xs + per-thread GV -> [SAH]V dereference for $@ etc. + Thread::Pool + check new condition variable word; fix cond.t + more Configure support + +Miscellaneous + sv_bless3 and '~'-magic to give choice on reblessing + rename and alter ISA.pm + +Compiler + auto-produce executable + typed lexicals should affect B::CC::load_pad + workarounds to help Win32 + $^C to track compiler/checker status + END blocks need saving in compiled output + _AUTOLOAD prodding + +Documentation + lots @@ -7,7 +7,7 @@ #endif #define dXSARGS \ - dSP; dMARK; \ + dTHR; dSP; dMARK; \ I32 ax = mark - stack_base + 1; \ I32 items = sp - mark @@ -30,8 +30,10 @@ AV* av; while (key) { sv = AvARRAY(av)[--key]; assert(sv); - if (sv != &sv_undef) + if (sv != &sv_undef) { + dTHR; (void)SvREFCNT_inc(sv); + } } key = AvARRAY(av) - AvALLOC(av); while (key) @@ -44,6 +46,7 @@ av_extend(av,key) AV *av; I32 key; { + dTHR; /* only necessary if we have to extend stack */ if (key > AvMAX(av)) { SV** ary; I32 tmp; @@ -87,10 +90,8 @@ I32 key; newmax = tmp - 1; New(2,ary, newmax+1, SV*); Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*); - if (AvMAX(av) > 64 && !nice_chunk) { - nice_chunk = (char*)AvALLOC(av); - nice_chunk_size = (AvMAX(av) + 1) * sizeof(SV*); - } + if (AvMAX(av) > 64) + offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*)); else Safefree(AvALLOC(av)); AvALLOC(av) = ary; @@ -134,6 +135,7 @@ I32 lval; if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P')) { + dTHR; sv = sv_newmortal(); mg_copy((SV*)av, sv, 0, key); Sv = sv; @@ -207,6 +209,7 @@ SV *val; ary = AvARRAY(av); if (AvFILL(av) < key) { if (!AvREAL(av)) { + dTHR; if (av == curstack && key > stack_sp - stack_base) stack_sp = stack_base + key; /* XPUSH in disguise */ do @@ -479,3 +482,277 @@ I32 fill; else (void)av_store(av,fill,&sv_undef); } + +SV** +avhv_fetch(av, key, klen, lval) +AV *av; +char *key; +U32 klen; +I32 lval; +{ + SV **keys, **indsvp; + I32 ind; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + indsvp = hv_fetch((HV*)SvRV(*keys), key, klen, FALSE); + if (indsvp) { + ind = SvIV(*indsvp); + if (ind < 1) + croak("Bad index while coercing array into hash"); + } else { + if (!lval) + return 0; + + ind = AvFILL(av) + 1; + hv_store((HV*)SvRV(*keys), key, klen, newSViv(ind), 0); + } + return av_fetch(av, ind, lval); +} + +SV** +avhv_fetch_ent(av, keysv, lval, hash) +AV *av; +SV *keysv; +I32 lval; +U32 hash; +{ + SV **keys, **indsvp; + HE *he; + I32 ind; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + he = hv_fetch_ent((HV*)SvRV(*keys), keysv, FALSE, hash); + if (he) { + ind = SvIV(HeVAL(he)); + if (ind < 1) + croak("Bad index while coercing array into hash"); + } else { + if (!lval) + return 0; + + ind = AvFILL(av) + 1; + hv_store_ent((HV*)SvRV(*keys), keysv, newSViv(ind), 0); + } + return av_fetch(av, ind, lval); +} + +SV** +avhv_store(av, key, klen, val, hash) +AV *av; +char *key; +U32 klen; +SV *val; +U32 hash; +{ + SV **keys, **indsvp; + I32 ind; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + indsvp = hv_fetch((HV*)SvRV(*keys), key, klen, FALSE); + if (indsvp) { + ind = SvIV(*indsvp); + if (ind < 1) + croak("Bad index while coercing array into hash"); + } else { + ind = AvFILL(av) + 1; + hv_store((HV*)SvRV(*keys), key, klen, newSViv(ind), hash); + } + return av_store(av, ind, val); +} + +SV** +avhv_store_ent(av, keysv, val, hash) +AV *av; +SV *keysv; +SV *val; +U32 hash; +{ + SV **keys; + HE *he; + I32 ind; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + he = hv_fetch_ent((HV*)SvRV(*keys), keysv, FALSE, hash); + if (he) { + ind = SvIV(HeVAL(he)); + if (ind < 1) + croak("Bad index while coercing array into hash"); + } else { + ind = AvFILL(av) + 1; + hv_store_ent((HV*)SvRV(*keys), keysv, newSViv(ind), hash); + } + return av_store(av, ind, val); +} + +bool +avhv_exists_ent(av, keysv, hash) +AV *av; +SV *keysv; +U32 hash; +{ + SV **keys; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + return hv_exists_ent((HV*)SvRV(*keys), keysv, hash); +} + +bool +avhv_exists(av, key, klen) +AV *av; +char *key; +U32 klen; +{ + SV **keys; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + return hv_exists((HV*)SvRV(*keys), key, klen); +} + +/* avhv_delete leaks. Caller can re-index and compress if so desired. */ +SV * +avhv_delete(av, key, klen, flags) +AV *av; +char *key; +U32 klen; +I32 flags; +{ + SV **keys; + SV *sv; + SV **svp; + I32 ind; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + sv = hv_delete((HV*)SvRV(*keys), key, klen, 0); + if (!sv) + return Nullsv; + ind = SvIV(sv); + if (ind < 1) + croak("Bad index while coercing array into hash"); + svp = av_fetch(av, ind, FALSE); + if (!svp) + return Nullsv; + if (flags & G_DISCARD) { + sv = Nullsv; + SvREFCNT_dec(*svp); + } else { + sv = sv_2mortal(*svp); + } + *svp = &sv_undef; + return sv; +} + +/* avhv_delete_ent leaks. Caller can re-index and compress if so desired. */ +SV * +avhv_delete_ent(av, keysv, flags, hash) +AV *av; +SV *keysv; +I32 flags; +U32 hash; +{ + SV **keys; + SV *sv; + SV **svp; + I32 ind; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + sv = hv_delete_ent((HV*)SvRV(*keys), keysv, 0, hash); + if (!sv) + return Nullsv; + ind = SvIV(sv); + if (ind < 1) + croak("Bad index while coercing array into hash"); + svp = av_fetch(av, ind, FALSE); + if (!svp) + return Nullsv; + if (flags & G_DISCARD) { + sv = Nullsv; + SvREFCNT_dec(*svp); + } else { + sv = sv_2mortal(*svp); + } + *svp = &sv_undef; + return sv; +} + +I32 +avhv_iterinit(av) +AV *av; +{ + SV **keys; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + return hv_iterinit((HV*)SvRV(*keys)); +} + +HE * +avhv_iternext(av) +AV *av; +{ + SV **keys; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + return hv_iternext((HV*)SvRV(*keys)); +} + +SV * +avhv_iterval(av, entry) +AV *av; +register HE *entry; +{ + SV **keys; + SV *sv; + I32 ind; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + sv = hv_iterval((HV*)SvRV(*keys), entry); + ind = SvIV(sv); + if (ind < 1) + croak("Bad index while coercing array into hash"); + return *av_fetch(av, ind, TRUE); +} + +SV * +avhv_iternextsv(av, key, retlen) +AV *av; +char **key; +I32 *retlen; +{ + SV **keys; + HE *he; + SV *sv; + I32 ind; + + keys = av_fetch(av, 0, FALSE); + if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV) + croak("Can't coerce array into hash"); + if ( (he = hv_iternext((HV*)SvRV(*keys))) == NULL) + return NULL; + *key = hv_iterkey(he, retlen); + sv = hv_iterval((HV*)SvRV(*keys), he); + ind = SvIV(sv); + if (ind < 1) + croak("Bad index while coercing array into hash"); + return *av_fetch(av, ind, TRUE); +} diff --git a/config_h.SH b/config_h.SH index cfae03ad99..cfae03ad99 100755..100644 --- a/config_h.SH +++ b/config_h.SH @@ -28,7 +28,9 @@ struct block_sub { CV * cv; GV * gv; GV * dfoutgv; +#ifndef USE_THREADS AV * savearray; +#endif /* USE_THREADS */ AV * argarray; U16 olddepth; U8 hasargs; @@ -54,11 +56,19 @@ struct block_sub { #define POPSUB1(cx) \ cxsub = cx->blk_sub; /* because DESTROY may clobber *cx */ +#ifdef USE_THREADS +#define POPSAVEARRAY() NOOP +#else +#define POPSAVEARRAY() \ + STMT_START { \ + SvREFCNT_dec(GvAV(defgv)); \ + GvAV(defgv) = cxsub.savearray; \ + } STMT_END +#endif /* USE_THREADS */ + #define POPSUB2() \ if (cxsub.hasargs) { \ - /* put back old @_ */ \ - SvREFCNT_dec(GvAV(defgv)); \ - GvAV(defgv) = cxsub.savearray; \ + POPSAVEARRAY(); \ /* destroy arg array */ \ av_clear(cxsub.argarray); \ AvREAL_off(cxsub.argarray); \ @@ -28,7 +28,11 @@ struct xpvcv { long xcv_depth; /* >= 2 indicates recursive call */ AV * xcv_padlist; CV * xcv_outside; - U8 xcv_flags; +#ifdef USE_THREADS + perl_mutex *xcv_mutexp; + struct thread *xcv_owner; /* current owner thread */ +#endif /* USE_THREADS */ + cv_flags_t xcv_flags; }; #define Nullcv Null(CV*) @@ -43,15 +47,21 @@ struct xpvcv { #define CvDEPTH(sv) ((XPVCV*)SvANY(sv))->xcv_depth #define CvPADLIST(sv) ((XPVCV*)SvANY(sv))->xcv_padlist #define CvOUTSIDE(sv) ((XPVCV*)SvANY(sv))->xcv_outside +#ifdef USE_THREADS +#define CvMUTEXP(sv) ((XPVCV*)SvANY(sv))->xcv_mutexp +#define CvOWNER(sv) ((XPVCV*)SvANY(sv))->xcv_owner +#endif /* USE_THREADS */ #define CvFLAGS(sv) ((XPVCV*)SvANY(sv))->xcv_flags -#define CVf_CLONE 0x01 /* anon CV uses external lexicals */ -#define CVf_CLONED 0x02 /* a clone of one of those */ -#define CVf_ANON 0x04 /* CvGV() can't be trusted */ -#define CVf_OLDSTYLE 0x08 -#define CVf_UNIQUE 0x10 /* can't be cloned */ -#define CVf_NODEBUG 0x20 /* no DB::sub indirection for this CV +#define CVf_CLONE 0x0001 /* anon CV uses external lexicals */ +#define CVf_CLONED 0x0002 /* a clone of one of those */ +#define CVf_ANON 0x0004 /* CvGV() can't be trusted */ +#define CVf_OLDSTYLE 0x0008 +#define CVf_UNIQUE 0x0010 /* can't be cloned */ +#define CVf_NODEBUG 0x0020 /* no DB::sub indirection for this CV (esp. useful for special XSUBs) */ +#define CVf_METHOD 0x0040 /* CV is explicitly marked as a method */ +#define CVf_LOCKED 0x0080 /* CV locks itself or first arg on entry */ #define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE) #define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE) @@ -76,3 +86,11 @@ struct xpvcv { #define CvNODEBUG(cv) (CvFLAGS(cv) & CVf_NODEBUG) #define CvNODEBUG_on(cv) (CvFLAGS(cv) |= CVf_NODEBUG) #define CvNODEBUG_off(cv) (CvFLAGS(cv) &= ~CVf_NODEBUG) + +#define CvMETHOD(cv) (CvFLAGS(cv) & CVf_METHOD) +#define CvMETHOD_on(cv) (CvFLAGS(cv) |= CVf_METHOD) +#define CvMETHOD_off(cv) (CvFLAGS(cv) &= ~CVf_METHOD) + +#define CvLOCKED(cv) (CvFLAGS(cv) & CVf_LOCKED) +#define CvLOCKED_on(cv) (CvFLAGS(cv) |= CVf_LOCKED) +#define CvLOCKED_off(cv) (CvFLAGS(cv) &= ~CVf_LOCKED) @@ -27,12 +27,20 @@ void deb(pat,a1,a2,a3,a4,a5,a6,a7,a8) char *pat; { + dTHR; register I32 i; GV* gv = curcop->cop_filegv; +#ifdef USE_THREADS + PerlIO_printf(Perl_debug_log,"0x%lx (%s:%ld)\t", + (unsigned long) thr, + SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>", + (long)curcop->cop_line); +#else PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>", (long)curcop->cop_line); +#endif /* USE_THREADS */ for (i=0; i<dlevel; i++) PerlIO_printf(Perl_debug_log, "%c%c ",debname[i],debdelim[i]); PerlIO_printf(Perl_debug_log, pat,a1,a2,a3,a4,a5,a6,a7,a8); @@ -51,13 +59,21 @@ deb(pat, va_alist) va_dcl # endif { + dTHR; va_list args; register I32 i; GV* gv = curcop->cop_filegv; +#ifdef USE_THREADS + PerlIO_printf(Perl_debug_log, "0x%lx (%s:%ld)\t", + (unsigned long) thr, + SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>", + (long)curcop->cop_line); +#else PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>", (long)curcop->cop_line); +#endif /* USE_THREADS */ for (i=0; i<dlevel; i++) PerlIO_printf(Perl_debug_log, "%c%c ",debname[i],debdelim[i]); @@ -82,6 +98,7 @@ deb_growlevel() I32 debstackptrs() { + dTHR; PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n", (unsigned long)curstack, (unsigned long)stack_base, (long)*markstack_ptr, (long)(stack_sp-stack_base), @@ -95,6 +112,7 @@ debstackptrs() I32 debstack() { + dTHR; I32 top = stack_sp - stack_base; register I32 i = top - 30; I32 *markscan = markstack; @@ -106,7 +124,12 @@ debstack() if (*markscan >= i) break; +#ifdef USE_THREADS + PerlIO_printf(Perl_debug_log, i ? "0x%lx => ... " : "0x%lx => ", + (unsigned long) thr); +#else PerlIO_printf(Perl_debug_log, i ? " => ... " : " => "); +#endif /* USE_THREADS */ if (stack_base[0] != &sv_undef || stack_sp < stack_base) PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); do { @@ -283,6 +283,7 @@ PerlIO *supplied_fp; } if (IoTYPE(io) && IoTYPE(io) != '|' && IoTYPE(io) != '-') { + dTHR; if (Fstat(PerlIO_fileno(fp),&statbuf) < 0) { (void)PerlIO_close(fp); goto say_false; @@ -297,8 +298,9 @@ PerlIO *supplied_fp; !statbuf.st_mode #endif ) { - Sock_size_t buflen = sizeof tokenbuf; - if (getsockname(PerlIO_fileno(fp), (struct sockaddr *)tokenbuf, + char tmpbuf[256]; + Sock_size_t buflen = sizeof tmpbuf; + if (getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf, &buflen) >= 0 || errno != ENOTSOCK) IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */ @@ -340,6 +342,7 @@ PerlIO *supplied_fp; #endif IoIFP(io) = fp; if (writing) { + dTHR; if (IoTYPE(io) == 's' || (IoTYPE(io) == '>' && S_ISCHR(statbuf.st_mode)) ) { if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) { @@ -384,6 +387,7 @@ register GV *gv; } filemode = 0; while (av_len(GvAV(gv)) >= 0) { + dTHR; STRLEN len; sv = av_shift(GvAV(gv)); SAVEFREESV(sv); @@ -624,6 +628,7 @@ bool do_eof(gv) GV *gv; { + dTHR; register IO *io; int ch; @@ -907,6 +912,7 @@ register SV **sp; char *tmps; if (sp > mark) { + dTHR; New(401,Argv, sp - mark + 1, char*); a = Argv; while (++mark <= sp) { @@ -1041,6 +1047,7 @@ I32 type; register SV **mark; register SV **sp; { + dTHR; register I32 val; register I32 val2; register I32 tot = 0; @@ -1294,6 +1301,7 @@ I32 optype; SV **mark; SV **sp; { + dTHR; key_t key; I32 n, flags; @@ -1329,6 +1337,7 @@ I32 optype; SV **mark; SV **sp; { + dTHR; SV *astr; char *a; I32 id, n, cmd, infosize, getinfo; @@ -1453,6 +1462,7 @@ SV **mark; SV **sp; { #ifdef HAS_MSG + dTHR; SV *mstr; char *mbuf; I32 id, msize, flags; @@ -1477,6 +1487,7 @@ SV **mark; SV **sp; { #ifdef HAS_MSG + dTHR; SV *mstr; char *mbuf; long mtype; @@ -1515,6 +1526,7 @@ SV **mark; SV **sp; { #ifdef HAS_SEM + dTHR; SV *opstr; char *opbuf; I32 id; @@ -1542,6 +1554,7 @@ SV **mark; SV **sp; { #ifdef HAS_SHM + dTHR; SV *mstr; char *mbuf, *shm; I32 id, mpos, msize; @@ -23,6 +23,7 @@ do_trans(sv,arg) SV *sv; OP *arg; { + dTHR; register short *tbl; register U8 *s; register U8 *send; @@ -453,7 +454,8 @@ dARGS I32 gimme = GIMME_V; I32 dokeys = (op->op_type == OP_KEYS); I32 dovalues = (op->op_type == OP_VALUES); - + I32 realhv = (SvTYPE(hv) == SVt_PVHV); + if (op->op_type == OP_RV2HV || op->op_type == OP_PADHV) dokeys = dovalues = TRUE; @@ -467,7 +469,10 @@ dARGS RETURN; } - (void)hv_iterinit(hv); /* always reset iterator regardless */ + if (realhv) + (void)hv_iterinit(hv); /* always reset iterator regardless */ + else + (void)avhv_iterinit((AV*)hv); if (gimme == G_VOID) RETURN; @@ -492,7 +497,7 @@ dARGS else { i = 0; /*SUPPRESS 560*/ - while (entry = hv_iternext(hv)) { + while (entry = realhv ? hv_iternext(hv) : avhv_iternext((AV*)hv)) { i++; } } @@ -504,14 +509,15 @@ dARGS EXTEND(sp, HvMAX(hv) * (dokeys + dovalues)); PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */ - while (entry = hv_iternext(hv)) { + while (entry = realhv ? hv_iternext(hv) : avhv_iternext((AV*)hv)) { SPAGAIN; if (dokeys) XPUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ if (dovalues) { tmpstr = sv_newmortal(); PUTBACK; - sv_setsv(tmpstr,hv_iterval(hv,entry)); + sv_setsv(tmpstr,realhv ? + hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry)); DEBUG_H(sv_setpvf(tmpstr, "%lu%%%d=%lu", (unsigned long)HeHASH(entry), HvMAX(hv)+1, @@ -523,4 +529,3 @@ dARGS } return NORMAL; } - @@ -31,6 +31,7 @@ static void dump(); void dump_all() { + dTHR; PerlIO_setlinebuf(Perl_debug_log); if (main_root) dump_op(main_root); @@ -41,6 +42,7 @@ void dump_packsubs(stash) HV* stash; { + dTHR; I32 i; HE *entry; @@ -100,36 +102,36 @@ dump_eval() } void -dump_op(op) -register OP *op; +dump_op(o) +register OP *o; { dump("{\n"); - if (op->op_seq) - PerlIO_printf(Perl_debug_log, "%-4d", op->op_seq); + if (o->op_seq) + PerlIO_printf(Perl_debug_log, "%-4d", o->op_seq); else PerlIO_printf(Perl_debug_log, " "); - dump("TYPE = %s ===> ", op_name[op->op_type]); - if (op->op_next) { - if (op->op_seq) - PerlIO_printf(Perl_debug_log, "%d\n", op->op_next->op_seq); + dump("TYPE = %s ===> ", op_name[o->op_type]); + if (o->op_next) { + if (o->op_seq) + PerlIO_printf(Perl_debug_log, "%d\n", o->op_next->op_seq); else - PerlIO_printf(Perl_debug_log, "(%d)\n", op->op_next->op_seq); + PerlIO_printf(Perl_debug_log, "(%d)\n", o->op_next->op_seq); } else PerlIO_printf(Perl_debug_log, "DONE\n"); dumplvl++; - if (op->op_targ) { - if (op->op_type == OP_NULL) - dump(" (was %s)\n", op_name[op->op_targ]); + if (o->op_targ) { + if (o->op_type == OP_NULL) + dump(" (was %s)\n", op_name[o->op_targ]); else - dump("TARG = %d\n", op->op_targ); + dump("TARG = %d\n", o->op_targ); } #ifdef DUMPADDR - dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next); + dump("ADDR = 0x%lx => 0x%lx\n",o, o->op_next); #endif - if (op->op_flags) { + if (o->op_flags) { SV *tmpsv = newSVpv("", 0); - switch (op->op_flags & OPf_WANT) { + switch (o->op_flags & OPf_WANT) { case OPf_WANT_VOID: sv_catpv(tmpsv, ",VOID"); break; @@ -143,58 +145,58 @@ register OP *op; sv_catpv(tmpsv, ",UNKNOWN"); break; } - if (op->op_flags & OPf_KIDS) + if (o->op_flags & OPf_KIDS) sv_catpv(tmpsv, ",KIDS"); - if (op->op_flags & OPf_PARENS) + if (o->op_flags & OPf_PARENS) sv_catpv(tmpsv, ",PARENS"); - if (op->op_flags & OPf_STACKED) + if (o->op_flags & OPf_STACKED) sv_catpv(tmpsv, ",STACKED"); - if (op->op_flags & OPf_REF) + if (o->op_flags & OPf_REF) sv_catpv(tmpsv, ",REF"); - if (op->op_flags & OPf_MOD) + if (o->op_flags & OPf_MOD) sv_catpv(tmpsv, ",MOD"); - if (op->op_flags & OPf_SPECIAL) + if (o->op_flags & OPf_SPECIAL) sv_catpv(tmpsv, ",SPECIAL"); dump("FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); SvREFCNT_dec(tmpsv); } - if (op->op_private) { + if (o->op_private) { SV *tmpsv = newSVpv("", 0); - if (op->op_type == OP_AASSIGN) { - if (op->op_private & OPpASSIGN_COMMON) + if (o->op_type == OP_AASSIGN) { + if (o->op_private & OPpASSIGN_COMMON) sv_catpv(tmpsv, ",COMMON"); } - else if (op->op_type == OP_SASSIGN) { - if (op->op_private & OPpASSIGN_BACKWARDS) + else if (o->op_type == OP_SASSIGN) { + if (o->op_private & OPpASSIGN_BACKWARDS) sv_catpv(tmpsv, ",BACKWARDS"); } - else if (op->op_type == OP_TRANS) { - if (op->op_private & OPpTRANS_SQUASH) + else if (o->op_type == OP_TRANS) { + if (o->op_private & OPpTRANS_SQUASH) sv_catpv(tmpsv, ",SQUASH"); - if (op->op_private & OPpTRANS_DELETE) + if (o->op_private & OPpTRANS_DELETE) sv_catpv(tmpsv, ",DELETE"); - if (op->op_private & OPpTRANS_COMPLEMENT) + if (o->op_private & OPpTRANS_COMPLEMENT) sv_catpv(tmpsv, ",COMPLEMENT"); } - else if (op->op_type == OP_REPEAT) { - if (op->op_private & OPpREPEAT_DOLIST) + else if (o->op_type == OP_REPEAT) { + if (o->op_private & OPpREPEAT_DOLIST) sv_catpv(tmpsv, ",DOLIST"); } - else if (op->op_type == OP_ENTERSUB || - op->op_type == OP_RV2SV || - op->op_type == OP_RV2AV || - op->op_type == OP_RV2HV || - op->op_type == OP_RV2GV || - op->op_type == OP_AELEM || - op->op_type == OP_HELEM ) + else if (o->op_type == OP_ENTERSUB || + o->op_type == OP_RV2SV || + o->op_type == OP_RV2AV || + o->op_type == OP_RV2HV || + o->op_type == OP_RV2GV || + o->op_type == OP_AELEM || + o->op_type == OP_HELEM ) { - if (op->op_type == OP_ENTERSUB) { - if (op->op_private & OPpENTERSUB_AMPER) + if (o->op_type == OP_ENTERSUB) { + if (o->op_private & OPpENTERSUB_AMPER) sv_catpv(tmpsv, ",AMPER"); - if (op->op_private & OPpENTERSUB_DB) + if (o->op_private & OPpENTERSUB_DB) sv_catpv(tmpsv, ",DB"); } - switch (op->op_private & OPpDEREF) { + switch (o->op_private & OPpDEREF) { case OPpDEREF_SV: sv_catpv(tmpsv, ",SV"); break; @@ -205,42 +207,42 @@ register OP *op; sv_catpv(tmpsv, ",HV"); break; } - if (op->op_type == OP_AELEM || op->op_type == OP_HELEM) { - if (op->op_private & OPpLVAL_DEFER) + if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) { + if (o->op_private & OPpLVAL_DEFER) sv_catpv(tmpsv, ",LVAL_DEFER"); } else { - if (op->op_private & HINT_STRICT_REFS) + if (o->op_private & HINT_STRICT_REFS) sv_catpv(tmpsv, ",STRICT_REFS"); } } - else if (op->op_type == OP_CONST) { - if (op->op_private & OPpCONST_BARE) + else if (o->op_type == OP_CONST) { + if (o->op_private & OPpCONST_BARE) sv_catpv(tmpsv, ",BARE"); } - else if (op->op_type == OP_FLIP) { - if (op->op_private & OPpFLIP_LINENUM) + else if (o->op_type == OP_FLIP) { + if (o->op_private & OPpFLIP_LINENUM) sv_catpv(tmpsv, ",LINENUM"); } - else if (op->op_type == OP_FLOP) { - if (op->op_private & OPpFLIP_LINENUM) + else if (o->op_type == OP_FLOP) { + if (o->op_private & OPpFLIP_LINENUM) sv_catpv(tmpsv, ",LINENUM"); } - if (op->op_flags & OPf_MOD && op->op_private & OPpLVAL_INTRO) + if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO) sv_catpv(tmpsv, ",INTRO"); if (SvCUR(tmpsv)) dump("PRIVATE = (%s)\n", SvPVX(tmpsv) + 1); SvREFCNT_dec(tmpsv); } - switch (op->op_type) { + switch (o->op_type) { case OP_GVSV: case OP_GV: - if (cGVOP->op_gv) { + if (cGVOPo->op_gv) { SV *tmpsv = NEWSV(0,0); ENTER; SAVEFREESV(tmpsv); - gv_fullname3(tmpsv, cGVOP->op_gv, Nullch); + gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch); dump("GV = %s\n", SvPV(tmpsv, na)); LEAVE; } @@ -248,41 +250,41 @@ register OP *op; dump("GV = NULL\n"); break; case OP_CONST: - dump("SV = %s\n", SvPEEK(cSVOP->op_sv)); + dump("SV = %s\n", SvPEEK(cSVOPo->op_sv)); break; case OP_NEXTSTATE: case OP_DBSTATE: - if (cCOP->cop_line) - dump("LINE = %d\n",cCOP->cop_line); - if (cCOP->cop_label) - dump("LABEL = \"%s\"\n",cCOP->cop_label); + if (cCOPo->cop_line) + dump("LINE = %d\n",cCOPo->cop_line); + if (cCOPo->cop_label) + dump("LABEL = \"%s\"\n",cCOPo->cop_label); break; case OP_ENTERLOOP: dump("REDO ===> "); - if (cLOOP->op_redoop) - PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq); + if (cLOOPo->op_redoop) + PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_redoop->op_seq); else PerlIO_printf(Perl_debug_log, "DONE\n"); dump("NEXT ===> "); - if (cLOOP->op_nextop) - PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq); + if (cLOOPo->op_nextop) + PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_nextop->op_seq); else PerlIO_printf(Perl_debug_log, "DONE\n"); dump("LAST ===> "); - if (cLOOP->op_lastop) - PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq); + if (cLOOPo->op_lastop) + PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_lastop->op_seq); else PerlIO_printf(Perl_debug_log, "DONE\n"); break; case OP_COND_EXPR: dump("TRUE ===> "); - if (cCONDOP->op_true) - PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq); + if (cCONDOPo->op_true) + PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_true->op_seq); else PerlIO_printf(Perl_debug_log, "DONE\n"); dump("FALSE ===> "); - if (cCONDOP->op_false) - PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq); + if (cCONDOPo->op_false) + PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_false->op_seq); else PerlIO_printf(Perl_debug_log, "DONE\n"); break; @@ -291,22 +293,22 @@ register OP *op; case OP_OR: case OP_AND: dump("OTHER ===> "); - if (cLOGOP->op_other) - PerlIO_printf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq); + if (cLOGOPo->op_other) + PerlIO_printf(Perl_debug_log, "%d\n", cLOGOPo->op_other->op_seq); else PerlIO_printf(Perl_debug_log, "DONE\n"); break; case OP_PUSHRE: case OP_MATCH: case OP_SUBST: - dump_pm((PMOP*)op); + dump_pm(cPMOPo); break; default: break; } - if (op->op_flags & OPf_KIDS) { + if (o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) dump_op(kid); } dumplvl--; @@ -50,6 +50,18 @@ #define av_store Perl_av_store #define av_undef Perl_av_undef #define av_unshift Perl_av_unshift +#define avhv_delete Perl_avhv_delete +#define avhv_delete_ent Perl_avhv_delete_ent +#define avhv_exists Perl_avhv_exists +#define avhv_exists_ent Perl_avhv_exists_ent +#define avhv_fetch Perl_avhv_fetch +#define avhv_fetch_ent Perl_avhv_fetch_ent +#define avhv_iterinit Perl_avhv_iterinit +#define avhv_iternext Perl_avhv_iternext +#define avhv_iternextsv Perl_avhv_iternextsv +#define avhv_iterval Perl_avhv_iterval +#define avhv_store Perl_avhv_store +#define avhv_store_ent Perl_avhv_store_ent #define band_amg Perl_band_amg #define bind_match Perl_bind_match #define block_end Perl_block_end @@ -114,6 +126,7 @@ #define comppad_name_fill Perl_comppad_name_fill #define concat_amg Perl_concat_amg #define concat_ass_amg Perl_concat_ass_amg +#define condpair_magic Perl_condpair_magic #define convert Perl_convert #define cop_seqmax Perl_cop_seqmax #define cos_amg Perl_cos_amg @@ -264,8 +277,10 @@ #define ibcmp Perl_ibcmp #define ibcmp_locale Perl_ibcmp_locale #define in_my Perl_in_my +#define in_my_stash Perl_in_my_stash #define inc_amg Perl_inc_amg #define ingroup Perl_ingroup +#define init_stacks Perl_init_stacks #define instr Perl_instr #define intro_my Perl_intro_my #define intuit_more Perl_intuit_more @@ -323,6 +338,7 @@ #define magic_gettaint Perl_magic_gettaint #define magic_getuvar Perl_magic_getuvar #define magic_len Perl_magic_len +#define magic_mutexfree Perl_magic_mutexfree #define magic_nextpack Perl_magic_nextpack #define magic_set Perl_magic_set #define magic_setamagic Perl_magic_setamagic @@ -476,6 +492,7 @@ #define op_name Perl_op_name #define op_seqmax Perl_op_seqmax #define opargs Perl_opargs +#define opsave Perl_opsave #define origalen Perl_origalen #define origenviron Perl_origenviron #define osname Perl_osname @@ -683,6 +700,7 @@ #define pp_list Perl_pp_list #define pp_listen Perl_pp_listen #define pp_localtime Perl_pp_localtime +#define pp_lock Perl_pp_lock #define pp_log Perl_pp_log #define pp_lslice Perl_pp_lslice #define pp_lstat Perl_pp_lstat @@ -926,6 +944,7 @@ #define save_list Perl_save_list #define save_long Perl_save_long #define save_nogv Perl_save_nogv +#define save_op Perl_save_op #define save_pptr Perl_save_pptr #define save_scalar Perl_save_scalar #define save_sptr Perl_save_sptr @@ -1005,6 +1024,7 @@ #define sv_add_arena Perl_sv_add_arena #define sv_backoff Perl_sv_backoff #define sv_bless Perl_sv_bless +#define sv_bless3 Perl_sv_bless3 #define sv_catpv Perl_sv_catpv #define sv_catpvf Perl_sv_catpvf #define sv_catpvn Perl_sv_catpvn @@ -1074,6 +1094,7 @@ #define too_many_arguments Perl_too_many_arguments #define uid Perl_uid #define unlnk Perl_unlnk +#define unlock_condpair Perl_unlock_condpair #define unshare_hek Perl_unshare_hek #define unsharepvn Perl_unsharepvn #define utilize Perl_utilize @@ -1095,6 +1116,7 @@ #define vtbl_isa Perl_vtbl_isa #define vtbl_isaelem Perl_vtbl_isaelem #define vtbl_mglob Perl_vtbl_mglob +#define vtbl_mutex Perl_vtbl_mutex #define vtbl_nkeys Perl_vtbl_nkeys #define vtbl_pack Perl_vtbl_pack #define vtbl_packelem Perl_vtbl_packelem @@ -1246,6 +1268,7 @@ #define gensym (curinterp->Igensym) #define in_eval (curinterp->Iin_eval) #define incgv (curinterp->Iincgv) +#define initav (curinterp->Iinitav) #define inplace (curinterp->Iinplace) #define last_in_gv (curinterp->Ilast_in_gv) #define lastfd (curinterp->Ilastfd) @@ -1400,6 +1423,7 @@ #define Igensym gensym #define Iin_eval in_eval #define Iincgv incgv +#define Iinitav initav #define Iinplace inplace #define Ilast_in_gv last_in_gv #define Ilastfd lastfd @@ -1563,6 +1587,7 @@ #define gensym Perl_gensym #define in_eval Perl_in_eval #define incgv Perl_incgv +#define initav Perl_initav #define inplace Perl_inplace #define last_in_gv Perl_last_in_gv #define lastfd Perl_lastfd diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index df1593fd65..9ed5185c6d 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,8 +1,8 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 29th Jun 1997 -# version 1.15 +# last modified 8th Oct 1997 +# version 1.16 # # Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -1676,6 +1676,10 @@ created to "DB_File". This makes sub-classing difficult. Now DB_File creats objects in the namespace of the package it has been inherited into. +=item 1.16 + +Minor changes to DB_File.xs to support multithreaded perl. + =back =head1 BUGS diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index d2c7e6c645..bd0c933329 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,8 +3,8 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) - last modified 29th Jun 1997 - version 1.15 + last modified 8th Oct 1997 + version 1.16 All comments/suggestions/problems are welcome @@ -44,7 +44,7 @@ database and an ordinary array to a HASH or BTREE database. 1.15 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined value" warning with db_get and db_seq. - + 1.16 - Minor additions to DB_File.xs to support multithreaded perl. */ @@ -140,6 +140,7 @@ btree_compare(key1, key2) const DBT * key1 ; const DBT * key2 ; { + dTHR ; dSP ; void * data1, * data2 ; int retval ; @@ -187,6 +188,7 @@ btree_prefix(key1, key2) const DBT * key1 ; const DBT * key2 ; { + dTHR ; dSP ; void * data1, * data2 ; int retval ; @@ -234,6 +236,7 @@ hash_cb(data, size) const void * data ; size_t size ; { + dTHR ; dSP ; int retval ; int count ; diff --git a/ext/Opcode/Makefile.PL b/ext/Opcode/Makefile.PL index 7fdcdf6ac1..48a6ed82b8 100644 --- a/ext/Opcode/Makefile.PL +++ b/ext/Opcode/Makefile.PL @@ -3,5 +3,5 @@ WriteMakefile( NAME => 'Opcode', MAN3PODS => ' ', VERSION_FROM => 'Opcode.pm', - XS_VERSION => '1.02' + XS_VERSION => '1.03' ); diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index a35ad1b47b..1878417ceb 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -5,7 +5,7 @@ require 5.002; use vars qw($VERSION $XS_VERSION @ISA @EXPORT_OK); $VERSION = "1.04"; -$XS_VERSION = "1.02"; +$XS_VERSION = "1.03"; use strict; use Carp; @@ -427,6 +427,12 @@ beyond the scope of the compartment. rand srand +=item :base_thread + +This op is related to multi-threading. + + lock + =item :default A handy tag name for a I<reasonable> default set of ops. (The current ops diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 9d4b726536..8307ade2ca 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -33,9 +33,10 @@ op_names_init() op_named_bits = newHV(); for(i=0; i < maxo; ++i) { - hv_store(op_named_bits, op_name[i],strlen(op_name[i]), - Sv=newSViv(i), 0); - SvREADONLY_on(Sv); + SV *sv; + sv = newSViv(i); + SvREADONLY_on(sv); + hv_store(op_named_bits, op_name[i], strlen(op_name[i]), sv, 0); } put_op_bitspec(":none",0, sv_2mortal(new_opset(Nullsv))); diff --git a/ext/attrs/Makefile.PL b/ext/attrs/Makefile.PL new file mode 100644 index 0000000000..c421757615 --- /dev/null +++ b/ext/attrs/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'attrs', + VERSION_FROM => 'attrs.pm', + MAN3PODS => ' ', # Pods will be built by installman. + XSPROTOARG => '-noprototypes' +); diff --git a/ext/attrs/attrs.pm b/ext/attrs/attrs.pm new file mode 100644 index 0000000000..fe2bf356e4 --- /dev/null +++ b/ext/attrs/attrs.pm @@ -0,0 +1,55 @@ +package attrs; +require DynaLoader; +use vars '@ISA'; +@ISA = 'DynaLoader'; + +use vars qw($VERSION); +$VERSION = "1.0"; + +=head1 NAME + +attrs - set/get attributes of a subroutine + +=head1 SYNOPSIS + + sub foo { + use attrs qw(locked method); + ... + } + + @a = attrs::get(\&foo); + +=head1 DESCRIPTION + +This module lets you set and get attributes for subroutines. +Setting attributes takes place at compile time; trying to set +invalid attribute names causes a compile-time error. Calling +C<attr::get> on a subroutine reference or name returns its list +of attribute names. Notice that C<attr::get> is not exported. +Valid attributes are as follows. + +=over + +=item method + +Indicates that the invoking subroutine is a method. + +=item locked + +Setting this attribute is only meaningful when the subroutine or +method is to be called by multiple threads. When set on a method +subroutine (i.e. one marked with the B<method> attribute above), +perl ensures that any invocation of it implicitly locks its first +argument before execution. When set on a non-method subroutine, +perl ensures that a lock is taken on the subroutine itself before +execution. The semantics of the lock are exactly those of one +explicitly taken with the C<lock> operator immediately after the +subroutine is entered. + +=back + +=cut + +bootstrap attrs $VERSION; + +1; diff --git a/ext/attrs/attrs.xs b/ext/attrs/attrs.xs new file mode 100644 index 0000000000..f34ac850ea --- /dev/null +++ b/ext/attrs/attrs.xs @@ -0,0 +1,60 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +static cv_flags_t +get_flag(attr) +char *attr; +{ + if (strnEQ(attr, "method", 6)) + return CVf_METHOD; + else if (strnEQ(attr, "locked", 6)) + return CVf_LOCKED; + else + return 0; +} + +MODULE = attrs PACKAGE = attrs + +void +import(class, ...) +char * class + ALIAS: + unimport = 1 + PREINIT: + int i; + CV *cv; + PPCODE: + if (!compcv || !(cv = CvOUTSIDE(compcv))) + croak("can't set attributes outside a subroutine scope"); + for (i = 1; i < items; i++) { + char *attr = SvPV(ST(i), na); + cv_flags_t flag = get_flag(attr); + if (!flag) + croak("invalid attribute name %s", attr); + if (ix) + CvFLAGS(cv) &= ~flag; + else + CvFLAGS(cv) |= flag; + } + +void +get(sub) +SV * sub + PPCODE: + if (SvROK(sub)) { + sub = SvRV(sub); + if (SvTYPE(sub) != SVt_PVCV) + sub = Nullsv; + } + else { + char *name = SvPV(sub, na); + sub = (SV*)perl_get_cv(name, FALSE); + } + if (!sub) + croak("invalid subroutine reference or name"); + if (CvFLAGS(sub) & CVf_METHOD) + XPUSHs(sv_2mortal(newSVpv("method", 0))); + if (CvFLAGS(sub) & CVf_LOCKED) + XPUSHs(sv_2mortal(newSVpv("locked", 0))); + diff --git a/global.sym b/global.sym index a8d99d75bb..023cd6a1a2 100644 --- a/global.sym +++ b/global.sym @@ -70,6 +70,7 @@ gt_amg hexdigit hints in_my +in_my_stash inc_amg io_close know_next @@ -149,6 +150,7 @@ op_desc op_name op_seqmax opargs +opsave origalen origenviron osname @@ -198,6 +200,7 @@ rsfp rsfp_filters rshift_amg rshift_ass_amg +runops savestack savestack_ix savestack_max @@ -254,6 +257,7 @@ vtbl_glob vtbl_isa vtbl_isaelem vtbl_mglob +vtbl_mutex vtbl_nkeys vtbl_pack vtbl_packelem @@ -301,6 +305,18 @@ append_elem append_list apply assertref +avhv_delete +avhv_delete_ent +avhv_exists +avhv_exists_ent +avhv_fetch +avhv_fetch_ent +avhv_iterinit +avhv_iternext +avhv_iternextsv +avhv_iterval +avhv_store +avhv_store_ent av_clear av_extend av_fake @@ -359,6 +375,7 @@ ck_split ck_subr ck_svconst ck_trunc +condpair_magic convert croak cv_ckproto @@ -479,6 +496,7 @@ hv_undef ibcmp ibcmp_locale ingroup +init_stacks instr intro_my intuit_more @@ -509,6 +527,7 @@ magic_getsig magic_gettaint magic_getuvar magic_len +magic_mutexfree magic_nextpack magic_set magic_setamagic @@ -815,6 +834,7 @@ pp_link pp_list pp_listen pp_localtime +pp_lock pp_log pp_lslice pp_lstat @@ -997,7 +1017,6 @@ rsignal rsignal_save rsignal_state rsignal_restore -runops rxres_free rxres_restore rxres_save @@ -1029,6 +1048,7 @@ save_iv save_list save_long save_nogv +save_op save_pptr save_scalar save_sptr @@ -1062,6 +1082,7 @@ setenv_getix share_hek sharepvn sighandler +sighandlerp skipspace stack_grow start_subparse @@ -1140,6 +1161,7 @@ taint_proper too_few_arguments too_many_arguments unlnk +unlock_condpair unshare_hek unsharepvn utilize @@ -58,6 +58,7 @@ GV * gv_fetchfile(name) char *name; { + dTHR; char smallbuf[256]; char *tmpbuf; STRLEN tmplen; @@ -92,6 +93,7 @@ char *name; STRLEN len; int multi; { + dTHR; register GP *gp; sv_upgrade((SV*)gv, SVt_PVGV); @@ -182,6 +184,7 @@ I32 level; basestash = gv_stashpvn(packname, packlen, TRUE); gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { + dTHR; /* just for SvREFCNT_dec */ gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); if (!gvp || !(gv = *gvp)) croak("Cannot create %s::ISA", HvNAME(stash)); @@ -231,6 +234,7 @@ I32 level; (cv = GvCV(gv)) && (CvROOT(cv) || CvXSUB(cv))) { + dTHR; /* just for SvREFCNT_inc */ if (cv = GvCV(topgv)) SvREFCNT_dec(cv); GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); @@ -258,6 +262,7 @@ HV* stash; char* name; I32 autoload; { + dTHR; register char *nend; char *nsplit = 0; GV* gv; @@ -420,6 +425,7 @@ char *nambeg; I32 add; I32 sv_type; { + dTHR; register char *name = nambeg; register GV *gv = 0; GV**gvp; @@ -820,6 +826,7 @@ GV *gv; IO * newIO() { + dTHR; IO *io; GV *iogv; @@ -838,6 +845,7 @@ void gv_check(stash) HV* stash; { + dTHR; register HE *entry; register I32 i; register GV *gv; @@ -965,6 +973,7 @@ bool Gv_AMupdate(stash) HV* stash; { + dTHR; GV** gvp; HV* hv; GV* gv; @@ -1128,6 +1137,7 @@ SV* right; int method; int flags; { + dTHR; MAGIC *mg; CV *cv; CV **cvp=NULL, **ocvp=NULL; @@ -1327,6 +1337,7 @@ int flags; || inc_dec_ass) RvDEEPCP(left); } { + dTHR; dSP; BINOP myop; SV* res; @@ -1339,12 +1350,12 @@ int flags; myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; ENTER; - SAVESPTR(op); + SAVEOP(); op = (OP *) &myop; if (PERLDB_SUB && curstash != debstash) op->op_private |= OPpENTERSUB_DB; PUTBACK; - pp_pushmark(); + pp_pushmark(ARGS); EXTEND(sp, notfound + 5); PUSHs(lr>0? right: left); @@ -1356,7 +1367,7 @@ int flags; PUSHs((SV*)cv); PUTBACK; - if (op = pp_entersub()) + if (op = pp_entersub(ARGS)) runops(); LEAVE; SPAGAIN; diff --git a/hints/dec_osf.sh b/hints/dec_osf.sh index 0ba4dad077..fa7596b398 100644 --- a/hints/dec_osf.sh +++ b/hints/dec_osf.sh @@ -161,6 +161,16 @@ case "$optimize" in ;; esac +if [ "X$usethreads" != "X" ]; then + ccflags="-DUSE_THREADS $ccflags" + optimize="-pthread $optimize" + ldflags="-pthread $ldflags" + set `echo X "$libswanted "| sed -e 's/ c / pthread c_r /'` + shift + libswanted="$*" + usemymalloc='n' +fi + # # Unset temporary variables no more needed. # diff --git a/hints/linux.sh b/hints/linux.sh index 6a11a42cc3..8ff7f5d747 100644 --- a/hints/linux.sh +++ b/hints/linux.sh @@ -194,3 +194,14 @@ fi # it should be: # ccdlflags='-Wl,-E' +if [ "X$usethreads" != "X" ]; then + ccflags="-D_REENTRANT -DUSE_THREADS $ccflags" + cppflags="-D_REENTRANT -DUSE_THREADS $cppflags" + # -lpthread needs to come before -lc but after other libraries such + # as -lgdbm and such like. We assume here that -lc is present in + # libswanted. If that fails to be true in future, then this can be + # changed to add pthread to the very end of libswanted. + set `echo X "$libswanted "| sed -e 's/ c / pthread c /'` + shift + libswanted="$*" +fi diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh index d2124edb06..21593f132f 100644 --- a/hints/solaris_2.sh +++ b/hints/solaris_2.sh @@ -223,6 +223,18 @@ esac # as --version or ld --version might dump core. rm -f core +if [ "X$usethreads" != "X" ]; then + ccflags="-D_REENTRANT -DUSE_THREADS $ccflags" + cppflags="-D_REENTRANT -DUSE_THREADS $cppflags" + # -lpthread needs to come before -lc but after other libraries such + # as -lgdbm and such like. We assume here that -lc is present in + # libswanted. If that fails to be true in future, then this can be + # changed to add pthread to the very end of libswanted. + set `echo X "$libswanted "| sed -e 's/ c / pthread c /'` + shift + libswanted="$*" +fi + # This is just a trick to include some useful notes. cat > /dev/null <<'End_of_Solaris_Notes' @@ -100,6 +100,7 @@ I32 lval; if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { + dTHR; sv = sv_newmortal(); mg_copy((SV*)hv, sv, key, klen); Sv = sv; @@ -511,6 +512,7 @@ U32 klen; if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { + dTHR; sv = sv_newmortal(); mg_copy((SV*)hv, sv, key, klen); magic_existspack(sv, mg_find(sv, 'p')); @@ -555,6 +557,7 @@ U32 hash; if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { + dTHR; /* just for SvTRUE */ sv = sv_newmortal(); keysv = sv_2mortal(newSVsv(keysv)); mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); @@ -615,9 +618,9 @@ HV *hv; assert(tmp >= newsize); New(2,a, tmp, HE*); Copy(xhv->xhv_array, a, oldsize, HE*); - if (oldsize >= 64 && !nice_chunk) { - nice_chunk = (char*)xhv->xhv_array; - nice_chunk_size = oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD; + if (oldsize >= 64) { + offer_nice_chunk(xhv->xhv_array, + oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD); } else Safefree(xhv->xhv_array); @@ -689,9 +692,9 @@ IV newmax; assert(j >= newsize); New(2, a, j, HE*); Copy(xhv->xhv_array, a, oldsize, HE*); - if (oldsize >= 64 && !nice_chunk) { - nice_chunk = (char*)xhv->xhv_array; - nice_chunk_size = oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD; + if (oldsize >= 64) { + offer_nice_chunk(xhv->xhv_array, + oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD); } else Safefree(xhv->xhv_array); @@ -922,6 +925,7 @@ HV *hv; } magic_nextpack((SV*) hv,mg,key); if (SvOK(key)) { + dTHR; /* just for SvREFCNT_inc */ /* force key to stay around until next time */ HeSVKEY_set(entry, SvREFCNT_inc(key)); return entry; /* beware, hent_val is not set */ diff --git a/interp.sym b/interp.sym index 753f53dc45..7da031c551 100644 --- a/interp.sym +++ b/interp.sym @@ -59,6 +59,7 @@ formtarget gensym in_eval incgv +initav inplace last_in_gv lastfd diff --git a/keywords.h b/keywords.h index 2be133b748..4b13795793 100644 --- a/keywords.h +++ b/keywords.h @@ -12,236 +12,238 @@ #define KEY_EQ 11 #define KEY_GE 12 #define KEY_GT 13 -#define KEY_LE 14 -#define KEY_LT 15 -#define KEY_NE 16 -#define KEY_abs 17 -#define KEY_accept 18 -#define KEY_alarm 19 -#define KEY_and 20 -#define KEY_atan2 21 -#define KEY_bind 22 -#define KEY_binmode 23 -#define KEY_bless 24 -#define KEY_caller 25 -#define KEY_chdir 26 -#define KEY_chmod 27 -#define KEY_chomp 28 -#define KEY_chop 29 -#define KEY_chown 30 -#define KEY_chr 31 -#define KEY_chroot 32 -#define KEY_close 33 -#define KEY_closedir 34 -#define KEY_cmp 35 -#define KEY_connect 36 -#define KEY_continue 37 -#define KEY_cos 38 -#define KEY_crypt 39 -#define KEY_dbmclose 40 -#define KEY_dbmopen 41 -#define KEY_defined 42 -#define KEY_delete 43 -#define KEY_die 44 -#define KEY_do 45 -#define KEY_dump 46 -#define KEY_each 47 -#define KEY_else 48 -#define KEY_elsif 49 -#define KEY_endgrent 50 -#define KEY_endhostent 51 -#define KEY_endnetent 52 -#define KEY_endprotoent 53 -#define KEY_endpwent 54 -#define KEY_endservent 55 -#define KEY_eof 56 -#define KEY_eq 57 -#define KEY_eval 58 -#define KEY_exec 59 -#define KEY_exists 60 -#define KEY_exit 61 -#define KEY_exp 62 -#define KEY_fcntl 63 -#define KEY_fileno 64 -#define KEY_flock 65 -#define KEY_for 66 -#define KEY_foreach 67 -#define KEY_fork 68 -#define KEY_format 69 -#define KEY_formline 70 -#define KEY_ge 71 -#define KEY_getc 72 -#define KEY_getgrent 73 -#define KEY_getgrgid 74 -#define KEY_getgrnam 75 -#define KEY_gethostbyaddr 76 -#define KEY_gethostbyname 77 -#define KEY_gethostent 78 -#define KEY_getlogin 79 -#define KEY_getnetbyaddr 80 -#define KEY_getnetbyname 81 -#define KEY_getnetent 82 -#define KEY_getpeername 83 -#define KEY_getpgrp 84 -#define KEY_getppid 85 -#define KEY_getpriority 86 -#define KEY_getprotobyname 87 -#define KEY_getprotobynumber 88 -#define KEY_getprotoent 89 -#define KEY_getpwent 90 -#define KEY_getpwnam 91 -#define KEY_getpwuid 92 -#define KEY_getservbyname 93 -#define KEY_getservbyport 94 -#define KEY_getservent 95 -#define KEY_getsockname 96 -#define KEY_getsockopt 97 -#define KEY_glob 98 -#define KEY_gmtime 99 -#define KEY_goto 100 -#define KEY_grep 101 -#define KEY_gt 102 -#define KEY_hex 103 -#define KEY_if 104 -#define KEY_index 105 -#define KEY_int 106 -#define KEY_ioctl 107 -#define KEY_join 108 -#define KEY_keys 109 -#define KEY_kill 110 -#define KEY_last 111 -#define KEY_lc 112 -#define KEY_lcfirst 113 -#define KEY_le 114 -#define KEY_length 115 -#define KEY_link 116 -#define KEY_listen 117 -#define KEY_local 118 -#define KEY_localtime 119 -#define KEY_log 120 -#define KEY_lstat 121 -#define KEY_lt 122 -#define KEY_m 123 -#define KEY_map 124 -#define KEY_mkdir 125 -#define KEY_msgctl 126 -#define KEY_msgget 127 -#define KEY_msgrcv 128 -#define KEY_msgsnd 129 -#define KEY_my 130 -#define KEY_ne 131 -#define KEY_next 132 -#define KEY_no 133 -#define KEY_not 134 -#define KEY_oct 135 -#define KEY_open 136 -#define KEY_opendir 137 -#define KEY_or 138 -#define KEY_ord 139 -#define KEY_pack 140 -#define KEY_package 141 -#define KEY_pipe 142 -#define KEY_pop 143 -#define KEY_pos 144 -#define KEY_print 145 -#define KEY_printf 146 -#define KEY_prototype 147 -#define KEY_push 148 -#define KEY_q 149 -#define KEY_qq 150 -#define KEY_quotemeta 151 -#define KEY_qw 152 -#define KEY_qx 153 -#define KEY_rand 154 -#define KEY_read 155 -#define KEY_readdir 156 -#define KEY_readline 157 -#define KEY_readlink 158 -#define KEY_readpipe 159 -#define KEY_recv 160 -#define KEY_redo 161 -#define KEY_ref 162 -#define KEY_rename 163 -#define KEY_require 164 -#define KEY_reset 165 -#define KEY_return 166 -#define KEY_reverse 167 -#define KEY_rewinddir 168 -#define KEY_rindex 169 -#define KEY_rmdir 170 -#define KEY_s 171 -#define KEY_scalar 172 -#define KEY_seek 173 -#define KEY_seekdir 174 -#define KEY_select 175 -#define KEY_semctl 176 -#define KEY_semget 177 -#define KEY_semop 178 -#define KEY_send 179 -#define KEY_setgrent 180 -#define KEY_sethostent 181 -#define KEY_setnetent 182 -#define KEY_setpgrp 183 -#define KEY_setpriority 184 -#define KEY_setprotoent 185 -#define KEY_setpwent 186 -#define KEY_setservent 187 -#define KEY_setsockopt 188 -#define KEY_shift 189 -#define KEY_shmctl 190 -#define KEY_shmget 191 -#define KEY_shmread 192 -#define KEY_shmwrite 193 -#define KEY_shutdown 194 -#define KEY_sin 195 -#define KEY_sleep 196 -#define KEY_socket 197 -#define KEY_socketpair 198 -#define KEY_sort 199 -#define KEY_splice 200 -#define KEY_split 201 -#define KEY_sprintf 202 -#define KEY_sqrt 203 -#define KEY_srand 204 -#define KEY_stat 205 -#define KEY_study 206 -#define KEY_sub 207 -#define KEY_substr 208 -#define KEY_symlink 209 -#define KEY_syscall 210 -#define KEY_sysopen 211 -#define KEY_sysread 212 -#define KEY_sysseek 213 -#define KEY_system 214 -#define KEY_syswrite 215 -#define KEY_tell 216 -#define KEY_telldir 217 -#define KEY_tie 218 -#define KEY_tied 219 -#define KEY_time 220 -#define KEY_times 221 -#define KEY_tr 222 -#define KEY_truncate 223 -#define KEY_uc 224 -#define KEY_ucfirst 225 -#define KEY_umask 226 -#define KEY_undef 227 -#define KEY_unless 228 -#define KEY_unlink 229 -#define KEY_unpack 230 -#define KEY_unshift 231 -#define KEY_untie 232 -#define KEY_until 233 -#define KEY_use 234 -#define KEY_utime 235 -#define KEY_values 236 -#define KEY_vec 237 -#define KEY_wait 238 -#define KEY_waitpid 239 -#define KEY_wantarray 240 -#define KEY_warn 241 -#define KEY_while 242 -#define KEY_write 243 -#define KEY_x 244 -#define KEY_xor 245 -#define KEY_y 246 +#define KEY_INIT 14 +#define KEY_LE 15 +#define KEY_LT 16 +#define KEY_NE 17 +#define KEY_abs 18 +#define KEY_accept 19 +#define KEY_alarm 20 +#define KEY_and 21 +#define KEY_atan2 22 +#define KEY_bind 23 +#define KEY_binmode 24 +#define KEY_bless 25 +#define KEY_caller 26 +#define KEY_chdir 27 +#define KEY_chmod 28 +#define KEY_chomp 29 +#define KEY_chop 30 +#define KEY_chown 31 +#define KEY_chr 32 +#define KEY_chroot 33 +#define KEY_close 34 +#define KEY_closedir 35 +#define KEY_cmp 36 +#define KEY_connect 37 +#define KEY_continue 38 +#define KEY_cos 39 +#define KEY_crypt 40 +#define KEY_dbmclose 41 +#define KEY_dbmopen 42 +#define KEY_defined 43 +#define KEY_delete 44 +#define KEY_die 45 +#define KEY_do 46 +#define KEY_dump 47 +#define KEY_each 48 +#define KEY_else 49 +#define KEY_elsif 50 +#define KEY_endgrent 51 +#define KEY_endhostent 52 +#define KEY_endnetent 53 +#define KEY_endprotoent 54 +#define KEY_endpwent 55 +#define KEY_endservent 56 +#define KEY_eof 57 +#define KEY_eq 58 +#define KEY_eval 59 +#define KEY_exec 60 +#define KEY_exists 61 +#define KEY_exit 62 +#define KEY_exp 63 +#define KEY_fcntl 64 +#define KEY_fileno 65 +#define KEY_flock 66 +#define KEY_for 67 +#define KEY_foreach 68 +#define KEY_fork 69 +#define KEY_format 70 +#define KEY_formline 71 +#define KEY_ge 72 +#define KEY_getc 73 +#define KEY_getgrent 74 +#define KEY_getgrgid 75 +#define KEY_getgrnam 76 +#define KEY_gethostbyaddr 77 +#define KEY_gethostbyname 78 +#define KEY_gethostent 79 +#define KEY_getlogin 80 +#define KEY_getnetbyaddr 81 +#define KEY_getnetbyname 82 +#define KEY_getnetent 83 +#define KEY_getpeername 84 +#define KEY_getpgrp 85 +#define KEY_getppid 86 +#define KEY_getpriority 87 +#define KEY_getprotobyname 88 +#define KEY_getprotobynumber 89 +#define KEY_getprotoent 90 +#define KEY_getpwent 91 +#define KEY_getpwnam 92 +#define KEY_getpwuid 93 +#define KEY_getservbyname 94 +#define KEY_getservbyport 95 +#define KEY_getservent 96 +#define KEY_getsockname 97 +#define KEY_getsockopt 98 +#define KEY_glob 99 +#define KEY_gmtime 100 +#define KEY_goto 101 +#define KEY_grep 102 +#define KEY_gt 103 +#define KEY_hex 104 +#define KEY_if 105 +#define KEY_index 106 +#define KEY_int 107 +#define KEY_ioctl 108 +#define KEY_join 109 +#define KEY_keys 110 +#define KEY_kill 111 +#define KEY_last 112 +#define KEY_lc 113 +#define KEY_lcfirst 114 +#define KEY_le 115 +#define KEY_length 116 +#define KEY_link 117 +#define KEY_listen 118 +#define KEY_local 119 +#define KEY_localtime 120 +#define KEY_lock 121 +#define KEY_log 122 +#define KEY_lstat 123 +#define KEY_lt 124 +#define KEY_m 125 +#define KEY_map 126 +#define KEY_mkdir 127 +#define KEY_msgctl 128 +#define KEY_msgget 129 +#define KEY_msgrcv 130 +#define KEY_msgsnd 131 +#define KEY_my 132 +#define KEY_ne 133 +#define KEY_next 134 +#define KEY_no 135 +#define KEY_not 136 +#define KEY_oct 137 +#define KEY_open 138 +#define KEY_opendir 139 +#define KEY_or 140 +#define KEY_ord 141 +#define KEY_pack 142 +#define KEY_package 143 +#define KEY_pipe 144 +#define KEY_pop 145 +#define KEY_pos 146 +#define KEY_print 147 +#define KEY_printf 148 +#define KEY_prototype 149 +#define KEY_push 150 +#define KEY_q 151 +#define KEY_qq 152 +#define KEY_quotemeta 153 +#define KEY_qw 154 +#define KEY_qx 155 +#define KEY_rand 156 +#define KEY_read 157 +#define KEY_readdir 158 +#define KEY_readline 159 +#define KEY_readlink 160 +#define KEY_readpipe 161 +#define KEY_recv 162 +#define KEY_redo 163 +#define KEY_ref 164 +#define KEY_rename 165 +#define KEY_require 166 +#define KEY_reset 167 +#define KEY_return 168 +#define KEY_reverse 169 +#define KEY_rewinddir 170 +#define KEY_rindex 171 +#define KEY_rmdir 172 +#define KEY_s 173 +#define KEY_scalar 174 +#define KEY_seek 175 +#define KEY_seekdir 176 +#define KEY_select 177 +#define KEY_semctl 178 +#define KEY_semget 179 +#define KEY_semop 180 +#define KEY_send 181 +#define KEY_setgrent 182 +#define KEY_sethostent 183 +#define KEY_setnetent 184 +#define KEY_setpgrp 185 +#define KEY_setpriority 186 +#define KEY_setprotoent 187 +#define KEY_setpwent 188 +#define KEY_setservent 189 +#define KEY_setsockopt 190 +#define KEY_shift 191 +#define KEY_shmctl 192 +#define KEY_shmget 193 +#define KEY_shmread 194 +#define KEY_shmwrite 195 +#define KEY_shutdown 196 +#define KEY_sin 197 +#define KEY_sleep 198 +#define KEY_socket 199 +#define KEY_socketpair 200 +#define KEY_sort 201 +#define KEY_splice 202 +#define KEY_split 203 +#define KEY_sprintf 204 +#define KEY_sqrt 205 +#define KEY_srand 206 +#define KEY_stat 207 +#define KEY_study 208 +#define KEY_sub 209 +#define KEY_substr 210 +#define KEY_symlink 211 +#define KEY_syscall 212 +#define KEY_sysopen 213 +#define KEY_sysread 214 +#define KEY_sysseek 215 +#define KEY_system 216 +#define KEY_syswrite 217 +#define KEY_tell 218 +#define KEY_telldir 219 +#define KEY_tie 220 +#define KEY_tied 221 +#define KEY_time 222 +#define KEY_times 223 +#define KEY_tr 224 +#define KEY_truncate 225 +#define KEY_uc 226 +#define KEY_ucfirst 227 +#define KEY_umask 228 +#define KEY_undef 229 +#define KEY_unless 230 +#define KEY_unlink 231 +#define KEY_unpack 232 +#define KEY_unshift 233 +#define KEY_untie 234 +#define KEY_until 235 +#define KEY_use 236 +#define KEY_utime 237 +#define KEY_values 238 +#define KEY_vec 239 +#define KEY_wait 240 +#define KEY_waitpid 241 +#define KEY_wantarray 242 +#define KEY_warn 243 +#define KEY_while 244 +#define KEY_write 245 +#define KEY_x 246 +#define KEY_xor 247 +#define KEY_y 248 diff --git a/keywords.pl b/keywords.pl index aebb3ee2e7..d1db4615ad 100755 --- a/keywords.pl +++ b/keywords.pl @@ -38,6 +38,7 @@ END EQ GE GT +INIT LE LT NE @@ -144,6 +145,7 @@ link listen local localtime +lock log lstat lt diff --git a/lib/Class/Fields.pm b/lib/Class/Fields.pm new file mode 100644 index 0000000000..4b23e7d731 --- /dev/null +++ b/lib/Class/Fields.pm @@ -0,0 +1,33 @@ +package Class::Fields; +use Carp; + +sub import { + my $class = shift; + my ($package) = caller; + my $fields = \%{"$package\::FIELDS"}; + my $i = $fields->{__MAX__}; + foreach my $f (@_) { + if (defined($fields->{$f})) { + croak "Field name $f already used by a base class" + } + $fields->{$f} = ++$i; + } + $fields->{__MAX__} = $i; + push(@{"$package\::ISA"}, "Class::Fields"); +} + +sub new { + my $class = shift; + bless [\%{"$class\::FIELDS"}, @_], $class; +} + +sub ISA { + my ($class, $package) = @_; + my $from_fields = \%{"$class\::FIELDS"}; + my $to_fields = \%{"$package\::FIELDS"}; + return unless defined %$from_fields; + croak "Ambiguous inheritance for %FIELDS" if defined %$to_fields; + %$to_fields = %$from_fields; +} + +1; diff --git a/lib/ISA.pm b/lib/ISA.pm new file mode 100644 index 0000000000..d18242c13a --- /dev/null +++ b/lib/ISA.pm @@ -0,0 +1,20 @@ +package ISA; +use Carp; + +sub import { + my $class = shift; + my ($package) = caller; + foreach my $base (@_) { + croak qq(No such class "$base") unless defined %{"$base\::"}; + eval { + $base->ISA($package); + }; + if ($@ && $@ !~ /^Can't locate object method/) { + $@ =~ s/ at .*? line \d+\n$//; + croak $@; + } + } + push(@{"$package\::ISA"}, @_); +} + +1; diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index 10016f3bb7..10016f3bb7 100644..100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm diff --git a/makeaperl.SH b/makeaperl.SH index 16b74350e0..16b74350e0 100755..100644 --- a/makeaperl.SH +++ b/makeaperl.SH @@ -291,6 +291,7 @@ malloc(nbytes) #endif #endif /* PERL_CORE */ + MUTEX_LOCK(&malloc_mutex); /* * Convert amount of memory requested into * closest block size stored in hash buckets @@ -321,6 +322,7 @@ malloc(nbytes) if (nextf[bucket] == NULL) morecore(bucket); if ((p = (union overhead *)nextf[bucket]) == NULL) { + MUTEX_UNLOCK(&malloc_mutex); #ifdef PERL_CORE if (!nomemok) { PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); @@ -358,6 +360,7 @@ malloc(nbytes) p->ov_rmagic = RMAGIC; *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC; #endif + MUTEX_UNLOCK(&malloc_mutex); return ((Malloc_t)(p + CHUNK_SHIFT)); } @@ -368,7 +371,7 @@ static void morecore(bucket) register int bucket; { - register union overhead *op; + register union overhead *ovp; register int rnu; /* 2^rnu bytes will be requested */ register int nblks; /* become nblks blocks of the desired size */ register MEM_SIZE siz, needed; @@ -385,10 +388,10 @@ morecore(bucket) * make getpageize call? */ #ifndef atarist /* on the atari we dont have to worry about this */ - op = (union overhead *)sbrk(0); + ovp = (union overhead *)sbrk(0); # ifndef I286 - if ((UV)op & (0x7FF >> CHUNK_SHIFT)) { - slack = (0x800 >> CHUNK_SHIFT) - ((UV)op & (0x7FF >> CHUNK_SHIFT)); + if ((UV)ovp & (0x7FF >> CHUNK_SHIFT)) { + slack = (0x800 >> CHUNK_SHIFT) - ((UV)ovp & (0x7FF >> CHUNK_SHIFT)); (void)sbrk(slack); # if defined(DEBUGGING_MSTATS) sbrk_slack += slack; @@ -412,11 +415,11 @@ morecore(bucket) #ifdef TWO_POT_OPTIMIZE needed += (bucket >= (FIRST_BIG_TWO_POT - 3) ? PERL_PAGESIZE : 0); #endif - op = (union overhead *)sbrk(needed); + ovp = (union overhead *)sbrk(needed); /* no more room! */ - if (op == (union overhead *)-1) { - op = (union overhead *)emergency_sbrk(needed); - if (op == (union overhead *)-1) + if (ovp == (union overhead *)-1) { + ovp = (union overhead *)emergency_sbrk(needed); + if (ovp == (union overhead *)-1) return; } #ifdef DEBUGGING_MSTATS @@ -428,11 +431,11 @@ morecore(bucket) */ #ifndef I286 # ifdef PACK_MALLOC - if ((UV)op & 0x7FF) + if ((UV)ovp & 0x7FF) croak("panic: Off-page sbrk"); # endif - if ((UV)op & 7) { - op = (union overhead *)(((UV)op + 8) & ~7); + if ((UV)ovp & 7) { + ovp = (union overhead *)(((UV)ovp + 8) & ~7); nblks--; } #else @@ -444,29 +447,29 @@ morecore(bucket) */ siz = 1 << (bucket + 3); #ifdef PACK_MALLOC - *(u_char*)op = bucket; /* Fill index. */ + *(u_char*)ovp = bucket; /* Fill index. */ if (bucket <= MAX_PACKED - 3) { - op = (union overhead *) ((char*)op + blk_shift[bucket]); + ovp = (union overhead *) ((char*)ovp + blk_shift[bucket]); nblks = n_blks[bucket]; # ifdef DEBUGGING_MSTATS start_slack += blk_shift[bucket]; # endif } else if (bucket <= 11 - 1 - 3) { - op = (union overhead *) ((char*)op + blk_shift[bucket]); + ovp = (union overhead *) ((char*)ovp + blk_shift[bucket]); /* nblks = n_blks[bucket]; */ siz -= sizeof(union overhead); - } else op++; /* One chunk per block. */ + } else ovp++; /* One chunk per block. */ #endif /* !PACK_MALLOC */ - nextf[bucket] = op; + nextf[bucket] = ovp; #ifdef DEBUGGING_MSTATS nmalloc[bucket] += nblks; #endif while (--nblks > 0) { - op->ov_next = (union overhead *)((caddr_t)op + siz); - op = (union overhead *)((caddr_t)op + siz); + ovp->ov_next = (union overhead *)((caddr_t)ovp + siz); + ovp = (union overhead *)((caddr_t)ovp + siz); } /* Not all sbrks return zeroed memory.*/ - op->ov_next = (union overhead *)NULL; + ovp->ov_next = (union overhead *)NULL; #ifdef PACK_MALLOC if (bucket == 7 - 3) { /* Special case, explanation is above. */ union overhead *n_op = nextf[7 - 3]->ov_next; @@ -482,7 +485,7 @@ free(mp) Malloc_t mp; { register MEM_SIZE size; - register union overhead *op; + register union overhead *ovp; char *cp = (char*)mp; #ifdef PACK_MALLOC u_char bucket; @@ -494,12 +497,12 @@ free(mp) if (cp == NULL) return; - op = (union overhead *)((caddr_t)cp - - sizeof (union overhead) * CHUNK_SHIFT); + ovp = (union overhead *)((caddr_t)cp + - sizeof (union overhead) * CHUNK_SHIFT); #ifdef PACK_MALLOC - bucket = OV_INDEX(op); + bucket = OV_INDEX(ovp); #endif - if (OV_MAGIC(op, bucket) != MAGIC) { + if (OV_MAGIC(ovp, bucket) != MAGIC) { static int bad_free_warn = -1; if (bad_free_warn == -1) { char *pbf = getenv("PERL_BADFREE"); @@ -509,22 +512,24 @@ free(mp) return; #ifdef RCHECK warn("%s free() ignored", - op->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad"); + ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad"); #else warn("Bad free() ignored"); #endif return; /* sanity */ } + MUTEX_LOCK(&malloc_mutex); #ifdef RCHECK - ASSERT(op->ov_rmagic == RMAGIC); - if (OV_INDEX(op) <= MAX_SHORT_BUCKET) - ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC); - op->ov_rmagic = RMAGIC - 1; + ASSERT(ovp->ov_rmagic == RMAGIC); + if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) + ASSERT(*(u_int *)((caddr_t)ovp + ovp->ov_size + 1 - RSLOP) == RMAGIC); + ovp->ov_rmagic = RMAGIC - 1; #endif - ASSERT(OV_INDEX(op) < NBUCKETS); - size = OV_INDEX(op); - op->ov_next = nextf[size]; - nextf[size] = op; + ASSERT(OV_INDEX(ovp) < NBUCKETS); + size = OV_INDEX(ovp); + ovp->ov_next = nextf[size]; + nextf[size] = ovp; + MUTEX_UNLOCK(&malloc_mutex); } /* @@ -546,7 +551,7 @@ realloc(mp, nbytes) MEM_SIZE nbytes; { register MEM_SIZE onb; - union overhead *op; + union overhead *ovp; char *res; register int i; int was_alloced = 0; @@ -572,10 +577,11 @@ realloc(mp, nbytes) #endif #endif /* PERL_CORE */ - op = (union overhead *)((caddr_t)cp - - sizeof (union overhead) * CHUNK_SHIFT); - i = OV_INDEX(op); - if (OV_MAGIC(op, i) == MAGIC) { + MUTEX_LOCK(&malloc_mutex); + ovp = (union overhead *)((caddr_t)cp + - sizeof (union overhead) * CHUNK_SHIFT); + i = OV_INDEX(ovp); + if (OV_MAGIC(ovp, i) == MAGIC) { was_alloced = 1; } else { /* @@ -589,8 +595,8 @@ realloc(mp, nbytes) * the memory block being realloc'd is the * smallest possible. */ - if ((i = findbucket(op, 1)) < 0 && - (i = findbucket(op, reall_srchlen)) < 0) + if ((i = findbucket(ovp, 1)) < 0 && + (i = findbucket(ovp, reall_srchlen)) < 0) i = 0; } onb = (1L << (i + 3)) - @@ -622,7 +628,7 @@ realloc(mp, nbytes) * Record new allocated size of block and * bound space with magic numbers. */ - if (OV_INDEX(op) <= MAX_SHORT_BUCKET) { + if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { /* * Convert amount of memory requested into * closest block size stored in hash buckets @@ -631,13 +637,15 @@ realloc(mp, nbytes) */ nbytes += M_OVERHEAD; nbytes = (nbytes + 3) &~ 3; - op->ov_size = nbytes - 1; - *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC; + ovp->ov_size = nbytes - 1; + *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC; } #endif res = cp; + MUTEX_UNLOCK(&malloc_mutex); } else { + MUTEX_UNLOCK(&malloc_mutex); if ((res = (char*)malloc(nbytes)) == NULL) return (NULL); if (cp != res) /* common optimization */ @@ -454,11 +454,14 @@ MAGIC *mg; #endif break; case '?': - sv_setiv(sv, (IV)STATUS_CURRENT); + { + dTHR; + sv_setiv(sv, (IV)STATUS_CURRENT); #ifdef COMPLEX_STATUS - LvTARGOFF(sv) = statusvalue; - LvTARGLEN(sv) = statusvalue_vms; + LvTARGOFF(sv) = statusvalue; + LvTARGLEN(sv) = statusvalue_vms; #endif + } break; case '^': s = IoTOP_NAME(GvIOp(defoutgv)); @@ -491,7 +494,7 @@ MAGIC *mg; case '/': break; case '[': - sv_setiv(sv, (IV)curcop->cop_arybase); + WITH_THR(sv_setiv(sv, (IV)curcop->cop_arybase)); break; case '|': sv_setiv(sv, (IV)(IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 ); @@ -626,13 +629,14 @@ MAGIC* mg; char *strend = s + len; while (s < strend) { + char tmpbuf[256]; struct stat st; - s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, + s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, strend, ':', &i); s++; - if (i >= sizeof tokenbuf /* too long -- assume the worst */ - || *tokenbuf != '/' - || (Stat(tokenbuf, &st) == 0 && (st.st_mode & 2)) ) { + if (i >= sizeof tmpbuf /* too long -- assume the worst */ + || *tmpbuf != '/' + || (Stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { MgTAINTEDDIR_on(mg); return 0; } @@ -704,6 +708,7 @@ MAGIC* mg; if(psig_ptr[i]) sv_setsv(sv,psig_ptr[i]); else { + dTHR; /* just for SvREFCNT_inc */ Sighandler_t sigstate = rsignal_state(i); /* cache state so we don't fetch it again */ @@ -743,6 +748,7 @@ magic_setsig(sv,mg) SV* sv; MAGIC* mg; { + dTHR; register char *s; I32 i; SV** svp; @@ -779,7 +785,7 @@ MAGIC* mg; } if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { if (i) - (void)rsignal(i, sighandler); + (void)rsignal(i, sighandlerp); else *svp = SvREFCNT_inc(sv); return 0; @@ -806,7 +812,7 @@ MAGIC* mg; if (!strchr(s,':') && !strchr(s,'\'')) sv_setpv(sv, form("main::%s", s)); if (i) - (void)rsignal(i, sighandler); + (void)rsignal(i, sighandlerp); else *svp = SvREFCNT_inc(sv); } @@ -854,6 +860,7 @@ SV* sv; MAGIC* mg; char *meth; { + dTHR; dSP; ENTER; @@ -895,6 +902,7 @@ magic_setpack(sv,mg) SV* sv; MAGIC* mg; { + dTHR; dSP; PUSHMARK(sp); @@ -928,6 +936,7 @@ int magic_wipepack(sv,mg) SV* sv; MAGIC* mg; { + dTHR; dSP; PUSHMARK(sp); @@ -945,6 +954,7 @@ SV* sv; MAGIC* mg; SV* key; { + dTHR; dSP; char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; @@ -978,6 +988,7 @@ magic_setdbline(sv,mg) SV* sv; MAGIC* mg; { + dTHR; OP *o; I32 i; GV* gv; @@ -999,6 +1010,7 @@ magic_getarylen(sv,mg) SV* sv; MAGIC* mg; { + dTHR; sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase); return 0; } @@ -1008,6 +1020,7 @@ magic_setarylen(sv,mg) SV* sv; MAGIC* mg; { + dTHR; av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase); return 0; } @@ -1022,6 +1035,7 @@ MAGIC* mg; if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { mg = mg_find(lsv, 'g'); if (mg && mg->mg_len >= 0) { + dTHR; sv_setiv(sv, mg->mg_len + curcop->cop_arybase); return 0; } @@ -1055,7 +1069,7 @@ MAGIC* mg; } len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv); - pos = SvIV(sv) - curcop->cop_arybase; + WITH_THR(pos = SvIV(sv) - curcop->cop_arybase); if (pos < 0) { pos += len; if (pos < 0) @@ -1132,6 +1146,7 @@ magic_settaint(sv,mg) SV* sv; MAGIC* mg; { + dTHR; if (localizing) { if (localizing == 1) mg->mg_len <<= 1; @@ -1173,6 +1188,7 @@ MAGIC* mg; targ = AvARRAY(av)[LvTARGOFF(sv)]; } if (targ && targ != &sv_undef) { + dTHR; /* just for SvREFCNT_dec */ /* somebody else defined it for us */ SvREFCNT_dec(LvTARG(sv)); LvTARG(sv) = SvREFCNT_inc(targ); @@ -1215,6 +1231,7 @@ void vivify_defelem(sv) SV* sv; { + dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/ MAGIC* mg; SV* value; @@ -1311,6 +1328,7 @@ magic_set(sv,mg) SV* sv; MAGIC* mg; { + dTHR; register char *s; I32 i; STRLEN len; @@ -1637,6 +1655,23 @@ MAGIC* mg; return 0; } +#ifdef USE_THREADS +int +magic_mutexfree(sv, mg) +SV *sv; +MAGIC *mg; +{ + dTHR; + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n", + (unsigned long)thr, (unsigned long)sv);) + if (MgOWNER(mg)) + croak("panic: magic_mutexfree"); + MUTEX_DESTROY(MgMUTEXP(mg)); + COND_DESTROY(MgCONDP(mg)); + return 0; +} +#endif /* USE_THREADS */ + I32 whichsig(sig) char *sig; @@ -1676,6 +1711,7 @@ Signal_t sighandler(sig) int sig; { + dTHR; dSP; GV *gv; HV *st; diff --git a/minimod.pl b/minimod.pl index 82760ee63d..82760ee63d 100755..100644 --- a/minimod.pl +++ b/minimod.pl @@ -18,32 +18,26 @@ #include "EXTERN.h" #include "perl.h" -#define USE_OP_MASK /* Turned on by default in 5.002beta1h */ - -#ifdef USE_OP_MASK /* - * In the following definition, the ", (OP *) op" is just to make the compiler + * In the following definition, the ", Nullop" is just to make the compiler * think the expression is of the right type: croak actually does a Siglongjmp. */ -#define CHECKOP(type,op) \ +#define CHECKOP(type,o) \ ((op_mask && op_mask[type]) \ - ? ( op_free((OP*)op), \ + ? ( op_free((OP*)o), \ croak("%s trapped by operation mask", op_desc[type]), \ Nullop ) \ - : (*check[type])((OP*)op)) -#else -#define CHECKOP(type,op) (*check[type])(op) -#endif /* USE_OP_MASK */ - -static I32 list_assignment _((OP *op)); -static OP *bad_type _((I32 n, char *t, char *name, OP *kid)); -static OP *modkids _((OP *op, I32 type)); -static OP *no_fh_allowed _((OP *op)); -static bool scalar_mod_type _((OP *op, I32 type)); -static OP *scalarboolean _((OP *op)); -static OP *too_few_arguments _((OP *op, char* name)); -static OP *too_many_arguments _((OP *op, char* name)); -static void null _((OP* op)); + : (*check[type])((OP*)o)) + +static I32 list_assignment _((OP *o)); +static void bad_type _((I32 n, char *t, char *name, OP *kid)); +static OP *modkids _((OP *o, I32 type)); +static OP *no_fh_allowed _((OP *o)); +static bool scalar_mod_type _((OP *o, I32 type)); +static OP *scalarboolean _((OP *o)); +static OP *too_few_arguments _((OP *o, char* name)); +static OP *too_many_arguments _((OP *o, char* name)); +static void null _((OP* o)); static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)); @@ -57,33 +51,33 @@ GV* gv; } static OP * -no_fh_allowed(op) -OP *op; +no_fh_allowed(o) +OP *o; { yyerror(form("Missing comma after first argument to %s function", - op_desc[op->op_type])); - return op; + op_desc[o->op_type])); + return o; } static OP * -too_few_arguments(op, name) -OP* op; +too_few_arguments(o, name) +OP* o; char* name; { yyerror(form("Not enough arguments for %s", name)); - return op; + return o; } static OP * -too_many_arguments(op, name) -OP *op; +too_many_arguments(o, name) +OP *o; char* name; { yyerror(form("Too many arguments for %s", name)); - return op; + return o; } -static OP * +static void bad_type(n, t, name, kid) I32 n; char *t; @@ -92,14 +86,13 @@ OP *kid; { yyerror(form("Type of arg %d to %s must be %s (not %s)", (int)n, name, t, op_desc[kid->op_type])); - return op; } void -assertref(op) -OP *op; +assertref(o) +OP *o; { - int type = op->op_type; + int type = o->op_type; if (type != OP_AELEM && type != OP_HELEM) { yyerror(form("Can't use subscript on %s", op_desc[type])); if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) @@ -114,6 +107,7 @@ PADOFFSET pad_allocmy(name) char *name; { + dTHR; PADOFFSET off; SV *sv; @@ -142,6 +136,14 @@ char *name; sv = NEWSV(1102,0); sv_upgrade(sv, SVt_PVNV); sv_setpv(sv, name); + if (in_my_stash) { + if (*name != '$') + croak("Can't declare class for non-scalar %s in \"my\"",name); + SvOBJECT_on(sv); + (void)SvUPGRADE(sv, SVt_PVMG); + SvSTASH(sv) = (HV*)SvREFCNT_inc(in_my_stash); + sv_objcount++; + } av_store(comppad_name, off, sv); SvNVX(sv) = (double)999999999; SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */ @@ -168,6 +170,7 @@ I32 cx_ix; pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) #endif { + dTHR; CV *cv; I32 off; SV *sv; @@ -295,12 +298,26 @@ PADOFFSET pad_findmy(name) char *name; { + dTHR; I32 off; I32 pendoff = 0; SV *sv; SV **svp = AvARRAY(comppad_name); U32 seq = cop_seqmax; +#ifdef USE_THREADS + /* + * Special case to get lexical (and hence per-thread) @_. + * XXX I need to find out how to tell at parse-time whether use + * of @_ should refer to a lexical (from a sub) or defgv (global + * scope and maybe weird sub-ish things like formats). See + * startsub in perly.y. It's possible that @_ could be lexical + * (at least from subs) even in non-threaded perl. + */ + if (strEQ(name, "@_")) + return 0; /* success. (NOT_IN_PAD indicates failure) */ +#endif /* USE_THREADS */ + /* The one we're looking for is probably just before comppad_name_fill. */ for (off = AvFILL(comppad_name); off > 0; off--) { if ((sv = svp[off]) && @@ -322,10 +339,9 @@ char *name; /* If there is a pending local definition, this new alias must die */ if (pendoff) SvIVX(AvARRAY(comppad_name)[off]) = seq; - return off; + return off; /* pad_findlex returns 0 for failure...*/ } - - return 0; + return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */ } void @@ -353,6 +369,7 @@ pad_alloc(optype,tmptype) I32 optype; U32 tmptype; { + dTHR; SV *sv; I32 retval; @@ -386,7 +403,14 @@ U32 tmptype; } SvFLAGS(sv) |= tmptype; curpad = AvARRAY(comppad); - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n", (long) retval, op_name[optype])); +#ifdef USE_THREADS + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx alloc %ld for %s\n", + (unsigned long) thr, (unsigned long) curpad, + (long) retval, op_name[optype])); +#else + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n", + (long) retval, op_name[optype])); +#endif /* USE_THREADS */ return (PADOFFSET)retval; } @@ -398,9 +422,15 @@ PADOFFSET po; pad_sv(PADOFFSET po) #endif /* CAN_PROTOTYPE */ { + dTHR; +#ifdef USE_THREADS + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx sv %d\n", + (unsigned long) thr, (unsigned long) curpad, po)); +#else if (!po) croak("panic: pad_sv po"); - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %lu\n", (unsigned long)po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %d\n", po)); +#endif /* USE_THREADS */ return curpad[po]; /* eventually we'll turn this into a macro */ } @@ -412,14 +442,20 @@ PADOFFSET po; pad_free(PADOFFSET po) #endif /* CAN_PROTOTYPE */ { + dTHR; if (!curpad) return; if (AvARRAY(comppad) != curpad) croak("panic: pad_free curpad"); if (!po) croak("panic: pad_free po"); - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %lu\n", (unsigned long)po)); - if (curpad[po] && !SvIMMORTAL(curpad[po])) +#ifdef USE_THREADS + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n", + (unsigned long) thr, (unsigned long) curpad, po)); +#else + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po)); +#endif /* USE_THREADS */ + if (curpad[po] && curpad[po] != &sv_undef) SvPADTMP_off(curpad[po]); if ((I32)po < padix) padix = po - 1; @@ -433,11 +469,17 @@ PADOFFSET po; pad_swipe(PADOFFSET po) #endif /* CAN_PROTOTYPE */ { + dTHR; if (AvARRAY(comppad) != curpad) croak("panic: pad_swipe curpad"); if (!po) croak("panic: pad_swipe po"); - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %lu\n", (unsigned long)po)); +#ifdef USE_THREADS + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n", + (unsigned long) thr, (unsigned long) curpad, po)); +#else + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %d\n", po)); +#endif /* USE_THREADS */ SvPADTMP_off(curpad[po]); curpad[po] = NEWSV(1107,0); SvPADTMP_on(curpad[po]); @@ -448,11 +490,17 @@ pad_swipe(PADOFFSET po) void pad_reset() { + dTHR; register I32 po; if (AvARRAY(comppad) != curpad) croak("panic: pad_reset curpad"); +#ifdef USE_THREADS + DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n", + (unsigned long) thr, (unsigned long) curpad)); +#else DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n")); +#endif /* USE_THREADS */ if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */ for (po = AvMAX(comppad); po > padix_floor; po--) { if (curpad[po] && !SvIMMORTAL(curpad[po])) @@ -466,80 +514,80 @@ pad_reset() /* Destructor */ void -op_free(op) -OP *op; +op_free(o) +OP *o; { register OP *kid, *nextkid; - if (!op || op->op_seq == (U16)-1) + if (!o || o->op_seq == (U16)-1) return; - if (op->op_flags & OPf_KIDS) { - for (kid = cUNOP->op_first; kid; kid = nextkid) { + if (o->op_flags & OPf_KIDS) { + for (kid = cUNOPo->op_first; kid; kid = nextkid) { nextkid = kid->op_sibling; /* Get before next freeing kid */ op_free(kid); } } - switch (op->op_type) { + switch (o->op_type) { case OP_NULL: - op->op_targ = 0; /* Was holding old type, if any. */ + o->op_targ = 0; /* Was holding old type, if any. */ break; case OP_ENTEREVAL: - op->op_targ = 0; /* Was holding hints. */ + o->op_targ = 0; /* Was holding hints. */ break; default: - if (!(op->op_flags & OPf_REF) || (check[op->op_type] != ck_ftst)) + if (!(o->op_flags & OPf_REF) || (check[o->op_type] != ck_ftst)) break; /* FALL THROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: - SvREFCNT_dec(cGVOP->op_gv); + SvREFCNT_dec(cGVOPo->op_gv); break; case OP_NEXTSTATE: case OP_DBSTATE: - Safefree(cCOP->cop_label); - SvREFCNT_dec(cCOP->cop_filegv); + Safefree(cCOPo->cop_label); + SvREFCNT_dec(cCOPo->cop_filegv); break; case OP_CONST: - SvREFCNT_dec(cSVOP->op_sv); + SvREFCNT_dec(cSVOPo->op_sv); break; case OP_GOTO: case OP_NEXT: case OP_LAST: case OP_REDO: - if (op->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) + if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) break; /* FALL THROUGH */ case OP_TRANS: - Safefree(cPVOP->op_pv); + Safefree(cPVOPo->op_pv); break; case OP_SUBST: - op_free(cPMOP->op_pmreplroot); + op_free(cPMOPo->op_pmreplroot); /* FALL THROUGH */ case OP_PUSHRE: case OP_MATCH: - pregfree(cPMOP->op_pmregexp); - SvREFCNT_dec(cPMOP->op_pmshort); + pregfree(cPMOPo->op_pmregexp); + SvREFCNT_dec(cPMOPo->op_pmshort); break; } - if (op->op_targ > 0) - pad_free(op->op_targ); + if (o->op_targ > 0) + pad_free(o->op_targ); - Safefree(op); + Safefree(o); } static void -null(op) -OP* op; +null(o) +OP* o; { - if (op->op_type != OP_NULL && op->op_targ > 0) - pad_free(op->op_targ); - op->op_targ = op->op_type; - op->op_type = OP_NULL; - op->op_ppaddr = ppaddr[OP_NULL]; + if (o->op_type != OP_NULL && o->op_targ > 0) + pad_free(o->op_targ); + o->op_targ = o->op_type; + o->op_type = OP_NULL; + o->op_ppaddr = ppaddr[OP_NULL]; } /* Contextualizers */ @@ -547,48 +595,49 @@ OP* op; #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) OP * -linklist(op) -OP *op; +linklist(o) +OP *o; { register OP *kid; - if (op->op_next) - return op->op_next; + if (o->op_next) + return o->op_next; /* establish postfix order */ - if (cUNOP->op_first) { - op->op_next = LINKLIST(cUNOP->op_first); - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { + if (cUNOPo->op_first) { + o->op_next = LINKLIST(cUNOPo->op_first); + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) kid->op_next = LINKLIST(kid->op_sibling); else - kid->op_next = op; + kid->op_next = o; } } else - op->op_next = op; + o->op_next = o; - return op->op_next; + return o->op_next; } OP * -scalarkids(op) -OP *op; +scalarkids(o) +OP *o; { OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + if (o && o->op_flags & OPf_KIDS) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) scalar(kid); } - return op; + return o; } static OP * -scalarboolean(op) -OP *op; +scalarboolean(o) +OP *o; { if (dowarn && - op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) { + o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { + dTHR; line_t oldline = curcop->cop_line; if (copline != NOLINE) @@ -596,36 +645,36 @@ OP *op; warn("Found = in conditional, should be =="); curcop->cop_line = oldline; } - return scalar(op); + return scalar(o); } OP * -scalar(op) -OP *op; +scalar(o) +OP *o; { OP *kid; /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_WANT) || error_count - || op->op_type == OP_RETURN) - return op; + if (!o || (o->op_flags & OPf_WANT) || error_count + || o->op_type == OP_RETURN) + return o; - op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; - switch (op->op_type) { + switch (o->op_type) { case OP_REPEAT: - if (op->op_private & OPpREPEAT_DOLIST) - null(((LISTOP*)cBINOP->op_first)->op_first); - scalar(cBINOP->op_first); + if (o->op_private & OPpREPEAT_DOLIST) + null(((LISTOP*)cBINOPo->op_first)->op_first); + scalar(cBINOPo->op_first); break; case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) scalar(kid); break; case OP_SPLIT: - if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) { + if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { if (!kPMOP->op_pmreplroot) deprecate("implicit split to @_"); } @@ -634,14 +683,14 @@ OP *op; case OP_SUBST: case OP_NULL: default: - if (op->op_flags & OPf_KIDS) { - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) + if (o->op_flags & OPf_KIDS) { + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) scalar(kid); } break; case OP_LEAVE: case OP_LEAVETRY: - kid = cLISTOP->op_first; + kid = cLISTOPo->op_first; scalar(kid); while (kid = kid->op_sibling) { if (kid->op_sibling) @@ -649,45 +698,45 @@ OP *op; else scalar(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) scalarvoid(kid); else scalar(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; } - return op; + return o; } OP * -scalarvoid(op) -OP *op; +scalarvoid(o) +OP *o; { OP *kid; char* useless = 0; SV* sv; /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_WANT) == OPf_WANT_LIST || error_count - || op->op_type == OP_RETURN) - return op; + if (!o || (o->op_flags & OPf_WANT) == OPf_WANT_LIST || error_count + || o->op_type == OP_RETURN) + return o; - op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; - switch (op->op_type) { + switch (o->op_type) { default: - if (!(opargs[op->op_type] & OA_FOLDCONST)) + if (!(opargs[o->op_type] & OA_FOLDCONST)) break; /* FALL THROUGH */ case OP_REPEAT: - if (op->op_flags & OPf_STACKED) + if (o->op_flags & OPf_STACKED) break; /* FALL THROUGH */ case OP_GVSV: @@ -758,26 +807,26 @@ OP *op; case OP_GGRNAM: case OP_GGRGID: case OP_GETLOGIN: - if (!(op->op_private & OPpLVAL_INTRO)) - useless = op_desc[op->op_type]; + if (!(o->op_private & OPpLVAL_INTRO)) + useless = op_desc[o->op_type]; break; case OP_RV2GV: case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: - if (!(op->op_private & OPpLVAL_INTRO) && - (!op->op_sibling || op->op_sibling->op_type != OP_READLINE)) + if (!(o->op_private & OPpLVAL_INTRO) && + (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) useless = "a variable"; break; case OP_NEXTSTATE: case OP_DBSTATE: - curcop = ((COP*)op); /* for warning below */ + WITH_THR(curcop = ((COP*)o)); /* for warning below */ break; case OP_CONST: - sv = cSVOP->op_sv; + sv = cSVOPo->op_sv; if (dowarn) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) @@ -789,37 +838,37 @@ OP *op; useless = 0; } } - null(op); /* don't execute a constant */ + null(o); /* don't execute a constant */ SvREFCNT_dec(sv); /* don't even remember it */ break; case OP_POSTINC: - op->op_type = OP_PREINC; /* pre-increment is faster */ - op->op_ppaddr = ppaddr[OP_PREINC]; + o->op_type = OP_PREINC; /* pre-increment is faster */ + o->op_ppaddr = ppaddr[OP_PREINC]; break; case OP_POSTDEC: - op->op_type = OP_PREDEC; /* pre-decrement is faster */ - op->op_ppaddr = ppaddr[OP_PREDEC]; + o->op_type = OP_PREDEC; /* pre-decrement is faster */ + o->op_ppaddr = ppaddr[OP_PREDEC]; break; case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) scalarvoid(kid); break; case OP_NULL: - if (op->op_targ == OP_NEXTSTATE || op->op_targ == OP_DBSTATE) - curcop = ((COP*)op); /* for warning below */ - if (op->op_flags & OPf_STACKED) + if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) + WITH_THR(curcop = ((COP*)o)); /* for warning below */ + if (o->op_flags & OPf_STACKED) break; /* FALL THROUGH */ case OP_ENTERTRY: case OP_ENTER: case OP_SCALAR: - if (!(op->op_flags & OPf_KIDS)) + if (!(o->op_flags & OPf_KIDS)) break; /* FALL THROUGH */ case OP_SCOPE: @@ -828,18 +877,18 @@ OP *op; case OP_LEAVELOOP: case OP_LINESEQ: case OP_LIST: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) scalarvoid(kid); break; case OP_ENTEREVAL: - scalarkids(op); + scalarkids(o); break; case OP_REQUIRE: /* all requires must return a boolean value */ - op->op_flags &= ~OPf_WANT; - return scalar(op); + o->op_flags &= ~OPf_WANT; + return scalar(o); case OP_SPLIT: - if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) { + if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { if (!kPMOP->op_pmreplroot) deprecate("implicit split to @_"); } @@ -847,61 +896,61 @@ OP *op; } if (useless && dowarn) warn("Useless use of %s in void context", useless); - return op; + return o; } OP * -listkids(op) -OP *op; +listkids(o) +OP *o; { OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + if (o && o->op_flags & OPf_KIDS) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) list(kid); } - return op; + return o; } OP * -list(op) -OP *op; +list(o) +OP *o; { OP *kid; /* assumes no premature commitment */ - if (!op || (op->op_flags & OPf_WANT) || error_count - || op->op_type == OP_RETURN) - return op; + if (!o || (o->op_flags & OPf_WANT) || error_count + || o->op_type == OP_RETURN) + return o; - op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_LIST; + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; - switch (op->op_type) { + switch (o->op_type) { case OP_FLOP: case OP_REPEAT: - list(cBINOP->op_first); + list(cBINOPo->op_first); break; case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) list(kid); break; default: case OP_MATCH: case OP_SUBST: case OP_NULL: - if (!(op->op_flags & OPf_KIDS)) + if (!(o->op_flags & OPf_KIDS)) break; - if (!op->op_next && cUNOP->op_first->op_type == OP_FLOP) { - list(cBINOP->op_first); - return gen_constant_list(op); + if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { + list(cBINOPo->op_first); + return gen_constant_list(o); } case OP_LIST: - listkids(op); + listkids(o); break; case OP_LEAVE: case OP_LEAVETRY: - kid = cLISTOP->op_first; + kid = cLISTOPo->op_first; list(kid); while (kid = kid->op_sibling) { if (kid->op_sibling) @@ -909,86 +958,88 @@ OP *op; else list(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; case OP_SCOPE: case OP_LINESEQ: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) scalarvoid(kid); else list(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; case OP_REQUIRE: /* all requires must return a boolean value */ - op->op_flags &= ~OPf_WANT; - return scalar(op); + o->op_flags &= ~OPf_WANT; + return scalar(o); } - return op; + return o; } OP * -scalarseq(op) -OP *op; +scalarseq(o) +OP *o; { OP *kid; - if (op) { - if (op->op_type == OP_LINESEQ || - op->op_type == OP_SCOPE || - op->op_type == OP_LEAVE || - op->op_type == OP_LEAVETRY) + if (o) { + if (o->op_type == OP_LINESEQ || + o->op_type == OP_SCOPE || + o->op_type == OP_LEAVE || + o->op_type == OP_LEAVETRY) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) { + dTHR; + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { scalarvoid(kid); } } curcop = &compiling; } - op->op_flags &= ~OPf_PARENS; + o->op_flags &= ~OPf_PARENS; if (hints & HINT_BLOCK_SCOPE) - op->op_flags |= OPf_PARENS; + o->op_flags |= OPf_PARENS; } else - op = newOP(OP_STUB, 0); - return op; + o = newOP(OP_STUB, 0); + return o; } static OP * -modkids(op, type) -OP *op; +modkids(o, type) +OP *o; I32 type; { OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + if (o && o->op_flags & OPf_KIDS) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); } - return op; + return o; } static I32 modcount; OP * -mod(op, type) -OP *op; +mod(o, type) +OP *o; I32 type; { + dTHR; OP *kid; SV *sv; - if (!op || error_count) - return op; + if (!o || error_count) + return o; - switch (op->op_type) { + switch (o->op_type) { case OP_UNDEF: modcount++; - return op; + return o; case OP_CONST: - if (!(op->op_private & (OPpCONST_ARYBASE))) + if (!(o->op_private & (OPpCONST_ARYBASE))) goto nomod; if (eval_start && eval_start->op_type == OP_CONST) { compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv); @@ -1004,16 +1055,16 @@ I32 type; croak("That use of $[ is unsupported"); break; case OP_STUB: - if (op->op_flags & OPf_PARENS) + if (o->op_flags & OPf_PARENS) break; goto nomod; case OP_ENTERSUB: if ((type == OP_UNDEF || type == OP_REFGEN) && - !(op->op_flags & OPf_STACKED)) { - op->op_type = OP_RV2CV; /* entersub => rv2cv */ - op->op_ppaddr = ppaddr[OP_RV2CV]; - assert(cUNOP->op_first->op_type == OP_NULL); - null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */ + !(o->op_flags & OPf_STACKED)) { + o->op_type = OP_RV2CV; /* entersub => rv2cv */ + o->op_ppaddr = ppaddr[OP_RV2CV]; + assert(cUNOPo->op_first->op_type == OP_NULL); + null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ break; } /* FALL THROUGH */ @@ -1023,9 +1074,9 @@ I32 type; if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) break; yyerror(form("Can't modify %s in %s", - op_desc[op->op_type], + op_desc[o->op_type], type ? op_desc[type] : "local")); - return op; + return o; case OP_PREINC: case OP_PREDEC: @@ -1047,29 +1098,29 @@ I32 type; case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: - if (!(op->op_flags & OPf_STACKED)) + if (!(o->op_flags & OPf_STACKED)) goto nomod; modcount++; break; case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, type); break; case OP_RV2AV: case OP_RV2HV: - if (!type && cUNOP->op_first->op_type != OP_GV) + if (!type && cUNOPo->op_first->op_type != OP_GV) croak("Can't localize through a reference"); - if (type == OP_REFGEN && op->op_flags & OPf_PARENS) { + if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { modcount = 10000; - return op; /* Treat \(@foo) like ordinary list. */ + return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ case OP_RV2GV: - if (scalar_mod_type(op, type)) + if (scalar_mod_type(o, type)) goto nomod; - ref(cUNOP->op_first, op->op_type); + ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_AASSIGN: case OP_ASLICE: @@ -1081,9 +1132,9 @@ I32 type; modcount = 10000; break; case OP_RV2SV: - if (!type && cUNOP->op_first->op_type != OP_GV) + if (!type && cUNOPo->op_first->op_type != OP_GV) croak("Can't localize through a reference"); - ref(cUNOP->op_first, op->op_type); + ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: @@ -1095,16 +1146,16 @@ I32 type; case OP_PADAV: case OP_PADHV: modcount = 10000; - if (type == OP_REFGEN && op->op_flags & OPf_PARENS) - return op; /* Treat \(@foo) like ordinary list. */ - if (scalar_mod_type(op, type)) + if (type == OP_REFGEN && o->op_flags & OPf_PARENS) + return o; /* Treat \(@foo) like ordinary list. */ + if (scalar_mod_type(o, type)) goto nomod; /* FALL THROUGH */ case OP_PADSV: modcount++; if (!type) croak("Can't localize lexical variable %s", - SvPV(*av_fetch(comppad_name, op->op_targ, 4), na)); + SvPV(*av_fetch(comppad_name, o->op_targ, 4), na)); break; case OP_PUSHMARK: @@ -1117,63 +1168,63 @@ I32 type; case OP_POS: case OP_VEC: case OP_SUBSTR: - pad_free(op->op_targ); - op->op_targ = pad_alloc(op->op_type, SVs_PADMY); - assert(SvTYPE(PAD_SV(op->op_targ)) == SVt_NULL); - if (op->op_flags & OPf_KIDS) - mod(cBINOP->op_first->op_sibling, type); + pad_free(o->op_targ); + o->op_targ = pad_alloc(o->op_type, SVs_PADMY); + assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); + if (o->op_flags & OPf_KIDS) + mod(cBINOPo->op_first->op_sibling, type); break; case OP_AELEM: case OP_HELEM: - ref(cBINOP->op_first, op->op_type); + ref(cBINOPo->op_first, o->op_type); if (type == OP_ENTERSUB && - !(op->op_private & (OPpLVAL_INTRO | OPpDEREF))) - op->op_private |= OPpLVAL_DEFER; + !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) + o->op_private |= OPpLVAL_DEFER; modcount++; break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: - if (op->op_flags & OPf_KIDS) - mod(cLISTOP->op_last, type); + if (o->op_flags & OPf_KIDS) + mod(cLISTOPo->op_last, type); break; case OP_NULL: - if (!(op->op_flags & OPf_KIDS)) + if (!(o->op_flags & OPf_KIDS)) break; - if (op->op_targ != OP_LIST) { - mod(cBINOP->op_first, type); + if (o->op_targ != OP_LIST) { + mod(cBINOPo->op_first, type); break; } /* FALL THROUGH */ case OP_LIST: - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; } - op->op_flags |= OPf_MOD; + o->op_flags |= OPf_MOD; if (type == OP_AASSIGN || type == OP_SASSIGN) - op->op_flags |= OPf_SPECIAL|OPf_REF; + o->op_flags |= OPf_SPECIAL|OPf_REF; else if (!type) { - op->op_private |= OPpLVAL_INTRO; - op->op_flags &= ~OPf_SPECIAL; + o->op_private |= OPpLVAL_INTRO; + o->op_flags &= ~OPf_SPECIAL; } else if (type != OP_GREPSTART && type != OP_ENTERSUB) - op->op_flags |= OPf_REF; - return op; + o->op_flags |= OPf_REF; + return o; } static bool -scalar_mod_type(op, type) -OP *op; +scalar_mod_type(o, type) +OP *o; I32 type; { switch (type) { case OP_SASSIGN: - if (op->op_type == OP_RV2GV) + if (o->op_type == OP_RV2GV) return FALSE; /* FALL THROUGH */ case OP_PREINC: @@ -1213,83 +1264,83 @@ I32 type; } OP * -refkids(op, type) -OP *op; +refkids(o, type) +OP *o; I32 type; { OP *kid; - if (op && op->op_flags & OPf_KIDS) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + if (o && o->op_flags & OPf_KIDS) { + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) ref(kid, type); } - return op; + return o; } OP * -ref(op, type) -OP *op; +ref(o, type) +OP *o; I32 type; { OP *kid; - if (!op || error_count) - return op; + if (!o || error_count) + return o; - switch (op->op_type) { + switch (o->op_type) { case OP_ENTERSUB: if ((type == OP_DEFINED) && - !(op->op_flags & OPf_STACKED)) { - op->op_type = OP_RV2CV; /* entersub => rv2cv */ - op->op_ppaddr = ppaddr[OP_RV2CV]; - assert(cUNOP->op_first->op_type == OP_NULL); - null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */ - op->op_flags |= OPf_SPECIAL; + !(o->op_flags & OPf_STACKED)) { + o->op_type = OP_RV2CV; /* entersub => rv2cv */ + o->op_ppaddr = ppaddr[OP_RV2CV]; + assert(cUNOPo->op_first->op_type == OP_NULL); + null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ + o->op_flags |= OPf_SPECIAL; } break; case OP_COND_EXPR: - for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) ref(kid, type); break; case OP_RV2SV: - ref(cUNOP->op_first, op->op_type); + ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_PADSV: if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { - op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV - : type == OP_RV2HV ? OPpDEREF_HV - : OPpDEREF_SV); - op->op_flags |= OPf_MOD; + o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); + o->op_flags |= OPf_MOD; } break; case OP_RV2AV: case OP_RV2HV: - op->op_flags |= OPf_REF; + o->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: - ref(cUNOP->op_first, op->op_type); + ref(cUNOPo->op_first, o->op_type); break; case OP_PADAV: case OP_PADHV: - op->op_flags |= OPf_REF; + o->op_flags |= OPf_REF; break; case OP_SCALAR: case OP_NULL: - if (!(op->op_flags & OPf_KIDS)) + if (!(o->op_flags & OPf_KIDS)) break; - ref(cBINOP->op_first, type); + ref(cBINOPo->op_first, type); break; case OP_AELEM: case OP_HELEM: - ref(cBINOP->op_first, op->op_type); + ref(cBINOPo->op_first, o->op_type); if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { - op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV - : type == OP_RV2HV ? OPpDEREF_HV - : OPpDEREF_SV); - op->op_flags |= OPf_MOD; + o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); + o->op_flags |= OPf_MOD; } break; @@ -1297,30 +1348,30 @@ I32 type; case OP_LEAVE: case OP_ENTER: case OP_LIST: - if (!(op->op_flags & OPf_KIDS)) + if (!(o->op_flags & OPf_KIDS)) break; - ref(cLISTOP->op_last, type); + ref(cLISTOPo->op_last, type); break; default: break; } - return scalar(op); + return scalar(o); } OP * -my(op) -OP *op; +my(o) +OP *o; { OP *kid; I32 type; - if (!op || error_count) - return op; + if (!o || error_count) + return o; - type = op->op_type; + type = o->op_type; if (type == OP_LIST) { - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) my(kid); } else if (type != OP_PADSV && @@ -1328,12 +1379,12 @@ OP *op; type != OP_PADHV && type != OP_PUSHMARK) { - yyerror(form("Can't declare %s in my", op_desc[op->op_type])); - return op; + yyerror(form("Can't declare %s in my", op_desc[o->op_type])); + return o; } - op->op_flags |= OPf_MOD; - op->op_private |= OPpLVAL_INTRO; - return op; + o->op_flags |= OPf_MOD; + o->op_private |= OPpLVAL_INTRO; + return o; } OP * @@ -1351,7 +1402,7 @@ I32 type; OP *left; OP *right; { - OP *op; + OP *o; if (dowarn && (left->op_type == OP_RV2AV || @@ -1374,12 +1425,12 @@ OP *right; if (right->op_type != OP_MATCH) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) - op = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); + o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); else - op = prepend_elem(right->op_type, scalar(left), right); + o = prepend_elem(right->op_type, scalar(left), right); if (type == OP_NOT) - return newUNOP(OP_NOT, 0, scalar(op)); - return op; + return newUNOP(OP_NOT, 0, scalar(o)); + return o; } else return bind_match(type, left, @@ -1387,13 +1438,13 @@ OP *right; } OP * -invert(op) -OP *op; +invert(o) +OP *o; { - if (!op) - return op; + if (!o) + return o; /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ - return newUNOP(OP_NOT, OPf_SPECIAL, scalar(op)); + return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } OP * @@ -1428,6 +1479,7 @@ int block_start(full) int full; { + dTHR; int retval = savestack_ix; SAVEI32(comppad_name_floor); if (full) { @@ -1453,6 +1505,7 @@ block_end(floor, seq) I32 floor; OP* seq; { + dTHR; int needblockscope = hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); LEAVE_SCOPE(floor); @@ -1465,19 +1518,20 @@ OP* seq; } void -newPROG(op) -OP *op; +newPROG(o) +OP *o; { + dTHR; if (in_eval) { - eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), op); + eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), o); eval_start = linklist(eval_root); eval_root->op_next = 0; peep(eval_start); } else { - if (!op) + if (!o) return; - main_root = scope(sawparens(scalarvoid(op))); + main_root = scope(sawparens(scalarvoid(o))); curcop = &compiling; main_start = LINKLIST(main_root); main_root->op_next = 0; @@ -1515,6 +1569,7 @@ I32 lex; } } in_my = FALSE; + in_my_stash = Nullhv; if (lex) return my(o); else @@ -1538,6 +1593,7 @@ OP * fold_constants(o) register OP *o; { + dTHR; register OP *curop; I32 type = o->op_type; SV *sv; @@ -1631,6 +1687,7 @@ OP * gen_constant_list(o) register OP *o; { + dTHR; register OP *curop; I32 oldtmps_floor = tmps_floor; @@ -1640,10 +1697,10 @@ register OP *o; op = curop = LINKLIST(o); o->op_next = 0; - pp_pushmark(); + pp_pushmark(ARGS); runops(); op = curop; - pp_anonlist(); + pp_anonlist(ARGS); tmps_floor = oldtmps_floor; o->op_type = OP_RV2AV; @@ -1656,38 +1713,38 @@ register OP *o; } OP * -convert(type, flags, op) +convert(type, flags, o) I32 type; I32 flags; -OP* op; +OP* o; { OP *kid; OP *last = 0; - if (!op || op->op_type != OP_LIST) - op = newLISTOP(OP_LIST, 0, op, Nullop); + if (!o || o->op_type != OP_LIST) + o = newLISTOP(OP_LIST, 0, o, Nullop); else - op->op_flags &= ~OPf_WANT; + o->op_flags &= ~OPf_WANT; if (!(opargs[type] & OA_MARK)) - null(cLISTOP->op_first); + null(cLISTOPo->op_first); - op->op_type = type; - op->op_ppaddr = ppaddr[type]; - op->op_flags |= flags; + o->op_type = type; + o->op_ppaddr = ppaddr[type]; + o->op_flags |= flags; - op = CHECKOP(type, op); - if (op->op_type != type) - return op; + o = CHECKOP(type, o); + if (o->op_type != type) + return o; - if (cLISTOP->op_children < 7) { + if (cLISTOPo->op_children < 7) { /* XXX do we really need to do this if we're done appending?? */ - for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) last = kid; - cLISTOP->op_last = last; /* in case check substituted last arg */ + cLISTOPo->op_last = last; /* in case check substituted last arg */ } - return fold_constants(op); + return fold_constants(o); } /* List constructors */ @@ -1787,13 +1844,13 @@ newNULLLIST() } OP * -force_list(op) -OP* op; +force_list(o) +OP *o; { - if (!op || op->op_type != OP_LIST) - op = newLISTOP(OP_LIST, 0, op, Nullop); - null(op); - return op; + if (!o || o->op_type != OP_LIST) + o = newLISTOP(OP_LIST, 0, o, Nullop); + null(o); + return o; } OP * @@ -1840,19 +1897,19 @@ newOP(type, flags) I32 type; I32 flags; { - OP *op; - Newz(1101, op, 1, OP); - op->op_type = type; - op->op_ppaddr = ppaddr[type]; - op->op_flags = flags; + OP *o; + Newz(1101, o, 1, OP); + o->op_type = type; + o->op_ppaddr = ppaddr[type]; + o->op_flags = flags; - op->op_next = op; - op->op_private = 0 + (flags >> 8); + o->op_next = o; + o->op_private = 0 + (flags >> 8); if (opargs[type] & OA_RETSCALAR) - scalar(op); + scalar(o); if (opargs[type] & OA_TARGET) - op->op_targ = pad_alloc(type, SVs_PADTMP); - return CHECKOP(type, op); + o->op_targ = pad_alloc(type, SVs_PADTMP); + return CHECKOP(type, o); } OP * @@ -1918,8 +1975,8 @@ OP* last; } OP * -pmtrans(op, expr, repl) -OP *op; +pmtrans(o, expr, repl) +OP *o; OP *expr; OP *repl; { @@ -1935,10 +1992,10 @@ OP *repl; I32 complement; register short *tbl; - tbl = (short*)cPVOP->op_pv; - complement = op->op_private & OPpTRANS_COMPLEMENT; - delete = op->op_private & OPpTRANS_DELETE; - /* squash = op->op_private & OPpTRANS_SQUASH; */ + tbl = (short*)cPVOPo->op_pv; + complement = o->op_private & OPpTRANS_COMPLEMENT; + delete = o->op_private & OPpTRANS_DELETE; + /* squash = o->op_private & OPpTRANS_SQUASH; */ if (complement) { Zero(tbl, 256, short); @@ -1981,7 +2038,7 @@ OP *repl; op_free(expr); op_free(repl); - return op; + return o; } OP * @@ -1989,6 +2046,7 @@ newPMOP(type, flags) I32 type; I32 flags; { + dTHR; PMOP *pmop; Newz(1101, pmop, 1, PMOP); @@ -2010,25 +2068,25 @@ I32 flags; } OP * -pmruntime(op, expr, repl) -OP *op; +pmruntime(o, expr, repl) +OP *o; OP *expr; OP *repl; { PMOP *pm; LOGOP *rcop; - if (op->op_type == OP_TRANS) - return pmtrans(op, expr, repl); + if (o->op_type == OP_TRANS) + return pmtrans(o, expr, repl); hints |= HINT_BLOCK_SCOPE; - pm = (PMOP*)op; + pm = (PMOP*)o; if (expr->op_type == OP_CONST) { STRLEN plen; SV *pat = ((SVOP*)expr)->op_sv; char *p = SvPV(pat, plen); - if ((op->op_flags & OPf_SPECIAL) && strEQ(p, " ")) { + if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) { sv_setpvn(pat, "\\s+", 3); p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; @@ -2049,7 +2107,7 @@ OP *repl; rcop->op_first = scalar(expr); rcop->op_flags |= OPf_KIDS; rcop->op_private = 1; - rcop->op_other = op; + rcop->op_other = o; /* establish postfix order */ if (pm->op_pmflags & PMf_KEEP) { @@ -2062,7 +2120,7 @@ OP *repl; expr->op_next = (OP*)rcop; } - prepend_elem(op->op_type, scalar((OP*)rcop), op); + prepend_elem(o->op_type, scalar((OP*)rcop), o); } if (repl) { @@ -2104,7 +2162,7 @@ OP *repl; if (curop == repl) { pm->op_pmflags |= PMf_CONST; /* const for long enough */ pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ - prepend_elem(op->op_type, scalar(repl), op); + prepend_elem(o->op_type, scalar(repl), o); } else { Newz(1101, rcop, 1, LOGOP); @@ -2113,7 +2171,7 @@ OP *repl; rcop->op_first = scalar(repl); rcop->op_flags |= OPf_KIDS; rcop->op_private = 1; - rcop->op_other = op; + rcop->op_other = o; /* establish postfix order */ rcop->op_next = LINKLIST(repl); @@ -2154,6 +2212,7 @@ I32 type; I32 flags; GV *gv; { + dTHR; GVOP *gvop; Newz(1101, gvop, 1, GVOP); gvop->op_type = type; @@ -2189,21 +2248,22 @@ char *pv; } void -package(op) -OP *op; +package(o) +OP *o; { + dTHR; SV *sv; save_hptr(&curstash); save_item(curstname); - if (op) { + if (o) { STRLEN len; char *name; - sv = cSVOP->op_sv; + sv = cSVOPo->op_sv; name = SvPV(sv, len); curstash = gv_stashpvn(name,len,TRUE); sv_setpvn(curstname, name, len); - op_free(op); + op_free(o); } else { sv_setpv(curstname,"<none>"); @@ -2306,18 +2366,18 @@ OP *listval; } static I32 -list_assignment(op) -register OP *op; +list_assignment(o) +register OP *o; { - if (!op) + if (!o) return TRUE; - if (op->op_type == OP_NULL && op->op_flags & OPf_KIDS) - op = cUNOP->op_first; + if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS) + o = cUNOPo->op_first; - if (op->op_type == OP_COND_EXPR) { - I32 t = list_assignment(cCONDOP->op_first->op_sibling); - I32 f = list_assignment(cCONDOP->op_first->op_sibling->op_sibling); + if (o->op_type == OP_COND_EXPR) { + I32 t = list_assignment(cCONDOPo->op_first->op_sibling); + I32 f = list_assignment(cCONDOPo->op_first->op_sibling->op_sibling); if (t && f) return TRUE; @@ -2326,15 +2386,15 @@ register OP *op; return FALSE; } - if (op->op_type == OP_LIST || op->op_flags & OPf_PARENS || - op->op_type == OP_RV2AV || op->op_type == OP_RV2HV || - op->op_type == OP_ASLICE || op->op_type == OP_HSLICE) + if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS || + o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || + o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) return TRUE; - if (op->op_type == OP_PADAV || op->op_type == OP_PADHV) + if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) return TRUE; - if (op->op_type == OP_RV2SV) + if (o->op_type == OP_RV2SV) return FALSE; return FALSE; @@ -2347,7 +2407,7 @@ OP *left; I32 optype; OP *right; { - OP *op; + OP *o; if (optype) { if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) { @@ -2372,16 +2432,16 @@ OP *right; op_free(right); return Nullop; } - op = newBINOP(OP_AASSIGN, flags, + o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), list(force_list(left)) ); - op->op_private = 0 | (flags >> 8); + o->op_private = 0 | (flags >> 8); if (!(left->op_private & OPpLVAL_INTRO)) { static int generation = 100; OP *curop; - OP *lastop = op; + OP *lastop = o; generation++; - for (curop = LINKLIST(op); curop != op; curop = LINKLIST(curop)) { + for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { if (opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { GV *gv = ((GVOP*)curop)->op_gv; @@ -2413,8 +2473,8 @@ OP *right; } lastop = curop; } - if (curop != op) - op->op_private = OPpASSIGN_COMMON; + if (curop != o) + o->op_private = OPpASSIGN_COMMON; } if (right && right->op_type == OP_SPLIT) { OP* tmpop; @@ -2424,17 +2484,17 @@ OP *right; PMOP *pm = (PMOP*)tmpop; if (left->op_type == OP_RV2AV && !(left->op_private & OPpLVAL_INTRO) && - !(op->op_private & OPpASSIGN_COMMON) ) + !(o->op_private & OPpASSIGN_COMMON) ) { tmpop = ((UNOP*)left)->op_first; if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { pm->op_pmreplroot = (OP*)((GVOP*)tmpop)->op_gv; pm->op_pmflags |= PMf_ONCE; - tmpop = ((UNOP*)op)->op_first; /* to list (nulled) */ + tmpop = cUNOPo->op_first; /* to list (nulled) */ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ tmpop->op_sibling = Nullop; /* don't free split */ right->op_next = tmpop->op_next; /* fix starting loc */ - op_free(op); /* blow off assign */ + op_free(o); /* blow off assign */ right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ return right; @@ -2451,7 +2511,7 @@ OP *right; } } } - return op; + return o; } if (!right) right = newOP(OP_UNDEF, 0); @@ -2461,24 +2521,25 @@ OP *right; } else { eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ - op = newBINOP(OP_SASSIGN, flags, + o = newBINOP(OP_SASSIGN, flags, scalar(right), mod(scalar(left), OP_SASSIGN) ); if (eval_start) eval_start = 0; else { - op_free(op); + op_free(o); return Nullop; } } - return op; + return o; } OP * -newSTATEOP(flags, label, op) +newSTATEOP(flags, label, o) I32 flags; char *label; -OP *op; +OP *o; { + dTHR; U32 seq = intro_my(); register COP *cop; @@ -2523,7 +2584,7 @@ OP *op; } } - return prepend_elem(OP_LINESEQ, (OP*)cop, op); + return prepend_elem(OP_LINESEQ, (OP*)cop, o); } /* "Introduce" my variables to visible status. */ @@ -2556,8 +2617,9 @@ I32 flags; OP* first; OP* other; { + dTHR; LOGOP *logop; - OP *op; + OP *o; if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); @@ -2570,12 +2632,12 @@ OP* other; type = OP_OR; else type = OP_AND; - op = first; - first = cUNOP->op_first; - if (op->op_next) - first->op_next = op->op_next; - cUNOP->op_first = Nullop; - op_free(op); + o = first; + first = cUNOPo->op_first; + if (o->op_next) + first->op_next = o->op_next; + cUNOPo->op_first = Nullop; + op_free(o); } } if (first->op_type == OP_CONST) { @@ -2647,10 +2709,10 @@ OP* other; first->op_next = (OP*)logop; first->op_sibling = other; - op = newUNOP(OP_NULL, 0, (OP*)logop); - other->op_next = op; + o = newUNOP(OP_NULL, 0, (OP*)logop); + other->op_next = o; - return op; + return o; } OP * @@ -2660,8 +2722,9 @@ OP* first; OP* trueop; OP* falseop; { + dTHR; CONDOP *condop; - OP *op; + OP *o; if (!falseop) return newLOGOP(OP_AND, 0, first, trueop); @@ -2701,12 +2764,12 @@ OP* falseop; first->op_sibling = trueop; trueop->op_sibling = falseop; - op = newUNOP(OP_NULL, 0, (OP*)condop); + o = newUNOP(OP_NULL, 0, (OP*)condop); - trueop->op_next = op; - falseop->op_next = op; + trueop->op_next = o; + falseop->op_next = o; - return op; + return o; } OP * @@ -2715,10 +2778,11 @@ I32 flags; OP *left; OP *right; { + dTHR; CONDOP *condop; OP *flip; OP *flop; - OP *op; + OP *o; Newz(1101, condop, 1, CONDOP); @@ -2735,7 +2799,7 @@ OP *right; condop->op_next = (OP*)condop; flip = newUNOP(OP_FLIP, flags, (OP*)condop); flop = newUNOP(OP_FLOP, 0, flip); - op = newUNOP(OP_NULL, 0, flop); + o = newUNOP(OP_NULL, 0, flop); linklist(flop); left->op_next = flip; @@ -2749,11 +2813,11 @@ OP *right; flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; - flip->op_next = op; + flip->op_next = o; if (!flip->op_private || !flop->op_private) - linklist(op); /* blow off optimizer unless constant */ + linklist(o); /* blow off optimizer unless constant */ - return op; + return o; } OP * @@ -2763,8 +2827,9 @@ I32 debuggable; OP *expr; OP *block; { + dTHR; OP* listop; - OP* op; + OP* o; int once = block && block->op_flags & OPf_SPECIAL && (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); @@ -2778,20 +2843,20 @@ OP *block; } listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); - op = newLOGOP(OP_AND, 0, expr, listop); + o = newLOGOP(OP_AND, 0, expr, listop); - ((LISTOP*)listop)->op_last->op_next = LINKLIST(op); + ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); - if (once && op != listop) - op->op_next = ((LOGOP*)cUNOP->op_first)->op_other; + if (once && o != listop) + o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; - if (op == listop) - op = newUNOP(OP_NULL, 0, op); /* or do {} while 1 loses outer block */ + if (o == listop) + o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ - op->op_flags |= flags; - op = scope(op); - op->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ - return op; + o->op_flags |= flags; + o = scope(o); + o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ + return o; } OP * @@ -2803,10 +2868,11 @@ OP *expr; OP *block; OP *cont; { + dTHR; OP *redo; OP *next = 0; OP *listop; - OP *op; + OP *o; OP *condop; if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) { @@ -2826,19 +2892,19 @@ OP *cont; redo = LINKLIST(listop); if (expr) { - op = newLOGOP(OP_AND, 0, expr, scalar(listop)); - if (op == expr && op->op_type == OP_CONST && !SvTRUE(cSVOP->op_sv)) { + o = newLOGOP(OP_AND, 0, expr, scalar(listop)); + if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { op_free(expr); /* oops, it's a while (0) */ op_free((OP*)loop); return Nullop; /* (listop already freed by newLOGOP) */ } ((LISTOP*)listop)->op_last->op_next = condop = - (op == listop ? redo : LINKLIST(op)); + (o == listop ? redo : LINKLIST(o)); if (!next) next = condop; } else - op = listop; + o = listop; if (!loop) { Newz(1101,loop,1,LOOP); @@ -2848,19 +2914,19 @@ OP *cont; loop->op_next = (OP*)loop; } - op = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, op); + o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); loop->op_redoop = redo; - loop->op_lastop = op; + loop->op_lastop = o; if (next) loop->op_nextop = next; else - loop->op_nextop = op; + loop->op_nextop = o; - op->op_flags |= flags; - op->op_private |= (flags >> 8); - return op; + o->op_flags |= flags; + o->op_private |= (flags >> 8); + return o; } OP * @@ -2917,9 +2983,10 @@ newLOOPEX(type, label) I32 type; OP* label; { - OP *op; + dTHR; + OP *o; if (type != OP_GOTO || label->op_type == OP_CONST) { - op = newPVOP(type, 0, savepv( + o = newPVOP(type, 0, savepv( label->op_type == OP_CONST ? SvPVx(((SVOP*)label)->op_sv, na) : "" )); @@ -2928,19 +2995,33 @@ OP* label; else { if (label->op_type == OP_ENTERSUB) label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); - op = newUNOP(type, OPf_STACKED, label); + o = newUNOP(type, OPf_STACKED, label); } hints |= HINT_BLOCK_SCOPE; - return op; + return o; } void cv_undef(cv) CV *cv; { + dTHR; +#ifdef USE_THREADS + if (CvMUTEXP(cv)) { + MUTEX_DESTROY(CvMUTEXP(cv)); + Safefree(CvMUTEXP(cv)); + CvMUTEXP(cv) = 0; + } +#endif /* USE_THREADS */ + if (!CvXSUB(cv) && CvROOT(cv)) { +#ifdef USE_THREADS + if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr)) + croak("Can't undef active subroutine"); +#else if (CvDEPTH(cv)) croak("Can't undef active subroutine"); +#endif /* USE_THREADS */ ENTER; SAVESPTR(curpad); @@ -3031,6 +3112,7 @@ cv_clone2(proto, outside) CV* proto; CV* outside; { + dTHR; AV* av; I32 ix; AV* protopadlist = CvPADLIST(proto); @@ -3057,6 +3139,11 @@ CV* outside; if (CvANON(proto)) CvANON_on(cv); +#ifdef USE_THREADS + New(666, CvMUTEXP(cv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(cv)); + CvOWNER(cv) = 0; +#endif /* USE_THREADS */ CvFILEGV(cv) = CvFILEGV(proto); CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto)); CvSTASH(cv) = CvSTASH(proto); @@ -3208,10 +3295,10 @@ CV* cv; if (sv) return Nullsv; if (type == OP_CONST) - sv = ((SVOP*)o)->op_sv; + sv = cSVOPo->op_sv; else if (type == OP_PADSV) { - AV* pad = (AV*)(AvARRAY(CvPADLIST(cv))[1]); - sv = pad ? AvARRAY(pad)[o->op_targ] : Nullsv; + AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]); + sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv; if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1)) return Nullsv; } @@ -3224,20 +3311,21 @@ CV* cv; } CV * -newSUB(floor,op,proto,block) +newSUB(floor,o,proto,block) I32 floor; -OP *op; +OP *o; OP *proto; OP *block; { - char *name = op ? SvPVx(cSVOP->op_sv, na) : Nullch; + dTHR; + char *name = o ? SvPVx(cSVOPo->op_sv, na) : Nullch; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch; register CV *cv; I32 ix; - if (op) - SAVEFREEOP(op); + if (o) + SAVEFREEOP(o); if (proto) SAVEFREEOP(proto); @@ -3290,6 +3378,11 @@ OP *block; CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; CvSTASH(cv) = curstash; +#ifdef USE_THREADS + CvOWNER(cv) = 0; + New(666, CvMUTEXP(cv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(cv)); +#endif /* USE_THREADS */ if (ps) sv_setpv((SV*)cv, ps); @@ -3422,6 +3515,11 @@ OP *block; av_store(endav, 0, (SV *)cv); GvCV(gv) = 0; } + else if (strEQ(s, "INIT") && !error_count) { + if (!initav) + initav = newAV(); + av_push(initav, SvREFCNT_inc(cv)); + } } done: @@ -3451,6 +3549,7 @@ char *name; void (*subaddr) _((CV*)); char *filename; { + dTHR; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; @@ -3485,6 +3584,11 @@ char *filename; } } CvGV(cv) = (GV*)SvREFCNT_inc(gv); +#ifdef USE_THREADS + New(666, CvMUTEXP(cv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(cv)); + CvOWNER(cv) = 0; +#endif /* USE_THREADS */ CvFILEGV(cv) = gv_fetchfile(filename); CvXSUB(cv) = subaddr; @@ -3507,6 +3611,11 @@ char *filename; av_store(endav, 0, (SV *)cv); GvCV(gv) = 0; } + else if (strEQ(s, "INIT")) { + if (!initav) + initav = newAV(); + av_push(initav, (SV *)cv); + } } else CvANON_on(cv); @@ -3515,18 +3624,19 @@ char *filename; } void -newFORM(floor,op,block) +newFORM(floor,o,block) I32 floor; -OP *op; +OP *o; OP *block; { + dTHR; register CV *cv; char *name; GV *gv; I32 ix; - if (op) - name = SvPVx(cSVOP->op_sv, na); + if (o) + name = SvPVx(cSVOPo->op_sv, na); else name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); @@ -3555,25 +3665,25 @@ OP *block; CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); - op_free(op); + op_free(o); copline = NOLINE; LEAVE_SCOPE(floor); } OP * -newANONLIST(op) -OP* op; +newANONLIST(o) +OP* o; { return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONLIST, 0, op)), OP_REFGEN)); + mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN)); } OP * -newANONHASH(op) -OP* op; +newANONHASH(o) +OP* o; { return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONHASH, 0, op)), OP_REFGEN)); + mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN)); } OP * @@ -3700,8 +3810,8 @@ OP *o; /* Check routines. */ OP * -ck_anoncode(op) -OP *op; +ck_anoncode(o) +OP *o; { PADOFFSET ix; SV* name; @@ -3711,42 +3821,42 @@ OP *op; sv_setpvn(name, "&", 1); SvIVX(name) = -1; SvNVX(name) = 1; - ix = pad_alloc(op->op_type, SVs_PADMY); + ix = pad_alloc(o->op_type, SVs_PADMY); av_store(comppad_name, ix, name); - av_store(comppad, ix, cSVOP->op_sv); - SvPADMY_on(cSVOP->op_sv); - cSVOP->op_sv = Nullsv; - cSVOP->op_targ = ix; - return op; + av_store(comppad, ix, cSVOPo->op_sv); + SvPADMY_on(cSVOPo->op_sv); + cSVOPo->op_sv = Nullsv; + cSVOPo->op_targ = ix; + return o; } OP * -ck_bitop(op) -OP *op; +ck_bitop(o) +OP *o; { - op->op_private = hints; - return op; + o->op_private = hints; + return o; } OP * -ck_concat(op) -OP *op; +ck_concat(o) +OP *o; { - if (cUNOP->op_first->op_type == OP_CONCAT) - op->op_flags |= OPf_STACKED; - return op; + if (cUNOPo->op_first->op_type == OP_CONCAT) + o->op_flags |= OPf_STACKED; + return o; } OP * -ck_spair(op) -OP *op; +ck_spair(o) +OP *o; { - if (op->op_flags & OPf_KIDS) { + if (o->op_flags & OPf_KIDS) { OP* newop; OP* kid; - OPCODE type = op->op_type; - op = modkids(ck_fun(op), type); - kid = cUNOP->op_first; + OPCODE type = o->op_type; + o = modkids(ck_fun(o), type); + kid = cUNOPo->op_first; newop = kUNOP->op_first->op_sibling; if (newop && (newop->op_sibling || @@ -3754,68 +3864,68 @@ OP *op; newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { - return op; + return o; } op_free(kUNOP->op_first); kUNOP->op_first = newop; } - op->op_ppaddr = ppaddr[++op->op_type]; - return ck_fun(op); + o->op_ppaddr = ppaddr[++o->op_type]; + return ck_fun(o); } OP * -ck_delete(op) -OP *op; +ck_delete(o) +OP *o; { - op = ck_fun(op); - op->op_private = 0; - if (op->op_flags & OPf_KIDS) { - OP *kid = cUNOP->op_first; + o = ck_fun(o); + o->op_private = 0; + if (o->op_flags & OPf_KIDS) { + OP *kid = cUNOPo->op_first; if (kid->op_type == OP_HSLICE) - op->op_private |= OPpSLICE; + o->op_private |= OPpSLICE; else if (kid->op_type != OP_HELEM) croak("%s argument is not a HASH element or slice", - op_desc[op->op_type]); + op_desc[o->op_type]); null(kid); } - return op; + return o; } OP * -ck_eof(op) -OP *op; +ck_eof(o) +OP *o; { - I32 type = op->op_type; + I32 type = o->op_type; - if (op->op_flags & OPf_KIDS) { - if (cLISTOP->op_first->op_type == OP_STUB) { - op_free(op); - op = newUNOP(type, OPf_SPECIAL, + if (o->op_flags & OPf_KIDS) { + if (cLISTOPo->op_first->op_type == OP_STUB) { + op_free(o); + o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, gv_fetchpv("main'ARGV", TRUE, SVt_PVAV))); } - return ck_fun(op); + return ck_fun(o); } - return op; + return o; } OP * -ck_eval(op) -OP *op; +ck_eval(o) +OP *o; { hints |= HINT_BLOCK_SCOPE; - if (op->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOP->op_first; + if (o->op_flags & OPf_KIDS) { + SVOP *kid = (SVOP*)cUNOPo->op_first; if (!kid) { - op->op_flags &= ~OPf_KIDS; - null(op); + o->op_flags &= ~OPf_KIDS; + null(o); } else if (kid->op_type == OP_LINESEQ) { LOGOP *enter; - kid->op_next = op->op_next; - cUNOP->op_first = 0; - op_free(op); + kid->op_next = o->op_next; + cUNOPo->op_first = 0; + op_free(o); Newz(1101, enter, 1, LOGOP); enter->op_type = OP_ENTERTRY; @@ -3825,49 +3935,49 @@ OP *op; /* establish postfix order */ enter->op_next = (OP*)enter; - op = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); - op->op_type = OP_LEAVETRY; - op->op_ppaddr = ppaddr[OP_LEAVETRY]; - enter->op_other = op; - return op; + o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); + o->op_type = OP_LEAVETRY; + o->op_ppaddr = ppaddr[OP_LEAVETRY]; + enter->op_other = o; + return o; } } else { - op_free(op); - op = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); + op_free(o); + o = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); } - op->op_targ = (PADOFFSET)hints; - return op; + o->op_targ = (PADOFFSET)hints; + return o; } OP * -ck_exec(op) -OP *op; +ck_exec(o) +OP *o; { OP *kid; - if (op->op_flags & OPf_STACKED) { - op = ck_fun(op); - kid = cUNOP->op_first->op_sibling; + if (o->op_flags & OPf_STACKED) { + o = ck_fun(o); + kid = cUNOPo->op_first->op_sibling; if (kid->op_type == OP_RV2GV) null(kid); } else - op = listkids(op); - return op; + o = listkids(o); + return o; } OP * -ck_exists(op) -OP *op; +ck_exists(o) +OP *o; { - op = ck_fun(op); - if (op->op_flags & OPf_KIDS) { - OP *kid = cUNOP->op_first; + o = ck_fun(o); + if (o->op_flags & OPf_KIDS) { + OP *kid = cUNOPo->op_first; if (kid->op_type != OP_HELEM) - croak("%s argument is not a HASH element", op_desc[op->op_type]); + croak("%s argument is not a HASH element", op_desc[o->op_type]); null(kid); } - return op; + return o; } OP * @@ -3881,12 +3991,13 @@ register OP *o; } OP * -ck_rvconst(op) -register OP *op; +ck_rvconst(o) +register OP *o; { - SVOP *kid = (SVOP*)cUNOP->op_first; + dTHR; + SVOP *kid = (SVOP*)cUNOPo->op_first; - op->op_private |= (hints & HINT_STRICT_REFS); + o->op_private |= (hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { char *name; int iscv; @@ -3895,7 +4006,7 @@ register OP *op; name = SvPV(kid->op_sv, na); if ((hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { char *badthing = Nullch; - switch (op->op_type) { + switch (o->op_type) { case OP_RV2SV: badthing = "a SCALAR"; break; @@ -3912,7 +4023,7 @@ register OP *op; name, badthing); } kid->op_type = OP_GV; - iscv = (op->op_type == OP_RV2CV) * 2; + iscv = (o->op_type == OP_RV2CV) * 2; for (gv = 0; !gv; iscv++) { /* * This is a little tricky. We only want to add the symbol if we @@ -3926,71 +4037,73 @@ register OP *op; iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV - : op->op_type == OP_RV2SV + : o->op_type == OP_RV2SV ? SVt_PV - : op->op_type == OP_RV2AV + : o->op_type == OP_RV2AV ? SVt_PVAV - : op->op_type == OP_RV2HV + : o->op_type == OP_RV2HV ? SVt_PVHV : SVt_PVGV); } SvREFCNT_dec(kid->op_sv); kid->op_sv = SvREFCNT_inc(gv); } - return op; + return o; } OP * -ck_ftst(op) -OP *op; +ck_ftst(o) +OP *o; { - I32 type = op->op_type; + dTHR; + I32 type = o->op_type; - if (op->op_flags & OPf_REF) - return op; + if (o->op_flags & OPf_REF) + return o; - if (op->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOP->op_first; + if (o->op_flags & OPf_KIDS) { + SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP *newop = newGVOP(type, OPf_REF, gv_fetchpv(SvPVx(kid->op_sv, na), TRUE, SVt_PVIO)); - op_free(op); + op_free(o); return newop; } } else { - op_free(op); + op_free(o); if (type == OP_FTTTY) return newGVOP(type, OPf_REF, gv_fetchpv("main'STDIN", TRUE, SVt_PVIO)); else return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); } - return op; + return o; } OP * -ck_fun(op) -OP *op; +ck_fun(o) +OP *o; { + dTHR; register OP *kid; OP **tokid; OP *sibl; I32 numargs = 0; - int type = op->op_type; + int type = o->op_type; register I32 oa = opargs[type] >> OASHIFT; - if (op->op_flags & OPf_STACKED) { + if (o->op_flags & OPf_STACKED) { if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) oa &= ~OA_OPTIONAL; else - return no_fh_allowed(op); + return no_fh_allowed(o); } - if (op->op_flags & OPf_KIDS) { - tokid = &cLISTOP->op_first; - kid = cLISTOP->op_first; + if (o->op_flags & OPf_KIDS) { + tokid = &cLISTOPo->op_first; + kid = cLISTOPo->op_first; if (kid->op_type == OP_PUSHMARK || kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK) { @@ -4030,7 +4143,7 @@ OP *op; *tokid = kid; } else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) - bad_type(numargs, "array", op_desc[op->op_type], kid); + bad_type(numargs, "array", op_desc[o->op_type], kid); mod(kid, type); break; case OA_HVREF: @@ -4048,7 +4161,7 @@ OP *op; *tokid = kid; } else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) - bad_type(numargs, "hash", op_desc[op->op_type], kid); + bad_type(numargs, "hash", op_desc[o->op_type], kid); mod(kid, type); break; case OA_CVREF: @@ -4089,13 +4202,13 @@ OP *op; tokid = &kid->op_sibling; kid = kid->op_sibling; } - op->op_private |= numargs; + o->op_private |= numargs; if (kid) - return too_many_arguments(op,op_desc[op->op_type]); - listkids(op); + return too_many_arguments(o,op_desc[o->op_type]); + listkids(o); } else if (opargs[type] & OA_DEFGV) { - op_free(op); + op_free(o); return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); } @@ -4103,87 +4216,87 @@ OP *op; while (oa & OA_OPTIONAL) oa >>= 4; if (oa && oa != OA_LIST) - return too_few_arguments(op,op_desc[op->op_type]); + return too_few_arguments(o,op_desc[o->op_type]); } - return op; + return o; } OP * -ck_glob(op) -OP *op; +ck_glob(o) +OP *o; { GV *gv = gv_fetchpv("glob", FALSE, SVt_PVCV); if (gv && GvIMPORTED_CV(gv)) { static int glob_index; - append_elem(OP_GLOB, op, + append_elem(OP_GLOB, o, newSVOP(OP_CONST, 0, newSViv(glob_index++))); - op->op_type = OP_LIST; - op->op_ppaddr = ppaddr[OP_LIST]; - ((LISTOP*)op)->op_first->op_type = OP_PUSHMARK; - ((LISTOP*)op)->op_first->op_ppaddr = ppaddr[OP_PUSHMARK]; - op = newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, op, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, gv))))); - return ck_subr(op); - } - if ((op->op_flags & OPf_KIDS) && !cLISTOP->op_first->op_sibling) - append_elem(OP_GLOB, op, newSVREF(newGVOP(OP_GV, 0, defgv))); + o->op_type = OP_LIST; + o->op_ppaddr = ppaddr[OP_LIST]; + cLISTOPo->op_first->op_type = OP_PUSHMARK; + cLISTOPo->op_first->op_ppaddr = ppaddr[OP_PUSHMARK]; + o = newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, o, + scalar(newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv))))); + return ck_subr(o); + } + if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) + append_elem(OP_GLOB, o, newSVREF(newGVOP(OP_GV, 0, defgv))); gv = newGVgen("main"); gv_IOadd(gv); - append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv)); - scalarkids(op); - return ck_fun(op); + append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); + scalarkids(o); + return ck_fun(o); } OP * -ck_grep(op) -OP *op; +ck_grep(o) +OP *o; { LOGOP *gwop; OP *kid; - OPCODE type = op->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; + OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; - op->op_ppaddr = ppaddr[OP_GREPSTART]; + o->op_ppaddr = ppaddr[OP_GREPSTART]; Newz(1101, gwop, 1, LOGOP); - if (op->op_flags & OPf_STACKED) { + if (o->op_flags & OPf_STACKED) { OP* k; - op = ck_sort(op); - kid = cLISTOP->op_first->op_sibling; - for (k = cLISTOP->op_first->op_sibling->op_next; k; k = k->op_next) { + o = ck_sort(o); + kid = cLISTOPo->op_first->op_sibling; + for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) { kid = k; } kid->op_next = (OP*)gwop; - op->op_flags &= ~OPf_STACKED; + o->op_flags &= ~OPf_STACKED; } - kid = cLISTOP->op_first->op_sibling; + kid = cLISTOPo->op_first->op_sibling; if (type == OP_MAPWHILE) list(kid); else scalar(kid); - op = ck_fun(op); + o = ck_fun(o); if (error_count) - return op; - kid = cLISTOP->op_first->op_sibling; + return o; + kid = cLISTOPo->op_first->op_sibling; if (kid->op_type != OP_NULL) croak("panic: ck_grep"); kid = kUNOP->op_first; gwop->op_type = type; gwop->op_ppaddr = ppaddr[type]; - gwop->op_first = listkids(op); + gwop->op_first = listkids(o); gwop->op_flags |= OPf_KIDS; gwop->op_private = 1; gwop->op_other = LINKLIST(kid); gwop->op_targ = pad_alloc(type, SVs_PADTMP); kid->op_next = (OP*)gwop; - kid = cLISTOP->op_first->op_sibling; + kid = cLISTOPo->op_first->op_sibling; if (!kid || !kid->op_sibling) - return too_few_arguments(op,op_desc[op->op_type]); + return too_few_arguments(o,op_desc[o->op_type]); for (kid = kid->op_sibling; kid; kid = kid->op_sibling) mod(kid, OP_GREPSTART); @@ -4191,142 +4304,142 @@ OP *op; } OP * -ck_index(op) -OP *op; +ck_index(o) +OP *o; { - if (op->op_flags & OPf_KIDS) { - OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_KIDS) { + OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_type == OP_CONST) fbm_compile(((SVOP*)kid)->op_sv); } - return ck_fun(op); + return ck_fun(o); } OP * -ck_lengthconst(op) -OP *op; +ck_lengthconst(o) +OP *o; { /* XXX length optimization goes here */ - return ck_fun(op); + return ck_fun(o); } OP * -ck_lfun(op) -OP *op; +ck_lfun(o) +OP *o; { - OPCODE type = op->op_type; - return modkids(ck_fun(op), type); + OPCODE type = o->op_type; + return modkids(ck_fun(o), type); } OP * -ck_rfun(op) -OP *op; +ck_rfun(o) +OP *o; { - OPCODE type = op->op_type; - return refkids(ck_fun(op), type); + OPCODE type = o->op_type; + return refkids(ck_fun(o), type); } OP * -ck_listiob(op) -OP *op; +ck_listiob(o) +OP *o; { register OP *kid; - kid = cLISTOP->op_first; + kid = cLISTOPo->op_first; if (!kid) { - op = force_list(op); - kid = cLISTOP->op_first; + o = force_list(o); + kid = cLISTOPo->op_first; } if (kid->op_type == OP_PUSHMARK) kid = kid->op_sibling; - if (kid && op->op_flags & OPf_STACKED) + if (kid && o->op_flags & OPf_STACKED) kid = kid->op_sibling; else if (kid && !kid->op_sibling) { /* print HANDLE; */ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) { - op->op_flags |= OPf_STACKED; /* make it a filehandle */ + o->op_flags |= OPf_STACKED; /* make it a filehandle */ kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); - cLISTOP->op_first->op_sibling = kid; - cLISTOP->op_last = kid; + cLISTOPo->op_first->op_sibling = kid; + cLISTOPo->op_last = kid; kid = kid->op_sibling; } } if (!kid) - append_elem(op->op_type, op, newSVREF(newGVOP(OP_GV, 0, defgv)) ); + append_elem(o->op_type, o, newSVREF(newGVOP(OP_GV, 0, defgv)) ); - op = listkids(op); + o = listkids(o); - op->op_private = 0; + o->op_private = 0; #ifdef USE_LOCALE if (hints & HINT_LOCALE) - op->op_private |= OPpLOCALE; + o->op_private |= OPpLOCALE; #endif - return op; + return o; } OP * -ck_fun_locale(op) -OP *op; +ck_fun_locale(o) +OP *o; { - op = ck_fun(op); + o = ck_fun(o); - op->op_private = 0; + o->op_private = 0; #ifdef USE_LOCALE if (hints & HINT_LOCALE) - op->op_private |= OPpLOCALE; + o->op_private |= OPpLOCALE; #endif - return op; + return o; } OP * -ck_scmp(op) -OP *op; +ck_scmp(o) +OP *o; { - op->op_private = 0; + o->op_private = 0; #ifdef USE_LOCALE if (hints & HINT_LOCALE) - op->op_private |= OPpLOCALE; + o->op_private |= OPpLOCALE; #endif - return op; + return o; } OP * -ck_match(op) -OP *op; +ck_match(o) +OP *o; { - op->op_private |= OPpRUNTIME; - return op; + o->op_private |= OPpRUNTIME; + return o; } OP * -ck_null(op) -OP *op; +ck_null(o) +OP *o; { - return op; + return o; } OP * -ck_repeat(op) -OP *op; +ck_repeat(o) +OP *o; { - if (cBINOP->op_first->op_flags & OPf_PARENS) { - op->op_private |= OPpREPEAT_DOLIST; - cBINOP->op_first = force_list(cBINOP->op_first); + if (cBINOPo->op_first->op_flags & OPf_PARENS) { + o->op_private |= OPpREPEAT_DOLIST; + cBINOPo->op_first = force_list(cBINOPo->op_first); } else - scalar(op); - return op; + scalar(o); + return o; } OP * -ck_require(op) -OP *op; +ck_require(o) +OP *o; { - if (op->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ - SVOP *kid = (SVOP*)cUNOP->op_first; + if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ + SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { char *s; @@ -4340,68 +4453,81 @@ OP *op; sv_catpvn(kid->op_sv, ".pm", 3); } } - return ck_fun(op); + return ck_fun(o); } OP * -ck_retarget(op) -OP *op; +ck_retarget(o) +OP *o; { croak("NOT IMPL LINE %d",__LINE__); /* STUB */ - return op; + return o; } OP * -ck_select(op) -OP *op; +ck_select(o) +OP *o; { OP* kid; - if (op->op_flags & OPf_KIDS) { - kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_KIDS) { + kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_sibling) { - op->op_type = OP_SSELECT; - op->op_ppaddr = ppaddr[OP_SSELECT]; - op = ck_fun(op); - return fold_constants(op); + o->op_type = OP_SSELECT; + o->op_ppaddr = ppaddr[OP_SSELECT]; + o = ck_fun(o); + return fold_constants(o); } } - op = ck_fun(op); - kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + o = ck_fun(o); + kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (kid && kid->op_type == OP_RV2GV) kid->op_private &= ~HINT_STRICT_REFS; - return op; + return o; } OP * -ck_shift(op) -OP *op; +ck_shift(o) +OP *o; { - I32 type = op->op_type; + I32 type = o->op_type; - if (!(op->op_flags & OPf_KIDS)) { - op_free(op); - return newUNOP(type, 0, - scalar(newUNOP(OP_RV2AV, 0, - scalar(newGVOP(OP_GV, 0, subline - ? defgv - : gv_fetchpv("ARGV", TRUE, SVt_PVAV) ))))); + if (!(o->op_flags & OPf_KIDS)) { + OP *argop; + + op_free(o); +#ifdef USE_THREADS + if (subline) { + argop = newOP(OP_PADAV, OPf_REF); + argop->op_targ = 0; /* curpad[0] is @_ */ + } + else { + argop = newUNOP(OP_RV2AV, 0, + scalar(newGVOP(OP_GV, 0, + gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); + } +#else + argop = newUNOP(OP_RV2AV, 0, + scalar(newGVOP(OP_GV, 0, subline ? + defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); +#endif /* USE_THREADS */ + return newUNOP(type, 0, scalar(argop)); } - return scalar(modkids(ck_fun(op), type)); + return scalar(modkids(ck_fun(o), type)); } OP * -ck_sort(op) -OP *op; +ck_sort(o) +OP *o; { - op->op_private = 0; + o->op_private = 0; #ifdef USE_LOCALE if (hints & HINT_LOCALE) - op->op_private |= OPpLOCALE; + o->op_private |= OPpLOCALE; #endif - if (op->op_flags & OPf_STACKED) { - OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_STACKED) { + OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ OP *k; kid = kUNOP->op_first; /* get past rv2gv */ @@ -4412,7 +4538,7 @@ OP *op; kid->op_next = 0; } else if (kid->op_type == OP_LEAVE) { - if (op->op_type == OP_SORT) { + if (o->op_type == OP_SORT) { null(kid); /* wipe out leave */ kid->op_next = kid; @@ -4427,47 +4553,47 @@ OP *op; } peep(k); - kid = cLISTOP->op_first->op_sibling; /* get past pushmark */ + kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ null(kid); /* wipe out rv2gv */ - if (op->op_type == OP_SORT) + if (o->op_type == OP_SORT) kid->op_next = kid; else kid->op_next = k; - op->op_flags |= OPf_SPECIAL; + o->op_flags |= OPf_SPECIAL; } } - return op; + return o; } OP * -ck_split(op) -OP *op; +ck_split(o) +OP *o; { register OP *kid; PMOP* pm; - if (op->op_flags & OPf_STACKED) - return no_fh_allowed(op); + if (o->op_flags & OPf_STACKED) + return no_fh_allowed(o); - kid = cLISTOP->op_first; + kid = cLISTOPo->op_first; if (kid->op_type != OP_NULL) croak("panic: ck_split"); kid = kid->op_sibling; - op_free(cLISTOP->op_first); - cLISTOP->op_first = kid; + op_free(cLISTOPo->op_first); + cLISTOPo->op_first = kid; if (!kid) { - cLISTOP->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1)); - cLISTOP->op_last = kid; /* There was only one element previously */ + cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1)); + cLISTOPo->op_last = kid; /* There was only one element previously */ } if (kid->op_type != OP_MATCH) { OP *sibl = kid->op_sibling; kid->op_sibling = 0; kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop); - if (cLISTOP->op_first == cLISTOP->op_last) - cLISTOP->op_last = kid; - cLISTOP->op_first = kid; + if (cLISTOPo->op_first == cLISTOPo->op_last) + cLISTOPo->op_last = kid; + cLISTOPo->op_first = kid; kid->op_sibling = sibl; } pm = (PMOP*)kid; @@ -4481,30 +4607,31 @@ OP *op; scalar(kid); if (!kid->op_sibling) - append_elem(OP_SPLIT, op, newSVREF(newGVOP(OP_GV, 0, defgv)) ); + append_elem(OP_SPLIT, o, newSVREF(newGVOP(OP_GV, 0, defgv)) ); kid = kid->op_sibling; scalar(kid); if (!kid->op_sibling) - append_elem(OP_SPLIT, op, newSVOP(OP_CONST, 0, newSViv(0))); + append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); kid = kid->op_sibling; scalar(kid); if (kid->op_sibling) - return too_many_arguments(op,op_desc[op->op_type]); + return too_many_arguments(o,op_desc[o->op_type]); - return op; + return o; } OP * -ck_subr(op) -OP *op; +ck_subr(o) +OP *o; { - OP *prev = ((cUNOP->op_first->op_sibling) - ? cUNOP : ((UNOP*)cUNOP->op_first))->op_first; - OP *o = prev->op_sibling; + dTHR; + OP *prev = ((cUNOPo->op_first->op_sibling) + ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; + OP *o2 = prev->op_sibling; OP *cvop; char *proto = 0; CV *cv = 0; @@ -4512,28 +4639,28 @@ OP *op; int optional = 0; I32 arg = 0; - for (cvop = o; cvop->op_sibling; cvop = cvop->op_sibling) ; + for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; if (cvop->op_type == OP_RV2CV) { SVOP* tmpop; - op->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); + o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); null(cvop); /* disable rv2cv */ tmpop = (SVOP*)((UNOP*)cvop)->op_first; if (tmpop->op_type == OP_GV) { cv = GvCVu(tmpop->op_sv); - if (cv && SvPOK(cv) && !(op->op_private & OPpENTERSUB_AMPER)) { + if (cv && SvPOK(cv) && !(o->op_private & OPpENTERSUB_AMPER)) { namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv); proto = SvPV((SV*)cv, na); } } } - op->op_private |= (hints & HINT_STRICT_REFS); + o->op_private |= (hints & HINT_STRICT_REFS); if (PERLDB_SUB && curstash != debstash) - op->op_private |= OPpENTERSUB_DB; - while (o != cvop) { + o->op_private |= OPpENTERSUB_DB; + while (o2 != cvop) { if (proto) { switch (*proto) { case '\0': - return too_many_arguments(op, gv_ename(namegv)); + return too_many_arguments(o, gv_ename(namegv)); case ';': optional = 1; proto++; @@ -4541,28 +4668,28 @@ OP *op; case '$': proto++; arg++; - scalar(o); + scalar(o2); break; case '%': case '@': - list(o); + list(o2); arg++; break; case '&': proto++; arg++; - if (o->op_type != OP_REFGEN && o->op_type != OP_UNDEF) - bad_type(arg, "block", gv_ename(namegv), o); + if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) + bad_type(arg, "block", gv_ename(namegv), o2); break; case '*': proto++; arg++; - if (o->op_type == OP_RV2GV) + if (o2->op_type == OP_RV2GV) goto wrapref; { - OP* kid = o; - o = newUNOP(OP_RV2GV, 0, kid); - o->op_sibling = kid->op_sibling; + OP* kid = o2; + o2 = newUNOP(OP_RV2GV, 0, kid); + o2->op_sibling = kid->op_sibling; kid->op_sibling = 0; prev->op_sibling = o; } @@ -4572,31 +4699,31 @@ OP *op; arg++; switch (*proto++) { case '*': - if (o->op_type != OP_RV2GV) - bad_type(arg, "symbol", gv_ename(namegv), o); + if (o2->op_type != OP_RV2GV) + bad_type(arg, "symbol", gv_ename(namegv), o2); goto wrapref; case '&': - if (o->op_type != OP_RV2CV) - bad_type(arg, "sub", gv_ename(namegv), o); + if (o2->op_type != OP_RV2CV) + bad_type(arg, "sub", gv_ename(namegv), o2); goto wrapref; case '$': - if (o->op_type != OP_RV2SV && o->op_type != OP_PADSV) - bad_type(arg, "scalar", gv_ename(namegv), o); + if (o2->op_type != OP_RV2SV && o2->op_type != OP_PADSV) + bad_type(arg, "scalar", gv_ename(namegv), o2); goto wrapref; case '@': - if (o->op_type != OP_RV2AV && o->op_type != OP_PADAV) - bad_type(arg, "array", gv_ename(namegv), o); + if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV) + bad_type(arg, "array", gv_ename(namegv), o2); goto wrapref; case '%': - if (o->op_type != OP_RV2HV && o->op_type != OP_PADHV) - bad_type(arg, "hash", gv_ename(namegv), o); + if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV) + bad_type(arg, "hash", gv_ename(namegv), o2); wrapref: { - OP* kid = o; - o = newUNOP(OP_REFGEN, 0, kid); - o->op_sibling = kid->op_sibling; + OP* kid = o2; + o2 = newUNOP(OP_REFGEN, 0, kid); + o2->op_sibling = kid->op_sibling; kid->op_sibling = 0; - prev->op_sibling = o; + prev->op_sibling = o2; } break; default: goto oops; @@ -4612,38 +4739,38 @@ OP *op; } } else - list(o); - mod(o, OP_ENTERSUB); - prev = o; - o = o->op_sibling; + list(o2); + mod(o2, OP_ENTERSUB); + prev = o2; + o2 = o2->op_sibling; } if (proto && !optional && *proto == '$') - return too_few_arguments(op, gv_ename(namegv)); - return op; + return too_few_arguments(o, gv_ename(namegv)); + return o; } OP * -ck_svconst(op) -OP *op; +ck_svconst(o) +OP *o; { - SvREADONLY_on(cSVOP->op_sv); - return op; + SvREADONLY_on(cSVOPo->op_sv); + return o; } OP * -ck_trunc(op) -OP *op; +ck_trunc(o) +OP *o; { - if (op->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOP->op_first; + if (o->op_flags & OPf_KIDS) { + SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_NULL) kid = (SVOP*)kid->op_sibling; if (kid && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) - op->op_flags |= OPf_SPECIAL; + o->op_flags |= OPf_SPECIAL; } - return ck_fun(op); + return ck_fun(o); } /* A peephole optimizer. We visit the ops in the order they're to execute. */ @@ -4652,11 +4779,12 @@ void peep(o) register OP* o; { + dTHR; register OP* oldop = 0; if (!o || o->op_seq) return; ENTER; - SAVESPTR(op); + SAVEOP(); SAVESPTR(curcop); for (; o; o = o->op_next) { if (o->op_seq) @@ -4782,6 +4910,47 @@ register OP* o; } } break; + + case OP_HELEM: { + UNOP *rop; + SV *lexname; + GV **fields; + SV **svp, **indsvp; + I32 ind; + char *key; + STRLEN keylen; + + if (o->op_private & (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO) + || ((BINOP*)o)->op_last->op_type != OP_CONST) + break; + rop = (UNOP*)((BINOP*)o)->op_first; + if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) + break; + lexname = *av_fetch(comppad_name, rop->op_first->op_targ, TRUE); + if (!SvOBJECT(lexname)) + break; + fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); + if (!fields || !GvHV(*fields)) + break; + svp = &((SVOP*)((BINOP*)o)->op_last)->op_sv; + key = SvPV(*svp, keylen); + indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); + if (!indsvp) { + croak("No such field \"%s\" in variable %s of type %s", + key, SvPV(lexname, na), HvNAME(SvSTASH(lexname))); + } + ind = SvIV(*indsvp); + if (ind < 1) + croak("Bad index while coercing array into hash"); + rop->op_type = OP_RV2AV; + rop->op_ppaddr = ppaddr[OP_RV2AV]; + o->op_type = OP_AELEM; + o->op_ppaddr = ppaddr[OP_AELEM]; + SvREFCNT_dec(*svp); + *svp = newSViv(ind); + break; + } + default: o->op_seq = op_seqmax++; break; @@ -24,6 +24,7 @@ */ typedef U32 PADOFFSET; +#define NOT_IN_PAD ((PADOFFSET) -1) #ifdef DEBUGGING_OPS #define OPCODE opcode @@ -233,6 +234,19 @@ struct loop { #define cCOP ((COP*)op) #define cLOOP ((LOOP*)op) +#define cUNOPo ((UNOP*)o) +#define cBINOPo ((BINOP*)o) +#define cLISTOPo ((LISTOP*)o) +#define cLOGOPo ((LOGOP*)o) +#define cCONDOPo ((CONDOP*)o) +#define cPMOPo ((PMOP*)o) +#define cSVOPo ((SVOP*)o) +#define cGVOPo ((GVOP*)o) +#define cPVOPo ((PVOP*)o) +#define cCVOPo ((CVOP*)o) +#define cCOPo ((COP*)o) +#define cLOOPo ((LOOP*)o) + #define kUNOP ((UNOP*)kid) #define kBINOP ((BINOP*)kid) #define kLISTOP ((LISTOP*)kid) @@ -348,10 +348,11 @@ typedef enum { OP_EGRENT, /* 341 */ OP_GETLOGIN, /* 342 */ OP_SYSCALL, /* 343 */ + OP_LOCK, /* 344 */ OP_max } opcode; -#define MAXO 344 +#define MAXO 345 #ifndef DOINIT EXT char *op_name[]; @@ -701,6 +702,7 @@ EXT char *op_name[] = { "egrent", "getlogin", "syscall", + "lock", }; #endif @@ -1052,386 +1054,388 @@ EXT char *op_desc[] = { "endgrent", "getlogin", "syscall", + "lock", }; #endif -OP * ck_anoncode _((OP* op)); -OP * ck_bitop _((OP* op)); -OP * ck_concat _((OP* op)); -OP * ck_delete _((OP* op)); -OP * ck_eof _((OP* op)); -OP * ck_eval _((OP* op)); -OP * ck_exec _((OP* op)); -OP * ck_exists _((OP* op)); -OP * ck_ftst _((OP* op)); -OP * ck_fun _((OP* op)); -OP * ck_fun_locale _((OP* op)); -OP * ck_glob _((OP* op)); -OP * ck_grep _((OP* op)); -OP * ck_index _((OP* op)); -OP * ck_lengthconst _((OP* op)); -OP * ck_lfun _((OP* op)); -OP * ck_listiob _((OP* op)); -OP * ck_match _((OP* op)); -OP * ck_null _((OP* op)); -OP * ck_repeat _((OP* op)); -OP * ck_require _((OP* op)); -OP * ck_rfun _((OP* op)); -OP * ck_rvconst _((OP* op)); -OP * ck_scmp _((OP* op)); -OP * ck_select _((OP* op)); -OP * ck_shift _((OP* op)); -OP * ck_sort _((OP* op)); -OP * ck_spair _((OP* op)); -OP * ck_split _((OP* op)); -OP * ck_subr _((OP* op)); -OP * ck_svconst _((OP* op)); -OP * ck_trunc _((OP* op)); +OP * ck_anoncode _((OP* o)); +OP * ck_bitop _((OP* o)); +OP * ck_concat _((OP* o)); +OP * ck_delete _((OP* o)); +OP * ck_eof _((OP* o)); +OP * ck_eval _((OP* o)); +OP * ck_exec _((OP* o)); +OP * ck_exists _((OP* o)); +OP * ck_ftst _((OP* o)); +OP * ck_fun _((OP* o)); +OP * ck_fun_locale _((OP* o)); +OP * ck_glob _((OP* o)); +OP * ck_grep _((OP* o)); +OP * ck_index _((OP* o)); +OP * ck_lengthconst _((OP* o)); +OP * ck_lfun _((OP* o)); +OP * ck_listiob _((OP* o)); +OP * ck_match _((OP* o)); +OP * ck_null _((OP* o)); +OP * ck_repeat _((OP* o)); +OP * ck_require _((OP* o)); +OP * ck_rfun _((OP* o)); +OP * ck_rvconst _((OP* o)); +OP * ck_scmp _((OP* o)); +OP * ck_select _((OP* o)); +OP * ck_shift _((OP* o)); +OP * ck_sort _((OP* o)); +OP * ck_spair _((OP* o)); +OP * ck_split _((OP* o)); +OP * ck_subr _((OP* o)); +OP * ck_svconst _((OP* o)); +OP * ck_trunc _((OP* o)); -OP * pp_null _((void)); -OP * pp_stub _((void)); -OP * pp_scalar _((void)); -OP * pp_pushmark _((void)); -OP * pp_wantarray _((void)); -OP * pp_const _((void)); -OP * pp_gvsv _((void)); -OP * pp_gv _((void)); -OP * pp_gelem _((void)); -OP * pp_padsv _((void)); -OP * pp_padav _((void)); -OP * pp_padhv _((void)); -OP * pp_padany _((void)); -OP * pp_pushre _((void)); -OP * pp_rv2gv _((void)); -OP * pp_rv2sv _((void)); -OP * pp_av2arylen _((void)); -OP * pp_rv2cv _((void)); -OP * pp_anoncode _((void)); -OP * pp_prototype _((void)); -OP * pp_refgen _((void)); -OP * pp_srefgen _((void)); -OP * pp_ref _((void)); -OP * pp_bless _((void)); -OP * pp_backtick _((void)); -OP * pp_glob _((void)); -OP * pp_readline _((void)); -OP * pp_rcatline _((void)); -OP * pp_regcmaybe _((void)); -OP * pp_regcomp _((void)); -OP * pp_match _((void)); -OP * pp_subst _((void)); -OP * pp_substcont _((void)); -OP * pp_trans _((void)); -OP * pp_sassign _((void)); -OP * pp_aassign _((void)); -OP * pp_chop _((void)); -OP * pp_schop _((void)); -OP * pp_chomp _((void)); -OP * pp_schomp _((void)); -OP * pp_defined _((void)); -OP * pp_undef _((void)); -OP * pp_study _((void)); -OP * pp_pos _((void)); -OP * pp_preinc _((void)); -OP * pp_i_preinc _((void)); -OP * pp_predec _((void)); -OP * pp_i_predec _((void)); -OP * pp_postinc _((void)); -OP * pp_i_postinc _((void)); -OP * pp_postdec _((void)); -OP * pp_i_postdec _((void)); -OP * pp_pow _((void)); -OP * pp_multiply _((void)); -OP * pp_i_multiply _((void)); -OP * pp_divide _((void)); -OP * pp_i_divide _((void)); -OP * pp_modulo _((void)); -OP * pp_i_modulo _((void)); -OP * pp_repeat _((void)); -OP * pp_add _((void)); -OP * pp_i_add _((void)); -OP * pp_subtract _((void)); -OP * pp_i_subtract _((void)); -OP * pp_concat _((void)); -OP * pp_stringify _((void)); -OP * pp_left_shift _((void)); -OP * pp_right_shift _((void)); -OP * pp_lt _((void)); -OP * pp_i_lt _((void)); -OP * pp_gt _((void)); -OP * pp_i_gt _((void)); -OP * pp_le _((void)); -OP * pp_i_le _((void)); -OP * pp_ge _((void)); -OP * pp_i_ge _((void)); -OP * pp_eq _((void)); -OP * pp_i_eq _((void)); -OP * pp_ne _((void)); -OP * pp_i_ne _((void)); -OP * pp_ncmp _((void)); -OP * pp_i_ncmp _((void)); -OP * pp_slt _((void)); -OP * pp_sgt _((void)); -OP * pp_sle _((void)); -OP * pp_sge _((void)); -OP * pp_seq _((void)); -OP * pp_sne _((void)); -OP * pp_scmp _((void)); -OP * pp_bit_and _((void)); -OP * pp_bit_xor _((void)); -OP * pp_bit_or _((void)); -OP * pp_negate _((void)); -OP * pp_i_negate _((void)); -OP * pp_not _((void)); -OP * pp_complement _((void)); -OP * pp_atan2 _((void)); -OP * pp_sin _((void)); -OP * pp_cos _((void)); -OP * pp_rand _((void)); -OP * pp_srand _((void)); -OP * pp_exp _((void)); -OP * pp_log _((void)); -OP * pp_sqrt _((void)); -OP * pp_int _((void)); -OP * pp_hex _((void)); -OP * pp_oct _((void)); -OP * pp_abs _((void)); -OP * pp_length _((void)); -OP * pp_substr _((void)); -OP * pp_vec _((void)); -OP * pp_index _((void)); -OP * pp_rindex _((void)); -OP * pp_sprintf _((void)); -OP * pp_formline _((void)); -OP * pp_ord _((void)); -OP * pp_chr _((void)); -OP * pp_crypt _((void)); -OP * pp_ucfirst _((void)); -OP * pp_lcfirst _((void)); -OP * pp_uc _((void)); -OP * pp_lc _((void)); -OP * pp_quotemeta _((void)); -OP * pp_rv2av _((void)); -OP * pp_aelemfast _((void)); -OP * pp_aelem _((void)); -OP * pp_aslice _((void)); -OP * pp_each _((void)); -OP * pp_values _((void)); -OP * pp_keys _((void)); -OP * pp_delete _((void)); -OP * pp_exists _((void)); -OP * pp_rv2hv _((void)); -OP * pp_helem _((void)); -OP * pp_hslice _((void)); -OP * pp_unpack _((void)); -OP * pp_pack _((void)); -OP * pp_split _((void)); -OP * pp_join _((void)); -OP * pp_list _((void)); -OP * pp_lslice _((void)); -OP * pp_anonlist _((void)); -OP * pp_anonhash _((void)); -OP * pp_splice _((void)); -OP * pp_push _((void)); -OP * pp_pop _((void)); -OP * pp_shift _((void)); -OP * pp_unshift _((void)); -OP * pp_sort _((void)); -OP * pp_reverse _((void)); -OP * pp_grepstart _((void)); -OP * pp_grepwhile _((void)); -OP * pp_mapstart _((void)); -OP * pp_mapwhile _((void)); -OP * pp_range _((void)); -OP * pp_flip _((void)); -OP * pp_flop _((void)); -OP * pp_and _((void)); -OP * pp_or _((void)); -OP * pp_xor _((void)); -OP * pp_cond_expr _((void)); -OP * pp_andassign _((void)); -OP * pp_orassign _((void)); -OP * pp_method _((void)); -OP * pp_entersub _((void)); -OP * pp_leavesub _((void)); -OP * pp_caller _((void)); -OP * pp_warn _((void)); -OP * pp_die _((void)); -OP * pp_reset _((void)); -OP * pp_lineseq _((void)); -OP * pp_nextstate _((void)); -OP * pp_dbstate _((void)); -OP * pp_unstack _((void)); -OP * pp_enter _((void)); -OP * pp_leave _((void)); -OP * pp_scope _((void)); -OP * pp_enteriter _((void)); -OP * pp_iter _((void)); -OP * pp_enterloop _((void)); -OP * pp_leaveloop _((void)); -OP * pp_return _((void)); -OP * pp_last _((void)); -OP * pp_next _((void)); -OP * pp_redo _((void)); -OP * pp_dump _((void)); -OP * pp_goto _((void)); -OP * pp_exit _((void)); -OP * pp_open _((void)); -OP * pp_close _((void)); -OP * pp_pipe_op _((void)); -OP * pp_fileno _((void)); -OP * pp_umask _((void)); -OP * pp_binmode _((void)); -OP * pp_tie _((void)); -OP * pp_untie _((void)); -OP * pp_tied _((void)); -OP * pp_dbmopen _((void)); -OP * pp_dbmclose _((void)); -OP * pp_sselect _((void)); -OP * pp_select _((void)); -OP * pp_getc _((void)); -OP * pp_read _((void)); -OP * pp_enterwrite _((void)); -OP * pp_leavewrite _((void)); -OP * pp_prtf _((void)); -OP * pp_print _((void)); -OP * pp_sysopen _((void)); -OP * pp_sysseek _((void)); -OP * pp_sysread _((void)); -OP * pp_syswrite _((void)); -OP * pp_send _((void)); -OP * pp_recv _((void)); -OP * pp_eof _((void)); -OP * pp_tell _((void)); -OP * pp_seek _((void)); -OP * pp_truncate _((void)); -OP * pp_fcntl _((void)); -OP * pp_ioctl _((void)); -OP * pp_flock _((void)); -OP * pp_socket _((void)); -OP * pp_sockpair _((void)); -OP * pp_bind _((void)); -OP * pp_connect _((void)); -OP * pp_listen _((void)); -OP * pp_accept _((void)); -OP * pp_shutdown _((void)); -OP * pp_gsockopt _((void)); -OP * pp_ssockopt _((void)); -OP * pp_getsockname _((void)); -OP * pp_getpeername _((void)); -OP * pp_lstat _((void)); -OP * pp_stat _((void)); -OP * pp_ftrread _((void)); -OP * pp_ftrwrite _((void)); -OP * pp_ftrexec _((void)); -OP * pp_fteread _((void)); -OP * pp_ftewrite _((void)); -OP * pp_fteexec _((void)); -OP * pp_ftis _((void)); -OP * pp_fteowned _((void)); -OP * pp_ftrowned _((void)); -OP * pp_ftzero _((void)); -OP * pp_ftsize _((void)); -OP * pp_ftmtime _((void)); -OP * pp_ftatime _((void)); -OP * pp_ftctime _((void)); -OP * pp_ftsock _((void)); -OP * pp_ftchr _((void)); -OP * pp_ftblk _((void)); -OP * pp_ftfile _((void)); -OP * pp_ftdir _((void)); -OP * pp_ftpipe _((void)); -OP * pp_ftlink _((void)); -OP * pp_ftsuid _((void)); -OP * pp_ftsgid _((void)); -OP * pp_ftsvtx _((void)); -OP * pp_fttty _((void)); -OP * pp_fttext _((void)); -OP * pp_ftbinary _((void)); -OP * pp_chdir _((void)); -OP * pp_chown _((void)); -OP * pp_chroot _((void)); -OP * pp_unlink _((void)); -OP * pp_chmod _((void)); -OP * pp_utime _((void)); -OP * pp_rename _((void)); -OP * pp_link _((void)); -OP * pp_symlink _((void)); -OP * pp_readlink _((void)); -OP * pp_mkdir _((void)); -OP * pp_rmdir _((void)); -OP * pp_open_dir _((void)); -OP * pp_readdir _((void)); -OP * pp_telldir _((void)); -OP * pp_seekdir _((void)); -OP * pp_rewinddir _((void)); -OP * pp_closedir _((void)); -OP * pp_fork _((void)); -OP * pp_wait _((void)); -OP * pp_waitpid _((void)); -OP * pp_system _((void)); -OP * pp_exec _((void)); -OP * pp_kill _((void)); -OP * pp_getppid _((void)); -OP * pp_getpgrp _((void)); -OP * pp_setpgrp _((void)); -OP * pp_getpriority _((void)); -OP * pp_setpriority _((void)); -OP * pp_time _((void)); -OP * pp_tms _((void)); -OP * pp_localtime _((void)); -OP * pp_gmtime _((void)); -OP * pp_alarm _((void)); -OP * pp_sleep _((void)); -OP * pp_shmget _((void)); -OP * pp_shmctl _((void)); -OP * pp_shmread _((void)); -OP * pp_shmwrite _((void)); -OP * pp_msgget _((void)); -OP * pp_msgctl _((void)); -OP * pp_msgsnd _((void)); -OP * pp_msgrcv _((void)); -OP * pp_semget _((void)); -OP * pp_semctl _((void)); -OP * pp_semop _((void)); -OP * pp_require _((void)); -OP * pp_dofile _((void)); -OP * pp_entereval _((void)); -OP * pp_leaveeval _((void)); -OP * pp_entertry _((void)); -OP * pp_leavetry _((void)); -OP * pp_ghbyname _((void)); -OP * pp_ghbyaddr _((void)); -OP * pp_ghostent _((void)); -OP * pp_gnbyname _((void)); -OP * pp_gnbyaddr _((void)); -OP * pp_gnetent _((void)); -OP * pp_gpbyname _((void)); -OP * pp_gpbynumber _((void)); -OP * pp_gprotoent _((void)); -OP * pp_gsbyname _((void)); -OP * pp_gsbyport _((void)); -OP * pp_gservent _((void)); -OP * pp_shostent _((void)); -OP * pp_snetent _((void)); -OP * pp_sprotoent _((void)); -OP * pp_sservent _((void)); -OP * pp_ehostent _((void)); -OP * pp_enetent _((void)); -OP * pp_eprotoent _((void)); -OP * pp_eservent _((void)); -OP * pp_gpwnam _((void)); -OP * pp_gpwuid _((void)); -OP * pp_gpwent _((void)); -OP * pp_spwent _((void)); -OP * pp_epwent _((void)); -OP * pp_ggrnam _((void)); -OP * pp_ggrgid _((void)); -OP * pp_ggrent _((void)); -OP * pp_sgrent _((void)); -OP * pp_egrent _((void)); -OP * pp_getlogin _((void)); -OP * pp_syscall _((void)); +OP * pp_null _((ARGSproto)); +OP * pp_stub _((ARGSproto)); +OP * pp_scalar _((ARGSproto)); +OP * pp_pushmark _((ARGSproto)); +OP * pp_wantarray _((ARGSproto)); +OP * pp_const _((ARGSproto)); +OP * pp_gvsv _((ARGSproto)); +OP * pp_gv _((ARGSproto)); +OP * pp_gelem _((ARGSproto)); +OP * pp_padsv _((ARGSproto)); +OP * pp_padav _((ARGSproto)); +OP * pp_padhv _((ARGSproto)); +OP * pp_padany _((ARGSproto)); +OP * pp_pushre _((ARGSproto)); +OP * pp_rv2gv _((ARGSproto)); +OP * pp_rv2sv _((ARGSproto)); +OP * pp_av2arylen _((ARGSproto)); +OP * pp_rv2cv _((ARGSproto)); +OP * pp_anoncode _((ARGSproto)); +OP * pp_prototype _((ARGSproto)); +OP * pp_refgen _((ARGSproto)); +OP * pp_srefgen _((ARGSproto)); +OP * pp_ref _((ARGSproto)); +OP * pp_bless _((ARGSproto)); +OP * pp_backtick _((ARGSproto)); +OP * pp_glob _((ARGSproto)); +OP * pp_readline _((ARGSproto)); +OP * pp_rcatline _((ARGSproto)); +OP * pp_regcmaybe _((ARGSproto)); +OP * pp_regcomp _((ARGSproto)); +OP * pp_match _((ARGSproto)); +OP * pp_subst _((ARGSproto)); +OP * pp_substcont _((ARGSproto)); +OP * pp_trans _((ARGSproto)); +OP * pp_sassign _((ARGSproto)); +OP * pp_aassign _((ARGSproto)); +OP * pp_chop _((ARGSproto)); +OP * pp_schop _((ARGSproto)); +OP * pp_chomp _((ARGSproto)); +OP * pp_schomp _((ARGSproto)); +OP * pp_defined _((ARGSproto)); +OP * pp_undef _((ARGSproto)); +OP * pp_study _((ARGSproto)); +OP * pp_pos _((ARGSproto)); +OP * pp_preinc _((ARGSproto)); +OP * pp_i_preinc _((ARGSproto)); +OP * pp_predec _((ARGSproto)); +OP * pp_i_predec _((ARGSproto)); +OP * pp_postinc _((ARGSproto)); +OP * pp_i_postinc _((ARGSproto)); +OP * pp_postdec _((ARGSproto)); +OP * pp_i_postdec _((ARGSproto)); +OP * pp_pow _((ARGSproto)); +OP * pp_multiply _((ARGSproto)); +OP * pp_i_multiply _((ARGSproto)); +OP * pp_divide _((ARGSproto)); +OP * pp_i_divide _((ARGSproto)); +OP * pp_modulo _((ARGSproto)); +OP * pp_i_modulo _((ARGSproto)); +OP * pp_repeat _((ARGSproto)); +OP * pp_add _((ARGSproto)); +OP * pp_i_add _((ARGSproto)); +OP * pp_subtract _((ARGSproto)); +OP * pp_i_subtract _((ARGSproto)); +OP * pp_concat _((ARGSproto)); +OP * pp_stringify _((ARGSproto)); +OP * pp_left_shift _((ARGSproto)); +OP * pp_right_shift _((ARGSproto)); +OP * pp_lt _((ARGSproto)); +OP * pp_i_lt _((ARGSproto)); +OP * pp_gt _((ARGSproto)); +OP * pp_i_gt _((ARGSproto)); +OP * pp_le _((ARGSproto)); +OP * pp_i_le _((ARGSproto)); +OP * pp_ge _((ARGSproto)); +OP * pp_i_ge _((ARGSproto)); +OP * pp_eq _((ARGSproto)); +OP * pp_i_eq _((ARGSproto)); +OP * pp_ne _((ARGSproto)); +OP * pp_i_ne _((ARGSproto)); +OP * pp_ncmp _((ARGSproto)); +OP * pp_i_ncmp _((ARGSproto)); +OP * pp_slt _((ARGSproto)); +OP * pp_sgt _((ARGSproto)); +OP * pp_sle _((ARGSproto)); +OP * pp_sge _((ARGSproto)); +OP * pp_seq _((ARGSproto)); +OP * pp_sne _((ARGSproto)); +OP * pp_scmp _((ARGSproto)); +OP * pp_bit_and _((ARGSproto)); +OP * pp_bit_xor _((ARGSproto)); +OP * pp_bit_or _((ARGSproto)); +OP * pp_negate _((ARGSproto)); +OP * pp_i_negate _((ARGSproto)); +OP * pp_not _((ARGSproto)); +OP * pp_complement _((ARGSproto)); +OP * pp_atan2 _((ARGSproto)); +OP * pp_sin _((ARGSproto)); +OP * pp_cos _((ARGSproto)); +OP * pp_rand _((ARGSproto)); +OP * pp_srand _((ARGSproto)); +OP * pp_exp _((ARGSproto)); +OP * pp_log _((ARGSproto)); +OP * pp_sqrt _((ARGSproto)); +OP * pp_int _((ARGSproto)); +OP * pp_hex _((ARGSproto)); +OP * pp_oct _((ARGSproto)); +OP * pp_abs _((ARGSproto)); +OP * pp_length _((ARGSproto)); +OP * pp_substr _((ARGSproto)); +OP * pp_vec _((ARGSproto)); +OP * pp_index _((ARGSproto)); +OP * pp_rindex _((ARGSproto)); +OP * pp_sprintf _((ARGSproto)); +OP * pp_formline _((ARGSproto)); +OP * pp_ord _((ARGSproto)); +OP * pp_chr _((ARGSproto)); +OP * pp_crypt _((ARGSproto)); +OP * pp_ucfirst _((ARGSproto)); +OP * pp_lcfirst _((ARGSproto)); +OP * pp_uc _((ARGSproto)); +OP * pp_lc _((ARGSproto)); +OP * pp_quotemeta _((ARGSproto)); +OP * pp_rv2av _((ARGSproto)); +OP * pp_aelemfast _((ARGSproto)); +OP * pp_aelem _((ARGSproto)); +OP * pp_aslice _((ARGSproto)); +OP * pp_each _((ARGSproto)); +OP * pp_values _((ARGSproto)); +OP * pp_keys _((ARGSproto)); +OP * pp_delete _((ARGSproto)); +OP * pp_exists _((ARGSproto)); +OP * pp_rv2hv _((ARGSproto)); +OP * pp_helem _((ARGSproto)); +OP * pp_hslice _((ARGSproto)); +OP * pp_unpack _((ARGSproto)); +OP * pp_pack _((ARGSproto)); +OP * pp_split _((ARGSproto)); +OP * pp_join _((ARGSproto)); +OP * pp_list _((ARGSproto)); +OP * pp_lslice _((ARGSproto)); +OP * pp_anonlist _((ARGSproto)); +OP * pp_anonhash _((ARGSproto)); +OP * pp_splice _((ARGSproto)); +OP * pp_push _((ARGSproto)); +OP * pp_pop _((ARGSproto)); +OP * pp_shift _((ARGSproto)); +OP * pp_unshift _((ARGSproto)); +OP * pp_sort _((ARGSproto)); +OP * pp_reverse _((ARGSproto)); +OP * pp_grepstart _((ARGSproto)); +OP * pp_grepwhile _((ARGSproto)); +OP * pp_mapstart _((ARGSproto)); +OP * pp_mapwhile _((ARGSproto)); +OP * pp_range _((ARGSproto)); +OP * pp_flip _((ARGSproto)); +OP * pp_flop _((ARGSproto)); +OP * pp_and _((ARGSproto)); +OP * pp_or _((ARGSproto)); +OP * pp_xor _((ARGSproto)); +OP * pp_cond_expr _((ARGSproto)); +OP * pp_andassign _((ARGSproto)); +OP * pp_orassign _((ARGSproto)); +OP * pp_method _((ARGSproto)); +OP * pp_entersub _((ARGSproto)); +OP * pp_leavesub _((ARGSproto)); +OP * pp_caller _((ARGSproto)); +OP * pp_warn _((ARGSproto)); +OP * pp_die _((ARGSproto)); +OP * pp_reset _((ARGSproto)); +OP * pp_lineseq _((ARGSproto)); +OP * pp_nextstate _((ARGSproto)); +OP * pp_dbstate _((ARGSproto)); +OP * pp_unstack _((ARGSproto)); +OP * pp_enter _((ARGSproto)); +OP * pp_leave _((ARGSproto)); +OP * pp_scope _((ARGSproto)); +OP * pp_enteriter _((ARGSproto)); +OP * pp_iter _((ARGSproto)); +OP * pp_enterloop _((ARGSproto)); +OP * pp_leaveloop _((ARGSproto)); +OP * pp_return _((ARGSproto)); +OP * pp_last _((ARGSproto)); +OP * pp_next _((ARGSproto)); +OP * pp_redo _((ARGSproto)); +OP * pp_dump _((ARGSproto)); +OP * pp_goto _((ARGSproto)); +OP * pp_exit _((ARGSproto)); +OP * pp_open _((ARGSproto)); +OP * pp_close _((ARGSproto)); +OP * pp_pipe_op _((ARGSproto)); +OP * pp_fileno _((ARGSproto)); +OP * pp_umask _((ARGSproto)); +OP * pp_binmode _((ARGSproto)); +OP * pp_tie _((ARGSproto)); +OP * pp_untie _((ARGSproto)); +OP * pp_tied _((ARGSproto)); +OP * pp_dbmopen _((ARGSproto)); +OP * pp_dbmclose _((ARGSproto)); +OP * pp_sselect _((ARGSproto)); +OP * pp_select _((ARGSproto)); +OP * pp_getc _((ARGSproto)); +OP * pp_read _((ARGSproto)); +OP * pp_enterwrite _((ARGSproto)); +OP * pp_leavewrite _((ARGSproto)); +OP * pp_prtf _((ARGSproto)); +OP * pp_print _((ARGSproto)); +OP * pp_sysopen _((ARGSproto)); +OP * pp_sysseek _((ARGSproto)); +OP * pp_sysread _((ARGSproto)); +OP * pp_syswrite _((ARGSproto)); +OP * pp_send _((ARGSproto)); +OP * pp_recv _((ARGSproto)); +OP * pp_eof _((ARGSproto)); +OP * pp_tell _((ARGSproto)); +OP * pp_seek _((ARGSproto)); +OP * pp_truncate _((ARGSproto)); +OP * pp_fcntl _((ARGSproto)); +OP * pp_ioctl _((ARGSproto)); +OP * pp_flock _((ARGSproto)); +OP * pp_socket _((ARGSproto)); +OP * pp_sockpair _((ARGSproto)); +OP * pp_bind _((ARGSproto)); +OP * pp_connect _((ARGSproto)); +OP * pp_listen _((ARGSproto)); +OP * pp_accept _((ARGSproto)); +OP * pp_shutdown _((ARGSproto)); +OP * pp_gsockopt _((ARGSproto)); +OP * pp_ssockopt _((ARGSproto)); +OP * pp_getsockname _((ARGSproto)); +OP * pp_getpeername _((ARGSproto)); +OP * pp_lstat _((ARGSproto)); +OP * pp_stat _((ARGSproto)); +OP * pp_ftrread _((ARGSproto)); +OP * pp_ftrwrite _((ARGSproto)); +OP * pp_ftrexec _((ARGSproto)); +OP * pp_fteread _((ARGSproto)); +OP * pp_ftewrite _((ARGSproto)); +OP * pp_fteexec _((ARGSproto)); +OP * pp_ftis _((ARGSproto)); +OP * pp_fteowned _((ARGSproto)); +OP * pp_ftrowned _((ARGSproto)); +OP * pp_ftzero _((ARGSproto)); +OP * pp_ftsize _((ARGSproto)); +OP * pp_ftmtime _((ARGSproto)); +OP * pp_ftatime _((ARGSproto)); +OP * pp_ftctime _((ARGSproto)); +OP * pp_ftsock _((ARGSproto)); +OP * pp_ftchr _((ARGSproto)); +OP * pp_ftblk _((ARGSproto)); +OP * pp_ftfile _((ARGSproto)); +OP * pp_ftdir _((ARGSproto)); +OP * pp_ftpipe _((ARGSproto)); +OP * pp_ftlink _((ARGSproto)); +OP * pp_ftsuid _((ARGSproto)); +OP * pp_ftsgid _((ARGSproto)); +OP * pp_ftsvtx _((ARGSproto)); +OP * pp_fttty _((ARGSproto)); +OP * pp_fttext _((ARGSproto)); +OP * pp_ftbinary _((ARGSproto)); +OP * pp_chdir _((ARGSproto)); +OP * pp_chown _((ARGSproto)); +OP * pp_chroot _((ARGSproto)); +OP * pp_unlink _((ARGSproto)); +OP * pp_chmod _((ARGSproto)); +OP * pp_utime _((ARGSproto)); +OP * pp_rename _((ARGSproto)); +OP * pp_link _((ARGSproto)); +OP * pp_symlink _((ARGSproto)); +OP * pp_readlink _((ARGSproto)); +OP * pp_mkdir _((ARGSproto)); +OP * pp_rmdir _((ARGSproto)); +OP * pp_open_dir _((ARGSproto)); +OP * pp_readdir _((ARGSproto)); +OP * pp_telldir _((ARGSproto)); +OP * pp_seekdir _((ARGSproto)); +OP * pp_rewinddir _((ARGSproto)); +OP * pp_closedir _((ARGSproto)); +OP * pp_fork _((ARGSproto)); +OP * pp_wait _((ARGSproto)); +OP * pp_waitpid _((ARGSproto)); +OP * pp_system _((ARGSproto)); +OP * pp_exec _((ARGSproto)); +OP * pp_kill _((ARGSproto)); +OP * pp_getppid _((ARGSproto)); +OP * pp_getpgrp _((ARGSproto)); +OP * pp_setpgrp _((ARGSproto)); +OP * pp_getpriority _((ARGSproto)); +OP * pp_setpriority _((ARGSproto)); +OP * pp_time _((ARGSproto)); +OP * pp_tms _((ARGSproto)); +OP * pp_localtime _((ARGSproto)); +OP * pp_gmtime _((ARGSproto)); +OP * pp_alarm _((ARGSproto)); +OP * pp_sleep _((ARGSproto)); +OP * pp_shmget _((ARGSproto)); +OP * pp_shmctl _((ARGSproto)); +OP * pp_shmread _((ARGSproto)); +OP * pp_shmwrite _((ARGSproto)); +OP * pp_msgget _((ARGSproto)); +OP * pp_msgctl _((ARGSproto)); +OP * pp_msgsnd _((ARGSproto)); +OP * pp_msgrcv _((ARGSproto)); +OP * pp_semget _((ARGSproto)); +OP * pp_semctl _((ARGSproto)); +OP * pp_semop _((ARGSproto)); +OP * pp_require _((ARGSproto)); +OP * pp_dofile _((ARGSproto)); +OP * pp_entereval _((ARGSproto)); +OP * pp_leaveeval _((ARGSproto)); +OP * pp_entertry _((ARGSproto)); +OP * pp_leavetry _((ARGSproto)); +OP * pp_ghbyname _((ARGSproto)); +OP * pp_ghbyaddr _((ARGSproto)); +OP * pp_ghostent _((ARGSproto)); +OP * pp_gnbyname _((ARGSproto)); +OP * pp_gnbyaddr _((ARGSproto)); +OP * pp_gnetent _((ARGSproto)); +OP * pp_gpbyname _((ARGSproto)); +OP * pp_gpbynumber _((ARGSproto)); +OP * pp_gprotoent _((ARGSproto)); +OP * pp_gsbyname _((ARGSproto)); +OP * pp_gsbyport _((ARGSproto)); +OP * pp_gservent _((ARGSproto)); +OP * pp_shostent _((ARGSproto)); +OP * pp_snetent _((ARGSproto)); +OP * pp_sprotoent _((ARGSproto)); +OP * pp_sservent _((ARGSproto)); +OP * pp_ehostent _((ARGSproto)); +OP * pp_enetent _((ARGSproto)); +OP * pp_eprotoent _((ARGSproto)); +OP * pp_eservent _((ARGSproto)); +OP * pp_gpwnam _((ARGSproto)); +OP * pp_gpwuid _((ARGSproto)); +OP * pp_gpwent _((ARGSproto)); +OP * pp_spwent _((ARGSproto)); +OP * pp_epwent _((ARGSproto)); +OP * pp_ggrnam _((ARGSproto)); +OP * pp_ggrgid _((ARGSproto)); +OP * pp_ggrent _((ARGSproto)); +OP * pp_sgrent _((ARGSproto)); +OP * pp_egrent _((ARGSproto)); +OP * pp_getlogin _((ARGSproto)); +OP * pp_syscall _((ARGSproto)); +OP * pp_lock _((ARGSproto)); #ifndef DOINIT EXT OP * (*ppaddr[])(); @@ -1781,6 +1785,7 @@ EXT OP * (*ppaddr[])() = { pp_egrent, pp_getlogin, pp_syscall, + pp_lock, }; #endif @@ -2132,6 +2137,7 @@ EXT OP * (*check[]) _((OP *op)) = { ck_null, /* egrent */ ck_null, /* getlogin */ ck_fun, /* syscall */ + ck_null, /* lock */ }; #endif @@ -2483,5 +2489,6 @@ EXT U32 opargs[] = { 0x00000014, /* egrent */ 0x0000000c, /* getlogin */ 0x0000211d, /* syscall */ + 0x00000104, /* lock */ }; #endif @@ -82,13 +82,13 @@ END # Emit function declarations. for (sort keys %ckname) { - print "OP *\t", &tab(3,$_),"_((OP* op));\n"; + print "OP *\t", &tab(3,$_),"_((OP* o));\n"; } print "\n"; for (@ops) { - print "OP *\t", &tab(3, "pp_\L$_"), "_((void));\n"; + print "OP *\t", &tab(3, "pp_\L$_"), "_((ARGSproto));\n"; } # Emit ppcode switch array. @@ -652,3 +652,6 @@ getlogin getlogin ck_null st # Miscellaneous. syscall syscall ck_fun imst S L + +# For multi-threading +lock lock ck_null s S diff --git a/patchlevel.h b/patchlevel.h index 7881ec90c9..ddbb585105 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 4 -#define SUBVERSION 3 +#define SUBVERSION 51 /* local_patches -- list of locally applied less-than-subversion patches. @@ -72,15 +72,30 @@ static void init_main_stash _((void)); static void init_perllib _((void)); static void init_postdump_symbols _((int, char **, char **)); static void init_predump_symbols _((void)); -static void init_stacks _((void)); static void my_exit_jump _((void)) __attribute__((noreturn)); static void nuke_stacks _((void)); static void open_script _((char *, bool, SV *)); +#ifdef USE_THREADS +static void thread_destruct _((void *)); +#endif /* USE_THREADS */ static void usage _((char *)); static void validate_suid _((char *, char*)); static int fdscript = -1; +#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) +#include <asm/sigcontext.h> +static void +catch_sigsegv(int signo, struct sigcontext_struct sc) +{ + signal(SIGSEGV, SIG_DFL); + fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n" + "return_address = 0x%lx, eip = 0x%lx\n", + sc.cr2, __builtin_return_address(0), sc.eip); + fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR); +} +#endif + PerlInterpreter * perl_alloc() { @@ -95,6 +110,10 @@ void perl_construct( sv_interp ) register PerlInterpreter *sv_interp; { +#if defined(USE_THREADS) && !defined(FAKE_THREADS) + struct thread *thr; +#endif + if (!(curinterp = sv_interp)) return; @@ -102,8 +121,37 @@ register PerlInterpreter *sv_interp; Zero(sv_interp, 1, PerlInterpreter); #endif - /* Init the real globals? */ + /* Init the real globals? */ if (!linestr) { +#ifdef USE_THREADS +#ifdef NEED_PTHREAD_INIT + pthread_init(); +#endif /* NEED_PTHREAD_INIT */ + New(53, thr, 1, struct thread); + MUTEX_INIT(&malloc_mutex); + MUTEX_INIT(&sv_mutex); + MUTEX_INIT(&eval_mutex); + COND_INIT(&eval_cond); + MUTEX_INIT(&nthreads_mutex); + COND_INIT(&nthreads_cond); + nthreads = 1; + cvcache = newHV(); + thrflags = 0; + curcop = &compiling; +#ifdef FAKE_THREADS + self = thr; + thr->next = thr->prev = thr->next_run = thr->prev_run = thr; + thr->wait_queue = 0; + thr->private = 0; +#else + self = pthread_self(); + if (pthread_key_create(&thr_key, thread_destruct)) + croak("panic: pthread_key_create"); + if (pthread_setspecific(thr_key, (void *) thr)) + croak("panic: pthread_setspecific"); +#endif /* FAKE_THREADS */ +#endif /* USE_THREADS */ + linestr = NEWSV(65,80); sv_upgrade(linestr,SVt_PVIV); @@ -122,6 +170,7 @@ register PerlInterpreter *sv_interp; nrs = newSVpv("\n", 1); rs = SvREFCNT_inc(nrs); + sighandlerp = sighandler; pidstatus = newHV(); #ifdef MSDOS @@ -169,14 +218,42 @@ register PerlInterpreter *sv_interp; fdpid = newAV(); /* for remembering popen pids by fd */ - init_stacks(); + init_stacks(ARGS); + DEBUG( { + New(51,debname,128,char); + New(52,debdelim,128,char); + } ) + ENTER; } +#ifdef USE_THREADS +void +thread_destruct(arg) +void *arg; +{ + struct thread *thr = (struct thread *) arg; + /* + * Decrement the global thread count and signal anyone listening. + * The only official thread listening is the original thread while + * in perl_destruct. It waits until it's the only thread and then + * performs END blocks and other process clean-ups. + */ + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "thread_destruct: 0x%lx\n", (unsigned long) thr)); + + Safefree(thr); + MUTEX_LOCK(&nthreads_mutex); + nthreads--; + COND_BROADCAST(&nthreads_cond); + MUTEX_UNLOCK(&nthreads_mutex); +} +#endif /* USE_THREADS */ + void perl_destruct(sv_interp) register PerlInterpreter *sv_interp; { + dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ I32 last_sv_count; HV *hv; @@ -184,6 +261,24 @@ register PerlInterpreter *sv_interp; if (!(curinterp = sv_interp)) return; +#ifdef USE_THREADS +#ifndef FAKE_THREADS + /* Wait until all user-created threads go away */ + MUTEX_LOCK(&nthreads_mutex); + while (nthreads > 1) + { + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: waiting for %d threads\n", + nthreads - 1)); + COND_WAIT(&nthreads_cond, &nthreads_mutex); + } + /* At this point, we're the last thread */ + MUTEX_UNLOCK(&nthreads_mutex); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n")); + MUTEX_DESTROY(&nthreads_mutex); + COND_DESTROY(&nthreads_cond); +#endif /* !defined(FAKE_THREADS) */ +#endif /* USE_THREADS */ + destruct_level = perl_destruct_level; #ifdef DEBUGGING { @@ -335,8 +430,10 @@ register PerlInterpreter *sv_interp; /* startup and shutdown function lists */ SvREFCNT_dec(beginav); SvREFCNT_dec(endav); + SvREFCNT_dec(initav); beginav = Nullav; endav = Nullav; + initav = Nullav; /* temp stack during pp_sort() */ SvREFCNT_dec(sortstack); @@ -431,6 +528,12 @@ register PerlInterpreter *sv_interp; hints = 0; /* Reset hints. Should hints be per-interpreter ? */ DEBUG_P(debprofdump()); +#ifdef USE_THREADS + MUTEX_DESTROY(&sv_mutex); + MUTEX_DESTROY(&malloc_mutex); + MUTEX_DESTROY(&eval_mutex); + COND_DESTROY(&eval_cond); +#endif /* USE_THREADS */ /* As the absolutely last thing, free the non-arena SV for mess() */ @@ -461,6 +564,7 @@ int argc; char **argv; char **env; { + dTHR; register SV *sv; register char *s; char *scriptname = NULL; @@ -773,6 +877,14 @@ print \" \\@INC:\\n @INC\\n\";"); comppad_name_fill = 0; min_intro_pending = 0; padix = 0; +#ifdef USE_THREADS + av_store(comppad_name, 0, newSVpv("@_", 2)); + curpad[0] = (SV*)newAV(); + SvPADMY_on(curpad[0]); /* XXX Needed? */ + CvOWNER(compcv) = 0; + New(666, CvMUTEXP(compcv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(compcv)); +#endif /* USE_THREADS */ comppadlist = newAV(); AvREAL_off(comppadlist); @@ -787,6 +899,10 @@ print \" \\@INC:\\n @INC\\n\";"); init_os_extras(); #endif +#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) + DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv);); +#endif + init_predump_symbols(); if (!do_undump) init_postdump_symbols(argc,argv,env); @@ -842,6 +958,7 @@ int perl_run(sv_interp) PerlInterpreter *sv_interp; { + dTHR; I32 oldscope; dJMPENV; int ret; @@ -890,6 +1007,10 @@ PerlInterpreter *sv_interp; if (!restartop) { DEBUG_x(dump_all()); DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); +#ifdef USE_THREADS + DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n", + (unsigned long) thr)); +#endif /* USE_THREADS */ if (minus_c) { PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename); @@ -897,6 +1018,8 @@ PerlInterpreter *sv_interp; } if (PERLDB_SINGLE && DBsingle) sv_setiv(DBsingle, 1); + if (initav) + call_list(oldscope, initav); } /* do it */ @@ -978,6 +1101,7 @@ char *subname; I32 flags; /* See G_* flags in cop.h */ register char **argv; /* null terminated arg list */ { + dTHR; dSP; PUSHMARK(sp); @@ -1004,13 +1128,14 @@ perl_call_method(methname, flags) char *methname; /* name of the subroutine */ I32 flags; /* See G_* flags in cop.h */ { + dTHR; dSP; OP myop; if (!op) op = &myop; XPUSHs(sv_2mortal(newSVpv(methname,0))); PUTBACK; - pp_method(); + pp_method(ARGS); return perl_call_sv(*stack_sp--, flags); } @@ -1020,6 +1145,7 @@ perl_call_sv(sv, flags) SV* sv; I32 flags; /* See G_* flags in cop.h */ { + dTHR; LOGOP myop; /* fake syntax tree node */ SV** sp = stack_sp; I32 oldmark; @@ -1043,7 +1169,7 @@ I32 flags; /* See G_* flags in cop.h */ myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : (flags & G_ARRAY) ? OPf_WANT_LIST : OPf_WANT_SCALAR); - SAVESPTR(op); + SAVEOP(); op = (OP*)&myop; EXTEND(stack_sp, 1); @@ -1119,7 +1245,7 @@ I32 flags; /* See G_* flags in cop.h */ CATCH_SET(TRUE); if (op == (OP*)&myop) - op = pp_entersub(); + op = pp_entersub(ARGS); if (op) runops(); retval = stack_sp - (stack_base + oldmark); @@ -1163,6 +1289,7 @@ perl_eval_sv(sv, flags) SV* sv; I32 flags; /* See G_* flags in cop.h */ { + dTHR; UNOP myop; /* fake syntax tree node */ SV** sp = stack_sp; I32 oldmark = sp - stack_base; @@ -1177,7 +1304,7 @@ I32 flags; /* See G_* flags in cop.h */ SAVETMPS; } - SAVESPTR(op); + SAVEOP(); op = (OP*)&myop; Zero(op, 1, UNOP); EXTEND(stack_sp, 1); @@ -1227,7 +1354,7 @@ I32 flags; /* See G_* flags in cop.h */ } if (op == (OP*)&myop) - op = pp_entereval(); + op = pp_entereval(ARGS); if (op) runops(); retval = stack_sp - (stack_base + oldmark); @@ -1251,6 +1378,7 @@ perl_eval_pv(p, croak_on_error) char* p; I32 croak_on_error; { + dTHR; dSP; SV* sv = newSVpv(p, 0); @@ -1446,30 +1574,31 @@ char *s; forbid_setid("-m"); /* XXX ? */ if (*++s) { char *start; + SV *sv; char *use = "use "; /* -M-foo == 'no foo' */ if (*s == '-') { use = "no "; ++s; } - Sv = newSVpv(use,0); + sv = newSVpv(use,0); start = s; /* We allow -M'Module qw(Foo Bar)' */ while(isALNUM(*s) || *s==':') ++s; if (*s != '=') { - sv_catpv(Sv, start); + sv_catpv(sv, start); if (*(start-1) == 'm') { if (*s != '\0') croak("Can't use '%c' after -mname", *s); - sv_catpv( Sv, " ()"); + sv_catpv( sv, " ()"); } } else { - sv_catpvn(Sv, start, s-start); - sv_catpv(Sv, " split(/,/,q{"); - sv_catpv(Sv, ++s); - sv_catpv(Sv, "})"); + sv_catpvn(sv, start, s-start); + sv_catpv(sv, " split(/,/,q{"); + sv_catpv(sv, ++s); + sv_catpv(sv, "})"); } s += strlen(s); if (preambleav == NULL) preambleav = newAV(); - av_push(preambleav, Sv); + av_push(preambleav, sv); } else croak("No space allowed after -%c", *(s-1)); @@ -1589,6 +1718,7 @@ my_unexec() static void init_main_stash() { + dTHR; GV *gv; /* Note that strtab is a rather special HV. Assumptions are made @@ -1632,6 +1762,7 @@ bool dosearch; SV *sv; #endif { + dTHR; char *xfound = Nullch; char *xfailed = Nullch; register char *s; @@ -2169,6 +2300,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #else /* !DOSUID */ if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW + dTHR; Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || @@ -2239,6 +2371,7 @@ char *s; static void init_debugger() { + dTHR; curstash = debstash; dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); AvREAL_off(dbargs); @@ -2254,8 +2387,9 @@ init_debugger() curstash = defstash; } -static void -init_stacks() +void +init_stacks(ARGS) +dARGS { curstack = newAV(); mainstack = curstack; /* remember in case we switch stacks */ @@ -2271,14 +2405,10 @@ init_stacks() cxstack_ix = -1; New(50,tmps_stack,128,SV*); + tmps_floor = -1; tmps_ix = -1; tmps_max = 128; - DEBUG( { - New(51,debname,128,char); - New(52,debdelim,128,char); - } ) - /* * The following stacks almost certainly should be per-interpreter, * but for now they're not. XXX @@ -2320,6 +2450,7 @@ init_stacks() static void nuke_stacks() { + dTHR; Safefree(cxstack); Safefree(tmps_stack); DEBUG( { @@ -2343,6 +2474,7 @@ init_lexer() static void init_predump_symbols() { + dTHR; GV *tmpgv; GV *othergv; @@ -2630,6 +2762,7 @@ call_list(oldscope, list) I32 oldscope; AV* list; { + dTHR; line_t oldline = curcop->cop_line; STRLEN len; dJMPENV; @@ -2702,6 +2835,12 @@ void my_exit(status) U32 status; { + dTHR; + +#ifdef USE_THREADS + DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n", + (unsigned long) thr, (unsigned long) status)); +#endif /* USE_THREADS */ switch (status) { case 0: STATUS_ALL_SUCCESS; @@ -2742,6 +2881,7 @@ my_failure_exit() static void my_exit_jump() { + dTHR; register CONTEXT *cx; I32 gimme; SV **newsp; @@ -29,6 +29,14 @@ #include "embed.h" +#ifdef OP_IN_REGISTER +# ifdef __GNUC__ +# define stringify_immed(s) #s +# define stringify(s) stringify_immed(s) +register struct op *op asm(stringify(OP_IN_REGISTER)); +# endif +#endif + /* * STMT_START { statements; } STMT_END; * can be used as a single statement, as in @@ -52,6 +60,20 @@ # endif #endif +#define NOOP (void)0 + +#define WITH_THR(s) do { dTHR; s; } while (0) +#ifdef USE_THREADS +#ifdef FAKE_THREADS +#include "fakethr.h" +#else +#include <pthread.h> +typedef pthread_mutex_t perl_mutex; +typedef pthread_cond_t perl_cond; +typedef pthread_key_t perl_key; +#endif /* FAKE_THREADS */ +#endif /* USE_THREADS */ + /* * SOFT_CAST can be used for args to prototyped functions to retain some * type checking; it only casts if the compiler does not know prototypes. @@ -845,6 +867,11 @@ #endif +/* Digital UNIX defines a typedef CONTEXT when pthreads is in use */ +#if defined(__osf__) +# define CONTEXT PERL_CONTEXT +#endif + typedef MEM_SIZE STRLEN; typedef struct op OP; @@ -996,6 +1023,12 @@ union any { void (*any_dptr) _((void*)); }; +#ifdef USE_THREADS +#define ARGSproto struct thread * +#else +#define ARGSproto void +#endif /* USE_THREADS */ + /* Work around some cygwin32 problems with importing global symbols */ #if defined(CYGWIN32) && defined(DLLIMPORT) # include "cw32imp.h" @@ -1284,8 +1317,20 @@ typedef Sighandler_t Sigsave_t; # define register # endif # define PAD_SV(po) pad_sv(po) +# define RUNOPS_DEFAULT runops_debug #else # define PAD_SV(po) curpad[po] +# define RUNOPS_DEFAULT runops_standard +#endif + +/* + * These need prototyping here because <proto.h> isn't + * included until after runops is initialised. + */ + +int runops_standard _((void)); +#ifdef DEBUGGING +int runops_debug _((void)); #endif /****************/ @@ -1294,6 +1339,21 @@ typedef Sighandler_t Sigsave_t; /* global state */ EXT PerlInterpreter * curinterp; /* currently running interpreter */ +#ifdef USE_THREADS +EXT perl_key thr_key; /* For per-thread struct thread ptr */ +EXT perl_mutex sv_mutex; /* Mutex for allocating SVs in sv.c */ +EXT perl_mutex malloc_mutex; /* Mutex for malloc */ +EXT perl_mutex eval_mutex; /* Mutex for doeval */ +EXT perl_cond eval_cond; /* Condition variable for doeval */ +EXT struct thread * eval_owner; /* Owner thread for doeval */ +EXT int nthreads; /* Number of threads currently */ +EXT perl_mutex nthreads_mutex; /* Mutex for nthreads */ +EXT perl_cond nthreads_cond; /* Condition variable for nthreads */ +#ifdef FAKE_THREADS +EXT struct thread * thr; /* Currently executing (fake) thread */ +#endif +#endif /* USE_THREADS */ + /* VMS doesn't use environ array and NeXT has problems with crt0.o globals */ #if !defined(VMS) && !(defined(NeXT) && defined(__DYNAMIC__)) #ifndef DONT_DECLARE_STD @@ -1325,6 +1385,7 @@ EXT U32 * profiledata; EXT int maxo INIT(MAXO);/* Number of ops */ EXT char * osname; /* operating system */ EXT char * sh_path INIT(SH_PATH); /* full path of shell */ +EXT Sighandler_t sighandlerp; EXT XPV* xiv_arenaroot; /* list of allocated xiv areas */ EXT IV ** xiv_root; /* free xiv list--shared by interpreters */ @@ -1342,8 +1403,12 @@ EXT SV ** stack_max; /* stack->array_ary + stack->array_max */ /* likewise for these */ -EXT OP * op; /* current op--oughta be in a global register */ - +#ifdef OP_IN_REGISTER +EXT OP * opsave; /* save current op register across longjmps */ +#else +EXT OP * op; /* current op--when not in a global register */ +#endif +EXT int (*runops) _((void)) INIT(RUNOPS_DEFAULT); EXT I32 * scopestack; /* blocks we've entered */ EXT I32 scopestack_ix; EXT I32 scopestack_max; @@ -1645,6 +1710,7 @@ EXT char * last_uni; /* position of last named-unary operator */ EXT char * last_lop; /* position of last list operator */ EXT OPCODE last_lop_op; /* last list operator */ EXT bool in_my; /* we're compiling a "my" declaration */ +EXT HV * in_my_stash; /* declared class of this "my" declaration */ #ifdef FCRYPT EXT I32 cryptseen; /* has fast crypt() been initialized? */ #endif @@ -1802,6 +1868,7 @@ IEXT HV * Idebstash; /* symbol table for perldb package */ IEXT SV * Icurstname; /* name of current package */ IEXT AV * Ibeginav; /* names of BEGIN subroutines */ IEXT AV * Iendav; /* names of END subroutines */ +IEXT AV * Iinitav; /* names of INIT subroutines */ IEXT HV * Istrtab; /* shared string table */ /* memory management */ @@ -1859,9 +1926,11 @@ IEXT I32 Irunlevel; /* stack stuff */ IEXT AV * Icurstack; /* THE STACK */ IEXT AV * Imainstack; /* the stack when nothing funny is happening */ +#if 0 IEXT SV ** Imystack_base; /* stack->array_ary */ IEXT SV ** Imystack_sp; /* stack pointer now */ IEXT SV ** Imystack_max; /* stack->array_ary + stack->array_max */ +#endif /* format accumulators */ IEXT SV * Iformtarget; @@ -1902,6 +1971,7 @@ struct interpreter { }; #endif +#include "thread.h" #include "pp.h" #ifdef __cplusplus @@ -1978,6 +2048,9 @@ EXT MGVTBL vtbl_fm = {0, magic_setfm, EXT MGVTBL vtbl_uvar = {magic_getuvar, magic_setuvar, 0, 0, 0}; +#ifdef USE_THREADS +EXT MGVTBL vtbl_mutex = {0, 0, 0, 0, magic_mutexfree}; +#endif /* USE_THREADS */ EXT MGVTBL vtbl_defelem = {magic_getdefelem,magic_setdefelem, 0, 0, magic_freedefelem}; @@ -2017,6 +2090,11 @@ EXT MGVTBL vtbl_pos; EXT MGVTBL vtbl_bm; EXT MGVTBL vtbl_fm; EXT MGVTBL vtbl_uvar; + +#ifdef USE_THREADS +EXT MGVTBL vtbl_mutex; +#endif /* USE_THREADS */ + EXT MGVTBL vtbl_defelem; #ifdef USE_LOCALE_COLLATE @@ -2217,5 +2295,18 @@ EXT bool numeric_local INIT(TRUE); /* Assume local numerics */ #define printf PerlIO_stdoutf #endif +/* + * nice_chunk and nice_chunk size need to be set + * and queried under the protection of sv_mutex + */ +#define offer_nice_chunk(chunk, chunk_size) do { \ + MUTEX_LOCK(&sv_mutex); \ + if (!nice_chunk) { \ + nice_chunk = (char*)(chunk); \ + nice_chunk_size = (chunk_size); \ + } \ + MUTEX_UNLOCK(&sv_mutex); \ + } while (0) + #endif /* Include guard */ diff --git a/perl_exp.SH b/perl_exp.SH index 06b587f9ef..06b587f9ef 100755..100644 --- a/perl_exp.SH +++ b/perl_exp.SH @@ -1284,7 +1284,7 @@ int yyerrflag; int yychar; YYSTYPE yyval; YYSTYPE yylval; -#line 631 "perly.y" +#line 632 "perly.y" /* PROGRAM */ #line 1360 "perly.c" #define YYABORT goto yyabort @@ -1763,303 +1763,304 @@ case 55: break; case 56: #line 291 "perly.y" -{ char *name = SvPVx(((SVOP*)yyvsp[0].opval)->op_sv, na); - if (strEQ(name, "BEGIN") || strEQ(name, "END")) +{ char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, na); + if (strEQ(name, "BEGIN") || strEQ(name, "END") + || strEQ(name, "INIT")) CvUNIQUE_on(compcv); yyval.opval = yyvsp[0].opval; } break; case 57: -#line 298 "perly.y" +#line 299 "perly.y" { yyval.opval = Nullop; } break; case 59: -#line 302 "perly.y" +#line 303 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 60: -#line 303 "perly.y" +#line 304 "perly.y" { yyval.opval = Nullop; expect = XSTATE; } break; case 61: -#line 307 "perly.y" +#line 308 "perly.y" { package(yyvsp[-1].opval); } break; case 62: -#line 309 "perly.y" +#line 310 "perly.y" { package(Nullop); } break; case 63: -#line 313 "perly.y" +#line 314 "perly.y" { CvUNIQUE_on(compcv); /* It's a BEGIN {} */ } break; case 64: -#line 315 "perly.y" +#line 316 "perly.y" { utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } break; case 65: -#line 319 "perly.y" +#line 320 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 66: -#line 321 "perly.y" +#line 322 "perly.y" { yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 68: -#line 326 "perly.y" +#line 327 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 69: -#line 328 "perly.y" +#line 329 "perly.y" { yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; case 71: -#line 333 "perly.y" +#line 334 "perly.y" { yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); } break; case 72: -#line 336 "perly.y" +#line 337 "perly.y" { yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); } break; case 73: -#line 339 "perly.y" +#line 340 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); } break; case 74: -#line 344 "perly.y" +#line 345 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval), newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); } break; case 75: -#line 349 "perly.y" +#line 350 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); } break; case 76: -#line 354 "perly.y" +#line 355 "perly.y" { yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 77: -#line 356 "perly.y" +#line 357 "perly.y" { yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 78: -#line 358 "perly.y" +#line 359 "perly.y" { yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 79: -#line 360 "perly.y" +#line 361 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); } break; case 82: -#line 370 "perly.y" +#line 371 "perly.y" { yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; case 83: -#line 372 "perly.y" +#line 373 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 84: -#line 374 "perly.y" +#line 375 "perly.y" { if (yyvsp[-1].ival != OP_REPEAT) scalar(yyvsp[-2].opval); yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); } break; case 85: -#line 378 "perly.y" +#line 379 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 86: -#line 380 "perly.y" +#line 381 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 87: -#line 382 "perly.y" +#line 383 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 88: -#line 384 "perly.y" +#line 385 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 89: -#line 386 "perly.y" +#line 387 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 90: -#line 388 "perly.y" +#line 389 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 91: -#line 390 "perly.y" +#line 391 "perly.y" { yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; case 92: -#line 392 "perly.y" +#line 393 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 93: -#line 394 "perly.y" +#line 395 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 94: -#line 396 "perly.y" +#line 397 "perly.y" { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; case 95: -#line 398 "perly.y" +#line 399 "perly.y" { yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; case 96: -#line 401 "perly.y" +#line 402 "perly.y" { yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; case 97: -#line 403 "perly.y" +#line 404 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 98: -#line 405 "perly.y" +#line 406 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 99: -#line 407 "perly.y" +#line 408 "perly.y" { yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; case 100: -#line 409 "perly.y" +#line 410 "perly.y" { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; case 101: -#line 411 "perly.y" +#line 412 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; case 102: -#line 414 "perly.y" +#line 415 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; case 103: -#line 417 "perly.y" +#line 418 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; case 104: -#line 420 "perly.y" +#line 421 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; case 105: -#line 423 "perly.y" +#line 424 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; case 106: -#line 425 "perly.y" +#line 426 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; case 107: -#line 427 "perly.y" +#line 428 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; case 108: -#line 429 "perly.y" +#line 430 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; case 109: -#line 431 "perly.y" +#line 432 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; case 110: -#line 433 "perly.y" +#line 434 "perly.y" { yyval.opval = newANONHASH(yyvsp[-2].opval); } break; case 111: -#line 435 "perly.y" +#line 436 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; case 112: -#line 437 "perly.y" +#line 438 "perly.y" { yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; case 113: -#line 439 "perly.y" +#line 440 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 114: -#line 441 "perly.y" +#line 442 "perly.y" { yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); } break; case 115: -#line 443 "perly.y" +#line 444 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 116: -#line 445 "perly.y" +#line 446 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; case 117: -#line 447 "perly.y" +#line 448 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 118: -#line 451 "perly.y" +#line 452 "perly.y" { assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 119: -#line 455 "perly.y" +#line 456 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 120: -#line 457 "perly.y" +#line 458 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 121: -#line 459 "perly.y" +#line 460 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; case 122: -#line 461 "perly.y" +#line 462 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 123: -#line 464 "perly.y" +#line 465 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 124: -#line 469 "perly.y" +#line 470 "perly.y" { assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 125: -#line 474 "perly.y" +#line 475 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; case 126: -#line 476 "perly.y" +#line 477 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; case 127: -#line 478 "perly.y" +#line 479 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -2067,7 +2068,7 @@ case 127: ref(yyvsp[-3].opval, OP_ASLICE))); } break; case 128: -#line 484 "perly.y" +#line 485 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2076,37 +2077,37 @@ case 128: expect = XOPERATOR; } break; case 129: -#line 491 "perly.y" +#line 492 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 130: -#line 493 "perly.y" +#line 494 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; case 131: -#line 495 "perly.y" +#line 496 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; case 132: -#line 497 "perly.y" +#line 498 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; case 133: -#line 500 "perly.y" +#line 501 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 134: -#line 503 "perly.y" +#line 504 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; case 135: -#line 505 "perly.y" +#line 506 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 136: -#line 507 "perly.y" +#line 508 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2116,7 +2117,7 @@ case 136: )),Nullop)); dep();} break; case 137: -#line 515 "perly.y" +#line 516 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2127,161 +2128,161 @@ case 137: )))); dep();} break; case 138: -#line 524 "perly.y" +#line 525 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();} break; case 139: -#line 528 "perly.y" +#line 529 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, yyvsp[-1].opval, scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();} break; case 140: -#line 533 "perly.y" +#line 534 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar(yyvsp[-3].opval))); } break; case 141: -#line 536 "perly.y" +#line 537 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, newCVREF(0, scalar(yyvsp[-4].opval)))); } break; case 142: -#line 540 "perly.y" +#line 541 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; case 143: -#line 543 "perly.y" +#line 544 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 144: -#line 545 "perly.y" +#line 546 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 145: -#line 547 "perly.y" +#line 548 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 146: -#line 549 "perly.y" +#line 550 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 147: -#line 551 "perly.y" +#line 552 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 148: -#line 553 "perly.y" +#line 554 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 149: -#line 556 "perly.y" +#line 557 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 150: -#line 558 "perly.y" +#line 559 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 151: -#line 560 "perly.y" +#line 561 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[0].opval)); } break; case 152: -#line 563 "perly.y" +#line 564 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 153: -#line 565 "perly.y" +#line 566 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 154: -#line 567 "perly.y" +#line 568 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 155: -#line 569 "perly.y" +#line 570 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 158: -#line 575 "perly.y" +#line 576 "perly.y" { yyval.opval = Nullop; } break; case 159: -#line 577 "perly.y" +#line 578 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 160: -#line 581 "perly.y" +#line 582 "perly.y" { yyval.opval = Nullop; } break; case 161: -#line 583 "perly.y" +#line 584 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 162: -#line 585 "perly.y" +#line 586 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 163: -#line 588 "perly.y" +#line 589 "perly.y" { yyval.ival = 0; } break; case 164: -#line 589 "perly.y" +#line 590 "perly.y" { yyval.ival = 1; } break; case 165: -#line 593 "perly.y" +#line 594 "perly.y" { in_my = 0; yyval.opval = my(yyvsp[0].opval); } break; case 166: -#line 597 "perly.y" +#line 598 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; case 167: -#line 601 "perly.y" +#line 602 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; case 168: -#line 605 "perly.y" +#line 606 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 169: -#line 609 "perly.y" +#line 610 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; case 170: -#line 613 "perly.y" +#line 614 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 171: -#line 617 "perly.y" +#line 618 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; case 172: -#line 621 "perly.y" +#line 622 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 173: -#line 623 "perly.y" +#line 624 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 174: -#line 625 "perly.y" +#line 626 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 175: -#line 628 "perly.y" +#line 629 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2271 "perly.c" +#line 2272 "perly.c" } yyssp -= yym; yystate = *yyssp; @@ -288,8 +288,9 @@ startformsub: /* NULL */ /* start a format subroutine scope */ { $$ = start_subparse(TRUE, 0); } ; -subname : WORD { char *name = SvPVx(((SVOP*)$1)->op_sv, na); - if (strEQ(name, "BEGIN") || strEQ(name, "END")) +subname : WORD { char *name = SvPV(((SVOP*)$1)->op_sv, na); + if (strEQ(name, "BEGIN") || strEQ(name, "END") + || strEQ(name, "INIT")) CvUNIQUE_on(compcv); $$ = $1; } ; diff --git a/pod/roffitall b/pod/roffitall index cbd19af4fe..cbd19af4fe 100755..100644 --- a/pod/roffitall +++ b/pod/roffitall @@ -396,6 +396,7 @@ SV* sv; else if (SvPADTMP(sv)) sv = newSVsv(sv); else { + dTHR; /* just for SvREFCNT_inc */ SvTEMP_off(sv); (void)SvREFCNT_inc(sv); } @@ -1461,6 +1462,7 @@ seed() #define SEED_C3 269 #define SEED_C5 26107 + dTHR; U32 u; #ifdef VMS # include <starlet.h> @@ -2118,9 +2120,11 @@ PP(pp_each) HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; + I32 realhv = (SvTYPE(hash) == SVt_PVHV); PUTBACK; - entry = hv_iternext(hash); /* might clobber stack_sp */ + /* might clobber stack_sp */ + entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash); SPAGAIN; EXTEND(SP, 2); @@ -2128,7 +2132,9 @@ PP(pp_each) PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { PUTBACK; - sv_setsv(TARG, hv_iterval(hash, entry)); /* might hit stack_sp */ + /* might clobber stack_sp */ + sv_setsv(TARG, realhv ? + hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry)); SPAGAIN; PUSHs(TARG); } @@ -2159,11 +2165,16 @@ PP(pp_delete) if (op->op_private & OPpSLICE) { dMARK; dORIGMARK; + U32 hvtype; hv = (HV*)POPs; - if (SvTYPE(hv) != SVt_PVHV) - DIE("Not a HASH reference"); + hvtype = SvTYPE(hv); while (++MARK <= SP) { - sv = hv_delete_ent(hv, *MARK, discard, 0); + if (hvtype == SVt_PVHV) + sv = hv_delete_ent(hv, *MARK, discard, 0); + else if (hvtype == SVt_PVAV) + sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0); + else + DIE("Not a HASH reference"); *MARK = sv ? sv : &sv_undef; } if (discard) @@ -2177,9 +2188,12 @@ PP(pp_delete) else { SV *keysv = POPs; hv = (HV*)POPs; - if (SvTYPE(hv) != SVt_PVHV) + if (SvTYPE(hv) == SVt_PVHV) + sv = hv_delete_ent(hv, keysv, discard, 0); + else if (SvTYPE(hv) == SVt_PVAV) + sv = avhv_delete_ent((AV*)hv, keysv, discard, 0); + else DIE("Not a HASH reference"); - sv = hv_delete_ent(hv, keysv, discard, 0); if (!sv) sv = &sv_undef; if (!discard) @@ -2193,12 +2207,15 @@ PP(pp_exists) dSP; SV *tmpsv = POPs; HV *hv = (HV*)POPs; - STRLEN len; - if (SvTYPE(hv) != SVt_PVHV) { + if (SvTYPE(hv) == SVt_PVHV) { + if (hv_exists_ent(hv, tmpsv, 0)) + RETPUSHYES; + } else if (SvTYPE(hv) == SVt_PVAV) { + if (avhv_exists_ent((AV*)hv, tmpsv, 0)) + RETPUSHYES; + } else { DIE("Not a HASH reference"); } - if (hv_exists_ent(hv, tmpsv, 0)) - RETPUSHYES; RETPUSHNO; } @@ -2208,12 +2225,18 @@ PP(pp_hslice) register HE *he; register HV *hv = (HV*)POPs; register I32 lval = op->op_flags & OPf_MOD; + I32 realhv = (SvTYPE(hv) == SVt_PVHV); - if (SvTYPE(hv) == SVt_PVHV) { + if (realhv || SvTYPE(hv) == SVt_PVAV) { while (++MARK <= SP) { SV *keysv = *MARK; - - he = hv_fetch_ent(hv, keysv, lval, 0); + SV **svp; + if (realhv) { + he = hv_fetch_ent(hv, keysv, lval, 0); + svp = he ? &HeVAL(he) : 0; + } else { + svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0); + } if (lval) { if (!he || HeVAL(he) == &sv_undef) DIE(no_helem, SvPV(keysv, na)); @@ -3950,7 +3973,11 @@ PP(pp_split) if (pm->op_pmreplroot) ary = GvAVn((GV*)pm->op_pmreplroot); else if (gimme != G_ARRAY) +#ifdef USE_THREADS + ary = (AV*)curpad[0]; +#else ary = GvAVn(defgv); +#endif /* USE_THREADS */ else ary = Nullav; if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { @@ -4132,3 +4159,50 @@ PP(pp_split) RETPUSHUNDEF; } +#ifdef USE_THREADS +void +unlock_condpair(svv) +void *svv; +{ + dTHR; + MAGIC *mg = mg_find((SV*)svv, 'm'); + + if (!mg) + croak("panic: unlock_condpair unlocking non-mutex"); + MUTEX_LOCK(MgMUTEXP(mg)); + if (MgOWNER(mg) != thr) + croak("panic: unlock_condpair unlocking mutex that we don't own"); + MgOWNER(mg) = 0; + COND_SIGNAL(MgOWNERCONDP(mg)); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n", + (unsigned long)thr, (unsigned long)svv);) + MUTEX_UNLOCK(MgMUTEXP(mg)); +} +#endif /* USE_THREADS */ + +PP(pp_lock) +{ + dSP; +#ifdef USE_THREADS + dTOPss; + MAGIC *mg; + + if (SvROK(sv)) + sv = SvRV(sv); + + mg = condpair_magic(sv); + MUTEX_LOCK(MgMUTEXP(mg)); + if (MgOWNER(mg) == thr) + MUTEX_UNLOCK(MgMUTEXP(mg)); + else { + while (MgOWNER(mg)) + COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); + MgOWNER(mg) = thr; + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", + (unsigned long)thr, (unsigned long)sv);) + MUTEX_UNLOCK(MgMUTEXP(mg)); + save_destructor(unlock_condpair, sv); + } +#endif /* USE_THREADS */ + RETURN; +} @@ -7,10 +7,15 @@ * */ +#ifdef USE_THREADS +#define ARGS thr +#define dARGS struct thread *thr; +#define PP(s) OP* s(ARGS) dARGS +#else #define ARGS -#define ARGSproto void #define dARGS #define PP(s) OP* s(ARGS) dARGS +#endif /* USE_THREADS */ #define SP sp #define MARK mark @@ -27,7 +27,7 @@ static OP *docatch _((OP *o)); static OP *doeval _((int gimme)); -static OP *dofindlabel _((OP *op, char *label, OP **opstack, OP **oplimit)); +static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit)); static void doparseform _((SV *sv)); static I32 dopoptoeval _((I32 startingblock)); static I32 dopoptolabel _((char *label)); @@ -533,8 +533,8 @@ PP(pp_grepstart) RETURNOP(op->op_next->op_next); } stack_sp = stack_base + *markstack_ptr + 1; - pp_pushmark(); /* push dst */ - pp_pushmark(); /* push src */ + pp_pushmark(ARGS); /* push dst */ + pp_pushmark(ARGS); /* push src */ ENTER; /* enter outer scope */ SAVETMPS; @@ -549,7 +549,7 @@ PP(pp_grepstart) PUTBACK; if (op->op_type == OP_MAPSTART) - pp_pushmark(); /* push top */ + pp_pushmark(ARGS); /* push top */ return ((LOGOP*)op->op_next)->op_other; } @@ -698,7 +698,7 @@ PP(pp_sort) bool oldcatch = CATCH_GET; SAVETMPS; - SAVESPTR(op); + SAVEOP(); oldstack = curstack; if (!sortstack) { @@ -850,6 +850,7 @@ static I32 dopoptolabel(label) char *label; { + dTHR; register I32 i; register CONTEXT *cx; @@ -896,6 +897,7 @@ dowantarray() I32 block_gimme() { + dTHR; I32 cxix; cxix = dopoptosub(cxstack_ix); @@ -918,6 +920,7 @@ static I32 dopoptosub(startingblock) I32 startingblock; { + dTHR; I32 i; register CONTEXT *cx; for (i = startingblock; i >= 0; i--) { @@ -938,6 +941,7 @@ static I32 dopoptoeval(startingblock) I32 startingblock; { + dTHR; I32 i; register CONTEXT *cx; for (i = startingblock; i >= 0; i--) { @@ -957,6 +961,7 @@ static I32 dopoptoloop(startingblock) I32 startingblock; { + dTHR; I32 i; register CONTEXT *cx; for (i = startingblock; i >= 0; i--) { @@ -990,6 +995,7 @@ void dounwind(cxix) I32 cxix; { + dTHR; register CONTEXT *cx; SV **newsp; I32 optype; @@ -1023,6 +1029,7 @@ OP * die_where(message) char *message; { + dTHR; if (in_eval) { I32 cxix; register CONTEXT *cx; @@ -1121,7 +1128,7 @@ PP(pp_entersubr) mark++; } *sp = cv; - return pp_entersub(); + return pp_entersub(ARGS); } #endif @@ -1227,6 +1234,7 @@ sortcv(a, b) const void *a; const void *b; { + dTHR; SV * const *str1 = (SV * const *)a; SV * const *str2 = (SV * const *)b; I32 oldsaveix = savestack_ix; @@ -1635,8 +1643,8 @@ PP(pp_redo) static OP* lastgotoprobe; static OP * -dofindlabel(op,label,opstack,oplimit) -OP *op; +dofindlabel(o,label,opstack,oplimit) +OP *o; char *label; OP **opstack; OP **oplimit; @@ -1647,24 +1655,24 @@ OP **oplimit; if (ops >= oplimit) croak(too_deep); - if (op->op_type == OP_LEAVE || - op->op_type == OP_SCOPE || - op->op_type == OP_LEAVELOOP || - op->op_type == OP_LEAVETRY) + if (o->op_type == OP_LEAVE || + o->op_type == OP_SCOPE || + o->op_type == OP_LEAVELOOP || + o->op_type == OP_LEAVETRY) { - *ops++ = cUNOP->op_first; + *ops++ = cUNOPo->op_first; if (ops >= oplimit) croak(too_deep); } *ops = 0; - if (op->op_flags & OPf_KIDS) { + if (o->op_flags & OPf_KIDS) { /* First try all the kids at this level, since that's likeliest. */ - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && kCOP->cop_label && strEQ(kCOP->cop_label, label)) return kid; } - for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid == lastgotoprobe) continue; if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && @@ -1672,8 +1680,8 @@ OP **oplimit; (ops[-1]->op_type != OP_NEXTSTATE && ops[-1]->op_type != OP_DBSTATE))) *ops++ = kid; - if (op = dofindlabel(kid, label, ops, oplimit)) - return op; + if (o = dofindlabel(kid, label, ops, oplimit)) + return o; } } *ops = 0; @@ -1735,8 +1743,10 @@ PP(pp_goto) EXTEND(stack_sp, items); /* @_ could have been extended. */ Copy(AvARRAY(av), stack_sp, items, SV*); stack_sp += items; +#ifndef USE_THREADS SvREFCNT_dec(GvAV(defgv)); GvAV(defgv) = cx->blk_sub.savearray; +#endif /* USE_THREADS */ AvREAL_off(av); av_clear(av); } @@ -1819,15 +1829,34 @@ PP(pp_goto) svp = AvARRAY(padlist); } } +#ifdef USE_THREADS + if (!cx->blk_sub.hasargs) { + AV* av = (AV*)curpad[0]; + + items = AvFILL(av) + 1; + if (items) { + /* Mark is at the end of the stack. */ + EXTEND(sp, items); + Copy(AvARRAY(av), sp + 1, items, SV*); + sp += items; + PUTBACK ; + } + } +#endif /* USE_THREADS */ SAVESPTR(curpad); curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); - if (cx->blk_sub.hasargs) { +#ifndef USE_THREADS + if (cx->blk_sub.hasargs) +#endif /* USE_THREADS */ + { AV* av = (AV*)curpad[0]; SV** ary; +#ifndef USE_THREADS cx->blk_sub.savearray = GvAV(defgv); - cx->blk_sub.argarray = av; GvAV(defgv) = (AV*)SvREFCNT_inc(av); +#endif /* USE_THREADS */ + cx->blk_sub.argarray = av; ++mark; if (items >= AvMAX(av) + 1) { @@ -1945,7 +1974,7 @@ PP(pp_goto) if (op->op_type == OP_ENTERITER) DIE("Can't \"goto\" into the middle of a foreach loop", label); - (*op->op_ppaddr)(); + (*op->op_ppaddr)(ARGS); } op = oldop; } @@ -2063,6 +2092,7 @@ static OP * docatch(o) OP *o; { + dTHR; int ret; I32 oldrunlevel = runlevel; OP *oldop = op; @@ -2099,10 +2129,12 @@ OP *o; return Nullop; } +/* With USE_THREADS, eval_owner must be held on entry to doeval */ static OP * doeval(gimme) int gimme; { + dTHR; dSP; OP *saveop = op; HV *newstash; @@ -2128,14 +2160,24 @@ int gimme; compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); CvUNIQUE_on(compcv); +#ifdef USE_THREADS + CvOWNER(compcv) = 0; + New(666, CvMUTEXP(compcv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(compcv)); +#endif /* USE_THREADS */ comppad = newAV(); + av_push(comppad, Nullsv); + curpad = AvARRAY(comppad); comppad_name = newAV(); comppad_name_fill = 0; min_intro_pending = 0; - av_push(comppad, Nullsv); - curpad = AvARRAY(comppad); padix = 0; +#ifdef USE_THREADS + av_store(comppad_name, 0, newSVpv("@_", 2)); + curpad[0] = (SV*)newAV(); + SvPADMY_on(curpad[0]); /* XXX Needed? */ +#endif /* USE_THREADS */ comppadlist = newAV(); AvREAL_off(comppadlist); @@ -2194,6 +2236,12 @@ int gimme; } SvREFCNT_dec(rs); rs = SvREFCNT_inc(nrs); +#ifdef USE_THREADS + MUTEX_LOCK(&eval_mutex); + eval_owner = 0; + COND_SIGNAL(&eval_cond); + MUTEX_UNLOCK(&eval_mutex); +#endif /* USE_THREADS */ RETPUSHUNDEF; } SvREFCNT_dec(rs); @@ -2224,8 +2272,14 @@ int gimme; /* compiled okay, so do it */ CvDEPTH(compcv) = 1; - SP = stack_base + POPMARK; /* pop original mark */ +#ifdef USE_THREADS + MUTEX_LOCK(&eval_mutex); + eval_owner = 0; + COND_SIGNAL(&eval_cond); + MUTEX_UNLOCK(&eval_mutex); +#endif /* USE_THREADS */ + RETURNOP(eval_start); } @@ -2363,6 +2417,14 @@ PP(pp_require) compiling.cop_line = 0; PUTBACK; +#ifdef USE_THREADS + MUTEX_LOCK(&eval_mutex); + if (eval_owner && eval_owner != thr) + while (eval_owner) + COND_WAIT(&eval_cond, &eval_mutex); + eval_owner = thr; + MUTEX_UNLOCK(&eval_mutex); +#endif /* USE_THREADS */ return DOCATCH(doeval(G_SCALAR)); } @@ -2415,6 +2477,14 @@ PP(pp_entereval) if (PERLDB_LINE && curstash != debstash) save_lines(GvAV(compiling.cop_filegv), linestr); PUTBACK; +#ifdef USE_THREADS + MUTEX_LOCK(&eval_mutex); + if (eval_owner && eval_owner != thr) + while (eval_owner) + COND_WAIT(&eval_cond, &eval_mutex); + eval_owner = thr; + MUTEX_UNLOCK(&eval_mutex); +#endif /* USE_THREADS */ ret = doeval(gimme); if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */ && ret != op->op_next) { /* Successive compilation. */ @@ -20,6 +20,29 @@ /* Hot code. */ +#ifdef USE_THREADS +static void +unset_cvowner(cvarg) +void *cvarg; +{ + register CV* cv = (CV *) cvarg; +#ifdef DEBUGGING + dTHR; +#endif /* DEBUGGING */ + + DEBUG_L((PerlIO_printf(PerlIO_stderr(), "0x%lx unsetting CvOWNER of 0x%lx:%s\n", + (unsigned long)thr, (unsigned long)cv, SvPEEK((SV*)cv)))); + MUTEX_LOCK(CvMUTEXP(cv)); + DEBUG_L(if (CvDEPTH(cv) != 0) + PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + CvDEPTH(cv));); + assert(thr == CvOWNER(cv)); + CvOWNER(cv) = 0; + MUTEX_UNLOCK(CvMUTEXP(cv)); + SvREFCNT_dec(cv); +} +#endif /* USE_THREADS */ + PP(pp_const) { dSP; @@ -499,7 +522,7 @@ PP(pp_rv2hv) if (SvROK(sv)) { wasref: hv = (HV*)SvRV(sv); - if (SvTYPE(hv) != SVt_PVHV) + if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) DIE("Not a HASH reference"); if (op->op_flags & OPf_REF) { SETs((SV*)hv); @@ -507,7 +530,7 @@ PP(pp_rv2hv) } } else { - if (SvTYPE(sv) == SVt_PVHV) { + if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) { hv = (HV*)sv; if (op->op_flags & OPf_REF) { SETs((SV*)hv); @@ -560,11 +583,13 @@ PP(pp_rv2hv) } else { dTARGET; + /* This bit is OK even when hv is really an AV */ if (HvFILL(hv)) sv_setpvf(TARG, "%ld/%ld", (long)HvFILL(hv), (long)HvMAX(hv) + 1); else sv_setiv(TARG, 0); + SETTARG; RETURN; } @@ -984,6 +1009,7 @@ ret_no: OP * do_readline() { + dTHR; dSP; dTARGETSTACKED; register SV *sv; STRLEN tmplen = 0; @@ -1265,16 +1291,24 @@ PP(pp_helem) { dSP; HE* he; + SV **svp; SV *keysv = POPs; HV *hv = (HV*)POPs; U32 lval = op->op_flags & OPf_MOD; U32 defer = op->op_private & OPpLVAL_DEFER; - if (SvTYPE(hv) != SVt_PVHV) + if (SvTYPE(hv) == SVt_PVHV) { + he = hv_fetch_ent(hv, keysv, lval && !defer, 0); + svp = he ? &HeVAL(he) : 0; + } + else if (SvTYPE(hv) == SVt_PVAV) { + svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0); + } + else { RETPUSHUNDEF; - he = hv_fetch_ent(hv, keysv, lval && !defer, 0); + } if (lval) { - if (!he || HeVAL(he) == &sv_undef) { + if (!svp || *svp == &sv_undef) { SV* lv; SV* key2; if (!defer) @@ -1290,15 +1324,15 @@ PP(pp_helem) RETURN; } if (op->op_private & OPpLVAL_INTRO) { - if (HvNAME(hv) && isGV(HeVAL(he))) - save_gp((GV*)HeVAL(he), !(op->op_flags & OPf_SPECIAL)); + if (HvNAME(hv) && isGV(*svp)) + save_gp((GV*)*svp, !(op->op_flags & OPf_SPECIAL)); else - save_svref(&HeVAL(he)); + save_svref(svp); } else if (op->op_private & OPpDEREF) - vivify_ref(HeVAL(he), op->op_private & OPpDEREF); + vivify_ref(*svp, op->op_private & OPpDEREF); } - PUSHs(he ? HeVAL(he) : &sv_undef); + PUSHs(svp ? *svp : &sv_undef); RETURN; } @@ -1841,6 +1875,134 @@ PP(pp_entersub) DIE("No DBsub routine"); } +#ifdef USE_THREADS + MUTEX_LOCK(CvMUTEXP(cv)); + if (CvFLAGS(cv) & CVf_LOCKED) { + MAGIC *mg; + if (CvFLAGS(cv) & CVf_METHOD) { + if (SP > stack_base + TOPMARK) + sv = *(stack_base + TOPMARK + 1); + else { + MUTEX_UNLOCK(CvMUTEXP(cv)); + croak("no argument for locked method call"); + } + if (SvROK(sv)) + sv = SvRV(sv); + } + else { + sv = (SV*)cv; + } + MUTEX_UNLOCK(CvMUTEXP(cv)); + mg = condpair_magic(sv); + MUTEX_LOCK(MgMUTEXP(mg)); + if (MgOWNER(mg) == thr) + MUTEX_UNLOCK(MgMUTEXP(mg)); + else { + while (MgOWNER(mg)) + COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); + MgOWNER(mg) = thr; + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "0x%lx: pp_entersub lock 0x%lx\n", + (unsigned long)thr, (unsigned long)sv);) + MUTEX_UNLOCK(MgMUTEXP(mg)); + save_destructor(unlock_condpair, sv); + } + MUTEX_LOCK(CvMUTEXP(cv)); + assert(CvOWNER(cv) == 0); + CvOWNER(cv) = thr; /* Assert ownership */ + SvREFCNT_inc(cv); + MUTEX_UNLOCK(CvMUTEXP(cv)); + if (CvDEPTH(cv) == 0) + SAVEDESTRUCTOR(unset_cvowner, (void*) cv); + } + else { + /* + * It's an ordinary unsynchronised CV so we must distinguish + * three cases. (1) It's ours already (and we're recursing); + * (2) it's free (but we may already be using a cached clone); + * (3) another thread owns it. Case (1) is easy: we just use it. + * Case (2) means we look for a clone--if we have one, use it + * otherwise grab ownership of cv. Case (3) means look we for a + * clone and have to create one if we don't already have one. + * Why look for a clone in case (2) when we could just grab + * ownership of cv straight away? Well, we could be recursing, + * i.e. we originally tried to enter cv while another thread + * owned it (hence we used a clone) but it has been freed up + * and we're now recursing into it. It may or may not be "better" + * to use the clone but at least CvDEPTH can be trusted. + */ + if (CvOWNER(cv) == thr) + MUTEX_UNLOCK(CvMUTEXP(cv)); + else { + /* Case (2) or (3) */ + SV **svp; + + /* + * XXX Might it be better to release CvMUTEXP(cv) while we + * do the hv_fetch? We might find someone has pinched it + * when we look again, in which case we would be in case + * (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); + if (svp) { + /* We already have a clone to use */ + MUTEX_UNLOCK(CvMUTEXP(cv)); + cv = *(CV**)svp; + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "entersub: 0x%lx already has clone 0x%lx:%s\n", + (unsigned long) thr, (unsigned long) cv, + SvPEEK((SV*)cv))); + CvOWNER(cv) = thr; + SvREFCNT_inc(cv); + if (CvDEPTH(cv) == 0) + SAVEDESTRUCTOR(unset_cvowner, (void*) cv); + } + else { + /* (2) => grab ownership of cv. (3) => make clone */ + if (!CvOWNER(cv)) { + CvOWNER(cv) = thr; + SvREFCNT_inc(cv); + MUTEX_UNLOCK(CvMUTEXP(cv)); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "entersub: 0x%lx grabbing 0x%lx:%s in stash %s\n", + (unsigned long) thr, (unsigned long) cv, + SvPEEK((SV*)cv), CvSTASH(cv) ? + HvNAME(CvSTASH(cv)) : "(none)")); + } else { + /* Make a new clone. */ + CV *clonecv; + SvREFCNT_inc(cv); /* don't let it vanish from under us */ + MUTEX_UNLOCK(CvMUTEXP(cv)); + DEBUG_L((PerlIO_printf(PerlIO_stderr(), + "entersub: 0x%lx cloning 0x%lx:%s\n", + (unsigned long) thr, (unsigned long) cv, + SvPEEK((SV*)cv)))); + /* + * We're creating a new clone so there's no race + * between the original MUTEX_UNLOCK and the + * SvREFCNT_inc since no one will be trying to undef + * it out from underneath us. At least, I don't think + * there's a race... + */ + clonecv = cv_clone(cv); + SvREFCNT_dec(cv); /* finished with this */ + hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0); + CvOWNER(clonecv) = thr; + cv = clonecv; + SvREFCNT_inc(cv); + } + DEBUG_L(if (CvDEPTH(cv) != 0) + PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + CvDEPTH(cv));); + SAVEDESTRUCTOR(unset_cvowner, (void*) cv); + } + } + } +#endif /* USE_THREADS */ + + gimme = GIMME; + if (CvXSUB(cv)) { if (CvOLDSTYLE(cv)) { I32 (*fp3)_((int,int,int)); @@ -1867,8 +2029,14 @@ PP(pp_entersub) /* Need to copy @_ to stack. Alternative may be to * switch stack to @_, and copy return values * back. This would allow popping @_ in XSUB, e.g.. XXXX */ - AV* av = GvAV(defgv); - I32 items = AvFILL(av) + 1; + AV* av; + I32 items; +#ifdef USE_THREADS + av = (AV*)curpad[0]; +#else + av = GvAV(defgv); +#endif /* USE_THREADS */ + items = AvFILL(av) + 1; if (items) { /* Mark is at the end of the stack. */ @@ -1953,19 +2121,43 @@ PP(pp_entersub) svp = AvARRAY(padlist); } } - SAVESPTR(curpad); - curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); - if (hasargs) { +#ifdef USE_THREADS + if (!hasargs) { AV* av = (AV*)curpad[0]; + + items = AvFILL(av) + 1; + if (items) { + /* Mark is at the end of the stack. */ + EXTEND(sp, items); + Copy(AvARRAY(av), sp + 1, items, SV*); + sp += items; + PUTBACK ; + } + } +#endif /* USE_THREADS */ + SAVESPTR(curpad); + curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); +#ifndef USE_THREADS + if (hasargs) +#endif /* USE_THREADS */ + { + AV* av; SV** ary; +#if 0 + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "%p entersub preparing @_\n", thr)); +#endif + av = (AV*)curpad[0]; if (AvREAL(av)) { av_clear(av); AvREAL_off(av); } +#ifndef USE_THREADS cx->blk_sub.savearray = GvAV(defgv); - cx->blk_sub.argarray = av; GvAV(defgv) = (AV*)SvREFCNT_inc(av); +#endif /* USE_THREADS */ + cx->blk_sub.argarray = av; ++MARK; if (items > AvMAX(av) + 1) { @@ -1990,6 +2182,10 @@ PP(pp_entersub) MARK++; } } +#if 0 + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "%p entersub returning %p\n", thr, CvSTART(cv))); +#endif RETURNOP(CvSTART(cv)); } } @@ -178,7 +178,8 @@ PP(pp_backtick) fp = my_popen(tmps, "r"); if (fp) { if (gimme == G_VOID) { - while (PerlIO_read(fp, tokenbuf, sizeof tokenbuf) > 0) + char tmpbuf[256]; + while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0) /*SUPPRESS 530*/ ; } @@ -533,7 +534,7 @@ PP(pp_tie) CATCH_SET(TRUE); ENTER; - SAVESPTR(op); + SAVEOP(); op = (OP *) &myop; if (PERLDB_SUB && curstash != debstash) op->op_private |= OPpENTERSUB_DB; @@ -541,7 +542,7 @@ PP(pp_tie) XPUSHs((SV*)GvCV(gv)); PUTBACK; - if (op = pp_entersub()) + if (op = pp_entersub(ARGS)) runops(); SPAGAIN; @@ -644,12 +645,12 @@ PP(pp_dbmopen) CATCH_SET(TRUE); ENTER; - SAVESPTR(op); + SAVEOP(); op = (OP *) &myop; if (PERLDB_SUB && curstash != debstash) op->op_private |= OPpENTERSUB_DB; PUTBACK; - pp_pushmark(); + pp_pushmark(ARGS); EXTEND(sp, 5); PUSHs(sv); @@ -662,7 +663,7 @@ PP(pp_dbmopen) PUSHs((SV*)GvCV(gv)); PUTBACK; - if (op = pp_entersub()) + if (op = pp_entersub(ARGS)) runops(); SPAGAIN; @@ -670,7 +671,7 @@ PP(pp_dbmopen) sp--; op = (OP *) &myop; PUTBACK; - pp_pushmark(); + pp_pushmark(ARGS); PUSHs(sv); PUSHs(left); @@ -679,7 +680,7 @@ PP(pp_dbmopen) PUSHs((SV*)GvCV(gv)); PUTBACK; - if (op = pp_entersub()) + if (op = pp_entersub(ARGS)) runops(); SPAGAIN; } @@ -834,6 +835,7 @@ void setdefout(gv) GV *gv; { + dTHR; if (gv) (void)SvREFCNT_inc(gv); if (defoutgv) @@ -921,6 +923,7 @@ CV *cv; GV *gv; OP *retop; { + dTHR; register CONTEXT *cx; I32 gimme = GIMME_V; AV* padlist = CvPADLIST(cv); @@ -13,7 +13,18 @@ bool Gv_AMupdate _((HV* stash)); OP* append_elem _((I32 optype, OP* head, OP* tail)); OP* append_list _((I32 optype, LISTOP* first, LISTOP* last)); I32 apply _((I32 type, SV** mark, SV** sp)); -void assertref _((OP* op)); +void assertref _((OP* o)); +SV* avhv_delete _((AV *ar, char* key, U32 klen, I32 flags)); +SV* avhv_delete_ent _((AV *ar, SV* keysv, I32 flags, U32 hash)); +bool avhv_exists _((AV *ar, char* key, U32 klen)); +bool avhv_exists_ent _((AV *ar, SV* keysv, U32 hash)); +SV** avhv_fetch _((AV *ar, char* key, U32 klen, I32 lval)); +SV** avhv_fetch_ent _((AV *ar, SV* keysv, I32 lval, U32 hash)); +I32 avhv_iterinit _((AV *ar)); +HE* avhv_iternext _((AV *ar)); +SV * avhv_iternextsv _((AV *ar, char** key, I32* retlen)); +SV* avhv_iterval _((AV *ar, HE* entry)); +SV** avhv_store _((AV *ar, char* key, U32 klen, SV* val, U32 hash)); void av_clear _((AV* ar)); void av_extend _((AV* ar, I32 key)); AV* av_fake _((I32 size, SV** svp)); @@ -41,8 +52,11 @@ U32 cast_ulong _((double f)); I32 my_chsize _((int fd, Off_t length)); #endif OP* ck_gvconst _((OP* o)); -OP* ck_retarget _((OP* op)); -OP* convert _((I32 optype, I32 flags, OP* op)); +OP* ck_retarget _((OP* o)); +#ifdef USE_THREADS +MAGIC * condpair_magic _((SV *sv)); +#endif +OP* convert _((I32 optype, I32 flags, OP* o)); void croak _((const char* pat,...)) __attribute__((noreturn)); void cv_ckproto _((CV* cv, GV* gv, char* p)); CV* cv_clone _((CV* proto)); @@ -57,7 +71,7 @@ I32 filter_read _((int idx, SV* buffer, int maxlen)); I32 cxinc _((void)); void deb _((const char* pat,...)) __attribute__((format(printf,1,2))); void deb_growlevel _((void)); -I32 debop _((OP* op)); +I32 debop _((OP* o)); I32 debstackptrs _((void)); #ifdef DEBUGGING void debprofdump _((void)); @@ -80,7 +94,7 @@ I32 do_ipcctl _((I32 optype, SV** mark, SV** sp)); I32 do_ipcget _((I32 optype, SV** mark, SV** sp)); #endif void do_join _((SV* sv, SV* del, SV** mark, SV** sp)); -OP* do_kv _((void)); +OP* do_kv _((ARGSproto)); #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) I32 do_msgrcv _((SV** mark, SV** sp)); I32 do_msgsnd _((SV** mark, SV** sp)); @@ -123,7 +137,7 @@ OP* force_list _((OP* arg)); OP* fold_constants _((OP* arg)); char* form _((const char* pat, ...)); void free_tmps _((void)); -OP* gen_constant_list _((OP* op)); +OP* gen_constant_list _((OP* o)); void gp_free _((GV* gv)); GP* gp_ref _((GP* gp)); GV* gv_AVadd _((GV* gv)); @@ -168,6 +182,7 @@ void hv_undef _((HV* tb)); I32 ibcmp _((char* a, char* b, I32 len)); I32 ibcmp_locale _((char* a, char* b, I32 len)); I32 ingroup _((I32 testgid, I32 effective)); +void init_stacks _((ARGSproto)); U32 intro_my _((void)); char* instr _((char* big, char* little)); bool io_close _((IO* io)); @@ -177,7 +192,7 @@ I32 keyword _((char* d, I32 len)); void leave_scope _((I32 base)); void lex_end _((void)); void lex_start _((SV* line)); -OP* linklist _((OP* op)); +OP* linklist _((OP* o)); OP* list _((OP* o)); OP* listkids _((OP* o)); OP* localize _((OP* arg, I32 lexical)); @@ -198,6 +213,9 @@ int magic_getsig _((SV* sv, MAGIC* mg)); int magic_gettaint _((SV* sv, MAGIC* mg)); int magic_getuvar _((SV* sv, MAGIC* mg)); U32 magic_len _((SV* sv, MAGIC* mg)); +#ifdef USE_THREADS +int magic_mutexfree _((SV* sv, MAGIC* mg)); +#endif /* USE_THREADS */ int magic_nextpack _((SV* sv, MAGIC* mg, SV* key)); int magic_set _((SV* sv, MAGIC* mg)); #ifdef OVERLOAD @@ -239,9 +257,9 @@ int mg_get _((SV* sv)); U32 mg_len _((SV* sv)); void mg_magical _((SV* sv)); int mg_set _((SV* sv)); -OP* mod _((OP* op, I32 type)); +OP* mod _((OP* o, I32 type)); char* moreswitches _((char* s)); -OP* my _((OP* op)); +OP* my _((OP* o)); #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) char* my_bcopy _((char* from, char* to, I32 len)); #endif @@ -250,7 +268,7 @@ char* my_bzero _((char* loc, I32 len)); #endif void my_exit _((U32 status)) __attribute__((noreturn)); void my_failure_exit _((void)) __attribute__((noreturn)); -I32 my_lstat _((void)); +I32 my_lstat _((ARGSproto)); #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) I32 my_memcmp _((char* s1, char* s2, I32 len)); #endif @@ -260,30 +278,30 @@ void* my_memset _((char* loc, I32 ch, I32 len)); I32 my_pclose _((PerlIO* ptr)); PerlIO* my_popen _((char* cmd, char* mode)); void my_setenv _((char* nam, char* val)); -I32 my_stat _((void)); +I32 my_stat _((ARGSproto)); #ifdef MYSWAP short my_swap _((short s)); long my_htonl _((long l)); long my_ntohl _((long l)); #endif void my_unexec _((void)); -OP* newANONLIST _((OP* op)); -OP* newANONHASH _((OP* op)); +OP* newANONLIST _((OP* o)); +OP* newANONHASH _((OP* o)); OP* newANONSUB _((I32 floor, OP* proto, OP* block)); OP* newASSIGNOP _((I32 flags, OP* left, I32 optype, OP* right)); OP* newCONDOP _((I32 flags, OP* expr, OP* trueop, OP* falseop)); -void newFORM _((I32 floor, OP* op, OP* block)); +void newFORM _((I32 floor, OP* o, OP* block)); OP* newFOROP _((I32 flags, char* label, line_t forline, OP* scalar, OP* expr, OP*block, OP*cont)); OP* newLOGOP _((I32 optype, I32 flags, OP* left, OP* right)); OP* newLOOPEX _((I32 type, OP* label)); OP* newLOOPOP _((I32 flags, I32 debuggable, OP* expr, OP* block)); OP* newNULLLIST _((void)); OP* newOP _((I32 optype, I32 flags)); -void newPROG _((OP* op)); +void newPROG _((OP* o)); OP* newRANGE _((I32 flags, OP* left, OP* right)); OP* newSLICEOP _((I32 flags, OP* subscript, OP* list)); OP* newSTATEOP _((I32 flags, char* label, OP* o)); -CV* newSUB _((I32 floor, OP* op, OP* proto, OP* block)); +CV* newSUB _((I32 floor, OP* o, OP* proto, OP* block)); CV* newXS _((char* name, void (*subaddr)(CV* cv), char* filename)); #ifdef DEPRECATED CV* newXSUB _((char* name, I32 ix, I32 (*subaddr)(int,int,int), char* filename)); @@ -321,7 +339,7 @@ PerlIO* nextargv _((GV* gv)); char* ninstr _((char* big, char* bigend, char* little, char* lend)); OP* oopsCV _((OP* o)); void op_free _((OP* arg)); -void package _((OP* op)); +void package _((OP* o)); PADOFFSET pad_alloc _((I32 optype, U32 tmptype)); PADOFFSET pad_allocmy _((char* name)); PADOFFSET pad_findmy _((char* name)); @@ -332,7 +350,7 @@ SV* pad_sv _((PADOFFSET po)); void pad_free _((PADOFFSET po)); void pad_reset _((void)); void pad_swipe _((PADOFFSET po)); -void peep _((OP* op)); +void peep _((OP* o)); PerlInterpreter* perl_alloc _((void)); I32 perl_call_argv _((char* subname, I32 flags, char** argv)); I32 perl_call_method _((char* methname, I32 flags)); @@ -361,27 +379,26 @@ int perl_run _((PerlInterpreter* sv_interp)); void pidgone _((int pid, int status)); void pmflag _((U16* pmfl, int ch)); OP* pmruntime _((OP* pm, OP* expr, OP* repl)); -OP* pmtrans _((OP* op, OP* expr, OP* repl)); +OP* pmtrans _((OP* o, OP* expr, OP* repl)); OP* pop_return _((void)); void pop_scope _((void)); OP* prepend_elem _((I32 optype, OP* head, OP* tail)); -void push_return _((OP* op)); +void push_return _((OP* o)); void push_scope _((void)); regexp* pregcomp _((char* exp, char* xend, PMOP* pm)); -OP* ref _((OP* op, I32 type)); -OP* refkids _((OP* op, I32 type)); +OP* ref _((OP* o, I32 type)); +OP* refkids _((OP* o, I32 type)); void regdump _((regexp* r)); I32 pregexec _((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, I32 safebase)); void pregfree _((struct regexp* r)); char* regnext _((char* p)); -void regprop _((SV* sv, char* op)); +void regprop _((SV* sv, char* o)); void repeatcpy _((char* to, char* from, I32 len, I32 count)); char* rninstr _((char* big, char* bigend, char* little, char* lend)); Sighandler_t rsignal _((int, Sighandler_t)); int rsignal_restore _((int, Sigsave_t*)); int rsignal_save _((int, Sighandler_t, Sigsave_t*)); Sighandler_t rsignal_state _((int)); -int runops _((void)); void rxres_free _((void** rsp)); void rxres_restore _((void** rsp, REGEXP* rx)); void rxres_save _((void** rsp, REGEXP* rx)); @@ -399,7 +416,7 @@ void save_delete _((HV* hv, char* key, I32 klen)); void save_destructor _((void (*f)(void*), void* p)); #endif /* titan */ void save_freesv _((SV* sv)); -void save_freeop _((OP* op)); +void save_freeop _((OP* o)); void save_freepv _((char* pv)); void save_gp _((GV* gv, I32 empty)); HV* save_hash _((GV* gv)); @@ -412,15 +429,16 @@ void save_iv _((IV* iv)); void save_list _((SV** sarg, I32 maxsarg)); void save_long _((long* longp)); void save_nogv _((GV* gv)); +void save_op _((void)); SV* save_scalar _((GV* gv)); void save_pptr _((char** pptr)); void save_sptr _((SV** sptr)); SV* save_svref _((SV** sptr)); OP* sawparens _((OP* o)); OP* scalar _((OP* o)); -OP* scalarkids _((OP* op)); +OP* scalarkids _((OP* o)); OP* scalarseq _((OP* o)); -OP* scalarvoid _((OP* op)); +OP* scalarvoid _((OP* o)); UV scan_hex _((char* start, I32 len, I32* retlen)); char* scan_num _((char* s)); UV scan_oct _((char* start, I32 len, I32* retlen)); @@ -517,6 +535,9 @@ void taint_proper _((const char* f, char* s)); #ifdef UNLINK_ALL_VERSIONS I32 unlnk _((char* f)); #endif +#ifdef USE_THREADS +void unlock_condpair _((void* svv)); +#endif void unsharepvn _((char* sv, I32 len, U32 hash)); void unshare_hek _((HEK* hek)); void utilize _((int aver, I32 floor, OP* version, OP* id, OP* arg)); @@ -58,6 +58,10 @@ #include "INTERN.h" #include "regcomp.h" +#ifdef USE_THREADS +#undef op +#endif /* USE_THREADS */ + #ifdef MSDOS # if defined(BUGGY_MSC6) /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */ @@ -1595,14 +1599,14 @@ regexp *r; - regprop - printable representation of opcode */ void -regprop(sv, op) +regprop(sv, o) SV *sv; -char *op; +char *o; { register char *p = 0; sv_setpv(sv, ":"); - switch (OP(op)) { + switch (OP(o)) { case BOL: p = "BOL"; break; @@ -1664,25 +1668,25 @@ char *op; p = "NBOUNDL"; break; case CURLY: - sv_catpvf(sv, "CURLY {%d,%d}", ARG1(op), ARG2(op)); + sv_catpvf(sv, "CURLY {%d,%d}", ARG1(o), ARG2(o)); break; case CURLYX: - sv_catpvf(sv, "CURLYX {%d,%d}", ARG1(op), ARG2(op)); + sv_catpvf(sv, "CURLYX {%d,%d}", ARG1(o), ARG2(o)); break; case REF: - sv_catpvf(sv, "REF%d", ARG1(op)); + sv_catpvf(sv, "REF%d", ARG1(o)); break; case REFF: - sv_catpvf(sv, "REFF%d", ARG1(op)); + sv_catpvf(sv, "REFF%d", ARG1(o)); break; case REFFL: - sv_catpvf(sv, "REFFL%d", ARG1(op)); + sv_catpvf(sv, "REFFL%d", ARG1(o)); break; case OPEN: - sv_catpvf(sv, "OPEN%d", ARG1(op)); + sv_catpvf(sv, "OPEN%d", ARG1(o)); break; case CLOSE: - sv_catpvf(sv, "CLOSE%d", ARG1(op)); + sv_catpvf(sv, "CLOSE%d", ARG1(o)); p = NULL; break; case STAR: @@ -89,6 +89,7 @@ static CHECKPOINT regcppush(parenfloor) I32 parenfloor; { + dTHR; int retval = savestack_ix; int i = (regsize - parenfloor) * 3; int p; @@ -110,6 +111,7 @@ I32 parenfloor; static char * regcppop() { + dTHR; I32 i = SSPOPINT; U32 paren = 0; char *input; @@ -145,6 +147,7 @@ regcppop() static void regcppartblow() { + dTHR; I32 i = SSPOPINT; U32 paren; char *startp; @@ -902,6 +905,7 @@ char *prog; *reglastparen = n; break; case CURLYX: { + dTHR; CURCUR cc; CHECKPOINT cp = savestack_ix; cc.oldcc = regcc; @@ -19,25 +19,24 @@ dEXT char **watchaddr = 0; dEXT char *watchok; -#ifndef DEBUGGING - int -runops() { +runops_standard() { + dTHR; SAVEI32(runlevel); runlevel++; - while ( op = (*op->op_ppaddr)() ) ; + while ( op = (*op->op_ppaddr)(ARGS) ) ; TAINT_NOT; return 0; } -#else - -static void debprof _((OP*op)); +#ifdef DEBUGGING +static void debprof _((OP*o)); int -runops() { +runops_debug() { + dTHR; if (!op) { warn("NULL OP IN RUN"); return 0; @@ -55,27 +54,27 @@ runops() { DEBUG_t(debop(op)); DEBUG_P(debprof(op)); } - } while ( op = (*op->op_ppaddr)() ); + } while ( op = (*op->op_ppaddr)(ARGS) ); TAINT_NOT; return 0; } I32 -debop(op) -OP *op; +debop(o) +OP *o; { SV *sv; - deb("%s", op_name[op->op_type]); - switch (op->op_type) { + deb("%s", op_name[o->op_type]); + switch (o->op_type) { case OP_CONST: - PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOP->op_sv)); + PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo->op_sv)); break; case OP_GVSV: case OP_GV: - if (cGVOP->op_gv) { + if (cGVOPo->op_gv) { sv = NEWSV(0,0); - gv_fullname3(sv, cGVOP->op_gv, Nullch); + gv_fullname3(sv, cGVOPo->op_gv, Nullch); PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, na)); SvREFCNT_dec(sv); } @@ -100,12 +99,12 @@ char **addr; } static void -debprof(op) -OP* op; +debprof(o) +OP* o; { if (!profiledata) New(000, profiledata, MAXO, U32); - ++profiledata[op->op_type]; + ++profiledata[o->op_type]; } void @@ -21,6 +21,7 @@ SV** sp; SV** p; int n; { + dTHR; stack_sp = sp; av_extend(curstack, (p - stack_base) + (n) + 128); return stack_sp; @@ -29,6 +30,7 @@ int n; I32 cxinc() { + dTHR; cxstack_max = cxstack_max * 3 / 2; Renew(cxstack, cxstack_max + 1, CONTEXT); /* XXX should fix CXINC macro */ return cxstack_ix + 1; @@ -38,6 +40,7 @@ void push_return(retop) OP *retop; { + dTHR; if (retstack_ix == retstack_max) { retstack_max = retstack_max * 3 / 2; Renew(retstack, retstack_max, OP*); @@ -48,6 +51,7 @@ OP *retop; OP * pop_return() { + dTHR; if (retstack_ix > 0) return retstack[--retstack_ix]; else @@ -57,6 +61,7 @@ pop_return() void push_scope() { + dTHR; if (scopestack_ix == scopestack_max) { scopestack_max = scopestack_max * 3 / 2; Renew(scopestack, scopestack_max, I32); @@ -68,6 +73,7 @@ push_scope() void pop_scope() { + dTHR; I32 oldsave = scopestack[--scopestack_ix]; LEAVE_SCOPE(oldsave); } @@ -75,6 +81,7 @@ pop_scope() void markstack_grow() { + dTHR; I32 oldmax = markstack_max - markstack; I32 newmax = oldmax * 3 / 2; @@ -86,6 +93,7 @@ markstack_grow() void savestack_grow() { + dTHR; savestack_max = savestack_max * 3 / 2; Renew(savestack, savestack_max, ANY); } @@ -93,6 +101,7 @@ savestack_grow() void free_tmps() { + dTHR; /* XXX should tmps_floor live in cxstack? */ I32 myfloor = tmps_floor; while (tmps_ix > myfloor) { /* clean up after last statement */ @@ -111,6 +120,7 @@ static SV * save_scalar_at(sptr) SV **sptr; { + dTHR; register SV *sv; SV *osv = *sptr; @@ -142,6 +152,7 @@ SV * save_scalar(gv) GV *gv; { + dTHR; SSCHECK(3); SSPUSHPTR(gv); SSPUSHPTR(GvSV(gv)); @@ -153,6 +164,7 @@ SV* save_svref(sptr) SV **sptr; { + dTHR; SSCHECK(3); SSPUSHPTR(sptr); SSPUSHPTR(*sptr); @@ -165,6 +177,7 @@ save_gp(gv, empty) GV *gv; I32 empty; { + dTHR; SSCHECK(3); SSPUSHPTR(SvREFCNT_inc(gv)); SSPUSHPTR(GvGP(gv)); @@ -188,6 +201,7 @@ AV * save_ary(gv) GV *gv; { + dTHR; SSCHECK(3); SSPUSHPTR(gv); SSPUSHPTR(GvAVn(gv)); @@ -201,6 +215,7 @@ HV * save_hash(gv) GV *gv; { + dTHR; SSCHECK(3); SSPUSHPTR(gv); SSPUSHPTR(GvHVn(gv)); @@ -214,6 +229,7 @@ void save_item(item) register SV *item; { + dTHR; register SV *sv; SSCHECK(3); @@ -228,6 +244,7 @@ void save_int(intp) int *intp; { + dTHR; SSCHECK(3); SSPUSHINT(*intp); SSPUSHPTR(intp); @@ -238,6 +255,7 @@ void save_long(longp) long *longp; { + dTHR; SSCHECK(3); SSPUSHLONG(*longp); SSPUSHPTR(longp); @@ -248,6 +266,7 @@ void save_I32(intp) I32 *intp; { + dTHR; SSCHECK(3); SSPUSHINT(*intp); SSPUSHPTR(intp); @@ -258,6 +277,7 @@ void save_I16(intp) I16 *intp; { + dTHR; SSCHECK(3); SSPUSHINT(*intp); SSPUSHPTR(intp); @@ -268,6 +288,7 @@ void save_iv(ivp) IV *ivp; { + dTHR; SSCHECK(3); SSPUSHIV(*ivp); SSPUSHPTR(ivp); @@ -281,6 +302,7 @@ void save_pptr(pptr) char **pptr; { + dTHR; SSCHECK(3); SSPUSHPTR(*pptr); SSPUSHPTR(pptr); @@ -291,6 +313,7 @@ void save_sptr(sptr) SV **sptr; { + dTHR; SSCHECK(3); SSPUSHPTR(*sptr); SSPUSHPTR(sptr); @@ -301,6 +324,7 @@ void save_nogv(gv) GV *gv; { + dTHR; SSCHECK(2); SSPUSHPTR(gv); SSPUSHINT(SAVEt_NSTAB); @@ -310,6 +334,7 @@ void save_hptr(hptr) HV **hptr; { + dTHR; SSCHECK(3); SSPUSHPTR(*hptr); SSPUSHPTR(hptr); @@ -320,6 +345,7 @@ void save_aptr(aptr) AV **aptr; { + dTHR; SSCHECK(3); SSPUSHPTR(*aptr); SSPUSHPTR(aptr); @@ -330,17 +356,19 @@ void save_freesv(sv) SV *sv; { + dTHR; SSCHECK(2); SSPUSHPTR(sv); SSPUSHINT(SAVEt_FREESV); } void -save_freeop(op) -OP *op; +save_freeop(o) +OP *o; { + dTHR; SSCHECK(2); - SSPUSHPTR(op); + SSPUSHPTR(o); SSPUSHINT(SAVEt_FREEOP); } @@ -348,6 +376,7 @@ void save_freepv(pv) char *pv; { + dTHR; SSCHECK(2); SSPUSHPTR(pv); SSPUSHINT(SAVEt_FREEPV); @@ -357,6 +386,7 @@ void save_clearsv(svp) SV** svp; { + dTHR; SSCHECK(2); SSPUSHLONG((long)(svp-curpad)); SSPUSHINT(SAVEt_CLEARSV); @@ -368,6 +398,7 @@ HV *hv; char *key; I32 klen; { + dTHR; SSCHECK(4); SSPUSHINT(klen); SSPUSHPTR(key); @@ -380,6 +411,7 @@ save_list(sarg,maxsarg) register SV **sarg; I32 maxsarg; { + dTHR; register SV *sv; register I32 i; @@ -398,6 +430,7 @@ save_destructor(f,p) void (*f) _((void*)); void* p; { + dTHR; SSCHECK(3); SSPUSHDPTR(f); SSPUSHPTR(p); @@ -405,9 +438,19 @@ void* p; } void +save_op() +{ + dTHR; + SSCHECK(2); + SSPUSHPTR(op); + SSPUSHINT(SAVEt_OP); +} + +void leave_scope(base) I32 base; { + dTHR; register SV *sv; register SV *value; register GV *gv; @@ -603,6 +646,9 @@ I32 base; stack_sp = stack_base + delta; } break; + case SAVEt_OP: + op = (OP*)SSPOPPTR; + break; default: croak("panic: leave_scope inconsistency"); } @@ -615,6 +661,7 @@ void cx_dump(cx) CONTEXT* cx; { + dTHR; PerlIO_printf(Perl_debug_log, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]); if (cx->cx_type != CXt_SUBST) { PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); @@ -22,6 +22,7 @@ #define SAVEt_REGCONTEXT 21 #define SAVEt_STACK_POS 22 #define SAVEt_I16 23 +#define SAVEt_OP 24 #define SSCHECK(need) if (savestack_ix + need > savestack_max) savestack_grow() #define SSPUSHINT(i) (savestack[savestack_ix++].any_i32 = (I32)(i)) @@ -69,7 +70,7 @@ SSPUSHINT(stack_sp - stack_base); \ SSPUSHINT(SAVEt_STACK_POS); \ } STMT_END - +#define SAVEOP() save_op() /* A jmpenv packages the state required to perform a proper non-local jump. * Note that there is a start_env initialized when perl starts, and top_env @@ -95,11 +96,21 @@ struct jmpenv { typedef struct jmpenv JMPENV; +#ifdef OP_IN_REGISTER +#define OP_REG_TO_MEM opsave = op +#define OP_MEM_TO_REG op = opsave +#else +#define OP_REG_TO_MEM NOOP +#define OP_MEM_TO_REG NOOP +#endif + #define dJMPENV JMPENV cur_env #define JMPENV_PUSH(v) \ STMT_START { \ cur_env.je_prev = top_env; \ + OP_REG_TO_MEM; \ cur_env.je_ret = Sigsetjmp(cur_env.je_buf, 1); \ + OP_MEM_TO_REG; \ top_env = &cur_env; \ cur_env.je_mustcatch = FALSE; \ (v) = cur_env.je_ret; \ @@ -108,6 +119,7 @@ typedef struct jmpenv JMPENV; STMT_START { top_env = cur_env.je_prev; } STMT_END #define JMPENV_JUMP(v) \ STMT_START { \ + OP_REG_TO_MEM; \ if (top_env->je_prev) \ Siglongjmp(top_env->je_buf, (v)); \ if ((v) == 2) \ @@ -57,6 +57,7 @@ static void del_xpv _((XPV* p)); static void del_xrv _((XRV* p)); static void sv_mortalgrow _((void)); static void sv_unglob _((SV* sv)); +static void sv_check_thinkfirst _((SV *sv)); typedef void (*SVFUNC) _((SV*)); @@ -64,14 +65,18 @@ typedef void (*SVFUNC) _((SV*)); #define new_SV(p) \ do { \ + MUTEX_LOCK(&sv_mutex); \ (p) = (SV*)safemalloc(sizeof(SV)); \ reg_add(p); \ + MUTEX_UNLOCK(&sv_mutex); \ } while (0) #define del_SV(p) \ do { \ + MUTEX_LOCK(&sv_mutex); \ reg_remove(p); \ free((char*)(p)); \ + MUTEX_UNLOCK(&sv_mutex); \ } while (0) static SV **registry; @@ -170,6 +175,7 @@ U32 flags; --sv_count; \ } while (0) +/* sv_mutex must be held while calling uproot_SV() */ #define uproot_SV(p) \ do { \ (p) = sv_root; \ @@ -177,19 +183,25 @@ U32 flags; ++sv_count; \ } while (0) -#define new_SV(p) \ - if (sv_root) \ - uproot_SV(p); \ - else \ - (p) = more_sv() +#define new_SV(p) do { \ + MUTEX_LOCK(&sv_mutex); \ + if (sv_root) \ + uproot_SV(p); \ + else \ + (p) = more_sv(); \ + MUTEX_UNLOCK(&sv_mutex); \ + } while (0) #ifdef DEBUGGING -#define del_SV(p) \ - if (debug & 32768) \ - del_sv(p); \ - else \ - plant_SV(p) +#define del_SV(p) do { \ + MUTEX_LOCK(&sv_mutex); \ + if (debug & 32768) \ + del_sv(p); \ + else \ + plant_SV(p); \ + MUTEX_UNLOCK(&sv_mutex); \ + } while (0) static void del_sv(p) @@ -250,6 +262,7 @@ U32 flags; SvFLAGS(sv) = SVTYPEMASK; } +/* sv_mutex must be held while calling more_sv() */ static SV* more_sv() { @@ -1092,12 +1105,7 @@ sv_setiv(sv,i) register SV *sv; IV i; { - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); - } + sv_check_thinkfirst(sv); switch (SvTYPE(sv)) { case SVt_NULL: sv_upgrade(sv, SVt_IV); @@ -1121,8 +1129,11 @@ IV i; case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: - croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), - op_desc[op->op_type]); + { + dTHR; + croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), + op_desc[op->op_type]); + } } (void)SvIOK_only(sv); /* validate number */ SvIVX(sv) = i; @@ -1145,12 +1156,7 @@ sv_setnv(sv,num) register SV *sv; double num; { - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); - } + sv_check_thinkfirst(sv); switch (SvTYPE(sv)) { case SVt_NULL: case SVt_IV: @@ -1180,8 +1186,11 @@ double num; case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: - croak("Can't coerce %s to number in %s", sv_reftype(sv,0), - op_name[op->op_type]); + { + dTHR; + croak("Can't coerce %s to number in %s", sv_reftype(sv,0), + op_name[op->op_type]); + } } SvNVX(sv) = num; (void)SvNOK_only(sv); /* validate number */ @@ -1192,6 +1201,7 @@ static void not_a_number(sv) SV *sv; { + dTHR; char tmpbuf[64]; char *d = tmpbuf; char *s; @@ -1262,6 +1272,7 @@ register SV *sv; if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); if (!SvROK(sv)) { + dTHR; /* just for localizing */ if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0; @@ -1313,6 +1324,7 @@ register SV *sv; SvIVX(sv) = asIV(sv); } else { + dTHR; if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0; @@ -1337,6 +1349,7 @@ register SV *sv; if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); if (!SvROK(sv)) { + dTHR; /* just for localizing */ if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0; @@ -1382,6 +1395,7 @@ register SV *sv; SvUVX(sv) = asUV(sv); } else { + dTHR; /* just for localizing */ if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0; @@ -1410,6 +1424,7 @@ register SV *sv; if (SvIOKp(sv)) return (double)SvIVX(sv); if (!SvROK(sv)) { + dTHR; /* just for localizing */ if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0; @@ -1461,6 +1476,7 @@ register SV *sv; SvNVX(sv) = atof(SvPVX(sv)); } else { + dTHR; if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); return 0.0; @@ -1595,6 +1611,7 @@ STRLEN *lp; register char *s; int olderrno; SV *tsv; + char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ if (!sv) { *lp = 0; @@ -1607,17 +1624,18 @@ STRLEN *lp; return SvPVX(sv); } if (SvIOKp(sv)) { - (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv)); + (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); tsv = Nullsv; goto tokensave; } if (SvNOKp(sv)) { SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); + Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); tsv = Nullsv; goto tokensave; } if (!SvROK(sv)) { + dTHR; /* just for localizing */ if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); *lp = 0; @@ -1668,12 +1686,12 @@ STRLEN *lp; if (SvREADONLY(sv)) { if (SvNOKp(sv)) { SET_NUMERIC_STANDARD(); - Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf); + Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); tsv = Nullsv; goto tokensave; } if (SvIOKp(sv)) { - (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv)); + (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); tsv = Nullsv; goto tokensave; } @@ -1725,6 +1743,7 @@ STRLEN *lp; SvIOKp_on(sv); } else { + dTHR; if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) warn(warn_uninit); *lp = 0; @@ -1742,7 +1761,7 @@ STRLEN *lp; tokensaveref: if (!tsv) - tsv = newSVpv(tokenbuf, 0); + tsv = newSVpv(tmpbuf, 0); sv_2mortal(tsv); *lp = SvCUR(tsv); return SvPVX(tsv); @@ -1757,8 +1776,8 @@ STRLEN *lp; len = SvCUR(tsv); } else { - t = tokenbuf; - len = strlen(tokenbuf); + t = tmpbuf; + len = strlen(tmpbuf); } #ifdef FIXNEGATIVEZERO if (len == 2 && t[0] == '-' && t[1] == '0') { @@ -1789,6 +1808,7 @@ register SV *sv; if (SvROK(sv)) { #ifdef OVERLOAD { + dTHR; SV* tmpsv; if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_))) return SvTRUE(tmpsv); @@ -1797,11 +1817,11 @@ register SV *sv; return SvRV(sv) != 0; } if (SvPOKp(sv)) { - register XPV* Xpv; - if ((Xpv = (XPV*)SvANY(sv)) && - (*Xpv->xpv_pv > '0' || - Xpv->xpv_cur > 1 || - (Xpv->xpv_cur && *Xpv->xpv_pv != '0'))) + register XPV* Xpvtmp; + if ((Xpvtmp = (XPV*)SvANY(sv)) && + (*Xpvtmp->xpv_pv > '0' || + Xpvtmp->xpv_cur > 1 || + (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0'))) return 1; else return 0; @@ -1828,18 +1848,14 @@ sv_setsv(dstr,sstr) SV *dstr; register SV *sstr; { + dTHR; register U32 sflags; register int dtype; register int stype; if (sstr == dstr) return; - if (SvTHINKFIRST(dstr)) { - if (SvREADONLY(dstr) && curcop != &compiling) - croak(no_modify); - if (SvROK(dstr)) - sv_unref(dstr); - } + sv_check_thinkfirst(dstr); if (!sstr) sstr = &sv_undef; stype = SvTYPE(sstr); @@ -1971,6 +1987,7 @@ register SV *sstr; if (sflags & SVf_ROK) { if (dtype >= SVt_PV) { if (dtype == SVt_PVGV) { + dTHR; SV *sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = 0; int intro = GvINTRO(dstr); @@ -2171,12 +2188,7 @@ register STRLEN len; { assert(len >= 0); /* STRLEN is probably unsigned, so this may elicit a warning, but it won't hurt. */ - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); - } + sv_check_thinkfirst(sv); if (!ptr) { (void)SvOK_off(sv); return; @@ -2202,12 +2214,7 @@ register const char *ptr; { register STRLEN len; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); - } + sv_check_thinkfirst(sv); if (!ptr) { (void)SvOK_off(sv); return; @@ -2232,12 +2239,7 @@ register SV *sv; register char *ptr; register STRLEN len; { - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); - } + sv_check_thinkfirst(sv); if (!SvUPGRADE(sv, SVt_PV)) return; if (!ptr) { @@ -2255,6 +2257,21 @@ register STRLEN len; SvTAINT(sv); } +static void +sv_check_thinkfirst(sv) +register SV *sv; +{ + if (SvTHINKFIRST(sv)) { + if (SvREADONLY(sv)) { + dTHR; + if (curcop != &compiling) + croak(no_modify); + } + if (SvROK(sv)) + sv_unref(sv); + } +} + void sv_chop(sv,ptr) /* like set but assuming ptr is in sv */ register SV *sv; @@ -2264,12 +2281,7 @@ register char *ptr; if (!ptr || !SvPOKp(sv)) return; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); - } + sv_check_thinkfirst(sv); if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv,SVt_PVIV); @@ -2374,8 +2386,11 @@ I32 namlen; { MAGIC* mg; - if (SvREADONLY(sv) && curcop != &compiling && !strchr("gBf", how)) - croak(no_modify); + if (SvREADONLY(sv)) { + dTHR; + if (curcop != &compiling && !strchr("gBf", how)) + croak(no_modify); + } if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { if (how == 't') @@ -2394,6 +2409,7 @@ I32 namlen; if (!obj || obj == sv || how == '#') mg->mg_obj = obj; else { + dTHR; mg->mg_obj = SvREFCNT_inc(obj); mg->mg_flags |= MGf_REFCOUNTED; } @@ -2402,8 +2418,10 @@ I32 namlen; if (name) if (namlen >= 0) mg->mg_ptr = savepvn(name, namlen); - else if (namlen == HEf_SVKEY) + else if (namlen == HEf_SVKEY) { + dTHR; /* just for SvREFCNT_inc */ mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name); + } switch (how) { case 0: @@ -2451,6 +2469,11 @@ I32 namlen; case 'l': mg->mg_virtual = &vtbl_dbline; break; +#ifdef USE_THREADS + case 'm': + mg->mg_virtual = &vtbl_mutex; + break; +#endif /* USE_THREADS */ #ifdef USE_LOCALE_COLLATE case 'o': mg->mg_virtual = &vtbl_collxfrm; @@ -2633,12 +2656,7 @@ register SV *sv; register SV *nsv; { U32 refcnt = SvREFCNT(sv); - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); - } + sv_check_thinkfirst(sv); if (SvREFCNT(nsv) != 1) warn("Reference miscount in sv_replace()"); if (SvMAGICAL(sv)) { @@ -2668,7 +2686,9 @@ register SV *sv; assert(SvREFCNT(sv) == 0); if (SvOBJECT(sv)) { + dTHR; if (defstash) { /* Still have a symbol table? */ + dTHR; dSP; GV* destructor; @@ -2847,7 +2867,7 @@ SV *sv; return; #ifdef DEBUGGING if (SvTEMP(sv)) { - warn("Attempt to free temp prematurely"); + warn("Attempt to free temp prematurely: %s", SvPEEK(sv)); return; } #endif @@ -3047,12 +3067,7 @@ I32 append; register I32 cnt; I32 i; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (SvROK(sv)) - sv_unref(sv); - } + sv_check_thinkfirst(sv); if (!SvUPGRADE(sv, SVt_PV)) return 0; SvSCREAM_off(sv); @@ -3290,8 +3305,11 @@ register SV *sv; if (!sv) return; if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); + if (SvREADONLY(sv)) { + dTHR; + if (curcop != &compiling) + croak(no_modify); + } if (SvROK(sv)) { #ifdef OVERLOAD if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; @@ -3365,8 +3383,11 @@ register SV *sv; if (!sv) return; if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); + if (SvREADONLY(sv)) { + dTHR; + if (curcop != &compiling) + croak(no_modify); + } if (SvROK(sv)) { #ifdef OVERLOAD if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; @@ -3410,6 +3431,7 @@ register SV *sv; static void sv_mortalgrow() { + dTHR; tmps_max += (tmps_max < 512) ? 128 : 512; Renew(tmps_stack, tmps_max, SV*); } @@ -3418,6 +3440,7 @@ SV * sv_mortalcopy(oldstr) SV *oldstr; { + dTHR; register SV *sv; new_SV(sv); @@ -3435,6 +3458,7 @@ SV *oldstr; SV * sv_newmortal() { + dTHR; register SV *sv; new_SV(sv); @@ -3453,6 +3477,7 @@ SV * sv_2mortal(sv) register SV *sv; { + dTHR; if (!sv) return sv; if (SvREADONLY(sv) && curcop != &compiling) @@ -3542,6 +3567,7 @@ SV * newRV(ref) SV *ref; { + dTHR; register SV *sv; new_SV(sv); @@ -3845,8 +3871,11 @@ STRLEN *lp; { char *s; - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); + if (SvREADONLY(sv)) { + dTHR; + if (curcop != &compiling) + croak(no_modify); + } if (SvPOK(sv)) { *lp = SvCUR(sv); @@ -3858,9 +3887,11 @@ STRLEN *lp; s = SvPVX(sv); *lp = SvCUR(sv); } - else + else { + dTHR; croak("Can't coerce %s to string in %s", sv_reftype(sv,0), op_name[op->op_type]); + } } else s = sv_2pv(sv, lp); @@ -3957,6 +3988,7 @@ newSVrv(rv, classname) SV *rv; char *classname; { + dTHR; SV *sv; new_SV(sv); @@ -4023,6 +4055,7 @@ sv_bless(sv,stash) SV* sv; HV* stash; { + dTHR; SV *ref; if (!SvROK(sv)) croak("Can't bless non-reference value"); @@ -4215,6 +4248,7 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale) I32 svmax; bool *used_locale; { + dTHR; char *p; char *q; char *patend; @@ -4907,6 +4941,12 @@ SV* sv; PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv)); PerlIO_printf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv)); PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv)); +#ifdef USE_THREADS + PerlIO_printf(Perl_debug_log, " MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv)); + PerlIO_printf(Perl_debug_log, " OWNER = 0x%lx\n", (long)CvOWNER(sv)); +#endif /* USE_THREADS */ + PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", + (unsigned long)CvFLAGS(sv)); if (type == SVt_PVFM) PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv)); break; @@ -220,6 +220,8 @@ struct xpvbm { /* This structure much match XPVCV */ +typedef U16 cv_flags_t; + struct xpvfm { char * xpv_pv; /* pointer to malloced string */ STRLEN xpv_cur; /* length of xpv_pv as a C string */ @@ -239,7 +241,12 @@ struct xpvfm { long xcv_depth; /* >= 2 indicates recursive call */ AV * xcv_padlist; CV * xcv_outside; - U8 xcv_flags; +#ifdef USE_THREADS + perl_mutex *xcv_mutexp; + perl_cond * xcv_condp; /* signalled when owner leaves CV */ + struct thread *xcv_owner; /* current owner thread */ +#endif /* USE_THREADS */ + cv_flags_t xcv_flags; I32 xfm_lines; }; diff --git a/t/comp/cpp.aux b/t/comp/cpp.aux index bb93d212c3..bb93d212c3 100644..100755 --- a/t/comp/cpp.aux +++ b/t/comp/cpp.aux diff --git a/t/harness b/t/harness index fe64a04629..fe64a04629 100755..100644 --- a/t/harness +++ b/t/harness @@ -10,7 +10,7 @@ sub foo1 sub foo2 { - shift(_); + shift; print $_[0]; $x = 'value'; $x; diff --git a/thread.h b/thread.h new file mode 100644 index 0000000000..5e5bebdc97 --- /dev/null +++ b/thread.h @@ -0,0 +1,295 @@ +#ifndef USE_THREADS +#define MUTEX_LOCK(m) +#define MUTEX_UNLOCK(m) +#define MUTEX_INIT(m) +#define MUTEX_DESTROY(m) +#define COND_INIT(c) +#define COND_SIGNAL(c) +#define COND_BROADCAST(c) +#define COND_WAIT(c, m) +#define COND_DESTROY(c) + +#define THR +/* Rats: if dTHR is just blank then the subsequent ";" throws an error */ +#define dTHR extern int errno +#else + +#ifdef FAKE_THREADS +typedef struct thread *perl_thread; +/* With fake threads, thr is global(ish) so we don't need dTHR */ +#define dTHR extern int errno + +/* + * Note that SCHEDULE() is only callable from pp code (which + * must be expecting to be restarted). We'll have to do + * something a bit different for XS code. + */ +#define SCHEDULE() return schedule(), op + +#define MUTEX_LOCK(m) +#define MUTEX_UNLOCK(m) +#define MUTEX_INIT(m) +#define MUTEX_DESTROY(m) +#define COND_INIT(c) perl_cond_init(c) +#define COND_SIGNAL(c) perl_cond_signal(c) +#define COND_BROADCAST(c) perl_cond_broadcast(c) +#define COND_WAIT(c, m) STMT_START { \ + perl_cond_wait(c); \ + SCHEDULE(); \ + } STMT_END +#define COND_DESTROY(c) + +#else +/* POSIXish threads */ +typedef pthread_t perl_thread; +#ifdef OLD_PTHREADS_API +#define pthread_mutexattr_init(a) pthread_mutexattr_create(a) +#define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t) +#define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d)) +#else +#define pthread_mutexattr_default NULL +#endif /* OLD_PTHREADS_API */ + +#define MUTEX_INIT(m) \ + if (pthread_mutex_init((m), pthread_mutexattr_default)) \ + croak("panic: MUTEX_INIT"); \ + else 1 +#define MUTEX_LOCK(m) \ + if (pthread_mutex_lock((m))) croak("panic: MUTEX_LOCK"); else 1 +#define MUTEX_UNLOCK(m) \ + if (pthread_mutex_unlock((m))) croak("panic: MUTEX_UNLOCK"); else 1 +#define MUTEX_DESTROY(m) \ + if (pthread_mutex_destroy((m))) croak("panic: MUTEX_DESTROY"); else 1 +#define COND_INIT(c) \ + if (pthread_cond_init((c), NULL)) croak("panic: COND_INIT"); else 1 +#define COND_SIGNAL(c) \ + if (pthread_cond_signal((c))) croak("panic: COND_SIGNAL"); else 1 +#define COND_BROADCAST(c) \ + if (pthread_cond_broadcast((c))) croak("panic: COND_BROADCAST"); else 1 +#define COND_WAIT(c, m) \ + if (pthread_cond_wait((c), (m))) croak("panic: COND_WAIT"); else 1 +#define COND_DESTROY(c) \ + if (pthread_cond_destroy((c))) croak("panic: COND_DESTROY"); else 1 +/* XXX Add "old" (?) POSIX draft interface too */ +#ifdef OLD_PTHREADS_API +struct thread *getTHR _((void)); +#define THR getTHR() +#else +#define THR ((struct thread *) pthread_getspecific(thr_key)) +#endif /* OLD_PTHREADS_API */ +#define dTHR struct thread *thr = THR +#endif /* FAKE_THREADS */ + +struct thread { + perl_thread Tself; + SV * Toursv; + + /* The fields that used to be global */ + SV ** Tstack_base; + SV ** Tstack_sp; + SV ** Tstack_max; + +#ifdef OP_IN_REGISTER + OP * Topsave; +#else + OP * Top; +#endif + + I32 * Tscopestack; + I32 Tscopestack_ix; + I32 Tscopestack_max; + + ANY * Tsavestack; + I32 Tsavestack_ix; + I32 Tsavestack_max; + + OP ** Tretstack; + I32 Tretstack_ix; + I32 Tretstack_max; + + I32 * Tmarkstack; + I32 * Tmarkstack_ptr; + I32 * Tmarkstack_max; + + SV ** Tcurpad; + + SV * TSv; + XPV * TXpv; + struct stat Tstatbuf; + struct tms Ttimesbuf; + + /* XXX What about regexp stuff? */ + + /* Now the fields that used to be "per interpreter" (even when global) */ + + /* XXX What about magic variables such as $/, $? and so on? */ + HV * Tdefstash; + HV * Tcurstash; + + SV ** Ttmps_stack; + I32 Ttmps_ix; + I32 Ttmps_floor; + I32 Ttmps_max; + + int Tin_eval; + OP * Trestartop; + int Tdelaymagic; + bool Tdirty; + U8 Tlocalizing; + COP * Tcurcop; + + CONTEXT * Tcxstack; + I32 Tcxstack_ix; + I32 Tcxstack_max; + + AV * Tcurstack; + AV * Tmainstack; + JMPENV * Ttop_env; + I32 Trunlevel; + + /* XXX Sort stuff, firstgv, secongv and so on? */ + + perl_mutex *Tthreadstart_mutexp; + HV * Tcvcache; + U32 Tthrflags; + +#ifdef FAKE_THREADS + perl_thread next, prev; /* Linked list of all threads */ + perl_thread next_run, prev_run; /* Linked list of runnable threads */ + perl_cond wait_queue; /* Wait queue that we are waiting on */ + IV private; /* Holds data across time slices */ + I32 savemark; /* Holds MARK for thread join values */ +#endif /* FAKE_THREADS */ +}; + +typedef struct thread *Thread; + +/* Values and macros for thrflags */ +#define THRf_STATE_MASK 3 +#define THRf_NORMAL 0 +#define THRf_DETACHED 1 +#define THRf_JOINED 2 +#define THRf_DEAD 3 + +#define THRf_DIE_FATAL 4 + +#define ThrSTATE(t) (t->Tthrflags & THRf_STATE_MASK) +#define ThrSETSTATE(t, s) STMT_START { \ + (t)->Tthrflags &= ~THRf_STATE_MASK; \ + (t)->Tthrflags |= (s); \ + DEBUG_L(fprintf(stderr, "thread 0x%lx set to state %d\n", \ + (unsigned long)(t), (s))); \ + } STMT_END + +typedef struct condpair { + perl_mutex mutex; + perl_cond owner_cond; + perl_cond cond; + Thread owner; +} condpair_t; + +#define MgMUTEXP(mg) (&((condpair_t *)(mg->mg_ptr))->mutex) +#define MgOWNERCONDP(mg) (&((condpair_t *)(mg->mg_ptr))->owner_cond) +#define MgCONDP(mg) (&((condpair_t *)(mg->mg_ptr))->cond) +#define MgOWNER(mg) ((condpair_t *)(mg->mg_ptr))->owner + +#undef stack_base +#undef stack_sp +#undef stack_max +#undef curstack +#undef mainstack +#undef markstack +#undef markstack_ptr +#undef markstack_max +#undef scopestack +#undef scopestack_ix +#undef scopestack_max +#undef savestack +#undef savestack_ix +#undef savestack_max +#undef retstack +#undef retstack_ix +#undef retstack_max +#undef curcop +#undef cxstack +#undef cxstack_ix +#undef cxstack_max +#undef defstash +#undef curstash +#undef tmps_stack +#undef tmps_floor +#undef tmps_ix +#undef tmps_max +#undef curpad +#undef Sv +#undef Xpv +#undef statbuf +#undef timesbuf +#undef top_env +#undef runlevel +#undef in_eval +#undef restartop +#undef delaymagic +#undef dirty +#undef localizing + +#define self (thr->Tself) +#define oursv (thr->Toursv) +#define stack_base (thr->Tstack_base) +#define stack_sp (thr->Tstack_sp) +#define stack_max (thr->Tstack_max) +#ifdef OP_IN_REGISTER +#define opsave (thr->Topsave) +#else +#undef op +#define op (thr->Top) +#endif +#define curcop (thr->Tcurcop) +#define stack (thr->Tstack) +#define curstack (thr->Tcurstack) +#define mainstack (thr->Tmainstack) +#define markstack (thr->Tmarkstack) +#define markstack_ptr (thr->Tmarkstack_ptr) +#define markstack_max (thr->Tmarkstack_max) +#define scopestack (thr->Tscopestack) +#define scopestack_ix (thr->Tscopestack_ix) +#define scopestack_max (thr->Tscopestack_max) + +#define savestack (thr->Tsavestack) +#define savestack_ix (thr->Tsavestack_ix) +#define savestack_max (thr->Tsavestack_max) + +#define retstack (thr->Tretstack) +#define retstack_ix (thr->Tretstack_ix) +#define retstack_max (thr->Tretstack_max) + +#define cxstack (thr->Tcxstack) +#define cxstack_ix (thr->Tcxstack_ix) +#define cxstack_max (thr->Tcxstack_max) + +#define curpad (thr->Tcurpad) +#define Sv (thr->TSv) +#define Xpv (thr->TXpv) +#define statbuf (thr->Tstatbuf) +#define timesbuf (thr->Ttimesbuf) +#define defstash (thr->Tdefstash) +#define curstash (thr->Tcurstash) + +#define tmps_stack (thr->Ttmps_stack) +#define tmps_ix (thr->Ttmps_ix) +#define tmps_floor (thr->Ttmps_floor) +#define tmps_max (thr->Ttmps_max) + +#define in_eval (thr->Tin_eval) +#define restartop (thr->Trestartop) +#define delaymagic (thr->Tdelaymagic) +#define dirty (thr->Tdirty) +#define localizing (thr->Tlocalizing) + +#define top_env (thr->Ttop_env) +#define runlevel (thr->Trunlevel) + +#define threadstart_mutexp (thr->Tthreadstart_mutexp) +#define cvcache (thr->Tcvcache) +#define thrflags (thr->Tthrflags) +#endif /* USE_THREADS */ @@ -226,6 +226,7 @@ void lex_start(line) SV *line; { + dTHR; char *s; STRLEN len; @@ -309,6 +310,7 @@ static void incline(s) char *s; { + dTHR; char *t; char *n; char ch; @@ -350,6 +352,7 @@ static char * skipspace(s) register char *s; { + dTHR; if (lex_formbrack && lex_brackets <= lex_formbrack) { while (s < bufend && (*s == ' ' || *s == '\t')) s++; @@ -462,6 +465,7 @@ expectation x; char *s; #endif /* CAN_PROTOTYPE */ { + dTHR; yylval.ival = f; CLINE; expect = x; @@ -535,11 +539,12 @@ register char *s; int kind; { if (s && *s) { - OP* op = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0)); - nextval[nexttoke].opval = op; + OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0)); + nextval[nexttoke].opval = o; force_next(WORD); if (kind) { - op->op_private = OPpCONST_ENTERED; + dTHR; /* just for in_eval */ + o->op_private = OPpCONST_ENTERED; /* XXX see note in pp_entereval() for why we forgo typo warnings if the symbol must be introduced in an eval. GSAR 96-10-12 */ @@ -653,6 +658,7 @@ sublex_start() static I32 sublex_push() { + dTHR; push_scope(); lex_state = sublex_info.super_state; @@ -757,7 +763,7 @@ char *start; register char *d = SvPVX(sv); bool dorange = FALSE; I32 len; - char *leave = + char *leaveit = lex_inpat ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#" : (lex_inwhat & OP_TRANS) @@ -803,7 +809,7 @@ char *start; } if (*s == '\\' && s+1 < send) { s++; - if (*s && strchr(leave, *s)) { + if (*s && strchr(leaveit, *s)) { *d++ = '\\'; *d++ = *s++; continue; @@ -1230,6 +1236,7 @@ EXT int yychar; /* last token */ int yylex() { + dTHR; register char *s; register char *d; register I32 tmp; @@ -1247,7 +1254,8 @@ yylex() return PRIVATEREF; } - if (!strchr(tokenbuf,':') && (tmp = pad_findmy(tokenbuf))) { + if (!strchr(tokenbuf,':') + && (tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) { if (last_lop_op == OP_SORT && tokenbuf[0] == '$' && (tokenbuf[1] == 'a' || tokenbuf[1] == 'b') @@ -2806,6 +2814,7 @@ yylex() case KEY_DESTROY: case KEY_BEGIN: case KEY_END: + case KEY_INIT: if (expect == XSTATE) { s = bufptr; goto really_sub; @@ -3168,6 +3177,9 @@ yylex() case KEY_listen: LOP(OP_LISTEN,XTERM); + case KEY_lock: + UNI(OP_LOCK); + case KEY_lstat: UNI(OP_LSTAT); @@ -3195,6 +3207,17 @@ yylex() case KEY_my: in_my = TRUE; + s = skipspace(s); + if (isIDFIRST(*s)) { + s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len); + in_my_stash = gv_stashpv(tokenbuf, FALSE); + if (!in_my_stash) { + char tmpbuf[1024]; + bufptr = s; + sprintf(tmpbuf, "No such class %.1000s", tokenbuf); + yyerror(tmpbuf); + } + } OPERATOR(MY); case KEY_next: @@ -3983,6 +4006,9 @@ I32 len; case 'h': if (strEQ(d,"hex")) return -KEY_hex; break; + case 'I': + if (strEQ(d,"INIT")) return KEY_INIT; + break; case 'i': switch (len) { case 2: @@ -4025,6 +4051,7 @@ I32 len; case 4: if (strEQ(d,"last")) return KEY_last; if (strEQ(d,"link")) return -KEY_link; + if (strEQ(d,"lock")) return -KEY_lock; break; case 5: if (strEQ(d,"local")) return KEY_local; @@ -4666,6 +4693,7 @@ void hoistmust(pm) register PMOP *pm; { + dTHR; if (!pm->op_pmshort && pm->op_pmregexp->regstart && (!pm->op_pmregexp->regmust || pm->op_pmregexp->reganch & ROPT_ANCH) ) { @@ -4707,7 +4735,7 @@ scan_trans(start) char *start; { register char* s; - OP *op; + OP *o; short *tbl; I32 squash; I32 delete; @@ -4737,7 +4765,7 @@ char *start; } New(803,tbl,256,short); - op = newPVOP(OP_TRANS, 0, (char*)tbl); + o = newPVOP(OP_TRANS, 0, (char*)tbl); complement = delete = squash = 0; while (*s == 'c' || *s == 'd' || *s == 's') { @@ -4749,9 +4777,9 @@ char *start; squash = OPpTRANS_SQUASH; s++; } - op->op_private = delete|squash|complement; + o->op_private = delete|squash|complement; - lex_op = op; + lex_op = o; yylval.ival = OP_TRANS; return s; } @@ -4760,6 +4788,7 @@ static char * scan_heredoc(s) register char *s; { + dTHR; SV *herewas; I32 op_type = OP_SCALAR; I32 len; @@ -4916,10 +4945,10 @@ char *start; (void)strcpy(d,"ARGV"); if (*d == '$') { I32 tmp; - if (tmp = pad_findmy(d)) { - OP *op = newOP(OP_PADSV, 0); - op->op_targ = tmp; - lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, op)); + if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { + OP *o = newOP(OP_PADSV, 0); + o->op_targ = tmp; + lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o)); } else { GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV); @@ -4943,6 +4972,7 @@ static char * scan_str(start) char *start; { + dTHR; SV *sv; char *tmps; register char *s = start; @@ -5173,6 +5203,7 @@ static char * scan_formline(s) register char *s; { + dTHR; register char *eol; register char *t; SV *stuff = newSVpv("",0); @@ -5253,6 +5284,7 @@ start_subparse(is_format, flags) I32 is_format; U32 flags; { + dTHR; I32 oldsavestack_ix = savestack_ix; CV* outsidecv = compcv; AV* comppadlist; @@ -5277,13 +5309,21 @@ U32 flags; CvFLAGS(compcv) |= flags; comppad = newAV(); + av_push(comppad, Nullsv); + curpad = AvARRAY(comppad); comppad_name = newAV(); comppad_name_fill = 0; min_intro_pending = 0; - av_push(comppad, Nullsv); - curpad = AvARRAY(comppad); padix = 0; subline = curcop->cop_line; +#ifdef USE_THREADS + av_store(comppad_name, 0, newSVpv("@_", 2)); + curpad[0] = (SV*)newAV(); + SvPADMY_on(curpad[0]); /* XXX Needed? */ + CvOWNER(compcv) = 0; + New(666, CvMUTEXP(compcv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(compcv)); +#endif /* USE_THREADS */ comppadlist = newAV(); AvREAL_off(comppadlist); @@ -5292,6 +5332,11 @@ U32 flags; CvPADLIST(compcv) = comppadlist; CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)outsidecv); +#ifdef USE_THREADS + CvOWNER(compcv) = 0; + New(666, CvMUTEXP(compcv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(compcv)); +#endif /* USE_THREADS */ return oldsavestack_ix; } @@ -5300,6 +5345,7 @@ int yywarn(s) char *s; { + dTHR; --error_count; in_eval |= 2; yyerror(s); @@ -5311,6 +5357,7 @@ int yyerror(s) char *s; { + dTHR; char *where = NULL; char *context = NULL; int contlen = -1; @@ -5375,5 +5422,6 @@ char *s; if (++error_count >= 10) croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv)); in_my = 0; + in_my_stash = Nullhv; return 0; } @@ -1131,6 +1131,7 @@ mess(pat, args) sv = mess_sv; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { + dTHR; if (dirty) sv_catpv(sv, dgd); else { @@ -1162,6 +1163,7 @@ die(pat, va_alist) va_dcl #endif { + dTHR; va_list args; char *message; I32 oldrunlevel = runlevel; @@ -1170,6 +1172,8 @@ die(pat, va_alist) GV *gv; CV *cv; + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "die: curstack = %p, mainstack= %p\n", + curstack, mainstack));/*debug*/ /* 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 */ @@ -1186,6 +1190,8 @@ die(pat, va_alist) message = mess(pat, &args); va_end(args); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "die: message = %s\ndiehook = %p\n", + message, diehook));/*debug*/ if (diehook) { /* sv_2cv might call croak() */ SV *olddiehook = diehook; @@ -1213,6 +1219,9 @@ die(pat, va_alist) } 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*/ if ((!restartop && was_in_eval) || oldrunlevel > 1) JMPENV_JUMP(3); return restartop; @@ -1229,6 +1238,7 @@ croak(pat, va_alist) va_dcl #endif { + dTHR; va_list args; char *message; HV *stash; @@ -1242,6 +1252,9 @@ croak(pat, va_alist) #endif message = mess(pat, &args); va_end(args); +#ifdef USE_THREADS + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); +#endif /* USE_THREADS */ if (diehook) { /* sv_2cv might call croak() */ SV *olddiehook = diehook; @@ -1302,6 +1315,7 @@ warn(pat,va_alist) if (warnhook) { /* sv_2cv might call warn() */ + dTHR; SV *oldwarnhook = warnhook; ENTER; SAVESPTR(warnhook); @@ -2335,6 +2349,138 @@ I32 *retlen; return retval; } +#ifdef USE_THREADS +#ifdef FAKE_THREADS +/* Very simplistic scheduler for now */ +void +schedule(void) +{ + thr = thr->next_run; +} + +void +perl_cond_init(cp) +perl_cond *cp; +{ + *cp = 0; +} + +void +perl_cond_signal(cp) +perl_cond *cp; +{ + perl_thread t; + perl_cond cond = *cp; + + if (!cond) + return; + t = cond->thread; + /* Insert t in the runnable queue just ahead of us */ + t->next_run = thr->next_run; + thr->next_run->prev_run = t; + t->prev_run = thr; + thr->next_run = t; + thr->wait_queue = 0; + /* Remove from the wait queue */ + *cp = cond->next; + Safefree(cond); +} + +void +perl_cond_broadcast(cp) +perl_cond *cp; +{ + perl_thread t; + perl_cond cond, cond_next; + + for (cond = *cp; cond; cond = cond_next) { + t = cond->thread; + /* Insert t in the runnable queue just ahead of us */ + t->next_run = thr->next_run; + thr->next_run->prev_run = t; + t->prev_run = thr; + thr->next_run = t; + thr->wait_queue = 0; + /* Remove from the wait queue */ + cond_next = cond->next; + Safefree(cond); + } + *cp = 0; +} + +void +perl_cond_wait(cp) +perl_cond *cp; +{ + perl_cond cond; + + if (thr->next_run == thr) + croak("panic: perl_cond_wait called by last runnable thread"); + + New(666, cond, 1, struct perl_wait_queue); + cond->thread = thr; + cond->next = *cp; + *cp = cond; + thr->wait_queue = cond; + /* Remove ourselves from runnable queue */ + thr->next_run->prev_run = thr->prev_run; + thr->prev_run->next_run = thr->next_run; +} +#endif /* FAKE_THREADS */ + +#ifdef OLD_PTHREADS_API +struct thread * +getTHR _((void)) +{ + pthread_addr_t t; + + if (pthread_getspecific(thr_key, &t)) + croak("panic: pthread_getspecific"); + return (struct thread *) t; +} +#endif /* OLD_PTHREADS_API */ + +MAGIC * +condpair_magic(sv) +SV *sv; +{ + MAGIC *mg; + + SvUPGRADE(sv, SVt_PVMG); + mg = mg_find(sv, 'm'); + if (!mg) { + condpair_t *cp; + + New(53, cp, 1, condpair_t); + MUTEX_INIT(&cp->mutex); + COND_INIT(&cp->owner_cond); + COND_INIT(&cp->cond); + cp->owner = 0; + MUTEX_LOCK(&sv_mutex); + mg = mg_find(sv, 'm'); + if (mg) { + /* someone else beat us to initialising it */ + MUTEX_UNLOCK(&sv_mutex); + MUTEX_DESTROY(&cp->mutex); + COND_DESTROY(&cp->owner_cond); + COND_DESTROY(&cp->cond); + Safefree(cp); + } + else { + sv_magic(sv, Nullsv, 'm', 0, 0); + mg = SvMAGIC(sv); + mg->mg_ptr = (char *)cp; + mg->mg_len = sizeof(cp); + MUTEX_UNLOCK(&sv_mutex); + DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(), + "0x%lx: condpair_magic 0x%lx\n", + (unsigned long)thr, + (unsigned long)sv));) + } + } + return mg; +} +#endif /* USE_THREADS */ #ifdef HUGE_VAL /* diff --git a/vms/perly_c.vms b/vms/perly_c.vms index 60b0f54c09..d0c8fa18f4 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -1285,7 +1285,7 @@ dEXT int yyerrflag; dEXT int yychar; dEXT YYSTYPE yyval; dEXT YYSTYPE yylval; -#line 631 "perly.y" +#line 632 "perly.y" /* PROGRAM */ #line 1360 "perly.c" #define YYABORT goto yyabort @@ -1766,303 +1766,304 @@ case 55: break; case 56: #line 291 "perly.y" -{ char *name = SvPVx(((SVOP*)yyvsp[0].opval)->op_sv, na); - if (strEQ(name, "BEGIN") || strEQ(name, "END")) +{ char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, na); + if (strEQ(name, "BEGIN") || strEQ(name, "END") + || strEQ(name, "INIT")) CvUNIQUE_on(compcv); yyval.opval = yyvsp[0].opval; } break; case 57: -#line 298 "perly.y" +#line 299 "perly.y" { yyval.opval = Nullop; } break; case 59: -#line 302 "perly.y" +#line 303 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 60: -#line 303 "perly.y" +#line 304 "perly.y" { yyval.opval = Nullop; expect = XSTATE; } break; case 61: -#line 307 "perly.y" +#line 308 "perly.y" { package(yyvsp[-1].opval); } break; case 62: -#line 309 "perly.y" +#line 310 "perly.y" { package(Nullop); } break; case 63: -#line 313 "perly.y" +#line 314 "perly.y" { CvUNIQUE_on(compcv); /* It's a BEGIN {} */ } break; case 64: -#line 315 "perly.y" +#line 316 "perly.y" { utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } break; case 65: -#line 319 "perly.y" +#line 320 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 66: -#line 321 "perly.y" +#line 322 "perly.y" { yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 68: -#line 326 "perly.y" +#line 327 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 69: -#line 328 "perly.y" +#line 329 "perly.y" { yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; case 71: -#line 333 "perly.y" +#line 334 "perly.y" { yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); } break; case 72: -#line 336 "perly.y" +#line 337 "perly.y" { yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); } break; case 73: -#line 339 "perly.y" +#line 340 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); } break; case 74: -#line 344 "perly.y" +#line 345 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval), newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); } break; case 75: -#line 349 "perly.y" +#line 350 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); } break; case 76: -#line 354 "perly.y" +#line 355 "perly.y" { yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 77: -#line 356 "perly.y" +#line 357 "perly.y" { yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 78: -#line 358 "perly.y" +#line 359 "perly.y" { yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 79: -#line 360 "perly.y" +#line 361 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); } break; case 82: -#line 370 "perly.y" +#line 371 "perly.y" { yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; case 83: -#line 372 "perly.y" +#line 373 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 84: -#line 374 "perly.y" +#line 375 "perly.y" { if (yyvsp[-1].ival != OP_REPEAT) scalar(yyvsp[-2].opval); yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); } break; case 85: -#line 378 "perly.y" +#line 379 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 86: -#line 380 "perly.y" +#line 381 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 87: -#line 382 "perly.y" +#line 383 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 88: -#line 384 "perly.y" +#line 385 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 89: -#line 386 "perly.y" +#line 387 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 90: -#line 388 "perly.y" +#line 389 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 91: -#line 390 "perly.y" +#line 391 "perly.y" { yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; case 92: -#line 392 "perly.y" +#line 393 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 93: -#line 394 "perly.y" +#line 395 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 94: -#line 396 "perly.y" +#line 397 "perly.y" { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; case 95: -#line 398 "perly.y" +#line 399 "perly.y" { yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; case 96: -#line 401 "perly.y" +#line 402 "perly.y" { yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; case 97: -#line 403 "perly.y" +#line 404 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 98: -#line 405 "perly.y" +#line 406 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 99: -#line 407 "perly.y" +#line 408 "perly.y" { yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; case 100: -#line 409 "perly.y" +#line 410 "perly.y" { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; case 101: -#line 411 "perly.y" +#line 412 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; case 102: -#line 414 "perly.y" +#line 415 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; case 103: -#line 417 "perly.y" +#line 418 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; case 104: -#line 420 "perly.y" +#line 421 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; case 105: -#line 423 "perly.y" +#line 424 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; case 106: -#line 425 "perly.y" +#line 426 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; case 107: -#line 427 "perly.y" +#line 428 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; case 108: -#line 429 "perly.y" +#line 430 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; case 109: -#line 431 "perly.y" +#line 432 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; case 110: -#line 433 "perly.y" +#line 434 "perly.y" { yyval.opval = newANONHASH(yyvsp[-2].opval); } break; case 111: -#line 435 "perly.y" +#line 436 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; case 112: -#line 437 "perly.y" +#line 438 "perly.y" { yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; case 113: -#line 439 "perly.y" +#line 440 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 114: -#line 441 "perly.y" +#line 442 "perly.y" { yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); } break; case 115: -#line 443 "perly.y" +#line 444 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 116: -#line 445 "perly.y" +#line 446 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; case 117: -#line 447 "perly.y" +#line 448 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 118: -#line 451 "perly.y" +#line 452 "perly.y" { assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 119: -#line 455 "perly.y" +#line 456 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 120: -#line 457 "perly.y" +#line 458 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 121: -#line 459 "perly.y" +#line 460 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; case 122: -#line 461 "perly.y" +#line 462 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 123: -#line 464 "perly.y" +#line 465 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 124: -#line 469 "perly.y" +#line 470 "perly.y" { assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 125: -#line 474 "perly.y" +#line 475 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; case 126: -#line 476 "perly.y" +#line 477 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; case 127: -#line 478 "perly.y" +#line 479 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -2070,7 +2071,7 @@ case 127: ref(yyvsp[-3].opval, OP_ASLICE))); } break; case 128: -#line 484 "perly.y" +#line 485 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2079,37 +2080,37 @@ case 128: expect = XOPERATOR; } break; case 129: -#line 491 "perly.y" +#line 492 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 130: -#line 493 "perly.y" +#line 494 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; case 131: -#line 495 "perly.y" +#line 496 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; case 132: -#line 497 "perly.y" +#line 498 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; case 133: -#line 500 "perly.y" +#line 501 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 134: -#line 503 "perly.y" +#line 504 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; case 135: -#line 505 "perly.y" +#line 506 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 136: -#line 507 "perly.y" +#line 508 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2119,7 +2120,7 @@ case 136: )),Nullop)); dep();} break; case 137: -#line 515 "perly.y" +#line 516 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2130,161 +2131,161 @@ case 137: )))); dep();} break; case 138: -#line 524 "perly.y" +#line 525 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();} break; case 139: -#line 528 "perly.y" +#line 529 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, yyvsp[-1].opval, scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();} break; case 140: -#line 533 "perly.y" +#line 534 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar(yyvsp[-3].opval))); } break; case 141: -#line 536 "perly.y" +#line 537 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, newCVREF(0, scalar(yyvsp[-4].opval)))); } break; case 142: -#line 540 "perly.y" +#line 541 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; case 143: -#line 543 "perly.y" +#line 544 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 144: -#line 545 "perly.y" +#line 546 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 145: -#line 547 "perly.y" +#line 548 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 146: -#line 549 "perly.y" +#line 550 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 147: -#line 551 "perly.y" +#line 552 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 148: -#line 553 "perly.y" +#line 554 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 149: -#line 556 "perly.y" +#line 557 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 150: -#line 558 "perly.y" +#line 559 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 151: -#line 560 "perly.y" +#line 561 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[0].opval)); } break; case 152: -#line 563 "perly.y" +#line 564 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 153: -#line 565 "perly.y" +#line 566 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 154: -#line 567 "perly.y" +#line 568 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 155: -#line 569 "perly.y" +#line 570 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 158: -#line 575 "perly.y" +#line 576 "perly.y" { yyval.opval = Nullop; } break; case 159: -#line 577 "perly.y" +#line 578 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 160: -#line 581 "perly.y" +#line 582 "perly.y" { yyval.opval = Nullop; } break; case 161: -#line 583 "perly.y" +#line 584 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 162: -#line 585 "perly.y" +#line 586 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 163: -#line 588 "perly.y" +#line 589 "perly.y" { yyval.ival = 0; } break; case 164: -#line 589 "perly.y" +#line 590 "perly.y" { yyval.ival = 1; } break; case 165: -#line 593 "perly.y" +#line 594 "perly.y" { in_my = 0; yyval.opval = my(yyvsp[0].opval); } break; case 166: -#line 597 "perly.y" +#line 598 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; case 167: -#line 601 "perly.y" +#line 602 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; case 168: -#line 605 "perly.y" +#line 606 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 169: -#line 609 "perly.y" +#line 610 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; case 170: -#line 613 "perly.y" +#line 614 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 171: -#line 617 "perly.y" +#line 618 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; case 172: -#line 621 "perly.y" +#line 622 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 173: -#line 623 "perly.y" +#line 624 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 174: -#line 625 "perly.y" +#line 626 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 175: -#line 628 "perly.y" +#line 629 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2271 "perly.c" +#line 2272 "perly.c" } yyssp -= yym; yystate = *yyssp; @@ -2683,6 +2683,7 @@ vms_execfree() { static char * setup_argstr(SV *really, SV **mark, SV **sp) { + dTHR; char *junk, *tmps = Nullch; register size_t cmdlen = 0; size_t rlen; @@ -3207,6 +3208,7 @@ static long int utc_offset_secs; /*{{{time_t my_time(time_t *timep)*/ time_t my_time(time_t *timep) { + dTHR; time_t when; if (gmtime_emulation_type == 0) { @@ -3254,6 +3256,7 @@ time_t my_time(time_t *timep) struct tm * my_gmtime(const time_t *timep) { + dTHR; char *p; time_t when; @@ -3279,6 +3282,7 @@ my_gmtime(const time_t *timep) struct tm * my_localtime(const time_t *timep) { + dTHR; time_t when; if (timep == NULL) { @@ -3324,6 +3328,7 @@ static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 }; /*{{{int my_utime(char *path, struct utimbuf *utimes)*/ int my_utime(char *file, struct utimbuf *utimes) { + dTHR; register int i; long int bintime[2], len = 2, lowbit, unixtime, secscale = 10000000; /* seconds --> 100 ns intervals */ @@ -3708,6 +3713,8 @@ cando_by_name(I32 bit, I32 effective, char *fname) int flex_fstat(int fd, struct mystat *statbufp) { + dTHR; + if (!fstat(fd,(stat_t *) statbufp)) { if (statbufp == (struct mystat *) &statcache) *namecache == '\0'; statbufp->st_dev = encode_dev(statbufp->st_devnam); @@ -3732,6 +3739,7 @@ flex_fstat(int fd, struct mystat *statbufp) int flex_stat(char *fspec, struct mystat *statbufp) { + dTHR; char fileified[NAM$C_MAXRSS+1]; int retval = -1; diff --git a/writemain.SH b/writemain.SH index c428383085..c428383085 100755..100644 --- a/writemain.SH +++ b/writemain.SH diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index 0ca3ff35db..0c9dfca841 100755 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -153,7 +153,8 @@ malloc.c: ../malloc.c sed <../malloc.c >malloc.c \ -e 's/"EXTERN.h"/"..\/EXTERN.h"/' \ -e 's/"perl.h"/"..\/perl.h"/' \ - -e 's/my_exit/exit/' + -e 's/my_exit/exit/' \ + -e 's/MUTEX_[A-Z_]*(&malloc_mutex);//' # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE $(obj): |