Start support for fake threads.

pp_lock now returns its argument.

p4raw-id: //depot/perl@41

16 files changed, 157 insertions, 55 deletions

diff --git a/MANIFEST b/MANIFEST
index 15837d4232..349e7193f0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -762,6 +762,7 @@ t/pragma/subs.t		See if subroutine pseudo-importation works
 t/pragma/warn-1global	Tests of global warnings for warning.t
 t/pragma/warning.t	See if warning controls work
 taint.c			Tainting code
+thread.h		Threading header
 toke.c			The tokener
 universal.c		The default UNIVERSAL package methods
 unixish.h		Defines that are assumed on Unix
diff --git a/Makefile.SH b/Makefile.SH
index ec99d02e5c..dc5111a7b6 100644
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -176,7 +176,7 @@ addedbyconf = UU $(shextract) $(plextract) pstruct
 h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h
 h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
 h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h
-h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h
+h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h thread.h
 h = $(h1) $(h2) $(h3) $(h4)
 
 c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c
diff --git a/cv.h b/cv.h
index 97dfeb6f6d..1e6b8de77a 100644
--- a/cv.h
+++ b/cv.h
@@ -29,9 +29,9 @@ struct xpvcv {
     AV *	xcv_padlist;
     CV *	xcv_outside;
 #ifdef USE_THREADS
-    pthread_mutex_t *	xcv_mutexp;
-    pthread_cond_t *	xcv_condp;	/* signalled when owner leaves CV */
-    struct thread *	xcv_owner;	/* current owner thread */
+    perl_mutex *xcv_mutexp;
+    perl_cond *	xcv_condp;	/* signalled when owner leaves CV */
+    struct thread *xcv_owner;	/* current owner thread */
 #endif /* USE_THREADS */
     U8		xcv_flags;
 };
diff --git a/op.c b/op.c
index 20e1384163..bd2f09aa36 100644
--- a/op.c
+++ b/op.c
@@ -3129,9 +3129,9 @@ CV* outside;
 	CvANON_on(cv);
 
 #ifdef USE_THREADS
-    New(666, CvMUTEXP(cv), 1, pthread_mutex_t);
+    New(666, CvMUTEXP(cv), 1, perl_mutex);
     MUTEX_INIT(CvMUTEXP(cv));
-    New(666, CvCONDP(cv), 1, pthread_cond_t);
+    New(666, CvCONDP(cv), 1, perl_cond);
     COND_INIT(CvCONDP(cv));
     CvOWNER(cv)		= 0;
 #endif /* USE_THREADS */
@@ -3371,9 +3371,9 @@ OP *block;
     CvSTASH(cv) = curstash;
 #ifdef USE_THREADS
     CvOWNER(cv) = 0;
-    New(666, CvMUTEXP(cv), 1, pthread_mutex_t);
+    New(666, CvMUTEXP(cv), 1, perl_mutex);
     MUTEX_INIT(CvMUTEXP(cv));
-    New(666, CvCONDP(cv), 1, pthread_cond_t);
+    New(666, CvCONDP(cv), 1, perl_cond);
     COND_INIT(CvCONDP(cv));
 #endif /* USE_THREADS */
 
@@ -3578,9 +3578,9 @@ char *filename;
     }
     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
 #ifdef USE_THREADS
-    New(666, CvMUTEXP(cv), 1, pthread_mutex_t);
+    New(666, CvMUTEXP(cv), 1, perl_mutex);
     MUTEX_INIT(CvMUTEXP(cv));
-    New(666, CvCONDP(cv), 1, pthread_cond_t);
+    New(666, CvCONDP(cv), 1, perl_cond);
     COND_INIT(CvCONDP(cv));
     CvOWNER(cv) = 0;
 #endif /* USE_THREADS */
diff --git a/opcode.h b/opcode.h
index 2e6f4b20c5..4ca997271f 100644
--- a/opcode.h
+++ b/opcode.h
@@ -2489,6 +2489,6 @@ EXT U32 opargs[] = {
 	0x00000014,	/* egrent */
 	0x0000000c,	/* getlogin */
 	0x0000211d,	/* syscall */
-	0x00000114,	/* lock */
+	0x00000104,	/* lock */
 };
 #endif
diff --git a/opcode.pl b/opcode.pl
index 89d076a57a..5250d57fe7 100755
--- a/opcode.pl
+++ b/opcode.pl
@@ -654,4 +654,4 @@ getlogin	getlogin		ck_null		st
 syscall		syscall			ck_fun		imst	S L
 
 # For multi-threading
-lock		lock			ck_null		is	S
+lock		lock			ck_null		s	S
diff --git a/perl.c b/perl.c
index d3567f0175..edaf97219d 100644
--- a/perl.c
+++ b/perl.c
@@ -843,9 +843,9 @@ print \"  \\@INC:\\n    @INC\\n\";");
     curpad[0] = (SV*)newAV();
     SvPADMY_on(curpad[0]);	/* XXX Needed? */
     CvOWNER(compcv) = 0;
-    New(666, CvMUTEXP(compcv), 1, pthread_mutex_t);
+    New(666, CvMUTEXP(compcv), 1, perl_mutex);
     MUTEX_INIT(CvMUTEXP(compcv));
-    New(666, CvCONDP(compcv), 1, pthread_cond_t);
+    New(666, CvCONDP(compcv), 1, perl_cond);
     COND_INIT(CvCONDP(compcv));
 #endif /* USE_THREADS */
 
diff --git a/perl.h b/perl.h
index 4d229b97e6..64d47acdc6 100644
--- a/perl.h
+++ b/perl.h
@@ -63,8 +63,14 @@ register struct op *op asm(stringify(OP_IN_REGISTER));
 #define NOOP (void)0
 
 #ifdef USE_THREADS
+#ifdef FAKE_THREADS
+#include "fakethr.h"
+#else
 #include <pthread.h>
-#endif
+typedef pthread_mutex_t perl_mutex;
+typedef pthread_cond_t perl_cond;
+#endif /* FAKE_THREADS */
+#endif /* USE_THREADS */
 
 /*
  * SOFT_CAST can be used for args to prototyped functions to retain some
@@ -1318,14 +1324,14 @@ typedef Sighandler_t Sigsave_t;
 EXT PerlInterpreter *	curinterp;	/* currently running interpreter */
 #ifdef USE_THREADS
 EXT pthread_key_t	thr_key;	/* For per-thread struct thread ptr */
-EXT pthread_mutex_t	sv_mutex;	/* Mutex for allocating SVs in sv.c */
-EXT pthread_mutex_t	malloc_mutex;	/* Mutex for malloc */
-EXT pthread_mutex_t	eval_mutex;	/* Mutex for doeval */
-EXT pthread_cond_t	eval_cond;	/* Condition variable for doeval */
+EXT perl_mutex		sv_mutex;	/* Mutex for allocating SVs in sv.c */
+EXT perl_mutex		malloc_mutex;	/* Mutex for malloc */
+EXT perl_mutex		eval_mutex;	/* Mutex for doeval */
+EXT perl_cond		eval_cond;	/* Condition variable for doeval */
 EXT struct thread *	eval_owner;	/* Owner thread for doeval */
 EXT int			nthreads;	/* Number of threads currently */
-EXT pthread_mutex_t	nthreads_mutex;	/* Mutex for nthreads */
-EXT pthread_cond_t	nthreads_cond;	/* Condition variable for nthreads */
+EXT perl_mutex		nthreads_mutex;	/* Mutex for nthreads */
+EXT perl_cond		nthreads_cond;	/* Condition variable for nthreads */
 #endif /* USE_THREADS */
 
 /* VMS doesn't use environ array and NeXT has problems with crt0.o globals */
diff --git a/pp.c b/pp.c
index c288a01b30..c956e80ad2 100644
--- a/pp.c
+++ b/pp.c
@@ -4157,6 +4157,5 @@ PP(pp_lock)
 	save_destructor(unlock_condpair, sv);
     }
 #endif /* USE_THREADS */
-    PUSHs(&sv_yes);
     RETURN;
 }
diff --git a/pp_ctl.c b/pp_ctl.c
index c6a6ea2911..3101e5c1d5 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2163,9 +2163,9 @@ int gimme;
     CvUNIQUE_on(compcv);
 #ifdef USE_THREADS
     CvOWNER(compcv) = 0;
-    New(666, CvMUTEXP(compcv), 1, pthread_mutex_t);
+    New(666, CvMUTEXP(compcv), 1, perl_mutex);
     MUTEX_INIT(CvMUTEXP(compcv));
-    New(666, CvCONDP(compcv), 1, pthread_cond_t);
+    New(666, CvCONDP(compcv), 1, perl_cond);
     COND_INIT(CvCONDP(compcv));
 #endif /* USE_THREADS */
 
diff --git a/pp_hot.c b/pp_hot.c
index f45fa681b3..07f0754cd5 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -41,20 +41,6 @@ void *cvarg;
     MUTEX_UNLOCK(CvMUTEXP(cv));
     SvREFCNT_dec(cv);
 }
-
-#if 0
-void
-mutex_unlock(m)
-void *m;
-{
-#ifdef DEBUGGING
-    dTHR;
-    DEBUG_L((fprintf(stderr, "0x%lx unlocking mutex 0x%lx\n",
-			 (unsigned long) thr, (unsigned long) m)));
-#endif /* DEBUGGING */
-    MUTEX_UNLOCK((pthread_mutex_t *) m);
-}
-#endif
 #endif /* USE_THREADS */
 
 PP(pp_const)
diff --git a/proto.h b/proto.h
index 5fbd81dd48..3ad298d0ad 100644
--- a/proto.h
+++ b/proto.h
@@ -258,9 +258,6 @@ void	mg_magical _((SV* sv));
 int	mg_set _((SV* sv));
 OP*	mod _((OP* o, I32 type));
 char*	moreswitches _((char* s));
-#ifdef USE_THREADS
-void	mutex_unlock _((void *m));
-#endif /* USE_THREADS */
 OP*	my _((OP* o));
 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 char*	my_bcopy _((char* from, char* to, I32 len));
diff --git a/sv.h b/sv.h
index d58aeb1d84..2651e43467 100644
--- a/sv.h
+++ b/sv.h
@@ -244,9 +244,9 @@ struct xpvfm {
     AV *	xcv_padlist;
     CV *	xcv_outside;
 #ifdef USE_THREADS
-    pthread_mutex_t *	xcv_mutexp;
-    pthread_cond_t *	xcv_condp;	/* signalled when owner leaves CV */
-    struct thread *	xcv_owner;	/* current owner thread */
+    perl_mutex *xcv_mutexp;
+    perl_cond *	xcv_condp;	/* signalled when owner leaves CV */
+    struct thread *xcv_owner;	/* current owner thread */
 #endif /* USE_THREADS */
     U8		xcv_flags;
 
diff --git a/thread.h b/thread.h
index 45e47c3405..8bef7a57a0 100644
--- a/thread.h
+++ b/thread.h
@@ -13,8 +13,35 @@
 /* Rats: if dTHR is just blank then the subsequent ";" throws an error */
 #define dTHR extern int errno
 #else
-#include <pthread.h>
 
+#ifdef FAKE_THREADS
+typedef struct thread *perl_thread;
+/* With fake threads, thr is global(ish) so we don't need dTHR */
+#define dTHR extern int errno
+
+/*
+ * Note that SCHEDULE() is only callable from pp code (which
+ * must be expecting to be restarted). We'll have to do
+ * something a bit different for XS code.
+ */
+#define SCHEDULE() return schedule(), op
+
+#define MUTEX_LOCK(m)
+#define MUTEX_UNLOCK(m)
+#define MUTEX_INIT(m)
+#define MUTEX_DESTROY(m)
+#define COND_INIT(c) perl_cond_init(c)
+#define COND_SIGNAL(c) perl_cond_signal(c)
+#define COND_BROADCAST(c) perl_cond_broadcast(c)
+#define COND_WAIT(c, m) STMT_START {	\
+	perl_cond_wait(c);		\
+	SCHEDULE();			\
+    } STMT_END
+#define COND_DESTROY(c)
+
+#else
+/* POSIXish threads */
+typedef pthread_t perl_thread;
 #ifdef OLD_PTHREADS_API
 #define pthread_mutexattr_init(a) pthread_mutexattr_create(a)
 #define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t)
@@ -51,9 +78,10 @@ struct thread *getTHR _((void));
 #define THR ((struct thread *) pthread_getspecific(thr_key))
 #endif /* OLD_PTHREADS_API */
 #define dTHR struct thread *thr = THR
+#endif /* FAKE_THREADS */
 
 struct thread {
-    pthread_t	Tself;
+    perl_thread	Tself;
 
     /* The fields that used to be global */
     SV **	Tstack_base;
@@ -123,9 +151,16 @@ struct thread {
 
     /* XXX Sort stuff, firstgv, secongv and so on? */
 
-    pthread_mutex_t *	Tthreadstart_mutexp;
+    perl_mutex *Tthreadstart_mutexp;
     HV *	Tcvcache;
     U32		Tthrflags;
+
+#ifdef FAKE_THREADS
+    perl_thread next, prev;		/* Linked list of all threads */
+    perl_thread next_run, prev_run;	/* Linked list of runnable threads */
+    perl_cond	wait_queue;		/* Wait queue that we are waiting on */
+    IV		private;		/* Holds data across time slices */
+#endif /* FAKE_THREADS */
 };
 
 typedef struct thread *Thread;
@@ -146,10 +181,10 @@ typedef struct thread *Thread;
     } STMT_END
 
 typedef struct condpair {
-    pthread_mutex_t	mutex;
-    pthread_cond_t	owner_cond;
-    pthread_cond_t	cond;
-    Thread		owner;
+    perl_mutex	mutex;
+    perl_cond	owner_cond;
+    perl_cond	cond;
+    Thread	owner;
 } condpair_t;
 
 #define MgMUTEXP(mg) (&((condpair_t *)(mg->mg_ptr))->mutex)
diff --git a/toke.c b/toke.c
index 54ad907d73..39359b7613 100644
--- a/toke.c
+++ b/toke.c
@@ -5237,9 +5237,9 @@ U32 flags;
     curpad[0] = (SV*)newAV();
     SvPADMY_on(curpad[0]);	/* XXX Needed? */
     CvOWNER(compcv) = 0;
-    New(666, CvMUTEXP(compcv), 1, pthread_mutex_t);
+    New(666, CvMUTEXP(compcv), 1, perl_mutex);
     MUTEX_INIT(CvMUTEXP(compcv));
-    New(666, CvCONDP(compcv), 1, pthread_cond_t);
+    New(666, CvCONDP(compcv), 1, perl_cond);
     COND_INIT(CvCONDP(compcv));
 #endif /* USE_THREADS */
 
@@ -5252,9 +5252,9 @@ U32 flags;
     CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)outsidecv);
 #ifdef USE_THREADS
     CvOWNER(compcv) = 0;
-    New(666, CvMUTEXP(compcv), 1, pthread_mutex_t);
+    New(666, CvMUTEXP(compcv), 1, perl_mutex);
     MUTEX_INIT(CvMUTEXP(compcv));
-    New(666, CvCONDP(compcv), 1, pthread_cond_t);
+    New(666, CvCONDP(compcv), 1, perl_cond);
     COND_INIT(CvCONDP(compcv));
 #endif /* USE_THREADS */
 
diff --git a/util.c b/util.c
index 14940ac267..5bf20955e6 100644
--- a/util.c
+++ b/util.c
@@ -2293,6 +2293,84 @@ I32 *retlen;
 }
 
 #ifdef USE_THREADS
+#ifdef FAKE_THREADS
+/* Very simplistic scheduler for now */
+void
+schedule(void)
+{
+    thr = thr->next_run;
+}
+
+void
+perl_cond_init(cp)
+perl_cond *cp;
+{
+    *cp = 0;
+}
+
+void
+perl_cond_signal(cp)
+perl_cond *cp;
+{
+    perl_thread t;
+    perl_cond cond = *cp;
+    
+    if (!cond)
+	return;
+    t = cond->thread;
+    /* Insert t in the runnable queue just ahead of us */
+    t->next_run = thr->next_run;
+    thr->next_run->prev_run = t;
+    t->prev_run = thr;
+    thr->next_run = t;
+    thr->wait_queue = 0;
+    /* Remove from the wait queue */
+    *cp = cond->next;
+    Safefree(cond);
+}
+
+void
+perl_cond_broadcast(cp)
+perl_cond *cp;
+{
+    perl_thread t;
+    perl_cond cond, cond_next;
+    
+    for (cond = *cp; cond; cond = cond_next) {
+	t = cond->thread;
+	/* Insert t in the runnable queue just ahead of us */
+	t->next_run = thr->next_run;
+	thr->next_run->prev_run = t;
+	t->prev_run = thr;
+	thr->next_run = t;
+	thr->wait_queue = 0;
+	/* Remove from the wait queue */
+	cond_next = cond->next;
+	Safefree(cond);
+    }
+    *cp = 0;
+}
+
+void
+perl_cond_wait(cp)
+perl_cond *cp;
+{
+    perl_cond cond;
+
+    if (thr->next_run == thr)
+	croak("panic: perl_cond_wait called by last runnable thread");
+    
+    New(666, cond, 1, perl_wait_queue);
+    cond->thread = thr;
+    cond->next = *cp;
+    *cp = cond;
+    thr->wait_queue = cond;
+    /* Remove ourselves from runnable queue */
+    thr->next_run->prev_run = thr->prev_run;
+    thr->prev_run->next_run = thr->next_run;
+}
+#endif /* FAKE_THREADS */
+
 #ifdef OLD_PTHREADS_API
 struct thread *
 getTHR _((void))