summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--README.threads74
-rw-r--r--Todo.5.00510
-rw-r--r--doop.c2
-rw-r--r--embed.h14
-rw-r--r--ext/Opcode/Opcode.pm4
-rw-r--r--ext/POSIX/POSIX.xs70
-rw-r--r--ext/Thread/Thread.xs137
-rw-r--r--fakethr.h32
-rw-r--r--global.sym5
-rw-r--r--gv.c3
-rw-r--r--hv.c2
-rw-r--r--interp.sym3
-rw-r--r--mg.c21
-rw-r--r--op.c126
-rw-r--r--op.h22
-rw-r--r--opcode.h637
-rwxr-xr-xopcode.pl727
-rw-r--r--patchlevel.h2
-rw-r--r--perl.c178
-rw-r--r--perl.h28
-rw-r--r--pp.c28
-rw-r--r--pp_ctl.c37
-rw-r--r--pp_hot.c23
-rw-r--r--pp_sys.c55
-rw-r--r--proto.h6
-rw-r--r--scope.h3
-rw-r--r--sv.c10
-rw-r--r--sv.h48
-rw-r--r--taint.c5
-rw-r--r--thread.h320
-rw-r--r--toke.c54
-rw-r--r--util.c117
-rw-r--r--vms/descrip.mms83
-rw-r--r--vms/gen_shrfls.pl1
-rw-r--r--vms/vms.c73
-rw-r--r--vms/vmsish.h39
-rw-r--r--win32/win32thread.c30
-rw-r--r--win32/win32thread.h102
38 files changed, 1887 insertions, 1244 deletions
diff --git a/README.threads b/README.threads
index 014eed833a..69bddca5a8 100644
--- a/README.threads
+++ b/README.threads
@@ -47,17 +47,44 @@ Now you can do a
make
+O/S specific bugs
+
+Solaris qsort uses a hidden mutex for synchronisation. If you die()
+while doing a sort() then the resulting longjmp() leaves the mutex
+locked so you get a deadlock the next time you try to sort().
+
+LinuxThreads 0.5 has a bug which can cause file descriptor 0 to be
+closed after a fork() leading to many strange symptoms. The
+development version of LinuxThreads has this fixed but the following
+patch can be applied to 0.5 for now:
+
+----------------------------- cut here -----------------------------
+--- linuxthreads-0.5/pthread.c.ORI Mon Oct 6 13:55:50 1997
++++ linuxthreads-0.5/pthread.c Mon Oct 6 13:57:24 1997
+@@ -312,8 +312,10 @@
+ free(pthread_manager_thread_bos);
+ pthread_manager_thread_bos = pthread_manager_thread_tos = NULL;
+ /* Close the two ends of the pipe */
+- close(pthread_manager_request);
+- close(pthread_manager_reader);
++ if (pthread_manager_request >= 0) {
++ close(pthread_manager_request);
++ close(pthread_manager_reader);
++ }
+ pthread_manager_request = pthread_manager_reader = -1;
+ /* Update the pid of the main thread */
+ self->p_pid = getpid();
+----------------------------- cut here -----------------------------
+
+
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
+The Thread extension is now part of the main perl distribution tree.
+If you did Configure -Dusethreads then it will have been added to
+the list of extensions automatically.
-Then you can try some of the tests with
+You can try some of the tests with
+ cd ext/Thread
perl -Mblib create.t
perl -Mblib join.t
perl -Mblib lock.t
@@ -70,11 +97,10 @@ 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.
+failures for op/misc test 45 (tries to do local(@_) but @_ is
+now lexical) and for some of the DBM/DB extensions (if there
+underlying libraries were not compiled to be thread-aware).
+may or may not work.
Bugs
@@ -88,7 +114,7 @@ extension won't build with it yet.
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.
+* There may still be races where bugs show up under contention.
* Need to document "lock", Thread.pm, Queue.pm, ...
@@ -111,8 +137,8 @@ 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
+All fields of struct thread which derived from original perl
+variables have names 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)
@@ -140,10 +166,16 @@ 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
+COND_{INIT,WAIT,SIGNAL,BROADCAST,DESTROY}.
+
+A mutex is only required to be a simple, fast mutex (e.g. it does not
+have to be recursive). It is only ever held across very short pieces
+of code. Condition variables are only ever signalled/broadcast while
+their associated mutex is held. (This constraint simplifies the
+implementation of condition variables in certain porting situations.)
+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).
@@ -202,4 +234,4 @@ ZOMBIE ----------------------------> DEAD
Malcolm Beattie
mbeattie@sable.ox.ac.uk
-2 October 1997
+6 November 1997
diff --git a/Todo.5.005 b/Todo.5.005
index 1159da58d1..743e597873 100644
--- a/Todo.5.005
+++ b/Todo.5.005
@@ -1,23 +1,17 @@
Merging
- 5.004_04
oneperl (THIS pointer)
Multi-threading
- Fix Thread->list
$AUTOLOAD. Hmm.
without USE_THREADS, change extern variable for dTHR
consistent semantics for exit/die in threads
SvREFCNT_dec(curstack) in threadstart() in Thread.xs
- $@ and other magic globals:
- global lexical pool with auto-binding for magicals
- move magicals that should be per-thread into thread.h
- sv_magic for the necessary global lexical pool entries
Thread::Pool
- check new condition variable word; fix cond.t
more Configure support
Miscellaneous
rename and alter ISA.pm
+ magic_setisa should be made to update %FIELDS
Compiler
auto-produce executable
@@ -26,6 +20,8 @@ Compiler
$^C to track compiler/checker status
END blocks need saving in compiled output
_AUTOLOAD prodding
+ fix comppadlist (names in comppad_name can have fake SvCUR
+ from where newASSIGNOP steals the field)
Documentation
lots
diff --git a/doop.c b/doop.c
index 3f8bd10a94..0be09acfc9 100644
--- a/doop.c
+++ b/doop.c
@@ -257,6 +257,7 @@ I32
do_chomp(sv)
register SV *sv;
{
+ dTHR;
register I32 count;
STRLEN len;
char *s;
@@ -334,6 +335,7 @@ SV *sv;
SV *left;
SV *right;
{
+ dTHR; /* just for taint */
#ifdef LIBERAL
register long *dl;
register long *ll;
diff --git a/embed.h b/embed.h
index f3601e8337..762ce18fab 100644
--- a/embed.h
+++ b/embed.h
@@ -282,6 +282,7 @@
#define inc_amg Perl_inc_amg
#define ingroup Perl_ingroup
#define init_stacks Perl_init_stacks
+#define init_thread_intern Perl_init_thread_intern
#define instr Perl_instr
#define intro_my Perl_intro_my
#define intuit_more Perl_intuit_more
@@ -458,6 +459,7 @@
#define newWHILEOP Perl_newWHILEOP
#define newXS Perl_newXS
#define newXSUB Perl_newXSUB
+#define new_struct_thread Perl_new_struct_thread
#define nextargv Perl_nextargv
#define nexttoke Perl_nexttoke
#define nexttype Perl_nexttype
@@ -479,6 +481,7 @@
#define nomemok Perl_nomemok
#define nomethod_amg Perl_nomethod_amg
#define not_amg Perl_not_amg
+#define nthreads Perl_nthreads
#define numer_amg Perl_numer_amg
#define numeric_local Perl_numeric_local
#define numeric_name Perl_numeric_name
@@ -510,6 +513,7 @@
#define padix Perl_padix
#define patleave Perl_patleave
#define peep Perl_peep
+#define per_thread_magicals Perl_per_thread_magicals
#define pidgone Perl_pidgone
#define pidstatus Perl_pidstatus
#define pmflag Perl_pmflag
@@ -816,6 +820,7 @@
#define pp_socket Perl_pp_socket
#define pp_sockpair Perl_pp_sockpair
#define pp_sort Perl_pp_sort
+#define pp_specific Perl_pp_specific
#define pp_splice Perl_pp_splice
#define pp_split Perl_pp_split
#define pp_sprintf Perl_pp_sprintf
@@ -1259,7 +1264,8 @@
#define e_tmpname (curinterp->Ie_tmpname)
#define endav (curinterp->Iendav)
#define envgv (curinterp->Ienvgv)
-#define errgv (curinterp->Ierrgv)
+#define errhv (curinterp->Ierrhv)
+#define errsv (curinterp->Ierrsv)
#define eval_root (curinterp->Ieval_root)
#define eval_start (curinterp->Ieval_start)
#define fdpid (curinterp->Ifdpid)
@@ -1411,7 +1417,8 @@
#define Ie_tmpname e_tmpname
#define Iendav endav
#define Ienvgv envgv
-#define Ierrgv errgv
+#define Ierrhv errhv
+#define Ierrsv errsv
#define Ieval_root eval_root
#define Ieval_start eval_start
#define Ifdpid fdpid
@@ -1572,7 +1579,8 @@
#define e_fp Perl_e_fp
#define e_tmpname Perl_e_tmpname
#define endav Perl_endav
-#define errgv Perl_errgv
+#define errhv Perl_errhv
+#define errsv Perl_errsv
#define eval_root Perl_eval_root
#define eval_start Perl_eval_start
#define fdpid Perl_fdpid
diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index 1878417ceb..d2db5ecba4 100644
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -429,9 +429,9 @@ beyond the scope of the compartment.
=item :base_thread
-This op is related to multi-threading.
+These ops are related to multi-threading.
- lock
+ lock specific
=item :default
diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index a09eafe37a..0e53a49183 100644
--- a/ext/POSIX/POSIX.xs
+++ b/ext/POSIX/POSIX.xs
@@ -58,76 +58,6 @@
#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
# define HAS_TZNAME /* shows up in VMS 7.0 or Dec C 5.6 */
# include <utsname.h>
-#else
- /* The default VMS emulation of Unix signals isn't very POSIXish */
- typedef int sigset_t;
-# define sigpending(a) (not_here("sigpending"),0)
-
- /* sigset_t is atomic under VMS, so these routines are easy */
- int sigemptyset(sigset_t *set) {
- if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
- *set = 0; return 0;
- }
- int sigfillset(sigset_t *set) {
- int i;
- if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
- for (i = 0; i < NSIG; i++) *set |= (1 << i);
- return 0;
- }
- int sigaddset(sigset_t *set, int sig) {
- if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
- if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
- *set |= (1 << (sig - 1));
- return 0;
- }
- int sigdelset(sigset_t *set, int sig) {
- if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
- if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
- *set &= ~(1 << (sig - 1));
- return 0;
- }
- int sigismember(sigset_t *set, int sig) {
- if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
- if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
- *set & (1 << (sig - 1));
- }
- /* The tools for sigprocmask() are there, just not the routine itself */
-# ifndef SIG_UNBLOCK
-# define SIG_UNBLOCK 1
-# endif
-# ifndef SIG_BLOCK
-# define SIG_BLOCK 2
-# endif
-# ifndef SIG_SETMASK
-# define SIG_SETMASK 3
-# endif
- int sigprocmask(int how, sigset_t *set, sigset_t *oset) {
- if (!set || !oset) {
- set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
- return -1;
- }
- switch (how) {
- case SIG_SETMASK:
- *oset = sigsetmask(*set);
- break;
- case SIG_BLOCK:
- *oset = sigblock(*set);
- break;
- case SIG_UNBLOCK:
- *oset = sigblock(0);
- sigsetmask(*oset & ~*set);
- break;
- default:
- set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
- return -1;
- }
- return 0;
- }
-# define sigaction sigvec
-# define sa_flags sv_onstack
-# define sa_handler sv_handler
-# define sa_mask sv_mask
-# define sigsuspend(set) sigpause(*set)
# endif /* __VMS_VER >= 70000000 or Dec C 5.6 */
/* The POSIX notion of ttyname() is better served by getname() under VMS */
diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs
index c4e87a30ee..9c0325e07d 100644
--- a/ext/Thread/Thread.xs
+++ b/ext/Thread/Thread.xs
@@ -2,25 +2,12 @@
#include "perl.h"
#include "XSUB.h"
-#ifdef WIN32
-#define ssize_t int
-#include <fcntl.h>
-#define THR_RET_TYPE DWORD
-#define THR_FUNC_TYPE THR_RET_TYPE WINAPI
-#else
-#define THR_RET_TYPE void *
-#define THR_FUNC_TYPE THR_RET_TYPE
-#endif
-
/* Magic signature for Thread's mg_private is "Th" */
#define Thread_MAGIC_SIGNATURE 0x5468
static U32 threadnum = 0;
static int sig_pipe[2];
-static void remove_thread _((Thread t));
-static THR_FUNC_TYPE threadstart _((void *));
-
static void
remove_thread(t)
Thread t;
@@ -36,8 +23,7 @@ Thread t;
MUTEX_UNLOCK(&threads_mutex);
}
-
-static THR_FUNC_TYPE
+static THREAD_RET_TYPE
threadstart(arg)
void *arg;
{
@@ -95,8 +81,8 @@ void *arg;
* Wait until our creator releases us. If we didn't do this, then
* it would be potentially possible for out thread to carry on and
* do stuff before our creator fills in our "self" field. For example,
- * if we went and created another thread which tried to pthread_join
- * with us, then we'd be in a mess.
+ * if we went and created another thread which tried to JOIN with us,
+ * then we'd be in a mess.
*/
MUTEX_LOCK(&thr->mutex);
MUTEX_UNLOCK(&thr->mutex);
@@ -106,12 +92,7 @@ void *arg;
* from our pthread_t structure to our struct thread, since we're
* the only thread who can get at it anyway.
*/
-#ifdef WIN32
- if (TlsSetValue(thr_key, (void *) thr) == 0)
-#else
- if (pthread_setspecific(thr_key, (void *) thr))
-#endif
- croak("panic: pthread_setspecific");
+ SET_THR(thr);
/* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */
DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
@@ -134,6 +115,8 @@ void *arg;
goto finishoff;
}
+ CATCH_SET(TRUE);
+
/* Now duplicate most of perl_call_sv but with a few twists */
op = (OP*)&myop;
Zero(op, 1, LOGOP);
@@ -161,13 +144,16 @@ void *arg;
/* removed for debug */
SvREFCNT_dec(curstack);
#endif
- SvREFCNT_dec(cvcache);
+ SvREFCNT_dec(thr->cvcache);
+ SvREFCNT_dec(thr->magicals);
+ SvREFCNT_dec(thr->specific);
Safefree(markstack);
Safefree(scopestack);
Safefree(savestack);
Safefree(retstack);
Safefree(cxstack);
Safefree(tmps_stack);
+ Safefree(ofs);
MUTEX_LOCK(&thr->mutex);
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
@@ -200,9 +186,9 @@ void *arg;
croak("panic: illegal state %u at end of threadstart", ThrSTATE(thr));
/* NOTREACHED */
}
- return (THR_RET_TYPE) returnav;/* Available for anyone to join with us */
- /* unless we are detached in which case */
- /* noone will see the value anyway. */
+ return THREAD_RET_CAST(returnav); /* Available for anyone to join with */
+ /* us unless we're detached, in which */
+ /* case noone sees the value anyway. */
#endif
}
@@ -217,45 +203,14 @@ char *class;
Thread savethread;
int i;
SV *sv;
-#ifndef WIN32
+ int err;
+#ifndef THREAD_CREATE
sigset_t fullmask, oldmask;
-#else
- DWORD junk;
#endif
savethread = thr;
- sv = newSVpv("", 0);
- SvGROW(sv, sizeof(struct thread) + 1);
- SvCUR_set(sv, sizeof(struct thread));
- thr = (Thread) SvPVX(sv);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: newthread(%s) = %p)\n",
- savethread, SvPEEK(startsv), thr));
- oursv = sv;
- /* If we don't zero these foostack pointers, init_stacks won't init them */
- markstack = 0;
- scopestack = 0;
- savestack = 0;
- retstack = 0;
- init_stacks(ARGS);
- curcop = savethread->Tcurcop; /* XXX As good a guess as any? */
+ thr = new_struct_thread(thr);
SPAGAIN;
- defstash = savethread->Tdefstash; /* XXX maybe these should */
- curstash = savethread->Tcurstash; /* always be set to main? */
- /* top_env? */
- /* runlevel */
- cvcache = newHV();
- thr->flags = THRf_R_JOINABLE;
- MUTEX_INIT(&thr->mutex);
- thr->tid = ++threadnum;
- /* Insert new thread into the circular linked list and bump nthreads */
- MUTEX_LOCK(&threads_mutex);
- thr->next = savethread->next;
- thr->prev = savethread;
- savethread->next = thr;
- thr->next->prev = thr;
- nthreads++;
- MUTEX_UNLOCK(&threads_mutex);
-
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
"%p: newthread, tid is %u, preparing stack\n",
savethread, thr->tid));
@@ -267,32 +222,38 @@ char *class;
XPUSHs(SvREFCNT_inc(startsv));
PUTBACK;
-#ifdef FAKE_THREADS
- threadstart(thr);
+#ifdef THREAD_CREATE
+ THREAD_CREATE(thr, threadstart);
#else
/* On your marks... */
MUTEX_LOCK(&thr->mutex);
- /* Get set...
- * Increment the global thread count.
- */
-#ifndef WIN32
+ /* Get set... */
sigfillset(&fullmask);
if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1)
croak("panic: sigprocmask");
- if (pthread_create(&self, NULL, threadstart, (void*) thr))
-#else
- if ((self = CreateThread(NULL,0,threadstart,(void*)thr,0,&junk)) == 0)
-#endif
- return NULL; /* XXX should clean up first */
+ err = pthread_create(&thr->self, pthread_attr_default,
+ threadstart, (void*) thr);
/* Go */
MUTEX_UNLOCK(&thr->mutex);
-#ifndef WIN32
+#endif
+ if (err) {
+ /* Thread creation failed--clean up */
+ SvREFCNT_dec(thr->cvcache);
+ remove_thread(thr);
+ MUTEX_DESTROY(&thr->mutex);
+ for (i = 0; i <= AvFILL(initargs); i++)
+ SvREFCNT_dec(*av_fetch(initargs, i, FALSE));
+ SvREFCNT_dec(startsv);
+ return NULL;
+ }
+#ifdef THREAD_POST_CREATE
+ THREAD_POST_CREATE(thr);
+#else
if (sigprocmask(SIG_SETMASK, &oldmask, 0))
croak("panic: sigprocmask");
#endif
-#endif
sv = newSViv(thr->tid);
- sv_magic(sv, oursv, '~', 0, 0);
+ sv_magic(sv, thr->oursv, '~', 0, 0);
SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
return sv_bless(newRV_noinc(sv), gv_stashpv(class, TRUE));
}
@@ -340,13 +301,7 @@ join(t)
croak("can't join with thread");
/* NOTREACHED */
}
-#ifdef WIN32
- if ((WaitForSingleObject(t->Tself,INFINITE) == WAIT_FAILED)
- || (GetExitCodeThread(t->Tself,(LPDWORD)&av) == 0))
-#else
- if (pthread_join(t->Tself, (void **) &av))
-#endif
- croak("pthread_join failed");
+ JOIN(t, &av);
/* Could easily speed up the following if necessary */
for (i = 0; i <= AvFILL(av); i++)
@@ -399,7 +354,7 @@ self(class)
SV *sv;
PPCODE:
sv = newSViv(thr->tid);
- sv_magic(sv, oursv, '~', 0, 0);
+ sv_magic(sv, thr->oursv, '~', 0, 0);
SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv), gv_stashpv(class, TRUE))));
@@ -422,17 +377,7 @@ DESTROY(t)
void
yield()
CODE:
-#ifdef OLD_PTHREADS_API
- pthread_yield();
-#else
-#ifndef NO_SCHED_YIELD
-#ifdef WIN32
- Sleep(0); /* same semantics as POSIX sched_yield() */
-#else
- sched_yield();
-#endif /* WIN32 */
-#endif /* NO_SCHED_YIELD */
-#endif /* OLD_PTHREADS_API */
+ YIELD;
void
cond_wait(sv)
@@ -536,7 +481,7 @@ list(class)
do {
SV *sv = (SV*)SvRV(*svp);
sv_setiv(sv, t->tid);
- SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->Toursv);
+ SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->oursv);
SvMAGIC(sv)->mg_flags |= MGf_REFCOUNTED;
SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
t = t->next;
@@ -573,7 +518,7 @@ SV *
await_signal()
PREINIT:
char c;
- ssize_t ret;
+ SSize_t ret;
CODE:
do {
ret = read(sig_pipe[1], &c, 1);
diff --git a/fakethr.h b/fakethr.h
index dac2cc9030..e09a757b6d 100644
--- a/fakethr.h
+++ b/fakethr.h
@@ -1,6 +1,10 @@
typedef int perl_mutex;
typedef int perl_key;
+typedef struct thread *perl_thread;
+/* With fake threads, thr is global(ish) so we don't need dTHR */
+#define dTHR extern int errno
+
struct perl_wait_queue {
struct thread * thread;
struct perl_wait_queue * next;
@@ -18,9 +22,35 @@ struct thread_intern {
#define init_thread_intern(t) \
STMT_START { \
- t->Tself = (t); \
+ t->self = (t); \
(t)->i.next_run = (t)->i.prev_run = (t); \
(t)->i.wait_queue = 0; \
(t)->i.private = 0; \
} STMT_END
+/*
+ * 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)
+
+#define THREAD_CREATE(t, f) f((t))
+#define THREAD_POST_CREATE(t) NOOP
+
+#define YIELD NOOP
diff --git a/global.sym b/global.sym
index 2083a4cab1..aab677c115 100644
--- a/global.sym
+++ b/global.sym
@@ -69,6 +69,7 @@ gid
gt_amg
hexdigit
hints
+init_thread_intern
in_my
in_my_stash
inc_amg
@@ -117,6 +118,7 @@ na
ncmp_amg
ne_amg
neg_amg
+new_struct_thread
nexttoke
nexttype
nextval
@@ -139,6 +141,7 @@ nomem
nomemok
nomethod_amg
not_amg
+nthreads
numeric_local
numeric_name
numeric_standard
@@ -158,6 +161,7 @@ pad_reset_pending
padix
padix_floor
patleave
+per_thread_magicals
pidstatus
pow_amg
pow_ass_amg
@@ -951,6 +955,7 @@ pp_snetent
pp_socket
pp_sockpair
pp_sort
+pp_specific
pp_splice
pp_split
pp_sprintf
diff --git a/gv.c b/gv.c
index 0928d686fc..857e19c221 100644
--- a/gv.c
+++ b/gv.c
@@ -234,7 +234,6 @@ 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));
@@ -638,7 +637,7 @@ I32 sv_type;
if (strEQ(name, "OVERLOAD")) {
HV* hv = GvHVn(gv);
GvMULTI_on(gv);
- sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
+ hv_magic(hv, gv, 'A');
}
break;
#endif /* OVERLOAD */
diff --git a/hv.c b/hv.c
index 50ff060e36..15d6c624de 100644
--- a/hv.c
+++ b/hv.c
@@ -316,6 +316,7 @@ register U32 hash;
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
+ dTHR;
bool save_taint = tainted;
if (tainting)
tainted = SvTAINTED(keysv);
@@ -925,7 +926,6 @@ 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 4d2bfb9d70..55fbeb0777 100644
--- a/interp.sym
+++ b/interp.sym
@@ -47,7 +47,8 @@ e_fp
e_tmpname
endav
envgv
-errgv
+errhv
+errsv
eval_root
eval_start
fdpid
diff --git a/mg.c b/mg.c
index dedf381629..47e05a1176 100644
--- a/mg.c
+++ b/mg.c
@@ -264,6 +264,7 @@ magic_len(sv, mg)
SV *sv;
MAGIC *mg;
{
+ dTHR;
register I32 paren;
register char *s;
register I32 i;
@@ -329,6 +330,7 @@ magic_get(sv, mg)
SV *sv;
MAGIC *mg;
{
+ dTHR;
register I32 paren;
register char *s;
register I32 i;
@@ -415,7 +417,11 @@ MAGIC *mg;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
if (curpm && (rx = curpm->op_pmregexp)) {
- paren = atoi(GvENAME((GV*)mg->mg_obj));
+ /*
+ * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
+ * XXX Does the new way break anything?
+ */
+ paren = atoi(mg->mg_ptr);
getparen:
if (paren <= rx->nparens &&
(s = rx->startp[paren]) &&
@@ -572,6 +578,11 @@ MAGIC *mg;
break;
case '0':
break;
+#ifdef USE_THREADS
+ case '@':
+ sv_setsv(sv, errsv);
+ break;
+#endif /* USE_THREADS */
}
return 0;
}
@@ -749,7 +760,6 @@ 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 */
@@ -1177,6 +1187,7 @@ magic_gettaint(sv,mg)
SV* sv;
MAGIC* mg;
{
+ dTHR;
TAINT_IF((mg->mg_len & 1) ||
(mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */
return 0;
@@ -1706,6 +1717,11 @@ MAGIC* mg;
origargv[i] = Nullch;
}
break;
+#ifdef USE_THREADS
+ case '@':
+ sv_setsv(errsv, sv);
+ break;
+#endif /* USE_THREADS */
}
return 0;
}
@@ -1723,6 +1739,7 @@ MAGIC *mg;
croak("panic: magic_mutexfree");
MUTEX_DESTROY(MgMUTEXP(mg));
COND_DESTROY(MgCONDP(mg));
+ SvREFCNT_dec(sv);
return 0;
}
#endif /* USE_THREADS */
diff --git a/op.c b/op.c
index 680b825865..3bd44fc280 100644
--- a/op.c
+++ b/op.c
@@ -511,6 +511,45 @@ pad_reset()
pad_reset_pending = FALSE;
}
+#ifdef USE_THREADS
+/* find_thread_magical is not reentrant */
+PADOFFSET
+find_thread_magical(name)
+char *name;
+{
+ dTHR;
+ char *p;
+ PADOFFSET key;
+ SV **svp;
+ /* We currently only handle single character magicals */
+ p = strchr(per_thread_magicals, *name);
+ if (!p)
+ return NOT_IN_PAD;
+ key = p - per_thread_magicals;
+ svp = av_fetch(thr->magicals, key, FALSE);
+ if (!svp) {
+ SV *sv = NEWSV(0, 0);
+ av_store(thr->magicals, key, sv);
+ /*
+ * Some magic variables used to be automagically initialised
+ * in gv_fetchpv. Those which are now per-thread magicals get
+ * initialised here instead.
+ */
+ switch (*name) {
+ case ';':
+ sv_setpv(sv, "\034");
+ break;
+ }
+ sv_magic(sv, 0, 0, name, 1);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "find_thread_magical: new SV %p for $%s%c\n",
+ sv, (*name < 32) ? "^" : "",
+ (*name < 32) ? toCTRL(*name) : *name));
+ }
+ return key;
+}
+#endif /* USE_THREADS */
+
/* Destructor */
void
@@ -536,6 +575,11 @@ OP *o;
case OP_ENTEREVAL:
o->op_targ = 0; /* Was holding hints. */
break;
+#ifdef USE_THREADS
+ case OP_SPECIFIC:
+ o->op_targ = 0; /* Was holding index into thr->magicals AV. */
+ break;
+#endif /* USE_THREADS */
default:
if (!(o->op_flags & OPf_REF) || (check[o->op_type] != ck_ftst))
break;
@@ -1158,6 +1202,16 @@ I32 type;
SvPV(*av_fetch(comppad_name, o->op_targ, 4), na));
break;
+#ifdef USE_THREADS
+ case OP_SPECIFIC:
+ modcount++; /* XXX ??? */
+#if 0
+ if (!type)
+ croak("Can't localize thread-specific variable");
+#endif
+ break;
+#endif /* USE_THREADS */
+
case OP_PUSHMARK:
break;
@@ -1288,7 +1342,7 @@ I32 type;
switch (o->op_type) {
case OP_ENTERSUB:
- if ((type == OP_DEFINED) &&
+ if ((type == OP_DEFINED || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
o->op_ppaddr = ppaddr[OP_RV2CV];
@@ -1314,6 +1368,10 @@ I32 type;
}
break;
+ case OP_SPECIFIC:
+ o->op_flags |= OPf_MOD; /* XXX ??? */
+ break;
+
case OP_RV2AV:
case OP_RV2HV:
o->op_flags |= OPf_REF;
@@ -1581,10 +1639,14 @@ jmaybe(o)
OP *o;
{
if (o->op_type == OP_LIST) {
- o = convert(OP_JOIN, 0,
- prepend_elem(OP_LIST,
- newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
- o));
+ OP *o2;
+#ifdef USE_THREADS
+ o2 = newOP(OP_SPECIFIC, 0);
+ o2->op_targ = find_thread_magical(";");
+#else
+ o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
+#endif /* USE_THREADS */
+ o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
}
@@ -2127,17 +2189,32 @@ OP *repl;
OP *curop;
if (pm->op_pmflags & PMf_EVAL)
curop = 0;
+#ifdef USE_THREADS
+ else if (repl->op_type == OP_SPECIFIC
+ && strchr("&`'123456789+",
+ per_thread_magicals[repl->op_targ]))
+ {
+ curop = 0;
+ }
+#endif /* USE_THREADS */
else if (repl->op_type == OP_CONST)
curop = repl;
else {
OP *lastop = 0;
for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
if (opargs[curop->op_type] & OA_DANGEROUS) {
+#ifdef USE_THREADS
+ if (curop->op_type == OP_SPECIFIC
+ && strchr("&`'123456789+", curop->op_private)) {
+ break;
+ }
+#else
if (curop->op_type == OP_GV) {
GV *gv = ((GVOP*)curop)->op_gv;
if (strchr("&`'123456789+", *GvENAME(gv)))
break;
}
+#endif /* USE_THREADS */
else if (curop->op_type == OP_RV2CV)
break;
else if (curop->op_type == OP_RV2SV ||
@@ -3410,8 +3487,8 @@ OP *block;
croak(not_safe);
else {
/* force display of errors found but not reported */
- sv_catpv(GvSV(errgv), not_safe);
- croak("%s", SvPVx(GvSV(errgv), na));
+ sv_catpv(errsv, not_safe);
+ croak("%s", SvPV(errsv, na));
}
}
}
@@ -3538,21 +3615,6 @@ OP *block;
return cv;
}
-#ifdef DEPRECATED
-CV *
-newXSUB(name, ix, subaddr, filename)
-char *name;
-I32 ix;
-I32 (*subaddr)();
-char *filename;
-{
- CV* cv = newXS(name, (void(*)())subaddr, filename);
- CvOLDSTYLE_on(cv);
- CvXSUBANY(cv).any_i32 = ix;
- return cv;
-}
-#endif
-
CV *
newXS(name, subaddr, filename)
char *name;
@@ -3814,6 +3876,8 @@ OP *o;
o->op_ppaddr = ppaddr[OP_PADSV];
return o;
}
+ else if (o->op_type == OP_SPECIFIC)
+ return o;
return newUNOP(OP_RV2SV, 0, scalar(o));
}
@@ -4886,6 +4950,24 @@ register OP* o;
o->op_seq = op_seqmax++;
break;
+ case OP_PADAV:
+ if (o->op_next->op_type == OP_RV2AV
+ && (o->op_next->op_flags && OPf_REF))
+ {
+ null(o->op_next);
+ o->op_next = o->op_next->op_next;
+ }
+ break;
+
+ case OP_PADHV:
+ if (o->op_next->op_type == OP_RV2HV
+ && (o->op_next->op_flags && OPf_REF))
+ {
+ null(o->op_next);
+ o->op_next = o->op_next->op_next;
+ }
+ break;
+
case OP_MAPWHILE:
case OP_GREPWHILE:
case OP_AND:
diff --git a/op.h b/op.h
index f9dad977ef..8f3b2b9e08 100644
--- a/op.h
+++ b/op.h
@@ -130,6 +130,9 @@ typedef U32 PADOFFSET;
/* Private for OP_SORT, OP_PRTF, OP_SPRINTF, string cmp'n, and case changers */
#define OPpLOCALE 64 /* Use locale */
+/* Private for OP_SPECIFIC */
+#define OPpPM_NOT_CONST 64 /* Not constant enough for pmruntime */
+
struct op {
BASEOP
};
@@ -271,7 +274,24 @@ struct loop {
#define OA_DANGEROUS 64
#define OA_DEFGV 128
-#define OASHIFT 8
+/* The next 4 bits encode op class information */
+#define OA_BASEOP (0 << 8)
+#define OA_UNOP (1 << 8)
+#define OA_BINOP (2 << 8)
+#define OA_LOGOP (3 << 8)
+#define OA_CONDOP (4 << 8)
+#define OA_LISTOP (5 << 8)
+#define OA_PMOP (6 << 8)
+#define OA_SVOP (7 << 8)
+#define OA_GVOP (8 << 8)
+#define OA_PVOP (9 << 8)
+#define OA_LOOP (10 << 8)
+#define OA_COP (11 << 8)
+#define OA_BASEOP_OR_UNOP (12 << 8)
+#define OA_FILESTATOP (13 << 8)
+#define OA_LOOPEXOP (14 << 8)
+
+#define OASHIFT 12
/* Remaining nybbles of opargs */
#define OA_SCALAR 1
diff --git a/opcode.h b/opcode.h
index 7cf7f66800..936831bada 100644
--- a/opcode.h
+++ b/opcode.h
@@ -349,10 +349,11 @@ typedef enum {
OP_GETLOGIN, /* 342 */
OP_SYSCALL, /* 343 */
OP_LOCK, /* 344 */
+ OP_SPECIFIC, /* 345 */
OP_max
} opcode;
-#define MAXO 345
+#define MAXO 346
#ifndef DOINIT
EXT char *op_name[];
@@ -703,6 +704,7 @@ EXT char *op_name[] = {
"getlogin",
"syscall",
"lock",
+ "specific",
};
#endif
@@ -1055,6 +1057,7 @@ EXT char *op_desc[] = {
"getlogin",
"syscall",
"lock",
+ "thread-specific",
};
#endif
@@ -1436,6 +1439,7 @@ OP * pp_egrent _((ARGSproto));
OP * pp_getlogin _((ARGSproto));
OP * pp_syscall _((ARGSproto));
OP * pp_lock _((ARGSproto));
+OP * pp_specific _((ARGSproto));
#ifndef DOINIT
EXT OP * (*ppaddr[])();
@@ -1786,6 +1790,7 @@ EXT OP * (*ppaddr[])() = {
pp_getlogin,
pp_syscall,
pp_lock,
+ pp_specific,
};
#endif
@@ -2137,7 +2142,8 @@ EXT OP * (*check[]) _((OP *op)) = {
ck_null, /* egrent */
ck_null, /* getlogin */
ck_fun, /* syscall */
- ck_null, /* lock */
+ ck_rfun, /* lock */
+ ck_null, /* specific */
};
#endif
@@ -2147,348 +2153,349 @@ EXT U32 opargs[];
EXT U32 opargs[] = {
0x00000000, /* null */
0x00000000, /* stub */
- 0x00000104, /* scalar */
+ 0x00001c04, /* scalar */
0x00000004, /* pushmark */
0x00000014, /* wantarray */
- 0x00000004, /* const */
- 0x00000044, /* gvsv */
- 0x00000044, /* gv */
- 0x00001140, /* gelem */
+ 0x00000704, /* const */
+ 0x00000844, /* gvsv */
+ 0x00000844, /* gv */
+ 0x00011240, /* gelem */
0x00000044, /* padsv */
0x00000040, /* padav */
0x00000040, /* padhv */
0x00000040, /* padany */
- 0x00000000, /* pushre */
- 0x00000044, /* rv2gv */
- 0x00000044, /* rv2sv */
- 0x00000014, /* av2arylen */
- 0x00000040, /* rv2cv */
- 0x00000000, /* anoncode */
- 0x00000104, /* prototype */
- 0x00000201, /* refgen */
- 0x00000106, /* srefgen */
- 0x0000098c, /* ref */
- 0x00009104, /* bless */
- 0x00000008, /* backtick */
- 0x00009908, /* glob */
- 0x00000008, /* readline */
- 0x00000008, /* rcatline */
- 0x00000104, /* regcmaybe */
- 0x00000104, /* regcomp */
- 0x00000040, /* match */
- 0x00000154, /* subst */
- 0x00000054, /* substcont */
- 0x00000114, /* trans */
+ 0x00000600, /* pushre */
+ 0x00000144, /* rv2gv */
+ 0x00000144, /* rv2sv */
+ 0x00000114, /* av2arylen */
+ 0x00000140, /* rv2cv */
+ 0x00000700, /* anoncode */
+ 0x00001c04, /* prototype */
+ 0x00002001, /* refgen */
+ 0x00001006, /* srefgen */
+ 0x00009c8c, /* ref */
+ 0x00091504, /* bless */
+ 0x00000c08, /* backtick */
+ 0x00099508, /* glob */
+ 0x00000c08, /* readline */
+ 0x00000c08, /* rcatline */
+ 0x00001104, /* regcmaybe */
+ 0x00001304, /* regcomp */
+ 0x00000640, /* match */
+ 0x00001654, /* subst */
+ 0x00000354, /* substcont */
+ 0x00001914, /* trans */
0x00000004, /* sassign */
- 0x00002208, /* aassign */
- 0x0000020d, /* chop */
- 0x0000098c, /* schop */
- 0x0000020d, /* chomp */
- 0x0000098c, /* schomp */
- 0x00000994, /* defined */
- 0x00000904, /* undef */
- 0x00000984, /* study */
- 0x0000098c, /* pos */
- 0x00000164, /* preinc */
- 0x00000154, /* i_preinc */
- 0x00000164, /* predec */
- 0x00000154, /* i_predec */
- 0x0000016c, /* postinc */
- 0x0000015c, /* i_postinc */
- 0x0000016c, /* postdec */
- 0x0000015c, /* i_postdec */
- 0x0000110e, /* pow */
- 0x0000112e, /* multiply */
- 0x0000111e, /* i_multiply */
- 0x0000112e, /* divide */
- 0x0000111e, /* i_divide */
- 0x0000113e, /* modulo */
- 0x0000111e, /* i_modulo */
- 0x00001209, /* repeat */
- 0x0000112e, /* add */
- 0x0000111e, /* i_add */
- 0x0000112e, /* subtract */
- 0x0000111e, /* i_subtract */
- 0x0000110e, /* concat */
- 0x0000010e, /* stringify */
- 0x0000110e, /* left_shift */
- 0x0000110e, /* right_shift */
- 0x00001136, /* lt */
- 0x00001116, /* i_lt */
- 0x00001136, /* gt */
- 0x00001116, /* i_gt */
- 0x00001136, /* le */
- 0x00001116, /* i_le */
- 0x00001136, /* ge */
- 0x00001116, /* i_ge */
- 0x00001136, /* eq */
- 0x00001116, /* i_eq */
- 0x00001136, /* ne */
- 0x00001116, /* i_ne */
- 0x0000113e, /* ncmp */
- 0x0000111e, /* i_ncmp */
- 0x00001116, /* slt */
- 0x00001116, /* sgt */
- 0x00001116, /* sle */
- 0x00001116, /* sge */
- 0x00001116, /* seq */
- 0x00001116, /* sne */
- 0x0000111e, /* scmp */
- 0x0000110e, /* bit_and */
- 0x0000110e, /* bit_xor */
- 0x0000110e, /* bit_or */
- 0x0000012e, /* negate */
- 0x0000011e, /* i_negate */
- 0x00000116, /* not */
- 0x0000010e, /* complement */
- 0x0000110e, /* atan2 */
- 0x0000098e, /* sin */
- 0x0000098e, /* cos */
- 0x0000090c, /* rand */
- 0x00000904, /* srand */
- 0x0000098e, /* exp */
- 0x0000098e, /* log */
- 0x0000098e, /* sqrt */
- 0x0000098e, /* int */
- 0x0000098e, /* hex */
- 0x0000098e, /* oct */
- 0x0000098e, /* abs */
- 0x0000099c, /* length */
- 0x0009110c, /* substr */
- 0x0001111c, /* vec */
- 0x0009111c, /* index */
- 0x0009111c, /* rindex */
- 0x0000210f, /* sprintf */
- 0x00002105, /* formline */
- 0x0000099e, /* ord */
- 0x0000098e, /* chr */
- 0x0000110e, /* crypt */
- 0x0000098e, /* ucfirst */
- 0x0000098e, /* lcfirst */
- 0x0000098e, /* uc */
- 0x0000098e, /* lc */
- 0x0000098e, /* quotemeta */
- 0x00000048, /* rv2av */
- 0x00001304, /* aelemfast */
- 0x00001304, /* aelem */
- 0x00002301, /* aslice */
- 0x00000408, /* each */
- 0x00000408, /* values */
- 0x00000408, /* keys */
- 0x00000100, /* delete */
- 0x00000114, /* exists */
- 0x00000048, /* rv2hv */
- 0x00001404, /* helem */
- 0x00002401, /* hslice */
- 0x00001100, /* unpack */
- 0x0000210d, /* pack */
- 0x00011108, /* split */
- 0x0000210d, /* join */
- 0x00000201, /* list */
- 0x00022400, /* lslice */
- 0x00000205, /* anonlist */
- 0x00000205, /* anonhash */
- 0x00299301, /* splice */
- 0x0000231d, /* push */
- 0x00000304, /* pop */
- 0x00000304, /* shift */
- 0x0000231d, /* unshift */
- 0x00002d01, /* sort */
- 0x00000209, /* reverse */
- 0x00002541, /* grepstart */
- 0x00000048, /* grepwhile */
- 0x00002541, /* mapstart */
- 0x00000048, /* mapwhile */
- 0x00001100, /* range */
- 0x00001100, /* flip */
- 0x00000000, /* flop */
- 0x00000000, /* and */
- 0x00000000, /* or */
- 0x00001106, /* xor */
- 0x00000040, /* cond_expr */
- 0x00000004, /* andassign */
- 0x00000004, /* orassign */
- 0x00000040, /* method */
- 0x00000249, /* entersub */
- 0x00000000, /* leavesub */
- 0x00000908, /* caller */
- 0x0000021d, /* warn */
- 0x0000025d, /* die */
- 0x00000914, /* reset */
- 0x00000000, /* lineseq */
- 0x00000004, /* nextstate */
- 0x00000004, /* dbstate */
+ 0x00022208, /* aassign */
+ 0x00002c0d, /* chop */
+ 0x00009c8c, /* schop */
+ 0x00002c0d, /* chomp */
+ 0x00009c8c, /* schomp */
+ 0x00009c94, /* defined */
+ 0x00009c04, /* undef */
+ 0x00009c84, /* study */
+ 0x00009c8c, /* pos */
+ 0x00001164, /* preinc */
+ 0x00001154, /* i_preinc */
+ 0x00001164, /* predec */
+ 0x00001154, /* i_predec */
+ 0x0000116c, /* postinc */
+ 0x0000115c, /* i_postinc */
+ 0x0000116c, /* postdec */
+ 0x0000115c, /* i_postdec */
+ 0x0001120e, /* pow */
+ 0x0001122e, /* multiply */
+ 0x0001121e, /* i_multiply */
+ 0x0001122e, /* divide */
+ 0x0001121e, /* i_divide */
+ 0x0001123e, /* modulo */
+ 0x0001121e, /* i_modulo */
+ 0x00012209, /* repeat */
+ 0x0001122e, /* add */
+ 0x0001121e, /* i_add */
+ 0x0001122e, /* subtract */
+ 0x0001121e, /* i_subtract */
+ 0x0001120e, /* concat */
+ 0x0000150e, /* stringify */
+ 0x0001120e, /* left_shift */
+ 0x0001120e, /* right_shift */
+ 0x00011236, /* lt */
+ 0x00011216, /* i_lt */
+ 0x00011236, /* gt */
+ 0x00011216, /* i_gt */
+ 0x00011236, /* le */
+ 0x00011216, /* i_le */
+ 0x00011236, /* ge */
+ 0x00011216, /* i_ge */
+ 0x00011236, /* eq */
+ 0x00011216, /* i_eq */
+ 0x00011236, /* ne */
+ 0x00011216, /* i_ne */
+ 0x0001123e, /* ncmp */
+ 0x0001121e, /* i_ncmp */
+ 0x00011216, /* slt */
+ 0x00011216, /* sgt */
+ 0x00011216, /* sle */
+ 0x00011216, /* sge */
+ 0x00011216, /* seq */
+ 0x00011216, /* sne */
+ 0x0001121e, /* scmp */
+ 0x0001120e, /* bit_and */
+ 0x0001120e, /* bit_xor */
+ 0x0001120e, /* bit_or */
+ 0x0000112e, /* negate */
+ 0x0000111e, /* i_negate */
+ 0x00001116, /* not */
+ 0x0000110e, /* complement */
+ 0x0001150e, /* atan2 */
+ 0x00009c8e, /* sin */
+ 0x00009c8e, /* cos */
+ 0x00009c0c, /* rand */
+ 0x00009c04, /* srand */
+ 0x00009c8e, /* exp */
+ 0x00009c8e, /* log */
+ 0x00009c8e, /* sqrt */
+ 0x00009c8e, /* int */
+ 0x00009c8e, /* hex */
+ 0x00009c8e, /* oct */
+ 0x00009c8e, /* abs */
+ 0x00009c9c, /* length */
+ 0x0091150c, /* substr */
+ 0x0011151c, /* vec */
+ 0x0091151c, /* index */
+ 0x0091151c, /* rindex */
+ 0x0002150f, /* sprintf */
+ 0x00021505, /* formline */
+ 0x00009c9e, /* ord */
+ 0x00009c8e, /* chr */
+ 0x0001150e, /* crypt */
+ 0x00009c8e, /* ucfirst */
+ 0x00009c8e, /* lcfirst */
+ 0x00009c8e, /* uc */
+ 0x00009c8e, /* lc */
+ 0x00009c8e, /* quotemeta */
+ 0x00000148, /* rv2av */
+ 0x00013804, /* aelemfast */
+ 0x00013204, /* aelem */
+ 0x00023501, /* aslice */
+ 0x00004c08, /* each */
+ 0x00004c08, /* values */
+ 0x00004c08, /* keys */
+ 0x00001c00, /* delete */
+ 0x00001c14, /* exists */
+ 0x00000148, /* rv2hv */
+ 0x00014204, /* helem */
+ 0x00024501, /* hslice */
+ 0x00011500, /* unpack */
+ 0x0002150d, /* pack */
+ 0x00111508, /* split */
+ 0x0002150d, /* join */
+ 0x00002501, /* list */
+ 0x00224200, /* lslice */
+ 0x00002505, /* anonlist */
+ 0x00002505, /* anonhash */
+ 0x02993501, /* splice */
+ 0x0002351d, /* push */
+ 0x00003c14, /* pop */
+ 0x00003c04, /* shift */
+ 0x0002351d, /* unshift */
+ 0x0002d501, /* sort */
+ 0x00002509, /* reverse */
+ 0x00025541, /* grepstart */
+ 0x00000348, /* grepwhile */
+ 0x00025541, /* mapstart */
+ 0x00000348, /* mapwhile */
+ 0x00011400, /* range */
+ 0x00011100, /* flip */
+ 0x00000100, /* flop */
+ 0x00000300, /* and */
+ 0x00000300, /* or */
+ 0x00011306, /* xor */
+ 0x00000440, /* cond_expr */
+ 0x00000304, /* andassign */
+ 0x00000304, /* orassign */
+ 0x00000140, /* method */
+ 0x00002149, /* entersub */
+ 0x00000100, /* leavesub */
+ 0x00009c08, /* caller */
+ 0x0000251d, /* warn */
+ 0x0000255d, /* die */
+ 0x00009c14, /* reset */
+ 0x00000500, /* lineseq */
+ 0x00000b04, /* nextstate */
+ 0x00000b04, /* dbstate */
0x00000004, /* unstack */
0x00000000, /* enter */
- 0x00000000, /* leave */
- 0x00000000, /* scope */
- 0x00000040, /* enteriter */
+ 0x00000500, /* leave */
+ 0x00000500, /* scope */
+ 0x00000a40, /* enteriter */
0x00000000, /* iter */
- 0x00000040, /* enterloop */
- 0x00000000, /* leaveloop */
- 0x00000241, /* return */
- 0x00000044, /* last */
- 0x00000044, /* next */
- 0x00000044, /* redo */
- 0x00000044, /* dump */
- 0x00000044, /* goto */
- 0x00000944, /* exit */
- 0x0000961c, /* open */
- 0x00000e14, /* close */
- 0x00006614, /* pipe_op */
- 0x0000061c, /* fileno */
- 0x0000091c, /* umask */
- 0x00000604, /* binmode */
- 0x00021755, /* tie */
- 0x00000714, /* untie */
- 0x00000704, /* tied */
- 0x00011414, /* dbmopen */
- 0x00000414, /* dbmclose */
- 0x00111108, /* sselect */
- 0x00000e0c, /* select */
- 0x00000e0c, /* getc */
- 0x0091761d, /* read */
- 0x00000e54, /* enterwrite */
- 0x00000000, /* leavewrite */
- 0x00002e15, /* prtf */
- 0x00002e15, /* print */
- 0x00911604, /* sysopen */
- 0x00011604, /* sysseek */
- 0x0091761d, /* sysread */
- 0x0091161d, /* syswrite */
- 0x0091161d, /* send */
- 0x0011761d, /* recv */
- 0x00000e14, /* eof */
- 0x00000e0c, /* tell */
- 0x00011604, /* seek */
- 0x00001114, /* truncate */
- 0x0001160c, /* fcntl */
- 0x0001160c, /* ioctl */
- 0x0000161c, /* flock */
- 0x00111614, /* socket */
- 0x01116614, /* sockpair */
- 0x00001614, /* bind */
- 0x00001614, /* connect */
- 0x00001614, /* listen */
- 0x0000661c, /* accept */
- 0x0000161c, /* shutdown */
- 0x00011614, /* gsockopt */
- 0x00111614, /* ssockopt */
- 0x00000614, /* getsockname */
- 0x00000614, /* getpeername */
- 0x00000680, /* lstat */
- 0x00000680, /* stat */
- 0x00000694, /* ftrread */
- 0x00000694, /* ftrwrite */
- 0x00000694, /* ftrexec */
- 0x00000694, /* fteread */
- 0x00000694, /* ftewrite */
- 0x00000694, /* fteexec */
- 0x00000694, /* ftis */
- 0x00000694, /* fteowned */
- 0x00000694, /* ftrowned */
- 0x00000694, /* ftzero */
- 0x0000069c, /* ftsize */
- 0x0000068c, /* ftmtime */
- 0x0000068c, /* ftatime */
- 0x0000068c, /* ftctime */
- 0x00000694, /* ftsock */
- 0x00000694, /* ftchr */
- 0x00000694, /* ftblk */
- 0x00000694, /* ftfile */
- 0x00000694, /* ftdir */
- 0x00000694, /* ftpipe */
- 0x00000694, /* ftlink */
- 0x00000694, /* ftsuid */
- 0x00000694, /* ftsgid */
- 0x00000694, /* ftsvtx */
- 0x00000614, /* fttty */
- 0x00000694, /* fttext */
- 0x00000694, /* ftbinary */
- 0x0000091c, /* chdir */
- 0x0000021d, /* chown */
- 0x0000099c, /* chroot */
- 0x0000029d, /* unlink */
- 0x0000021d, /* chmod */
- 0x0000021d, /* utime */
- 0x0000111c, /* rename */
- 0x0000111c, /* link */
- 0x0000111c, /* symlink */
- 0x0000098c, /* readlink */
- 0x0000111c, /* mkdir */
- 0x0000099c, /* rmdir */
- 0x00001614, /* open_dir */
- 0x00000600, /* readdir */
- 0x0000060c, /* telldir */
- 0x00001604, /* seekdir */
- 0x00000604, /* rewinddir */
- 0x00000614, /* closedir */
+ 0x00000a40, /* enterloop */
+ 0x00000200, /* leaveloop */
+ 0x00002541, /* return */
+ 0x00000e44, /* last */
+ 0x00000e44, /* next */
+ 0x00000e44, /* redo */
+ 0x00000e44, /* dump */
+ 0x00000e44, /* goto */
+ 0x00009c44, /* exit */
+ 0x0009651c, /* open */
+ 0x0000ec14, /* close */
+ 0x00066514, /* pipe_op */
+ 0x00006c1c, /* fileno */
+ 0x00009c1c, /* umask */
+ 0x00006c04, /* binmode */
+ 0x00217555, /* tie */
+ 0x00007c14, /* untie */
+ 0x00007c04, /* tied */
+ 0x00114514, /* dbmopen */
+ 0x00004c14, /* dbmclose */
+ 0x01111508, /* sselect */
+ 0x0000e50c, /* select */
+ 0x0000ec0c, /* getc */
+ 0x0917651d, /* read */
+ 0x0000ec54, /* enterwrite */
+ 0x00000100, /* leavewrite */
+ 0x0002e515, /* prtf */
+ 0x0002e515, /* print */
+ 0x09116504, /* sysopen */
+ 0x00116504, /* sysseek */
+ 0x0917651d, /* sysread */
+ 0x0911651d, /* syswrite */
+ 0x0911651d, /* send */
+ 0x0117651d, /* recv */
+ 0x0000ec14, /* eof */
+ 0x0000ec0c, /* tell */
+ 0x00116504, /* seek */
+ 0x00011514, /* truncate */
+ 0x0011650c, /* fcntl */
+ 0x0011650c, /* ioctl */
+ 0x0001651c, /* flock */
+ 0x01116514, /* socket */
+ 0x11166514, /* sockpair */
+ 0x00016514, /* bind */
+ 0x00016514, /* connect */
+ 0x00016514, /* listen */
+ 0x0006651c, /* accept */
+ 0x0001651c, /* shutdown */
+ 0x00116514, /* gsockopt */
+ 0x01116514, /* ssockopt */
+ 0x00006c14, /* getsockname */
+ 0x00006c14, /* getpeername */
+ 0x00006d80, /* lstat */
+ 0x00006d80, /* stat */
+ 0x00006d94, /* ftrread */
+ 0x00006d94, /* ftrwrite */
+ 0x00006d94, /* ftrexec */
+ 0x00006d94, /* fteread */
+ 0x00006d94, /* ftewrite */
+ 0x00006d94, /* fteexec */
+ 0x00006d94, /* ftis */
+ 0x00006d94, /* fteowned */
+ 0x00006d94, /* ftrowned */
+ 0x00006d94, /* ftzero */
+ 0x00006d9c, /* ftsize */
+ 0x00006d8c, /* ftmtime */
+ 0x00006d8c, /* ftatime */
+ 0x00006d8c, /* ftctime */
+ 0x00006d94, /* ftsock */
+ 0x00006d94, /* ftchr */
+ 0x00006d94, /* ftblk */
+ 0x00006d94, /* ftfile */
+ 0x00006d94, /* ftdir */
+ 0x00006d94, /* ftpipe */
+ 0x00006d94, /* ftlink */
+ 0x00006d94, /* ftsuid */
+ 0x00006d94, /* ftsgid */
+ 0x00006d94, /* ftsvtx */
+ 0x00006d14, /* fttty */
+ 0x00006d94, /* fttext */
+ 0x00006d94, /* ftbinary */
+ 0x00009c1c, /* chdir */
+ 0x0000251d, /* chown */
+ 0x00009c9c, /* chroot */
+ 0x0000259d, /* unlink */
+ 0x0000251d, /* chmod */
+ 0x0000251d, /* utime */
+ 0x0001151c, /* rename */
+ 0x0001151c, /* link */
+ 0x0001151c, /* symlink */
+ 0x00009c8c, /* readlink */
+ 0x0001151c, /* mkdir */
+ 0x00009c9c, /* rmdir */
+ 0x00016514, /* open_dir */
+ 0x00006c00, /* readdir */
+ 0x00006c0c, /* telldir */
+ 0x00016504, /* seekdir */
+ 0x00006c04, /* rewinddir */
+ 0x00006c14, /* closedir */
0x0000001c, /* fork */
0x0000001c, /* wait */
- 0x0000111c, /* waitpid */
- 0x0000291d, /* system */
- 0x0000295d, /* exec */
- 0x0000025d, /* kill */
+ 0x0001151c, /* waitpid */
+ 0x0002951d, /* system */
+ 0x0002955d, /* exec */
+ 0x0000255d, /* kill */
0x0000001c, /* getppid */
- 0x0000091c, /* getpgrp */
- 0x0000991c, /* setpgrp */
- 0x0000111c, /* getpriority */
- 0x0001111c, /* setpriority */
+ 0x00009c1c, /* getpgrp */
+ 0x0009951c, /* setpgrp */
+ 0x0001151c, /* getpriority */
+ 0x0011151c, /* setpriority */
0x0000001c, /* time */
0x00000000, /* tms */
- 0x00000908, /* localtime */
- 0x00000908, /* gmtime */
- 0x0000099c, /* alarm */
- 0x0000091c, /* sleep */
- 0x0001111d, /* shmget */
- 0x0001111d, /* shmctl */
- 0x0011111d, /* shmread */
- 0x0011111d, /* shmwrite */
- 0x0000111d, /* msgget */
- 0x0001111d, /* msgctl */
- 0x0001111d, /* msgsnd */
- 0x0111111d, /* msgrcv */
- 0x0001111d, /* semget */
- 0x0011111d, /* semctl */
- 0x0000111d, /* semop */
- 0x000009c0, /* require */
- 0x00000140, /* dofile */
- 0x00000140, /* entereval */
- 0x00000100, /* leaveeval */
- 0x00000000, /* entertry */
- 0x00000000, /* leavetry */
- 0x00000100, /* ghbyname */
- 0x00001100, /* ghbyaddr */
+ 0x00009c08, /* localtime */
+ 0x00009c08, /* gmtime */
+ 0x00009c9c, /* alarm */
+ 0x00009c1c, /* sleep */
+ 0x0011151d, /* shmget */
+ 0x0011151d, /* shmctl */
+ 0x0111151d, /* shmread */
+ 0x0111151d, /* shmwrite */
+ 0x0001151d, /* msgget */
+ 0x0011151d, /* msgctl */
+ 0x0011151d, /* msgsnd */
+ 0x1111151d, /* msgrcv */
+ 0x0011151d, /* semget */
+ 0x0111151d, /* semctl */
+ 0x0001151d, /* semop */
+ 0x00009cc0, /* require */
+ 0x00001140, /* dofile */
+ 0x00001c40, /* entereval */
+ 0x00001100, /* leaveeval */
+ 0x00000300, /* entertry */
+ 0x00000500, /* leavetry */
+ 0x00001c00, /* ghbyname */
+ 0x00011500, /* ghbyaddr */
0x00000000, /* ghostent */
- 0x00000100, /* gnbyname */
- 0x00001100, /* gnbyaddr */
+ 0x00001c00, /* gnbyname */
+ 0x00011500, /* gnbyaddr */
0x00000000, /* gnetent */
- 0x00000100, /* gpbyname */
- 0x00000100, /* gpbynumber */
+ 0x00001c00, /* gpbyname */
+ 0x00001500, /* gpbynumber */
0x00000000, /* gprotoent */
- 0x00001100, /* gsbyname */
- 0x00001100, /* gsbyport */
+ 0x00011500, /* gsbyname */
+ 0x00011500, /* gsbyport */
0x00000000, /* gservent */
- 0x00000114, /* shostent */
- 0x00000114, /* snetent */
- 0x00000114, /* sprotoent */
- 0x00000114, /* sservent */
+ 0x00001c14, /* shostent */
+ 0x00001c14, /* snetent */
+ 0x00001c14, /* sprotoent */
+ 0x00001c14, /* sservent */
0x00000014, /* ehostent */
0x00000014, /* enetent */
0x00000014, /* eprotoent */
0x00000014, /* eservent */
- 0x00000100, /* gpwnam */
- 0x00000100, /* gpwuid */
+ 0x00001c00, /* gpwnam */
+ 0x00001c00, /* gpwuid */
0x00000000, /* gpwent */
0x00000014, /* spwent */
0x00000014, /* epwent */
- 0x00000100, /* ggrnam */
- 0x00000100, /* ggrgid */
+ 0x00001c00, /* ggrnam */
+ 0x00001c00, /* ggrgid */
0x00000000, /* ggrent */
0x00000014, /* sgrent */
0x00000014, /* egrent */
0x0000000c, /* getlogin */
- 0x0000211d, /* syscall */
- 0x00000104, /* lock */
+ 0x0002151d, /* syscall */
+ 0x00001c04, /* lock */
+ 0x00000044, /* specific */
};
#endif
diff --git a/opcode.pl b/opcode.pl
index fb3accc307..a97e987546 100755
--- a/opcode.pl
+++ b/opcode.pl
@@ -88,7 +88,7 @@ for (sort keys %ckname) {
print "\n";
for (@ops) {
- print "OP *\t", &tab(3, "pp_\L$_"), "_((ARGSproto));\n";
+ print "OP *\t", &tab(3, "pp_$_"), "_((ARGSproto));\n";
}
# Emit ppcode switch array.
@@ -102,7 +102,7 @@ EXT OP * (*ppaddr[])() = {
END
for (@ops) {
- print "\tpp_\L$_,\n";
+ print "\tpp_$_,\n";
}
print <<END;
@@ -121,7 +121,7 @@ EXT OP * (*check[]) _((OP *op)) = {
END
for (@ops) {
- print "\t", &tab(3, "$check{$_},"), "/* \L$_ */\n";
+ print "\t", &tab(3, "$check{$_},"), "/* $_ */\n";
}
print <<END;
@@ -149,6 +149,24 @@ END
R, 7, # scalar reference
);
+%opclass = (
+ '0', 0, # baseop
+ '1', 1, # unop
+ '2', 2, # binop
+ '|', 3, # logop
+ '?', 4, # condop
+ '@', 5, # listop
+ '/', 6, # pmop
+ '$', 7, # svop
+ '*', 8, # gvop
+ '"', 9, # pvop
+ '{', 10, # loop
+ ';', 11, # cop
+ '%', 12, # baseop_or_unop
+ '-', 13, # filestatop
+ '}', 14, # loopexop
+);
+
for (@ops) {
$argsum = 0;
$flags = $flags{$_};
@@ -160,7 +178,10 @@ for (@ops) {
$argsum |= 32 if $flags =~ /I/; # has corresponding int op
$argsum |= 64 if $flags =~ /d/; # danger, unknown side effects
$argsum |= 128 if $flags =~ /u/; # defaults to $_
- $mul = 256;
+
+ $flags =~ /([^a-zA-Z])/ or die qq[Opcode "$_" has no class indicator];
+ $argsum |= $opclass{$1} << 8;
+ $mul = 4096; # 2 ^ OASHIFT
for $arg (split(' ',$args{$_})) {
$argnum = ($arg =~ s/\?//) ? 8 : 0;
$argnum += $argnum{$arg};
@@ -168,7 +189,7 @@ for (@ops) {
$mul <<= 4;
}
$argsum = sprintf("0x%08x", $argsum);
- print "\t", &tab(3, "$argsum,"), "/* \L$_ */\n";
+ print "\t", &tab(3, "$argsum,"), "/* $_ */\n";
}
print <<END;
@@ -189,469 +210,471 @@ __END__
null null operation ck_null 0
stub stub ck_null 0
-scalar scalar ck_fun s S
+scalar scalar ck_fun s% S
# Pushy stuff.
-pushmark pushmark ck_null s
-wantarray wantarray ck_null is
+pushmark pushmark ck_null s0
+wantarray wantarray ck_null is0
-const constant item ck_svconst s
+const constant item ck_svconst s$
-gvsv scalar variable ck_null ds
-gv glob value ck_null ds
-gelem glob elem ck_null d S S
-padsv private variable ck_null ds
-padav private array ck_null d
-padhv private hash ck_null d
-padany private something ck_null d
+gvsv scalar variable ck_null ds*
+gv glob value ck_null ds*
+gelem glob elem ck_null d2 S S
+padsv private variable ck_null ds0
+padav private array ck_null d0
+padhv private hash ck_null d0
+padany private something ck_null d0
-pushre push regexp ck_null 0
+pushre push regexp ck_null /
# References and stuff.
-rv2gv ref-to-glob cast ck_rvconst ds
-rv2sv scalar deref ck_rvconst ds
-av2arylen array length ck_null is
-rv2cv subroutine deref ck_rvconst d
-anoncode anonymous subroutine ck_anoncode 0
-prototype subroutine prototype ck_null s S
-refgen reference constructor ck_spair m L
-srefgen scalar ref constructor ck_null fs S
-ref reference-type operator ck_fun stu S?
-bless bless ck_fun s S S?
+rv2gv ref-to-glob cast ck_rvconst ds1
+rv2sv scalar deref ck_rvconst ds1
+av2arylen array length ck_null is1
+rv2cv subroutine deref ck_rvconst d1
+anoncode anonymous subroutine ck_anoncode $
+prototype subroutine prototype ck_null s% S
+refgen reference constructor ck_spair m0 L
+srefgen scalar ref constructor ck_null fs0 S
+ref reference-type operator ck_fun stu% S?
+bless bless ck_fun s@ S S?
# Pushy I/O.
-backtick backticks ck_null t
+backtick backticks ck_null t%
# glob defaults its first arg to $_
-glob glob ck_glob t S? S?
-readline <HANDLE> ck_null t
-rcatline append I/O operator ck_null t
+glob glob ck_glob t@ S? S?
+readline <HANDLE> ck_null t%
+rcatline append I/O operator ck_null t%
# Bindable operators.
-regcmaybe regexp comp once ck_fun s S
-regcomp regexp compilation ck_null s S
-match pattern match ck_match d
-subst substitution ck_null dis S
-substcont substitution cont ck_null dis
-trans character translation ck_null is S
+regcmaybe regexp comp once ck_fun s1 S
+regcomp regexp compilation ck_null s| S
+match pattern match ck_match d/
+subst substitution ck_null dis/ S
+substcont substitution cont ck_null dis|
+trans character translation ck_null is" S
# Lvalue operators.
-
-sassign scalar assignment ck_null s
-aassign list assignment ck_null t L L
-
-chop chop ck_spair mts L
-schop scalar chop ck_null stu S?
-chomp safe chop ck_spair mts L
-schomp scalar safe chop ck_null stu S?
-defined defined operator ck_rfun isu S?
-undef undef operator ck_lfun s S?
-study study ck_fun su S?
-pos match position ck_lfun stu S?
-
-preinc preincrement ck_lfun dIs S
-i_preinc integer preincrement ck_lfun dis S
-predec predecrement ck_lfun dIs S
-i_predec integer predecrement ck_lfun dis S
-postinc postincrement ck_lfun dIst S
-i_postinc integer postincrement ck_lfun dist S
-postdec postdecrement ck_lfun dIst S
-i_postdec integer postdecrement ck_lfun dist S
+# sassign is special-cased for op class
+
+sassign scalar assignment ck_null s0
+aassign list assignment ck_null t2 L L
+
+chop chop ck_spair mts% L
+schop scalar chop ck_null stu% S?
+chomp safe chop ck_spair mts% L
+schomp scalar safe chop ck_null stu% S?
+defined defined operator ck_rfun isu% S?
+undef undef operator ck_lfun s% S?
+study study ck_fun su% S?
+pos match position ck_lfun stu% S?
+
+preinc preincrement ck_lfun dIs1 S
+i_preinc integer preincrement ck_lfun dis1 S
+predec predecrement ck_lfun dIs1 S
+i_predec integer predecrement ck_lfun dis1 S
+postinc postincrement ck_lfun dIst1 S
+i_postinc integer postincrement ck_lfun dist1 S
+postdec postdecrement ck_lfun dIst1 S
+i_postdec integer postdecrement ck_lfun dist1 S
# Ordinary operators.
-pow exponentiation ck_null fst S S
-
-multiply multiplication ck_null Ifst S S
-i_multiply integer multiplication ck_null ifst S S
-divide division ck_null Ifst S S
-i_divide integer division ck_null ifst S S
-modulo modulus ck_null Iifst S S
-i_modulo integer modulus ck_null ifst S S
-repeat repeat ck_repeat mt L S
-
-add addition ck_null Ifst S S
-i_add integer addition ck_null ifst S S
-subtract subtraction ck_null Ifst S S
-i_subtract integer subtraction ck_null ifst S S
-concat concatenation ck_concat fst S S
-stringify string ck_fun fst S
-
-left_shift left bitshift ck_bitop fst S S
-right_shift right bitshift ck_bitop fst S S
-
-lt numeric lt ck_null Iifs S S
-i_lt integer lt ck_null ifs S S
-gt numeric gt ck_null Iifs S S
-i_gt integer gt ck_null ifs S S
-le numeric le ck_null Iifs S S
-i_le integer le ck_null ifs S S
-ge numeric ge ck_null Iifs S S
-i_ge integer ge ck_null ifs S S
-eq numeric eq ck_null Iifs S S
-i_eq integer eq ck_null ifs S S
-ne numeric ne ck_null Iifs S S
-i_ne integer ne ck_null ifs S S
-ncmp spaceship operator ck_null Iifst S S
-i_ncmp integer spaceship ck_null ifst S S
-
-slt string lt ck_scmp ifs S S
-sgt string gt ck_scmp ifs S S
-sle string le ck_scmp ifs S S
-sge string ge ck_scmp ifs S S
-seq string eq ck_null ifs S S
-sne string ne ck_null ifs S S
-scmp string comparison ck_scmp ifst S S
-
-bit_and bitwise and ck_bitop fst S S
-bit_xor bitwise xor ck_bitop fst S S
-bit_or bitwise or ck_bitop fst S S
-
-negate negate ck_null Ifst S
-i_negate integer negate ck_null ifst S
-not not ck_null ifs S
-complement 1's complement ck_bitop fst S
+pow exponentiation ck_null fst2 S S
+
+multiply multiplication ck_null Ifst2 S S
+i_multiply integer multiplication ck_null ifst2 S S
+divide division ck_null Ifst2 S S
+i_divide integer division ck_null ifst2 S S
+modulo modulus ck_null Iifst2 S S
+i_modulo integer modulus ck_null ifst2 S S
+repeat repeat ck_repeat mt2 L S
+
+add addition ck_null Ifst2 S S
+i_add integer addition ck_null ifst2 S S
+subtract subtraction ck_null Ifst2 S S
+i_subtract integer subtraction ck_null ifst2 S S
+concat concatenation ck_concat fst2 S S
+stringify string ck_fun fst@ S
+
+left_shift left bitshift ck_bitop fst2 S S
+right_shift right bitshift ck_bitop fst2 S S
+
+lt numeric lt ck_null Iifs2 S S
+i_lt integer lt ck_null ifs2 S S
+gt numeric gt ck_null Iifs2 S S
+i_gt integer gt ck_null ifs2 S S
+le numeric le ck_null Iifs2 S S
+i_le integer le ck_null ifs2 S S
+ge numeric ge ck_null Iifs2 S S
+i_ge integer ge ck_null ifs2 S S
+eq numeric eq ck_null Iifs2 S S
+i_eq integer eq ck_null ifs2 S S
+ne numeric ne ck_null Iifs2 S S
+i_ne integer ne ck_null ifs2 S S
+ncmp spaceship operator ck_null Iifst2 S S
+i_ncmp integer spaceship ck_null ifst2 S S
+
+slt string lt ck_scmp ifs2 S S
+sgt string gt ck_scmp ifs2 S S
+sle string le ck_scmp ifs2 S S
+sge string ge ck_scmp ifs2 S S
+seq string eq ck_null ifs2 S S
+sne string ne ck_null ifs2 S S
+scmp string comparison ck_scmp ifst2 S S
+
+bit_and bitwise and ck_bitop fst2 S S
+bit_xor bitwise xor ck_bitop fst2 S S
+bit_or bitwise or ck_bitop fst2 S S
+
+negate negate ck_null Ifst1 S
+i_negate integer negate ck_null ifst1 S
+not not ck_null ifs1 S
+complement 1's complement ck_bitop fst1 S
# High falutin' math.
-atan2 atan2 ck_fun fst S S
-sin sin ck_fun fstu S?
-cos cos ck_fun fstu S?
-rand rand ck_fun st S?
-srand srand ck_fun s S?
-exp exp ck_fun fstu S?
-log log ck_fun fstu S?
-sqrt sqrt ck_fun fstu S?
+atan2 atan2 ck_fun fst@ S S
+sin sin ck_fun fstu% S?
+cos cos ck_fun fstu% S?
+rand rand ck_fun st% S?
+srand srand ck_fun s% S?
+exp exp ck_fun fstu% S?
+log log ck_fun fstu% S?
+sqrt sqrt ck_fun fstu% S?
# Lowbrow math.
-int int ck_fun fstu S?
-hex hex ck_fun fstu S?
-oct oct ck_fun fstu S?
-abs abs ck_fun fstu S?
+int int ck_fun fstu% S?
+hex hex ck_fun fstu% S?
+oct oct ck_fun fstu% S?
+abs abs ck_fun fstu% S?
# String stuff.
-length length ck_lengthconst istu S?
-substr substr ck_fun st S S S?
-vec vec ck_fun ist S S S
+length length ck_lengthconst istu% S?
+substr substr ck_fun st@ S S S?
+vec vec ck_fun ist@ S S S
-index index ck_index ist S S S?
-rindex rindex ck_index ist S S S?
+index index ck_index ist@ S S S?
+rindex rindex ck_index ist@ S S S?
-sprintf sprintf ck_fun_locale mfst S L
-formline formline ck_fun ms S L
-ord ord ck_fun ifstu S?
-chr chr ck_fun fstu S?
-crypt crypt ck_fun fst S S
-ucfirst upper case first ck_fun_locale fstu S?
-lcfirst lower case first ck_fun_locale fstu S?
-uc upper case ck_fun_locale fstu S?
-lc lower case ck_fun_locale fstu S?
-quotemeta quote metachars ck_fun fstu S?
+sprintf sprintf ck_fun_locale mfst@ S L
+formline formline ck_fun ms@ S L
+ord ord ck_fun ifstu% S?
+chr chr ck_fun fstu% S?
+crypt crypt ck_fun fst@ S S
+ucfirst upper case first ck_fun_locale fstu% S?
+lcfirst lower case first ck_fun_locale fstu% S?
+uc upper case ck_fun_locale fstu% S?
+lc lower case ck_fun_locale fstu% S?
+quotemeta quote metachars ck_fun fstu% S?
# Arrays.
-rv2av array deref ck_rvconst dt
-aelemfast known array element ck_null s A S
-aelem array element ck_null s A S
-aslice array slice ck_null m A L
+rv2av array deref ck_rvconst dt1
+aelemfast known array element ck_null s* A S
+aelem array element ck_null s2 A S
+aslice array slice ck_null m@ A L
# Hashes.
-each each ck_fun t H
-values values ck_fun t H
-keys keys ck_fun t H
-delete delete ck_delete 0 S
-exists exists operator ck_exists is S
-rv2hv hash deref ck_rvconst dt
-helem hash elem ck_null s H S
-hslice hash slice ck_null m H L
+each each ck_fun t% H
+values values ck_fun t% H
+keys keys ck_fun t% H
+delete delete ck_delete % S
+exists exists operator ck_exists is% S
+rv2hv hash deref ck_rvconst dt1
+helem hash elem ck_null s2@ H S
+hslice hash slice ck_null m@ H L
# Explosives and implosives.
-unpack unpack ck_fun 0 S S
-pack pack ck_fun mst S L
-split split ck_split t S S S
-join join ck_fun mst S L
+unpack unpack ck_fun @ S S
+pack pack ck_fun mst@ S L
+split split ck_split t@ S S S
+join join ck_fun mst@ S L
# List operators.
-list list ck_null m L
-lslice list slice ck_null 0 H L L
-anonlist anonymous list ck_fun ms L
-anonhash anonymous hash ck_fun ms L
+list list ck_null m@ L
+lslice list slice ck_null 2 H L L
+anonlist anonymous list ck_fun ms@ L
+anonhash anonymous hash ck_fun ms@ L
-splice splice ck_fun m A S? S? L
-push push ck_fun imst A L
-pop pop ck_shift s A
-shift shift ck_shift s A
-unshift unshift ck_fun imst A L
-sort sort ck_sort m C? L
-reverse reverse ck_fun mt L
+splice splice ck_fun m@ A S? S? L
+push push ck_fun imst@ A L
+pop pop ck_shift si% A
+shift shift ck_shift s% A
+unshift unshift ck_fun imst@ A L
+sort sort ck_sort m@ C? L
+reverse reverse ck_fun mt@ L
-grepstart grep ck_grep dm C L
-grepwhile grep iterator ck_null dt
+grepstart grep ck_grep dm@ C L
+grepwhile grep iterator ck_null dt|
-mapstart map ck_grep dm C L
-mapwhile map iterator ck_null dt
+mapstart map ck_grep dm@ C L
+mapwhile map iterator ck_null dt|
# Range stuff.
-range flipflop ck_null 0 S S
-flip range (or flip) ck_null 0 S S
-flop range (or flop) ck_null 0
+range flipflop ck_null ? S S
+flip range (or flip) ck_null 1 S S
+flop range (or flop) ck_null 1
# Control.
-and logical and ck_null 0
-or logical or ck_null 0
-xor logical xor ck_null fs S S
-cond_expr conditional expression ck_null d
-andassign logical and assignment ck_null s
-orassign logical or assignment ck_null s
-
-method method lookup ck_null d
-entersub subroutine entry ck_subr dmt L
-leavesub subroutine exit ck_null 0
-caller caller ck_fun t S?
-warn warn ck_fun imst L
-die die ck_fun dimst L
-reset reset ck_fun is S?
-
-lineseq line sequence ck_null 0
-nextstate next statement ck_null s
-dbstate debug next statement ck_null s
-unstack unstack ck_null s
+and logical and ck_null |
+or logical or ck_null |
+xor logical xor ck_null fs| S S
+cond_expr conditional expression ck_null d?
+andassign logical and assignment ck_null s|
+orassign logical or assignment ck_null s|
+
+method method lookup ck_null d1
+entersub subroutine entry ck_subr dmt1 L
+leavesub subroutine exit ck_null 1
+caller caller ck_fun t% S?
+warn warn ck_fun imst@ L
+die die ck_fun dimst@ L
+reset reset ck_fun is% S?
+
+lineseq line sequence ck_null @
+nextstate next statement ck_null s;
+dbstate debug next statement ck_null s;
+unstack unstack ck_null s0
enter block entry ck_null 0
-leave block exit ck_null 0
-scope block ck_null 0
-enteriter foreach loop entry ck_null d
+leave block exit ck_null @
+scope block ck_null @
+enteriter foreach loop entry ck_null d{
iter foreach loop iterator ck_null 0
-enterloop loop entry ck_null d
-leaveloop loop exit ck_null 0
-return return ck_null dm L
-last last ck_null ds
-next next ck_null ds
-redo redo ck_null ds
-dump dump ck_null ds
-goto goto ck_null ds
-exit exit ck_fun ds S?
+enterloop loop entry ck_null d{
+leaveloop loop exit ck_null 2
+return return ck_null dm@ L
+last last ck_null ds}
+next next ck_null ds}
+redo redo ck_null ds}
+dump dump ck_null ds}
+goto goto ck_null ds}
+exit exit ck_fun ds% S?
#nswitch numeric switch ck_null d
#cswitch character switch ck_null d
# I/O.
-open open ck_fun ist F S?
-close close ck_fun is F?
-pipe_op pipe ck_fun is F F
+open open ck_fun ist@ F S?
+close close ck_fun is% F?
+pipe_op pipe ck_fun is@ F F
-fileno fileno ck_fun ist F
-umask umask ck_fun ist S?
-binmode binmode ck_fun s F
+fileno fileno ck_fun ist% F
+umask umask ck_fun ist% S?
+binmode binmode ck_fun s% F
-tie tie ck_fun idms R S L
-untie untie ck_fun is R
-tied tied ck_fun s R
-dbmopen dbmopen ck_fun is H S S
-dbmclose dbmclose ck_fun is H
+tie tie ck_fun idms@ R S L
+untie untie ck_fun is% R
+tied tied ck_fun s% R
+dbmopen dbmopen ck_fun is@ H S S
+dbmclose dbmclose ck_fun is% H
-sselect select system call ck_select t S S S S
-select select ck_select st F?
+sselect select system call ck_select t@ S S S S
+select select ck_select st@ F?
-getc getc ck_eof st F?
-read read ck_fun imst F R S S?
-enterwrite write ck_fun dis F?
-leavewrite write exit ck_null 0
+getc getc ck_eof st% F?
+read read ck_fun imst@ F R S S?
+enterwrite write ck_fun dis% F?
+leavewrite write exit ck_null 1
-prtf printf ck_listiob ims F? L
-print print ck_listiob ims F? L
+prtf printf ck_listiob ims@ F? L
+print print ck_listiob ims@ F? L
-sysopen sysopen ck_fun s F S S S?
-sysseek sysseek ck_fun s F S S
-sysread sysread ck_fun imst F R S S?
-syswrite syswrite ck_fun imst F S S S?
+sysopen sysopen ck_fun s@ F S S S?
+sysseek sysseek ck_fun s@ F S S
+sysread sysread ck_fun imst@ F R S S?
+syswrite syswrite ck_fun imst@ F S S S?
-send send ck_fun imst F S S S?
-recv recv ck_fun imst F R S S
+send send ck_fun imst@ F S S S?
+recv recv ck_fun imst@ F R S S
-eof eof ck_eof is F?
-tell tell ck_fun st F?
-seek seek ck_fun s F S S
+eof eof ck_eof is% F?
+tell tell ck_fun st% F?
+seek seek ck_fun s@ F S S
# truncate really behaves as if it had both "S S" and "F S"
-truncate truncate ck_trunc is S S
+truncate truncate ck_trunc is@ S S
-fcntl fcntl ck_fun st F S S
-ioctl ioctl ck_fun st F S S
-flock flock ck_fun ist F S
+fcntl fcntl ck_fun st@ F S S
+ioctl ioctl ck_fun st@ F S S
+flock flock ck_fun ist@ F S
# Sockets.
-socket socket ck_fun is F S S S
-sockpair socketpair ck_fun is F F S S S
+socket socket ck_fun is@ F S S S
+sockpair socketpair ck_fun is@ F F S S S
-bind bind ck_fun is F S
-connect connect ck_fun is F S
-listen listen ck_fun is F S
-accept accept ck_fun ist F F
-shutdown shutdown ck_fun ist F S
+bind bind ck_fun is@ F S
+connect connect ck_fun is@ F S
+listen listen ck_fun is@ F S
+accept accept ck_fun ist@ F F
+shutdown shutdown ck_fun ist@ F S
-gsockopt getsockopt ck_fun is F S S
-ssockopt setsockopt ck_fun is F S S S
+gsockopt getsockopt ck_fun is@ F S S
+ssockopt setsockopt ck_fun is@ F S S S
-getsockname getsockname ck_fun is F
-getpeername getpeername ck_fun is F
+getsockname getsockname ck_fun is% F
+getpeername getpeername ck_fun is% F
# Stat calls.
-lstat lstat ck_ftst u F
-stat stat ck_ftst u F
-ftrread -R ck_ftst isu F
-ftrwrite -W ck_ftst isu F
-ftrexec -X ck_ftst isu F
-fteread -r ck_ftst isu F
-ftewrite -w ck_ftst isu F
-fteexec -x ck_ftst isu F
-ftis -e ck_ftst isu F
-fteowned -O ck_ftst isu F
-ftrowned -o ck_ftst isu F
-ftzero -z ck_ftst isu F
-ftsize -s ck_ftst istu F
-ftmtime -M ck_ftst stu F
-ftatime -A ck_ftst stu F
-ftctime -C ck_ftst stu F
-ftsock -S ck_ftst isu F
-ftchr -c ck_ftst isu F
-ftblk -b ck_ftst isu F
-ftfile -f ck_ftst isu F
-ftdir -d ck_ftst isu F
-ftpipe -p ck_ftst isu F
-ftlink -l ck_ftst isu F
-ftsuid -u ck_ftst isu F
-ftsgid -g ck_ftst isu F
-ftsvtx -k ck_ftst isu F
-fttty -t ck_ftst is F
-fttext -T ck_ftst isu F
-ftbinary -B ck_ftst isu F
+lstat lstat ck_ftst u- F
+stat stat ck_ftst u- F
+ftrread -R ck_ftst isu- F
+ftrwrite -W ck_ftst isu- F
+ftrexec -X ck_ftst isu- F
+fteread -r ck_ftst isu- F
+ftewrite -w ck_ftst isu- F
+fteexec -x ck_ftst isu- F
+ftis -e ck_ftst isu- F
+fteowned -O ck_ftst isu- F
+ftrowned -o ck_ftst isu- F
+ftzero -z ck_ftst isu- F
+ftsize -s ck_ftst istu- F
+ftmtime -M ck_ftst stu- F
+ftatime -A ck_ftst stu- F
+ftctime -C ck_ftst stu- F
+ftsock -S ck_ftst isu- F
+ftchr -c ck_ftst isu- F
+ftblk -b ck_ftst isu- F
+ftfile -f ck_ftst isu- F
+ftdir -d ck_ftst isu- F
+ftpipe -p ck_ftst isu- F
+ftlink -l ck_ftst isu- F
+ftsuid -u ck_ftst isu- F
+ftsgid -g ck_ftst isu- F
+ftsvtx -k ck_ftst isu- F
+fttty -t ck_ftst is- F
+fttext -T ck_ftst isu- F
+ftbinary -B ck_ftst isu- F
# File calls.
-chdir chdir ck_fun ist S?
-chown chown ck_fun imst L
-chroot chroot ck_fun istu S?
-unlink unlink ck_fun imstu L
-chmod chmod ck_fun imst L
-utime utime ck_fun imst L
-rename rename ck_fun ist S S
-link link ck_fun ist S S
-symlink symlink ck_fun ist S S
-readlink readlink ck_fun stu S?
-mkdir mkdir ck_fun ist S S
-rmdir rmdir ck_fun istu S?
+chdir chdir ck_fun ist% S?
+chown chown ck_fun imst@ L
+chroot chroot ck_fun istu% S?
+unlink unlink ck_fun imstu@ L
+chmod chmod ck_fun imst@ L
+utime utime ck_fun imst@ L
+rename rename ck_fun ist@ S S
+link link ck_fun ist@ S S
+symlink symlink ck_fun ist@ S S
+readlink readlink ck_fun stu% S?
+mkdir mkdir ck_fun ist@ S S
+rmdir rmdir ck_fun istu% S?
# Directory calls.
-open_dir opendir ck_fun is F S
-readdir readdir ck_fun 0 F
-telldir telldir ck_fun st F
-seekdir seekdir ck_fun s F S
-rewinddir rewinddir ck_fun s F
-closedir closedir ck_fun is F
+open_dir opendir ck_fun is@ F S
+readdir readdir ck_fun % F
+telldir telldir ck_fun st% F
+seekdir seekdir ck_fun s@ F S
+rewinddir rewinddir ck_fun s% F
+closedir closedir ck_fun is% F
# Process control.
-fork fork ck_null ist
-wait wait ck_null ist
-waitpid waitpid ck_fun ist S S
-system system ck_exec imst S? L
-exec exec ck_exec dimst S? L
-kill kill ck_fun dimst L
-getppid getppid ck_null ist
-getpgrp getpgrp ck_fun ist S?
-setpgrp setpgrp ck_fun ist S? S?
-getpriority getpriority ck_fun ist S S
-setpriority setpriority ck_fun ist S S S
+fork fork ck_null ist0
+wait wait ck_null ist0
+waitpid waitpid ck_fun ist@ S S
+system system ck_exec imst@ S? L
+exec exec ck_exec dimst@ S? L
+kill kill ck_fun dimst@ L
+getppid getppid ck_null ist0
+getpgrp getpgrp ck_fun ist% S?
+setpgrp setpgrp ck_fun ist@ S? S?
+getpriority getpriority ck_fun ist@ S S
+setpriority setpriority ck_fun ist@ S S S
# Time calls.
-time time ck_null ist
+time time ck_null ist0
tms times ck_null 0
-localtime localtime ck_fun t S?
-gmtime gmtime ck_fun t S?
-alarm alarm ck_fun istu S?
-sleep sleep ck_fun ist S?
+localtime localtime ck_fun t% S?
+gmtime gmtime ck_fun t% S?
+alarm alarm ck_fun istu% S?
+sleep sleep ck_fun ist% S?
# Shared memory.
-shmget shmget ck_fun imst S S S
-shmctl shmctl ck_fun imst S S S
-shmread shmread ck_fun imst S S S S
-shmwrite shmwrite ck_fun imst S S S S
+shmget shmget ck_fun imst@ S S S
+shmctl shmctl ck_fun imst@ S S S
+shmread shmread ck_fun imst@ S S S S
+shmwrite shmwrite ck_fun imst@ S S S S
# Message passing.
-msgget msgget ck_fun imst S S
-msgctl msgctl ck_fun imst S S S
-msgsnd msgsnd ck_fun imst S S S
-msgrcv msgrcv ck_fun imst S S S S S
+msgget msgget ck_fun imst@ S S
+msgctl msgctl ck_fun imst@ S S S
+msgsnd msgsnd ck_fun imst@ S S S
+msgrcv msgrcv ck_fun imst@ S S S S S
# Semaphores.
-semget semget ck_fun imst S S S
-semctl semctl ck_fun imst S S S S
-semop semop ck_fun imst S S
+semget semget ck_fun imst@ S S S
+semctl semctl ck_fun imst@ S S S S
+semop semop ck_fun imst@ S S
# Eval.
-require require ck_require du S?
-dofile do 'file' ck_fun d S
-entereval eval string ck_eval d S
-leaveeval eval exit ck_null 0 S
-#evalonce eval constant string ck_null d S
-entertry eval block ck_null 0
-leavetry eval block exit ck_null 0
+require require ck_require du% S?
+dofile do 'file' ck_fun d1 S
+entereval eval string ck_eval d% S
+leaveeval eval exit ck_null 1 S
+#evalonce eval constant string ck_null d1 S
+entertry eval block ck_null |
+leavetry eval block exit ck_null @
# Get system info.
-ghbyname gethostbyname ck_fun 0 S
-ghbyaddr gethostbyaddr ck_fun 0 S S
+ghbyname gethostbyname ck_fun % S
+ghbyaddr gethostbyaddr ck_fun @ S S
ghostent gethostent ck_null 0
-gnbyname getnetbyname ck_fun 0 S
-gnbyaddr getnetbyaddr ck_fun 0 S S
+gnbyname getnetbyname ck_fun % S
+gnbyaddr getnetbyaddr ck_fun @ S S
gnetent getnetent ck_null 0
-gpbyname getprotobyname ck_fun 0 S
-gpbynumber getprotobynumber ck_fun 0 S
+gpbyname getprotobyname ck_fun % S
+gpbynumber getprotobynumber ck_fun @ S
gprotoent getprotoent ck_null 0
-gsbyname getservbyname ck_fun 0 S S
-gsbyport getservbyport ck_fun 0 S S
+gsbyname getservbyname ck_fun @ S S
+gsbyport getservbyport ck_fun @ S S
gservent getservent ck_null 0
-shostent sethostent ck_fun is S
-snetent setnetent ck_fun is S
-sprotoent setprotoent ck_fun is S
-sservent setservent ck_fun is S
-ehostent endhostent ck_null is
-enetent endnetent ck_null is
-eprotoent endprotoent ck_null is
-eservent endservent ck_null is
-gpwnam getpwnam ck_fun 0 S
-gpwuid getpwuid ck_fun 0 S
+shostent sethostent ck_fun is% S
+snetent setnetent ck_fun is% S
+sprotoent setprotoent ck_fun is% S
+sservent setservent ck_fun is% S
+ehostent endhostent ck_null is0
+enetent endnetent ck_null is0
+eprotoent endprotoent ck_null is0
+eservent endservent ck_null is0
+gpwnam getpwnam ck_fun % S
+gpwuid getpwuid ck_fun % S
gpwent getpwent ck_null 0
-spwent setpwent ck_null is
-epwent endpwent ck_null is
-ggrnam getgrnam ck_fun 0 S
-ggrgid getgrgid ck_fun 0 S
+spwent setpwent ck_null is0
+epwent endpwent ck_null is0
+ggrnam getgrnam ck_fun % S
+ggrgid getgrgid ck_fun % S
ggrent getgrent ck_null 0
-sgrent setgrent ck_null is
-egrent endgrent ck_null is
-getlogin getlogin ck_null st
+sgrent setgrent ck_null is0
+egrent endgrent ck_null is0
+getlogin getlogin ck_null st0
# Miscellaneous.
-syscall syscall ck_fun imst S L
+syscall syscall ck_fun imst@ S L
# For multi-threading
-lock lock ck_null s S
+lock lock ck_rfun s% S
+specific thread-specific ck_null ds0
diff --git a/patchlevel.h b/patchlevel.h
index d8da982693..c5dff601ed 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -1,5 +1,5 @@
#define PATCHLEVEL 4
-#define SUBVERSION 52
+#define SUBVERSION 54
/*
local_patches -- list of locally applied less-than-subversion patches.
diff --git a/perl.c b/perl.c
index 279e217fff..fff0450593 100644
--- a/perl.c
+++ b/perl.c
@@ -69,6 +69,9 @@ static void init_ids _((void));
static void init_debugger _((void));
static void init_lexer _((void));
static void init_main_stash _((void));
+#ifdef USE_THREADS
+static struct thread * init_main_thread _((void));
+#endif /* USE_THREADS */
static void init_perllib _((void));
static void init_postdump_symbols _((int, char **, char **));
static void init_predump_symbols _((void));
@@ -107,9 +110,12 @@ void
perl_construct( sv_interp )
register PerlInterpreter *sv_interp;
{
-#if defined(USE_THREADS) && !defined(FAKE_THREADS)
+#ifdef USE_THREADS
+ int i;
+#ifndef FAKE_THREADS
struct thread *thr;
-#endif
+#endif /* FAKE_THREADS */
+#endif /* USE_THREADS */
if (!(curinterp = sv_interp))
return;
@@ -121,60 +127,22 @@ register PerlInterpreter *sv_interp;
/* Init the real globals (and main thread)? */
if (!linestr) {
#ifdef USE_THREADS
- XPV *xpv;
INIT_THREADS;
- Newz(53, thr, 1, struct thread);
+ if (pthread_key_create(&thr_key, 0))
+ croak("panic: pthread_key_create");
MUTEX_INIT(&malloc_mutex);
MUTEX_INIT(&sv_mutex);
- /* Safe to use SVs from now on */
+ /*
+ * Safe to use basic SV functions from now on (though
+ * not things like mortals or tainting yet).
+ */
MUTEX_INIT(&eval_mutex);
COND_INIT(&eval_cond);
MUTEX_INIT(&threads_mutex);
COND_INIT(&nthreads_cond);
- nthreads = 1;
- cvcache = newHV();
- curcop = &compiling;
- thr->flags = THRf_R_JOINABLE;
- MUTEX_INIT(&thr->mutex);
- thr->next = thr;
- thr->prev = thr;
- thr->tid = 0;
-
- /* Handcraft thrsv similarly to mess_sv */
- New(53, thrsv, 1, SV);
- Newz(53, xpv, 1, XPV);
- SvFLAGS(thrsv) = SVt_PV;
- SvANY(thrsv) = (void*)xpv;
- SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
- SvPVX(thrsv) = (char*)thr;
- SvCUR_set(thrsv, sizeof(thr));
- SvLEN_set(thrsv, sizeof(thr));
- *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
- oursv = thrsv;
-#ifdef HAVE_THREAD_INTERN
- init_thread_intern(thr);
-#else
-#ifdef WIN32
- DuplicateHandle(GetCurrentProcess(),
- GetCurrentThread(),
- GetCurrentProcess(),
- &self,
- 0,
- FALSE,
- DUPLICATE_SAME_ACCESS);
- if ((thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
- croak("panic: pthread_key_create");
- if (TlsSetValue(thr_key, (LPVOID) thr) != TRUE)
- croak("panic: pthread_setspecific");
-#else
- self = pthread_self();
- if (pthread_key_create(&thr_key, 0))
- croak("panic: pthread_key_create");
- if (pthread_setspecific(thr_key, (void *) thr))
- croak("panic: pthread_setspecific");
-#endif /* WIN32 */
-#endif /* FAKE_THREADS */
+
+ thr = init_main_thread();
#endif /* USE_THREADS */
linestr = NEWSV(65,80);
@@ -293,13 +261,7 @@ register PerlInterpreter *sv_interp;
* all over again.
*/
MUTEX_UNLOCK(&threads_mutex);
-#ifdef WIN32
- if ((WaitForSingleObject(t->Tself,INFINITE) == WAIT_FAILED)
- || (GetExitCodeThread(t->Tself,(LPDWORD)&av) == 0))
-#else
- if (pthread_join(t->Tself, (void**)&av))
-#endif
- croak("panic: pthread_join failed during global destruction");
+ JOIN(t, &av);
SvREFCNT_dec((SV*)av);
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: joined zombie %p OK\n", t));
@@ -508,7 +470,8 @@ register PerlInterpreter *sv_interp;
envgv = Nullgv;
siggv = Nullgv;
incgv = Nullgv;
- errgv = Nullgv;
+ errhv = Nullhv;
+ errsv = Nullsv;
argvgv = Nullgv;
argvoutgv = Nullgv;
stdingv = Nullgv;
@@ -1008,8 +971,11 @@ print \" \\@INC:\\n @INC\\n\";");
/* now that script is parsed, we can modify record separator */
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
+#ifdef USE_THREADS
+ sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs);
+#else
sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
-
+#endif /* USE_THREADS */
if (do_undump)
my_unexec();
@@ -1281,7 +1247,7 @@ I32 flags; /* See G_* flags in cop.h */
if (flags & G_KEEPERR)
in_eval |= 4;
else
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
}
markstack_ptr++;
@@ -1326,7 +1292,7 @@ I32 flags; /* See G_* flags in cop.h */
runops();
retval = stack_sp - (stack_base + oldmark);
if ((flags & G_EVAL) && !(flags & G_KEEPERR))
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
cleanup:
if (flags & G_EVAL) {
@@ -1435,7 +1401,7 @@ I32 flags; /* See G_* flags in cop.h */
runops();
retval = stack_sp - (stack_base + oldmark);
if (!(flags & G_KEEPERR))
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
cleanup:
JMPENV_POP;
@@ -1466,8 +1432,8 @@ I32 croak_on_error;
sv = POPs;
PUTBACK;
- if (croak_on_error && SvTRUE(GvSV(errgv)))
- croak(SvPVx(GvSV(errgv), na));
+ if (croak_on_error && SvTRUE(errsv))
+ croak(SvPV(errsv, na));
return sv;
}
@@ -1549,6 +1515,8 @@ char *s;
switch (*s) {
case '0':
+ {
+ dTHR;
rschar = scan_oct(s, 4, &numlen);
SvREFCNT_dec(nrs);
if (rschar & ~((U8)~0))
@@ -1560,6 +1528,7 @@ char *s;
nrs = newSVpv(&ch, 1);
}
return s + numlen;
+ }
case 'F':
minus_F = TRUE;
splitstr = savepv(s + 1);
@@ -1646,6 +1615,7 @@ char *s;
s += numlen;
}
else {
+ dTHR;
if (RsPARA(nrs)) {
ors = "\n\n";
orslen = 2;
@@ -1834,11 +1804,11 @@ init_main_stash()
incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
GvMULTI_on(incgv);
defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
- errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
- GvMULTI_on(errgv);
+ errsv = newSVpv("", 0);
+ errhv = newHV();
(void)form("%240s",""); /* Preallocate temp - for immediate signals. */
- sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
- sv_setpvn(GvSV(errgv), "", 0);
+ sv_grow(errsv, 240); /* Preallocate - for immediate signals. */
+ sv_setpvn(errsv, "", 0);
curstash = defstash;
compiling.cop_stash = defstash;
debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
@@ -2197,6 +2167,7 @@ char *scriptname;
*/
#ifdef DOSUID
+ dTHR;
char *s, *s2;
if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
@@ -2573,7 +2544,11 @@ init_predump_symbols()
GV *tmpgv;
GV *othergv;
+#ifdef USE_THREADS
+ sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1);
+#else
sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
+#endif /* USE_THREADS */
stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
GvMULTI_on(stdingv);
@@ -2609,6 +2584,7 @@ register int argc;
register char **argv;
register char **env;
{
+ dTHR;
char *s;
SV *sv;
GV* tmpgv;
@@ -2852,6 +2828,63 @@ int addsubdirs;
SvREFCNT_dec(subdir);
}
+#ifdef USE_THREADS
+static struct thread *
+init_main_thread()
+{
+ struct thread *thr;
+ XPV *xpv;
+
+ Newz(53, thr, 1, struct thread);
+ curcop = &compiling;
+ thr->cvcache = newHV();
+ thr->magicals = newAV();
+ thr->specific = newAV();
+ thr->flags = THRf_R_JOINABLE;
+ MUTEX_INIT(&thr->mutex);
+ /* Handcraft thrsv similarly to mess_sv */
+ New(53, thrsv, 1, SV);
+ Newz(53, xpv, 1, XPV);
+ SvFLAGS(thrsv) = SVt_PV;
+ SvANY(thrsv) = (void*)xpv;
+ SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
+ SvPVX(thrsv) = (char*)thr;
+ SvCUR_set(thrsv, sizeof(thr));
+ SvLEN_set(thrsv, sizeof(thr));
+ *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
+ thr->oursv = thrsv;
+ curcop = &compiling;
+ chopset = " \n-";
+
+ MUTEX_LOCK(&threads_mutex);
+ nthreads++;
+ thr->tid = 0;
+ thr->next = thr;
+ thr->prev = thr;
+ MUTEX_UNLOCK(&threads_mutex);
+
+#ifdef HAVE_THREAD_INTERN
+ init_thread_intern(thr);
+#else
+ thr->self = pthread_self();
+#endif /* HAVE_THREAD_INTERN */
+ SET_THR(thr);
+
+ /*
+ * These must come after the SET_THR because sv_setpvn does
+ * SvTAINT and the taint fields require dTHR.
+ */
+ toptarget = NEWSV(0,0);
+ sv_upgrade(toptarget, SVt_PVFM);
+ sv_setpvn(toptarget, "", 0);
+ bodytarget = NEWSV(0,0);
+ sv_upgrade(bodytarget, SVt_PVFM);
+ sv_setpvn(bodytarget, "", 0);
+ formtarget = bodytarget;
+ return thr;
+}
+#endif /* USE_THREADS */
+
void
call_list(oldscope, list)
I32 oldscope;
@@ -2871,21 +2904,20 @@ AV* list;
JMPENV_PUSH(ret);
switch (ret) {
case 0: {
- SV* atsv = GvSV(errgv);
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
- (void)SvPV(atsv, len);
+ (void)SvPV(errsv, len);
if (len) {
JMPENV_POP;
curcop = &compiling;
curcop->cop_line = oldline;
if (list == beginav)
- sv_catpv(atsv, "BEGIN failed--compilation aborted");
+ sv_catpv(errsv, "BEGIN failed--compilation aborted");
else
- sv_catpv(atsv, "END failed--cleanup aborted");
+ sv_catpv(errsv, "END failed--cleanup aborted");
while (scopestack_ix > oldscope)
LEAVE;
- croak("%s", SvPVX(atsv));
+ croak("%s", SvPVX(errsv));
}
}
break;
@@ -2933,8 +2965,8 @@ 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));
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
+ thr, (unsigned long) status));
#endif /* USE_THREADS */
switch (status) {
case 0:
diff --git a/perl.h b/perl.h
index ce1112b42b..09cb1d6b87 100644
--- a/perl.h
+++ b/perl.h
@@ -63,22 +63,20 @@ register struct op *op asm(stringify(OP_IN_REGISTER));
#define NOOP (void)0
#define WITH_THR(s) do { dTHR; s; } while (0)
+
#ifdef USE_THREADS
-#ifdef FAKE_THREADS
-#include "fakethr.h"
-#else
-#ifdef WIN32
-/*typedef CRITICAL_SECTION perl_mutex;*/
-typedef HANDLE perl_mutex;
-typedef HANDLE perl_cond;
-typedef DWORD perl_key;
-#else
-#include <pthread.h>
+# ifdef FAKE_THREADS
+# include "fakethr.h"
+# else
+# ifdef WIN32
+# include "win32/win32thread.h"
+# else
+# include <pthread.h>
typedef pthread_mutex_t perl_mutex;
typedef pthread_cond_t perl_cond;
typedef pthread_key_t perl_key;
-#endif /* WIN32 */
-#endif /* FAKE_THREADS */
+# endif /* WIN32 */
+# endif /* FAKE_THREADS */
#endif /* USE_THREADS */
/*
@@ -1340,6 +1338,8 @@ int runops_standard _((void));
int runops_debug _((void));
#endif
+#define PER_THREAD_MAGICALS "123456789&`'+/.,\\\";^-%=|~:\001\005!@"
+
/****************/
/* Truly global */
/****************/
@@ -1356,6 +1356,7 @@ EXT struct thread * eval_owner; /* Owner thread for doeval */
EXT int nthreads; /* Number of threads currently */
EXT perl_mutex threads_mutex; /* Mutex for nthreads and thread list */
EXT perl_cond nthreads_cond; /* Condition variable for nthreads */
+EXT char * per_thread_magicals INIT(PER_THREAD_MAGICALS);
#ifdef FAKE_THREADS
EXT struct thread * thr; /* Currently executing (fake) thread */
#endif
@@ -1858,7 +1859,8 @@ IEXT I32 Imaxscream IINIT(-1);
IEXT SV * Ilastscream;
/* shortcuts to misc objects */
-IEXT GV * Ierrgv;
+IEXT HV * Ierrhv;
+IEXT SV * Ierrsv;
/* shortcuts to debugging objects */
IEXT GV * IDBgv;
diff --git a/pp.c b/pp.c
index d002a1f0c5..c2585aed16 100644
--- a/pp.c
+++ b/pp.c
@@ -396,7 +396,6 @@ SV* sv;
else if (SvPADTMP(sv))
sv = newSVsv(sv);
else {
- dTHR; /* just for SvREFCNT_inc */
SvTEMP_off(sv);
(void)SvREFCNT_inc(sv);
}
@@ -4266,8 +4265,9 @@ void *svv;
PP(pp_lock)
{
dSP;
-#ifdef USE_THREADS
dTOPss;
+ SV *retsv = sv;
+#ifdef USE_THREADS
MAGIC *mg;
if (SvROK(sv))
@@ -4284,8 +4284,32 @@ PP(pp_lock)
DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
(unsigned long)thr, (unsigned long)sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
+ SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
save_destructor(unlock_condpair, sv);
}
#endif /* USE_THREADS */
+ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
+ || SvTYPE(retsv) == SVt_PVCV) {
+ retsv = refto(retsv);
+ }
+ SETs(retsv);
+ RETURN;
+}
+
+PP(pp_specific)
+{
+ dSP;
+#ifdef USE_THREADS
+ SV **svp = av_fetch(thr->magicals, op->op_targ, FALSE);
+ if (!svp)
+ croak("panic: pp_specific");
+ EXTEND(sp, 1);
+ if (op->op_private & OPpLVAL_INTRO)
+ PUSHs(save_svref(svp));
+ else
+ PUSHs(*svp);
+#else
+ DIE("tried to access thread-specific data in non-threaded perl");
+#endif /* USE_THREADS */
RETURN;
}
diff --git a/pp_ctl.c b/pp_ctl.c
index d14fa4b502..915ee6c588 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1040,21 +1040,21 @@ char *message;
SV **svp;
STRLEN klen = strlen(message);
- svp = hv_fetch(GvHV(errgv), message, klen, TRUE);
+ svp = hv_fetch(errhv, message, klen, TRUE);
if (svp) {
if (!SvIOK(*svp)) {
static char prefix[] = "\t(in cleanup) ";
sv_upgrade(*svp, SVt_IV);
(void)SvIOK_only(*svp);
- SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen);
- sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1);
- sv_catpvn(GvSV(errgv), message, klen);
+ SvGROW(errsv, SvCUR(errsv)+sizeof(prefix)+klen);
+ sv_catpvn(errsv, prefix, sizeof(prefix)-1);
+ sv_catpvn(errsv, message, klen);
}
sv_inc(*svp);
}
}
else
- sv_setpv(GvSV(errgv), message);
+ sv_setpv(errsv, message);
cxix = dopoptoeval(cxstack_ix);
if (cxix >= 0) {
@@ -1077,7 +1077,7 @@ char *message;
LEAVE;
if (optype == OP_REQUIRE) {
- char* msg = SvPVx(GvSV(errgv), na);
+ char* msg = SvPV(errsv, na);
DIE("%s", *msg ? msg : "Compilation failed in require");
}
return pop_return();
@@ -1117,21 +1117,6 @@ PP(pp_orassign)
RETURNOP(cLOGOP->op_other);
}
-#ifdef DEPRECATED
-PP(pp_entersubr)
-{
- dSP;
- SV** mark = (stack_base + *markstack_ptr + 1);
- SV* cv = *mark;
- while (mark < sp) { /* emulate old interface */
- *mark = mark[1];
- mark++;
- }
- *sp = cv;
- return pp_entersub(ARGS);
-}
-#endif
-
PP(pp_caller)
{
dSP;
@@ -2212,7 +2197,7 @@ int gimme;
if (saveop->op_flags & OPf_SPECIAL)
in_eval |= 4;
else
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
if (yyparse() || error_count || !eval_root) {
SV **newsp;
I32 gimme;
@@ -2231,7 +2216,7 @@ int gimme;
lex_end();
LEAVE;
if (optype == OP_REQUIRE) {
- char* msg = SvPVx(GvSV(errgv), na);
+ char* msg = SvPV(errsv, na);
DIE("%s", *msg ? msg : "Compilation failed in require");
}
SvREFCNT_dec(rs);
@@ -2585,7 +2570,7 @@ PP(pp_leaveeval)
LEAVE;
if (!(save_flags & OPf_SPECIAL))
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
RETURNOP(retop);
}
@@ -2605,7 +2590,7 @@ PP(pp_entertry)
eval_root = op; /* Only needed so that goto works right. */
in_eval = 1;
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
PUTBACK;
return DOCATCH(op->op_next);
}
@@ -2653,7 +2638,7 @@ PP(pp_leavetry)
curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
RETURN;
}
diff --git a/pp_hot.c b/pp_hot.c
index c19e928f67..6df60d7934 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1713,16 +1713,16 @@ PP(pp_leavesub)
}
static CV *
-get_db_sub(sv)
-SV *sv;
+get_db_sub(svp, cv)
+SV **svp;
+CV *cv;
{
dTHR;
- SV *oldsv = sv;
+ SV *oldsv = *svp;
GV *gv;
- CV *cv;
- sv = GvSV(DBsub);
- save_item(sv);
+ *svp = GvSV(DBsub);
+ save_item(*svp);
gv = CvGV(cv);
if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
@@ -1731,10 +1731,10 @@ SV *sv;
&& (gv = (GV*)oldsv) ))) {
/* Use GV from the stack as a fallback. */
/* GV is potentially non-unique, or contain different CV. */
- sv_setsv(sv, newRV((SV*)cv));
+ sv_setsv(*svp, newRV((SV*)cv));
}
else {
- gv_efullname3(sv, gv, Nullch);
+ gv_efullname3(*svp, gv, Nullch);
}
cv = GvCV(DBsub);
if (CvXSUB(cv))
@@ -1827,7 +1827,7 @@ PP(pp_entersub)
gimme = GIMME_V;
if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv))
- cv = get_db_sub(sv);
+ cv = get_db_sub(&sv, cv);
if (!cv)
DIE("No DBsub routine");
@@ -1866,6 +1866,7 @@ PP(pp_entersub)
DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
thr, sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
+ SvREFCNT_inc(sv); /* Keep alive until magic_mutexfree */
save_destructor(unlock_condpair, sv);
}
MUTEX_LOCK(CvMUTEXP(cv));
@@ -1900,7 +1901,7 @@ PP(pp_entersub)
* (3) instead of (2) so we'd have to clone. Would the fact
* that we released the mutex more quickly make up for this?
*/
- svp = hv_fetch(cvcache, (char *)cv, sizeof(cv), FALSE);
+ svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE);
if (svp) {
/* We already have a clone to use */
MUTEX_UNLOCK(CvMUTEXP(cv));
@@ -1940,7 +1941,7 @@ PP(pp_entersub)
*/
clonecv = cv_clone(cv);
SvREFCNT_dec(cv); /* finished with this */
- hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
+ hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
CvOWNER(clonecv) = thr;
cv = clonecv;
SvREFCNT_inc(cv);
diff --git a/pp_sys.c b/pp_sys.c
index 99abde927b..5eaa1e19d9 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -278,11 +278,10 @@ PP(pp_warn)
tmps = SvPV(TOPs, na);
}
if (!tmps || !*tmps) {
- SV *error = GvSV(errgv);
- (void)SvUPGRADE(error, SVt_PV);
- if (SvPOK(error) && SvCUR(error))
- sv_catpv(error, "\t...caught");
- tmps = SvPV(error, na);
+ (void)SvUPGRADE(errsv, SVt_PV);
+ if (SvPOK(errsv) && SvCUR(errsv))
+ sv_catpv(errsv, "\t...caught");
+ tmps = SvPV(errsv, na);
}
if (!tmps || !*tmps)
tmps = "Warning: something's wrong";
@@ -304,11 +303,10 @@ PP(pp_die)
tmps = SvPV(TOPs, na);
}
if (!tmps || !*tmps) {
- SV *error = GvSV(errgv);
- (void)SvUPGRADE(error, SVt_PV);
- if (SvPOK(error) && SvCUR(error))
- sv_catpv(error, "\t...propagated");
- tmps = SvPV(error, na);
+ (void)SvUPGRADE(errsv, SVt_PV);
+ if (SvPOK(errsv) && SvCUR(errsv))
+ sv_catpv(errsv, "\t...propagated");
+ tmps = SvPV(errsv, na);
}
if (!tmps || !*tmps)
tmps = "Died";
@@ -505,12 +503,14 @@ PP(pp_tie)
SV *varsv;
HV* stash;
GV *gv;
- BINOP myop;
SV *sv;
SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */
I32 markoff = mark - stack_base - 1;
char *methname;
+#ifdef ORIGINAL_TIE
+ BINOP myop;
bool oldcatch = CATCH_GET;
+#endif
varsv = mark[0];
if (SvTYPE(varsv) == SVt_PVHV)
@@ -527,6 +527,7 @@ PP(pp_tie)
DIE("Can't locate object method \"%s\" via package \"%s\"",
methname, SvPV(mark[1],na));
+#ifdef ORIGINAL_TIE
Zero(&myop, 1, BINOP);
myop.op_last = (OP *) &myop;
myop.op_next = Nullop;
@@ -547,6 +548,11 @@ PP(pp_tie)
SPAGAIN;
CATCH_SET(oldcatch);
+#else
+ ENTER;
+ perl_call_sv((SV*)gv, G_SCALAR);
+ SPAGAIN;
+#endif
sv = TOPs;
if (sv_isobject(sv)) {
if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
@@ -621,9 +627,11 @@ PP(pp_dbmopen)
dPOPPOPssrl;
HV* stash;
GV *gv;
- BINOP myop;
SV *sv;
+#ifdef ORIGINAL_TIE
+ BINOP myop;
bool oldcatch = CATCH_GET;
+#endif
hv = (HV*)POPs;
@@ -638,6 +646,7 @@ PP(pp_dbmopen)
DIE("No dbm on this machine");
}
+#ifdef ORIGINAL_TIE
Zero(&myop, 1, BINOP);
myop.op_last = (OP *) &myop;
myop.op_next = Nullop;
@@ -651,7 +660,10 @@ PP(pp_dbmopen)
op->op_private |= OPpENTERSUB_DB;
PUTBACK;
pp_pushmark(ARGS);
-
+#else
+ ENTER;
+ PUSHMARK(sp);
+#endif
EXTEND(sp, 5);
PUSHs(sv);
PUSHs(left);
@@ -660,32 +672,49 @@ PP(pp_dbmopen)
else
PUSHs(sv_2mortal(newSViv(O_RDWR)));
PUSHs(right);
+#ifdef ORIGINAL_TIE
PUSHs((SV*)GvCV(gv));
PUTBACK;
if (op = pp_entersub(ARGS))
runops();
+#else
+ PUTBACK;
+ perl_call_sv((SV*)gv, G_SCALAR);
+#endif
SPAGAIN;
if (!sv_isobject(TOPs)) {
sp--;
+#ifdef ORIGINAL_TIE
op = (OP *) &myop;
PUTBACK;
pp_pushmark(ARGS);
+#else
+ PUSHMARK(sp);
+#endif
PUSHs(sv);
PUSHs(left);
PUSHs(sv_2mortal(newSViv(O_RDONLY)));
PUSHs(right);
+#ifdef ORIGINAL_TIE
PUSHs((SV*)GvCV(gv));
+#endif
PUTBACK;
+#ifdef ORIGINAL_TIE
if (op = pp_entersub(ARGS))
runops();
+#else
+ perl_call_sv((SV*)gv, G_SCALAR);
+#endif
SPAGAIN;
}
+#ifdef ORIGINAL_TIE
CATCH_SET(oldcatch);
+#endif
if (sv_isobject(TOPs))
sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
LEAVE;
diff --git a/proto.h b/proto.h
index 7123beebca..2bfc9be3d5 100644
--- a/proto.h
+++ b/proto.h
@@ -305,9 +305,6 @@ OP* newSLICEOP _((I32 flags, OP* subscript, OP* list));
OP* newSTATEOP _((I32 flags, char* label, OP* o));
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));
-#endif
AV* newAV _((void));
OP* newAVREF _((OP* o));
OP* newBINOP _((I32 type, I32 flags, OP* first, OP* last));
@@ -338,6 +335,9 @@ SV* newSVsv _((SV* old));
OP* newUNOP _((I32 type, I32 flags, OP* first));
OP* newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop,
I32 whileline, OP* expr, OP* block, OP* cont));
+#ifdef USE_THREADS
+struct thread * new_struct_thread _((struct thread *t));
+#endif
PerlIO* nextargv _((GV* gv));
char* ninstr _((char* big, char* bigend, char* little, char* lend));
OP* oopsCV _((OP* o));
diff --git a/scope.h b/scope.h
index d9fe15a0a3..a65cb628a9 100644
--- a/scope.h
+++ b/scope.h
@@ -38,9 +38,6 @@
#define SAVETMPS save_int((int*)&tmps_floor), tmps_floor = tmps_ix
#define FREETMPS if (tmps_ix > tmps_floor) free_tmps()
-#ifdef DEPRECATED
-#define FREE_TMPS() FREETMPS
-#endif
#define ENTER push_scope()
#define LEAVE pop_scope()
diff --git a/sv.c b/sv.c
index da4c73d6df..13bad80b02 100644
--- a/sv.c
+++ b/sv.c
@@ -1105,6 +1105,7 @@ sv_setiv(sv,i)
register SV *sv;
IV i;
{
+ dTHR; /* just for taint */
sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
@@ -1156,6 +1157,7 @@ sv_setnv(sv,num)
register SV *sv;
double num;
{
+ dTHR; /* just for taint */
sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
@@ -2186,6 +2188,7 @@ register SV *sv;
register const char *ptr;
register STRLEN len;
{
+ dTHR; /* just for taint */
assert(len >= 0); /* STRLEN is probably unsigned, so this may
elicit a warning, but it won't hurt. */
sv_check_thinkfirst(sv);
@@ -2212,6 +2215,7 @@ sv_setpv(sv,ptr)
register SV *sv;
register const char *ptr;
{
+ dTHR; /* just for taint */
register STRLEN len;
sv_check_thinkfirst(sv);
@@ -2239,6 +2243,7 @@ register SV *sv;
register char *ptr;
register STRLEN len;
{
+ dTHR; /* just for taint */
sv_check_thinkfirst(sv);
if (!SvUPGRADE(sv, SVt_PV))
return;
@@ -2303,6 +2308,7 @@ register SV *sv;
register char *ptr;
register STRLEN len;
{
+ dTHR; /* just for taint */
STRLEN tlen;
char *junk;
@@ -2335,6 +2341,7 @@ sv_catpv(sv,ptr)
register SV *sv;
register char *ptr;
{
+ dTHR; /* just for taint */
register STRLEN len;
STRLEN tlen;
char *junk;
@@ -3060,6 +3067,7 @@ register SV *sv;
register PerlIO *fp;
I32 append;
{
+ dTHR;
char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
@@ -3667,6 +3675,7 @@ HV *stash;
sv = GvSV(gv);
(void)SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
+ dTHR; /* just for taint */
SvCUR_set(sv, 0);
if (SvPVX(sv) != Nullch)
*SvPVX(sv) = '\0';
@@ -3907,6 +3916,7 @@ STRLEN *lp;
*SvEND(sv) = '\0';
}
if (!SvPOK(sv)) {
+ dTHR; /* just for taint */
SvPOK_on(sv); /* validate pointer */
SvTAINT(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
diff --git a/sv.h b/sv.h
index 884b206fd3..916dc17fe6 100644
--- a/sv.h
+++ b/sv.h
@@ -70,17 +70,20 @@ struct io {
#define SvANY(sv) (sv)->sv_any
#define SvFLAGS(sv) (sv)->sv_flags
-
#define SvREFCNT(sv) (sv)->sv_refcnt
-#ifdef CRIPPLED_CC
-#define SvREFCNT_inc(sv) sv_newref((SV*)sv)
-#define SvREFCNT_dec(sv) sv_free((SV*)sv)
+
+#ifdef __GNUC__
+# define SvREFCNT_inc(sv) ({SV* nsv=(SV*)(sv); if(nsv) ++SvREFCNT(nsv); nsv;})
#else
-#define SvREFCNT_inc(sv) ((Sv = (SV*)(sv)), \
- (Sv && ++SvREFCNT(Sv)), (SV*)Sv)
-#define SvREFCNT_dec(sv) sv_free((SV*)sv)
+# if defined(CRIPPLED_CC) || defined(USE_THREADS)
+# define SvREFCNT_inc(sv) sv_newref((SV*)sv)
+# else
+# define SvREFCNT_inc(sv) ((Sv=(SV*)(sv)), (Sv && ++SvREFCNT(Sv)), (SV*)Sv)
+# endif
#endif
+#define SvREFCNT_dec(sv) sv_free((SV*)sv)
+
#define SVTYPEMASK 0xff
#define SvTYPE(sv) ((sv)->sv_flags & SVTYPEMASK)
@@ -242,8 +245,7 @@ struct xpvfm {
AV * xcv_padlist;
CV * xcv_outside;
#ifdef USE_THREADS
- perl_mutex *xcv_mutexp;
- perl_cond * xcv_condp; /* signalled when owner leaves CV */
+ perl_mutex *xcv_mutexp; /* protects xcv_owner */
struct thread *xcv_owner; /* current owner thread */
#endif /* USE_THREADS */
cv_flags_t xcv_flags;
@@ -545,20 +547,32 @@ I32 SvTRUE _((SV *));
? SvNVX(sv) != 0.0 \
: sv_2bool(sv) )
-#define SvIVx(sv) ((Sv = (sv)), SvIV(Sv))
-#define SvUVx(sv) ((Sv = (sv)), SvUV(Sv))
-#define SvNVx(sv) ((Sv = (sv)), SvNV(Sv))
-#define SvPVx(sv, lp) ((Sv = (sv)), SvPV(Sv, lp))
+#ifdef __GNUC__
+# define SvIVx(sv) ({SV *nsv = (SV*)(sv); SvIV(nsv); })
+# define SvUVx(sv) ({SV *nsv = (SV*)(sv); SvUV(nsv); })
+# define SvNVx(sv) ({SV *nsv = (SV*)(sv); SvNV(nsv); })
+# define SvPVx(sv, lp) ({SV *nsv = (sv); SvPV(nsv, lp); })
+#else
+# define SvIVx(sv) ((Sv = (sv)), SvIV(Sv))
+# define SvUVx(sv) ((Sv = (sv)), SvUV(Sv))
+# define SvNVx(sv) ((Sv = (sv)), SvNV(Sv))
+# define SvPVx(sv, lp) ((Sv = (sv)), SvPV(Sv, lp))
+#endif /* __GNUC__ */
+
#define SvTRUEx(sv) ((Sv = (sv)), SvTRUE(Sv))
#endif /* CRIPPLED_CC */
#define newRV_inc(sv) newRV(sv)
-#ifdef CRIPPLED_CC
-SV *newRV_noinc _((SV *));
+#ifdef __GNUC__
+# define newRV_noinc(sv) ({SV *nsv=newRV((sv)); --SvREFCNT(SvRV(nsv)); nsv;})
#else
-#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
-#endif
+# if defined(CRIPPLED_CC) || defined(USE_THREADS)
+SV *newRV_noinc _((SV *));
+# else
+# define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
+# endif
+#endif /* __GNUC__ */
/* the following macro updates any magic values this sv is associated with */
diff --git a/taint.c b/taint.c
index 6776272782..af943e0647 100644
--- a/taint.c
+++ b/taint.c
@@ -12,6 +12,7 @@ taint_proper(f, s)
const char *f;
char *s;
{
+ dTHR; /* just for taint */
char *ug;
DEBUG_u(PerlIO_printf(Perl_debug_log,
@@ -70,10 +71,12 @@ taint_env()
svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE);
if (svp && *svp) {
if (SvTAINTED(*svp)) {
+ dTHR;
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
+ dTHR;
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
@@ -83,6 +86,7 @@ taint_env()
/* tainted $TERM is okay if it contains no metachars */
svp = hv_fetch(GvHVn(envgv),"TERM",4,FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
+ dTHR; /* just for taint */
bool was_tainted = tainted;
char *t = SvPV(*svp, na);
char *e = t + na;
@@ -101,6 +105,7 @@ taint_env()
for (e = misc_env; *e; e++) {
svp = hv_fetch(GvHVn(envgv), *e, strlen(*e), FALSE);
if (svp && *svp != &sv_undef && SvTAINTED(*svp)) {
+ dTHR; /* just for taint */
TAINT;
taint_proper("Insecure $ENV{%s}%s", *e);
}
diff --git a/thread.h b/thread.h
index f4accfa04e..305155c3ff 100644
--- a/thread.h
+++ b/thread.h
@@ -1,180 +1,123 @@
-#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)
+#ifdef USE_THREADS
-#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
+#ifdef WIN32
+# include "win32/win32thread.h"
+#endif
-#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(); \
+/* 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))
+# define YIELD pthread_yield()
+# define DETACH(t) \
+ STMT_START { \
+ if (pthread_detach(&(t)->self)) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ croak("panic: DETACH"); \
+ } \
} STMT_END
-#define COND_DESTROY(c)
#else
+# define pthread_mutexattr_default NULL
+# define pthread_condattr_default NULL
+# define pthread_attr_default NULL
+#endif /* OLD_PTHREADS_API */
-#ifdef WIN32
-
-typedef HANDLE perl_thread;
-
-/* XXX Critical Sections used instead of mutexes: lightweight,
- * but can't be communicated to child processes, and can't get
- * HANDLE to it for use elsewhere
- */
-/*
-#define MUTEX_INIT(m) InitializeCriticalSection(m)
-#define MUTEX_LOCK(m) EnterCriticalSection(m)
-#define MUTEX_UNLOCK(m) LeaveCriticalSection(m)
-#define MUTEX_DESTROY(m) DeleteCriticalSection(m)
-*/
+#ifndef YIELD
+# define YIELD sched_yield()
+#endif
-#define MUTEX_INIT(m) \
+#ifndef MUTEX_INIT
+#define MUTEX_INIT(m) \
STMT_START { \
- if ((*(m) = CreateMutex(NULL,FALSE,NULL)) == NULL) \
+ if (pthread_mutex_init((m), pthread_mutexattr_default)) \
croak("panic: MUTEX_INIT"); \
} STMT_END
-#define MUTEX_LOCK(m) \
- STMT_START { \
- if (WaitForSingleObject(*(m),INFINITE) == WAIT_FAILED) \
- croak("panic: MUTEX_LOCK"); \
+#define MUTEX_LOCK(m) \
+ STMT_START { \
+ if (pthread_mutex_lock((m))) \
+ croak("panic: MUTEX_LOCK"); \
} STMT_END
-#define MUTEX_UNLOCK(m) \
- STMT_START { \
- if (ReleaseMutex(*(m)) == 0) \
- croak("panic: MUTEX_UNLOCK"); \
+#define MUTEX_UNLOCK(m) \
+ STMT_START { \
+ if (pthread_mutex_unlock((m))) \
+ croak("panic: MUTEX_UNLOCK"); \
} STMT_END
-#define MUTEX_DESTROY(m) \
- STMT_START { \
- if (CloseHandle(*(m)) == 0) \
- croak("panic: MUTEX_DESTROY"); \
+#define MUTEX_DESTROY(m) \
+ STMT_START { \
+ if (pthread_mutex_destroy((m))) \
+ croak("panic: MUTEX_DESTROY"); \
} STMT_END
+#endif /* MUTEX_INIT */
-#define COND_INIT(c) \
+#ifndef COND_INIT
+#define COND_INIT(c) \
STMT_START { \
- if ((*(c) = CreateEvent(NULL,TRUE,FALSE,NULL)) == NULL) \
+ if (pthread_cond_init((c), pthread_condattr_default)) \
croak("panic: COND_INIT"); \
} STMT_END
-#define COND_SIGNAL(c) \
- STMT_START { \
- if (PulseEvent(*(c)) == 0) \
- croak("panic: COND_SIGNAL (%ld)",GetLastError()); \
+#define COND_SIGNAL(c) \
+ STMT_START { \
+ if (pthread_cond_signal((c))) \
+ croak("panic: COND_SIGNAL"); \
} STMT_END
-#define COND_BROADCAST(c) \
- STMT_START { \
- if (PulseEvent(*(c)) == 0) \
- croak("panic: COND_BROADCAST"); \
+#define COND_BROADCAST(c) \
+ STMT_START { \
+ if (pthread_cond_broadcast((c))) \
+ croak("panic: COND_BROADCAST"); \
} STMT_END
-/* #define COND_WAIT(c, m) \
- STMT_START { \
- if (WaitForSingleObject(*(c),INFINITE) == WAIT_FAILED) \
- croak("panic: COND_WAIT"); \
+#define COND_WAIT(c, m) \
+ STMT_START { \
+ if (pthread_cond_wait((c), (m))) \
+ croak("panic: COND_WAIT"); \
} STMT_END
-*/
-#define COND_WAIT(c, m) \
- STMT_START { \
- if (SignalObjectAndWait(*(m),*(c),INFINITE,FALSE) == WAIT_FAILED)\
- croak("panic: COND_WAIT"); \
- else \
- MUTEX_LOCK(m); \
- } STMT_END
-#define COND_DESTROY(c) \
- STMT_START { \
- if (CloseHandle(*(c)) == 0) \
- croak("panic: COND_DESTROY"); \
+#define COND_DESTROY(c) \
+ STMT_START { \
+ if (pthread_cond_destroy((c))) \
+ croak("panic: COND_DESTROY"); \
} STMT_END
+#endif /* COND_INIT */
-#define DETACH(t) \
- STMT_START { \
- if (CloseHandle((t)->Tself) == 0) { \
- MUTEX_UNLOCK(&(t)->mutex); \
- croak("panic: DETACH"); \
- } \
+/* DETACH(t) must only be called while holding t->mutex */
+#ifndef DETACH
+#define DETACH(t) \
+ STMT_START { \
+ if (pthread_detach((t)->self)) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ croak("panic: DETACH"); \
+ } \
} STMT_END
+#endif /* DETACH */
-#define THR ((struct thread *) TlsGetValue(thr_key))
-#define pthread_getspecific(k) TlsGetValue(k)
-#define pthread_setspecific(k,v) (TlsSetValue(k,v) == 0)
-
-#else /* !WIN32 */
-
-/* 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
-#define pthread_condattr_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), pthread_condattr_default)) \
- 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
+#ifndef JOIN
+#define JOIN(t, avp) \
+ STMT_START { \
+ if (pthread_join((t)->self, (void**)(avp))) \
+ croak("panic: pthread_join"); \
+ } STMT_END
+#endif /* JOIN */
-/* DETACH(t) must only be called while holding t->mutex */
-#define DETACH(t) \
- if (pthread_detach((t)->Tself)) { \
- MUTEX_UNLOCK(&(t)->mutex); \
- croak("panic: DETACH"); \
- } else 1
+#ifndef SET_THR
+#define SET_THR(t) \
+ STMT_START { \
+ if (pthread_setspecific(thr_key, (void *) (t))) \
+ croak("panic: pthread_setspecific"); \
+ } STMT_END
+#endif /* SET_THR */
-/* XXX Add "old" (?) POSIX draft interface too */
-#ifdef OLD_PTHREADS_API
+#ifndef THR
+# ifdef OLD_PTHREADS_API
struct thread *getTHR _((void));
-#define THR getTHR()
-#else
-#define THR ((struct thread *) pthread_getspecific(thr_key))
-#endif /* OLD_PTHREADS_API */
-#endif /* WIN32 */
-#define dTHR struct thread *thr = THR
-#endif /* FAKE_THREADS */
+# define THR getTHR()
+# else
+# define THR ((struct thread *) pthread_getspecific(thr_key))
+# endif /* OLD_PTHREADS_API */
+#endif /* THR */
+
+#ifndef dTHR
+# define dTHR struct thread *thr = THR
+#endif /* dTHR */
#ifndef INIT_THREADS
# ifdef NEED_PTHREAD_INIT
@@ -184,6 +127,11 @@ struct thread *getTHR _((void));
# endif
#endif
+#ifndef THREAD_RET_TYPE
+# define THREAD_RET_TYPE void *
+# define THREAD_RET_CAST(p) ((void *)(p))
+#endif /* THREAD_RET */
+
struct thread {
/* The fields that used to be global */
/* Important ones in the first cache line (if alignment is done right) */
@@ -223,10 +171,25 @@ struct thread {
/* Now the fields that used to be "per interpreter" (even when global) */
- /* XXX What about magic variables such as $/, $? and so on? */
+ /* Fields used by magic variables such as $@, $/ and so on */
+ bool Ttainted;
+ PMOP * Tcurpm;
+ SV * Tnrs;
+ SV * Trs;
+ GV * Tlast_in_gv;
+ char * Tofs;
+ STRLEN Tofslen;
+ GV * Tdefoutgv;
+ char * Tchopset;
+ SV * Tformtarget;
+ SV * Tbodytarget;
+ SV * Ttoptarget;
+
+ /* Stashes */
HV * Tdefstash;
HV * Tcurstash;
+ /* Stacks */
SV ** Ttmps_stack;
I32 Ttmps_ix;
I32 Ttmps_floor;
@@ -250,10 +213,12 @@ struct thread {
/* XXX Sort stuff, firstgv, secongv and so on? */
- perl_thread Tself;
- SV * Toursv;
- HV * Tcvcache;
+ SV * oursv;
+ HV * cvcache;
+ perl_thread self; /* Underlying thread object */
U32 flags;
+ AV * magicals; /* Per-thread magicals */
+ AV * specific; /* Thread-specific user data */
perl_mutex mutex; /* For the fields others can change */
U32 tid;
struct thread *next, *prev; /* Circular linked list of threads */
@@ -261,7 +226,7 @@ struct thread {
#ifdef ADD_THREAD_INTERN
struct thread_intern i; /* Platform-dependent internals */
#endif
- char trailing_nul; /* For the sake of thrsv, t->Toursv */
+ char trailing_nul; /* For the sake of thrsv and oursv */
};
typedef struct thread *Thread;
@@ -329,6 +294,18 @@ typedef struct condpair {
#undef Xpv
#undef statbuf
#undef timesbuf
+#undef tainted
+#undef curpm
+#undef nrs
+#undef rs
+#undef last_in_gv
+#undef ofs
+#undef ofslen
+#undef defoutgv
+#undef chopset
+#undef formtarget
+#undef bodytarget
+#undef toptarget
#undef top_env
#undef runlevel
#undef in_eval
@@ -337,8 +314,6 @@ typedef struct condpair {
#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)
@@ -376,6 +351,19 @@ typedef struct condpair {
#define Xpv (thr->TXpv)
#define statbuf (thr->Tstatbuf)
#define timesbuf (thr->Ttimesbuf)
+#define tainted (thr->Ttainted)
+#define tainted (thr->Ttainted)
+#define curpm (thr->Tcurpm)
+#define nrs (thr->Tnrs)
+#define rs (thr->Trs)
+#define last_in_gv (thr->Tlast_in_gv)
+#define ofs (thr->Tofs)
+#define ofslen (thr->Tofslen)
+#define defoutgv (thr->Tdefoutgv)
+#define chopset (thr->Tchopset)
+#define formtarget (thr->Tformtarget)
+#define bodytarget (thr->Tbodytarget)
+#define toptarget (thr->Ttoptarget)
#define defstash (thr->Tdefstash)
#define curstash (thr->Tcurstash)
@@ -393,5 +381,19 @@ typedef struct condpair {
#define top_env (thr->Ttop_env)
#define runlevel (thr->Trunlevel)
-#define cvcache (thr->Tcvcache)
+#else
+/* USE_THREADS is not defined */
+#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
#endif /* USE_THREADS */
diff --git a/toke.c b/toke.c
index bfcab10278..6c53b99dd5 100644
--- a/toke.c
+++ b/toke.c
@@ -1256,27 +1256,39 @@ yylex()
return PRIVATEREF;
}
- if (!strchr(tokenbuf,':')
- && (tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
- if (last_lop_op == OP_SORT &&
- tokenbuf[0] == '$' &&
- (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
- && !tokenbuf[2])
+ if (!strchr(tokenbuf,':')) {
+#ifdef USE_THREADS
+ /* Check for single character per-thread magicals */
+ if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
+ && !isALPHA(tokenbuf[1]) /* Rule out obvious non-magicals */
+ && (tmp = find_thread_magical(&tokenbuf[1])) != NOT_IN_PAD)
{
- for (d = in_eval ? oldoldbufptr : linestart;
- d < bufend && *d != '\n';
- d++)
+ yylval.opval = newOP(OP_SPECIFIC, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
+#endif /* USE_THREADS */
+ if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
+ if (last_lop_op == OP_SORT &&
+ tokenbuf[0] == '$' &&
+ (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
+ && !tokenbuf[2])
{
- if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
- croak("Can't use \"my %s\" in sort comparison",
- tokenbuf);
+ for (d = in_eval ? oldoldbufptr : linestart;
+ d < bufend && *d != '\n';
+ d++)
+ {
+ if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
+ croak("Can't use \"my %s\" in sort comparison",
+ tokenbuf);
+ }
}
}
- }
- yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = tmp;
- return PRIVATEREF;
+ yylval.opval = newOP(OP_PADANY, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
}
/* Force them to make up their mind on "@foo". */
@@ -1391,7 +1403,13 @@ yylex()
if (lex_dojoin) {
nextval[nexttoke].ival = 0;
force_next(',');
+#ifdef USE_THREADS
+ nextval[nexttoke].opval = newOP(OP_SPECIFIC, 0);
+ nextval[nexttoke].opval->op_targ = find_thread_magical("\"");
+ force_next(PRIVATEREF);
+#else
force_ident("\"", '$');
+#endif /* USE_THREADS */
nextval[nexttoke].ival = 0;
force_next('$');
nextval[nexttoke].ival = 0;
@@ -5328,7 +5346,7 @@ U32 flags;
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(compcv) = comppadlist;
- CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)outsidecv);
+ CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
#ifdef USE_THREADS
CvOWNER(compcv) = 0;
New(666, CvMUTEXP(compcv), 1, perl_mutex);
@@ -5413,7 +5431,7 @@ char *s;
if (in_eval & 2)
warn("%_", msg);
else if (in_eval)
- sv_catsv(GvSV(errgv), msg);
+ sv_catsv(errsv, msg);
else
PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
if (++error_count >= 10)
diff --git a/util.c b/util.c
index 0d33863411..72c76a0ade 100644
--- a/util.c
+++ b/util.c
@@ -56,6 +56,10 @@
static void xstat _((void));
#endif
+#ifdef USE_THREADS
+static U32 threadnum = 0;
+#endif /* USE_THREADS */
+
#ifndef MYMALLOC
/* paranoid version of malloc */
@@ -1172,8 +1176,11 @@ die(pat, va_alist)
GV *gv;
CV *cv;
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "die: curstack = %p, mainstack= %p\n",
- curstack, mainstack));/*debug*/
+#ifdef USE_THREADS
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "%p: die: curstack = %p, mainstack = %p\n",
+ thr, curstack, mainstack));
+#endif /* USE_THREADS */
/* 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 */
@@ -1190,8 +1197,11 @@ 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*/
+#ifdef USE_THREADS
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "%p: die: message = %s\ndiehook = %p\n",
+ thr, message, diehook));
+#endif /* USE_THREADS */
if (diehook) {
/* sv_2cv might call croak() */
SV *olddiehook = diehook;
@@ -1219,9 +1229,11 @@ die(pat, va_alist)
}
restartop = die_where(message);
+#ifdef USE_THREADS
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
- "die: restartop = %p, was_in_eval = %d, oldrunlevel = %d\n",
- restartop, was_in_eval, oldrunlevel));/*debug*/
+ "%p: die: restartop = %p, was_in_eval = %d, oldrunlevel = %d\n",
+ thr, restartop, was_in_eval, oldrunlevel));
+#endif /* USE_THREADS */
if ((!restartop && was_in_eval) || oldrunlevel > 1)
JMPENV_JUMP(3);
return restartop;
@@ -2478,6 +2490,99 @@ SV *sv;
}
return mg;
}
+
+/*
+ * Make a new perl thread structure using t as a prototype. Some of the
+ * fields for the new thread are copied from the prototype thread, t,
+ * so t should not be running in perl at the time this function is
+ * called. The use by ext/Thread/Thread.xs in core perl (where t is the
+ * thread calling new_struct_thread) clearly satisfies this constraint.
+ */
+struct thread *
+new_struct_thread(t)
+struct thread *t;
+{
+ struct thread *thr;
+ SV *sv;
+ SV **svp;
+ I32 i;
+
+ sv = newSVpv("", 0);
+ SvGROW(sv, sizeof(struct thread) + 1);
+ SvCUR_set(sv, sizeof(struct thread));
+ thr = (Thread) SvPVX(sv);
+ /* Zero(thr, 1, struct thread); */
+
+ /* debug */
+ memset(thr, 0xab, sizeof(struct thread));
+ markstack = 0;
+ scopestack = 0;
+ savestack = 0;
+ retstack = 0;
+ dirty = 0;
+ localizing = 0;
+ /* end debug */
+
+ thr->oursv = sv;
+ init_stacks(thr);
+
+ curcop = &compiling;
+ thr->cvcache = newHV();
+ thr->magicals = newAV();
+ thr->specific = newAV();
+ thr->flags = THRf_R_JOINABLE;
+ MUTEX_INIT(&thr->mutex);
+
+ curcop = t->Tcurcop; /* XXX As good a guess as any? */
+ defstash = t->Tdefstash; /* XXX maybe these should */
+ curstash = t->Tcurstash; /* always be set to main? */
+ /* top_env needs to be non-zero. The particular value doesn't matter */
+ top_env = t->Ttop_env;
+ runlevel = 1; /* XXX should be safe ? */
+ in_eval = FALSE;
+ restartop = 0;
+
+ tainted = t->Ttainted;
+ curpm = t->Tcurpm; /* XXX No PMOP ref count */
+ nrs = newSVsv(t->Tnrs);
+ rs = newSVsv(t->Trs);
+ last_in_gv = (GV*)SvREFCNT_inc(t->Tlast_in_gv);
+ ofslen = t->Tofslen;
+ ofs = savepvn(t->Tofs, ofslen);
+ defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
+ chopset = t->Tchopset;
+ formtarget = newSVsv(t->Tformtarget);
+ bodytarget = newSVsv(t->Tbodytarget);
+ toptarget = newSVsv(t->Ttoptarget);
+
+ /* Initialise all per-thread magicals that the template thread used */
+ svp = AvARRAY(t->magicals);
+ for (i = 0; i <= AvFILL(t->magicals); i++, svp++) {
+ if (*svp && *svp != &sv_undef) {
+ SV *sv = newSVsv(*svp);
+ av_store(thr->magicals, i, sv);
+ sv_magic(sv, 0, 0, &per_thread_magicals[i], 1);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "new_struct_thread: copied magical %d\n",i));
+ }
+ }
+
+ MUTEX_LOCK(&threads_mutex);
+ nthreads++;
+ thr->tid = ++threadnum;
+ thr->next = t->next;
+ thr->prev = t;
+ t->next = thr;
+ thr->next->prev = thr;
+ MUTEX_UNLOCK(&threads_mutex);
+
+#ifdef HAVE_THREAD_INTERN
+ init_thread_intern(thr);
+#else
+ thr->self = pthread_self();
+#endif /* HAVE_THREAD_INTERN */
+ return thr;
+}
#endif /* USE_THREADS */
#ifdef HUGE_VAL
diff --git a/vms/descrip.mms b/vms/descrip.mms
index 7681f21586..47e192e9b0 100644
--- a/vms/descrip.mms
+++ b/vms/descrip.mms
@@ -28,6 +28,12 @@
#: SOCKETSHR socket support.
#: /Macro="DECC_SOCKETS=1" to include UCX (or
#: compatible) socket support
+#: /Macro="OLDTHREADED=1" to compile with the old
+#: pthreads API (VMS version 6.2 and previous)
+#: /Macro="THREADED=1" to compile with full POSIX
+#: threads. (VMS 7.0 and above)
+#: /Macro="FAKETHREADED=1" to compile with the
+#: fake threads package
#
# tidy -- purge files generated by executing this file
# clean -- remove all intermediate (e.g. object files, C files generated
@@ -202,8 +208,33 @@ SOCKOBJ =
SOCKPM =
.endif
+THREADH =
+THREAD =
+
+.ifdef THREADED
+THREADDEF = ,USE_THREADS,MULTIPLICITY
+THREADH = thread.h
+THREAD = THREAD
+.endif
+
+.ifdef OLDTHREADED
+THREADDEF = ,USE_THREADS,MULTIPLICITY,OLD_PTHREADS_API
+THREADH = thread.h
+THREAD = THREAD
+LIBS2 = sys$share:cma$lib_shr/share,cma$rtl/share
+.ifdef __AXP__
+LIBS2 = $(LIBS2),sys$share:cma$open_lib_shr/share,cma$open_rtl/share
+.endif
+.endif
+
+.ifdef FAKETHREADED
+THREADDEF = ,USE_THREADS,MULTIPLICITY,FAKE_THREADS
+THREADH = thread.h fakethr.h
+THREAD = THREAD
+.endif
+
# C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger
-CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS)
+CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF)$(THREADDEF))$(XTRACCFLAGS)$(DBGCCFLAGS)
LINKFLAGS = $(DBGLINKFLAGS)
MAKE = $(MMS)
@@ -246,7 +277,7 @@ h1 = EXTERN.h, INTERN.h, XSUB.h, av.h, config.h, cop.h, cv.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, vmsish.h, util.h, perlio.h, perlsdio.h
-h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
+h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS) $(THREADH)
c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c, universal.c, perlio.c
c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c
@@ -311,7 +342,7 @@ all : base extras x2p archcorefiles preplibrary perlpods
.endif
base : miniperl perl
@ $(NOOP)
-extras : Fcntl IO Opcode $(POSIX) libmods utils podxform
+extras : Fcntl IO Opcode attrs $(POSIX) $(THREAD) libmods utils podxform
@ $(NOOP)
libmods : $(LIBPREREQ)
@ $(NOOP)
@@ -466,6 +497,25 @@ Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+attrs : [.lib]attrs.pm [.lib.auto.attrs]attrs$(E)
+ @ $(NOOP)
+
+[.lib]attrs.pm : [.ext.attrs]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.attrs]
+ $(MMS)
+ @ Set Default [--]
+
+[.lib.auto.attrs]attrs$(E) : [.ext.attrs]Descrip.MMS
+ @ Set Default [.ext.attrs]
+ $(MMS)
+ @ Set Default [--]
+
+# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
+# ${@} necessary to distract different versions of MM[SK]/make
+[.ext.attrs]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
+ $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.attrs]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+
POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E)
@ $(NOOP)
@@ -485,6 +535,25 @@ POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E)
[.ext.POSIX]Descrip.MMS : [.ext.POSIX]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.POSIX]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+THREAD : [.lib]THREAD.pm [.lib.auto.THREAD]THREAD$(E)
+ @ $(NOOP)
+
+[.lib]THREAD.pm : [.ext.THREAD]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.THREAD]
+ $(MMS)
+ @ Set Default [--]
+
+[.lib.auto.THREAD]THREAD$(E) : [.ext.THREAD]Descrip.MMS
+ @ Set Default [.ext.THREAD]
+ $(MMS)
+ @ Set Default [--]
+
+# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
+# ${@} necessary to distract different versions of MM[SK]/make
+[.ext.THREAD]Descrip.MMS : [.ext.THREAD]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
+ $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.THREAD]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+
IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E)
@ $(NOOP)
@@ -1783,6 +1852,14 @@ realclean : clean
Set Default [.ext.Opcode]
- $(MMS) realclean
Set Default [--]
+ Set Default [.ext.attrs]
+ - $(MMS) realclean
+ Set Default [--]
+.ifdef THREAD
+ Set Default [.ext.Thread]
+ - $(MMS) realclean
+ Set Default [--]
+.endif
.ifdef DECC
Set Default [.ext.POSIX]
- $(MMS) realclean
diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl
index e451e1826b..5767c5f73f 100644
--- a/vms/gen_shrfls.pl
+++ b/vms/gen_shrfls.pl
@@ -150,6 +150,7 @@ sub scan_var {
$line =~ s/\[.*//;
$line =~ s/=.*//;
$line =~ s/\W*;?\s*$//;
+ $line =~ s/\(void//;
print "\tfiltered to \\$line\\\n" if $debug > 1;
if ($line =~ /(\w+)$/) {
print "\tvar name is \\$1\\" . ($const ? ' (const)' : '') . "\n" if $debug > 1;
diff --git a/vms/vms.c b/vms/vms.c
index d4f3f30124..84330e2f98 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -3179,6 +3179,79 @@ void my_endpwent()
/*}}}*/
#if __VMS_VER < 70000000 || __DECC_VER < 50200000
+/* Signal handling routines, pulled into the core from POSIX.xs.
+ *
+ * We need these for threads, so they've been rolled into the core,
+ * rather than left in POSIX.xs.
+ *
+ * (DRS, Oct 23, 1997)
+ */
+
+/* sigset_t is atomic under VMS, so these routines are easy */
+int my_sigemptyset(sigset_t *set) {
+ if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
+ *set = 0; return 0;
+}
+int my_sigfillset(sigset_t *set) {
+ int i;
+ if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
+ for (i = 0; i < NSIG; i++) *set |= (1 << i);
+ return 0;
+}
+int my_sigaddset(sigset_t *set, int sig) {
+ if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
+ if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
+ *set |= (1 << (sig - 1));
+ return 0;
+}
+int my_sigdelset(sigset_t *set, int sig) {
+ if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
+ if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
+ *set &= ~(1 << (sig - 1));
+ return 0;
+}
+int my_sigismember(sigset_t *set, int sig) {
+ if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
+ if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
+ *set & (1 << (sig - 1));
+}
+int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
+ sigset_t tempmask;
+
+ /* If set and oset are both null, then things are badky wrong. Bail */
+ if ((oset == NULL) && (set == NULL)) {
+ set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
+ return -1;
+ }
+
+ /* If set's null, then we're just handling a fetch. */
+ if (set == NULL) {
+ tempmask = sigblock(0);
+ } else {
+ switch (how) {
+ case SIG_SETMASK:
+ tempmask = sigsetmask(*set);
+ break;
+ case SIG_BLOCK:
+ tempmask = sigblock(*set);
+ break;
+ case SIG_UNBLOCK:
+ tempmask = sigblock(0);
+ sigsetmask(*oset & ~tempmask);
+ break;
+ default:
+ set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
+ return -1;
+ }
+ }
+
+ /* Did they pass us an oset? If so, stick our holding mask into it */
+ if (oset)
+ *oset = tempmask;
+
+ return 0;
+}
+
/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
* my_utime(), and flex_stat(), all of which operate on UTC unless
* VMSISH_TIMES is true.
diff --git a/vms/vmsish.h b/vms/vmsish.h
index 2da1639baa..410031cca3 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -115,6 +115,12 @@
# define my_gmtime Perl_my_gmtime
# define my_localtime Perl_my_localtime
# define my_time Perl_my_time
+# define my_sigemptyset Perl_my_sigemptyset
+# define my_sigfillset Perl_my_sigfillset
+# define my_sigaddset Perl_my_sigaddset
+# define my_sigdelset Perl_my_sigdelset
+# define my_sigismember Perl_my_sigismember
+# define my_sigprocmask Perl_my_sigprocmask
#endif
# define cando_by_name Perl_cando_by_name
# define flex_fstat Perl_flex_fstat
@@ -336,6 +342,29 @@ struct utimbuf {
#define gmtime(t) my_gmtime(t)
#define localtime(t) my_localtime(t)
#define time(t) my_time(t)
+#define sigemptyset(t) my_sigemptyset(t)
+#define sigfillset(t) my_sigfillset(t)
+#define sigaddset(t, u) my_sigaddset(t, u)
+#define sigdelset(t, u) my_sigdelset(t, u)
+#define sigismember(t, u) my_sigismember(t, u)
+#define sigprocmask(t, u, v) my_sigprocmask(t, u, v)
+typedef int sigset_t;
+/* The tools for sigprocmask() are there, just not the routine itself */
+# ifndef SIG_UNBLOCK
+# define SIG_UNBLOCK 1
+# endif
+# ifndef SIG_BLOCK
+# define SIG_BLOCK 2
+# endif
+# ifndef SIG_SETMASK
+# define SIG_SETMASK 3
+# endif
+# define sigaction sigvec
+# define sa_flags sv_onstack
+# define sa_handler sv_handler
+# define sa_mask sv_mask
+# define sigsuspend(set) sigpause(*set)
+# define sigpending(a) (not_here("sigpending"),0)
#endif
/* VMS doesn't use a real sys_nerr, but we need this when scanning for error
@@ -541,6 +570,16 @@ struct tm * my_gmtime _((const time_t *));
struct tm * my_localtime _((const time_t *));
time_t my_time _((time_t *));
#endif /* We're assuming these three come as a package */
+/* We're just gonna assume that if we've got an antique here that we */
+/* need the signal functions */
+#if __VMS_VER < 70000000 || __DECC_VER < 50200000
+int my_sigemptyset _((sigset_t *));
+int my_sigfillset _((sigset_t *));
+int my_sigaddset _((sigset_t *, int));
+int my_sigdelset _((sigset_t *, int));
+int my_sigismember _((sigset_t *, int));
+int my_sigprocmask _((int, sigset_t *, sigset_t *));
+#endif
I32 cando_by_name _((I32, I32, char *));
int flex_fstat _((int, struct mystat *));
int flex_stat _((char *, struct mystat *));
diff --git a/win32/win32thread.c b/win32/win32thread.c
new file mode 100644
index 0000000000..9f63d178f4
--- /dev/null
+++ b/win32/win32thread.c
@@ -0,0 +1,30 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "win32/win32thread.h"
+
+void
+init_thread_intern(struct thread *thr)
+{
+ DuplicateHandle(GetCurrentProcess(),
+ GetCurrentThread(),
+ GetCurrentProcess(),
+ &thr->self,
+ 0,
+ FALSE,
+ DUPLICATE_SAME_ACCESS);
+ if ((thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
+ croak("panic: TlsAlloc");
+ if (TlsSetValue(thr_key, (LPVOID) thr) != TRUE)
+ croak("panic: TlsSetValue");
+}
+
+int
+thread_create(struct thread *thr, THREAD_RET_TYPE (*fn)(void *))
+{
+ DWORD junk;
+
+ MUTEX_LOCK(&thr->mutex);
+ thr->self = CreateThread(NULL, 0, fn, (void*)thr, 0, &junk);
+ MUTEX_UNLOCK(&thr->mutex);
+ return thr->self ? 0 : -1;
+}
diff --git a/win32/win32thread.h b/win32/win32thread.h
new file mode 100644
index 0000000000..ab0dbc598f
--- /dev/null
+++ b/win32/win32thread.h
@@ -0,0 +1,102 @@
+/*typedef CRITICAL_SECTION perl_mutex;*/
+typedef HANDLE perl_mutex;
+typedef HANDLE perl_cond;
+typedef DWORD perl_key;
+typedef HANDLE perl_thread;
+
+/* XXX Critical Sections used instead of mutexes: lightweight,
+ * but can't be communicated to child processes, and can't get
+ * HANDLE to it for use elsewhere
+ */
+/*
+#define MUTEX_INIT(m) InitializeCriticalSection(m)
+#define MUTEX_LOCK(m) EnterCriticalSection(m)
+#define MUTEX_UNLOCK(m) LeaveCriticalSection(m)
+#define MUTEX_DESTROY(m) DeleteCriticalSection(m)
+*/
+
+#define MUTEX_INIT(m) \
+ STMT_START { \
+ if ((*(m) = CreateMutex(NULL,FALSE,NULL)) == NULL) \
+ croak("panic: MUTEX_INIT"); \
+ } STMT_END
+#define MUTEX_LOCK(m) \
+ STMT_START { \
+ if (WaitForSingleObject(*(m),INFINITE) == WAIT_FAILED) \
+ croak("panic: MUTEX_LOCK"); \
+ } STMT_END
+#define MUTEX_UNLOCK(m) \
+ STMT_START { \
+ if (ReleaseMutex(*(m)) == 0) \
+ croak("panic: MUTEX_UNLOCK"); \
+ } STMT_END
+#define MUTEX_DESTROY(m) \
+ STMT_START { \
+ if (CloseHandle(*(m)) == 0) \
+ croak("panic: MUTEX_DESTROY"); \
+ } STMT_END
+
+#define COND_INIT(c) \
+ STMT_START { \
+ if ((*(c) = CreateEvent(NULL,TRUE,FALSE,NULL)) == NULL) \
+ croak("panic: COND_INIT"); \
+ } STMT_END
+#define COND_SIGNAL(c) \
+ STMT_START { \
+ if (PulseEvent(*(c)) == 0) \
+ croak("panic: COND_SIGNAL (%ld)",GetLastError()); \
+ } STMT_END
+#define COND_BROADCAST(c) \
+ STMT_START { \
+ if (PulseEvent(*(c)) == 0) \
+ croak("panic: COND_BROADCAST"); \
+ } STMT_END
+/* #define COND_WAIT(c, m) \
+ STMT_START { \
+ if (WaitForSingleObject(*(c),INFINITE) == WAIT_FAILED) \
+ croak("panic: COND_WAIT"); \
+ } STMT_END
+*/
+#define COND_WAIT(c, m) \
+ STMT_START { \
+ if (SignalObjectAndWait(*(m),*(c),INFINITE,FALSE) == WAIT_FAILED)\
+ croak("panic: COND_WAIT"); \
+ else \
+ MUTEX_LOCK(m); \
+ } STMT_END
+#define COND_DESTROY(c) \
+ STMT_START { \
+ if (CloseHandle(*(c)) == 0) \
+ croak("panic: COND_DESTROY"); \
+ } STMT_END
+
+#define DETACH(t) \
+ STMT_START { \
+ if (CloseHandle((t)->self) == 0) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ croak("panic: DETACH"); \
+ } \
+ } STMT_END
+
+#define THR ((struct thread *) TlsGetValue(thr_key))
+
+#define HAVE_THREAD_INTERN
+
+#define JOIN(t, avp) \
+ STMT_START { \
+ if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \
+ || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0)) \
+ croak("panic: JOIN"); \
+ } STMT_END
+
+#define SET_THR(t) \
+ STMT_START { \
+ if (TlsSetValue(thr_key, (void *) (t)) == 0) \
+ croak("panic: TlsSetValue"); \
+ } STMT_END
+
+#define THREAD_CREATE(t, f) thread_create(t, f)
+#define THREAD_POST_CREATE(t) NOOP
+#define THREAD_RET_TYPE DWORD WINAPI
+#define THREAD_RET_CAST(p) ((DWORD)(p))
+#define YIELD Sleep(0)
View Lorry Controller Status