[project @ 2000-03-20 04:26:23 by andy]

Second attack at supporting threads inside STG Hugs.
We now support most of the concurrency primitives.

Also a wibble in Evaluator.c, letting Hugs compile.

ghc/includes/options.h

@@ -7,8 +7,8 @@
  * Hugs version 1.4, December 1997
  *
  * $RCSfile: options.h,v $
- * $Revision: 1.22 $
- * $Date: 2000/03/10 18:28:26 $
+ * $Revision: 1.23 $
+ * $Date: 2000/03/20 04:26:24 $
  * ------------------------------------------------------------------------*/
 
 
@@ -158,15 +158,13 @@
  * without attention.  However, standard Haskell 98 is supported 
  * is supported without needing them.
  */
-#undef  PROVIDE_STABLE
-#undef  PROVIDE_FOREIGN
 #undef  PROVIDE_WEAK
-#undef  PROVIDE_CONCURRENT
-#undef  PROVIDE_PTREQUALITY
-#undef  PROVIDE_COERCE
 
-#define  PROVIDE_COERCE     1
+#define PROVIDE_STABLE      1
+#define PROVIDE_FOREIGN     1
+#define PROVIDE_COERCE      1
 #define PROVIDE_PTREQUALITY 1
+#define PROVIDE_CONCURRENT  1
 
 /* Enable a crude profiler which counts BCO entries, bytes allocated
    and bytecode insns executed on a per-fn basis.  Used for assessing

ghc/interpreter/connect.h

@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: connect.h,v $
- * $Revision: 1.30 $
- * $Date: 2000/03/15 23:27:16 $
+ * $Revision: 1.31 $
+ * $Date: 2000/03/20 04:26:23 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
@@ -1025,4 +1025,7 @@ extern Bool  sameType		( Type,Int,Type,Int );
 extern Bool  matchType		( Type,Int,Type,Int );
 extern Bool  typeMatches        ( Type,Type );
 
+#ifdef DEBUG
+extern Void  checkBytecodeCount  ( Void );
+#endif
 /*-------------------------------------------------------------------------*/

ghc/interpreter/hugs.c

@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: hugs.c,v $
- * $Revision: 1.44 $
- * $Date: 2000/03/15 23:27:16 $
+ * $Revision: 1.45 $
+ * $Date: 2000/03/20 04:26:23 $
  * ------------------------------------------------------------------------*/
 
 #include <setjmp.h>
@@ -228,6 +228,10 @@ char *argv[]; {
 
     CStackBase = &argc;                 /* Save stack base for use in gc   */
 
+#ifdef DEBUG
+    checkBytecodeCount();		/* check for too many bytecodes    */
+#endif
+
     /* If first arg is +Q or -Q, be entirely silent, and automatically run
        main after loading scripts.  Useful for running the nofib suite.    */
     if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {

ghc/interpreter/lib/Makefile

 # -------------------------------------------------------------------------- #
-# $Id: Makefile,v 1.7 2000/03/08 22:05:43 andy Exp $ 
+# $Id: Makefile,v 1.8 2000/03/20 04:26:23 andy Exp $ 
 # -------------------------------------------------------------------------- #
 
 TOP = ../..
@@ -52,12 +52,17 @@ UTIL_LIBS = QuickCheck.hs QuickCheckBatch.hs QuickCheckPoly.hs \
 	Regex.lhs RegexString.lhs Observe.lhs Memo.lhs Readline.lhs \
 	Select.lhs 
 
+CONC_LIBS = Channel.lhs ChannelVar.lhs Concurrent.lhs Merge.lhs \
+	Parallel.lhs SampleVar.lhs Semaphore.lhs Strategies.lhs
+
+
 LIBS =  $(PRELUDE) \
         $(STD_LIBS) \
 	$(DATA_LIBS) \
 	$(LANG_LIBS) \
 	$(TEXT_LIBS) \
-	$(UTIL_LIBS)
+	$(CONC_LIBS) \
+	$(UTIL_LIBS) 
 
 all :: $(LIBS)
 

ghc/interpreter/machdep.c

@@ -13,8 +13,8 @@
  * included in the distribution.
  *
  * $RCSfile: machdep.c,v $
- * $Revision: 1.20 $
- * $Date: 2000/03/13 11:37:16 $
+ * $Revision: 1.21 $
+ * $Date: 2000/03/20 04:26:23 $
  * ------------------------------------------------------------------------*/
 
 #ifdef HAVE_SIGNAL_H
@@ -251,7 +251,7 @@ static Void   local searchChr     ( Int );
 static Void   local searchStr     ( String );
 static Bool   local tryEndings    ( String );
 
-#if DOS_FILENAMES
+#if (DOS_FILENAMES || __CYGWIN32__) 
 # define SLASH                   '\\'
 # define isSLASH(c)              ((c)=='\\' || (c)=='/')
 # define PATHSEP                 ';'
@@ -690,7 +690,7 @@ Bool findFilesForModule (
    strcat(augdPath, "lib");
    strcat(augdPath, PATHSEP_STR);
 
-   /* fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
+   /*   fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
 
    peEnd = augdPath-1;
    while (1) {

ghc/lib/hugs/Prelude.hs

@@ -2049,10 +2049,11 @@ swapMVar mvar new =
     putMVar mvar new    >>
     return old
 
+isEmptyMVar var = error "isEmptyMVar is not (yet) implemented in Hugs"
+
 instance Eq (MVar a) where
     m1 == m2 = primSameMVar m1 m2
 
-
 data ThreadId
 
 instance Eq ThreadId where
@@ -2081,6 +2082,11 @@ forkIO computation
 trace_quiet s x
    = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x
 
+
+-- Foreign ------------------------------------------------------------------
+
+data ForeignObj
+
 -- showFloat ------------------------------------------------------------------
 
 showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS

ghc/rts/Assembler.c

@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Assembler.c,v $
- * $Revision: 1.23 $
- * $Date: 2000/03/17 14:37:21 $
+ * $Revision: 1.24 $
+ * $Date: 2000/03/20 04:26:24 $
  *
  * This module provides functions to construct BCOs and other closures
  * required by the bytecode compiler.
@@ -1399,19 +1399,21 @@ AsmPrim asmPrimOps[] = {
 #endif
 #ifdef PROVIDE_CONCURRENT
     /* Concurrency operations */
-    , { "primFork",                  "a", "T",   MONAD_IO, i_PRIMOP2, i_fork }
+    , { "primForkIO",                "a", "T",   MONAD_IO, i_PRIMOP2, i_forkIO }
     , { "primKillThread",            "T", "",    MONAD_IO, i_PRIMOP2, i_killThread }
-    , { "primDelay",                 "I", "",    MONAD_IO, i_PRIMOP2, i_delay }
+    , { "primRaiseInThread",         "TE", "",   MONAD_IO, i_PRIMOP2, i_raiseInThread }
+
     , { "primWaitRead",              "I", "",    MONAD_IO, i_PRIMOP2, i_waitRead }
     , { "primWaitWrite",             "I", "",    MONAD_IO, i_PRIMOP2, i_waitWrite }
+    , { "primYield",                 "", "",     MONAD_IO, i_PRIMOP2, i_yield }    , { "primDelay",                 "I", "",    MONAD_IO, i_PRIMOP2, i_delay }
+    , { "primGetThreadId",           "",   "T",  MONAD_IO, i_PRIMOP2, i_getThreadId }
+    , { "primCmpThreadIds",          "TT", "I",  MONAD_Id, i_PRIMOP2, i_cmpThreadIds }
 #endif
-    , { "primNewEmptyMVar",         "",  "r",   MONAD_IO, i_PRIMOP2, i_newMVar }
+    , { "primNewEmptyMVar",          "",  "r",   MONAD_IO, i_PRIMOP2, i_newMVar }
       /* primTakeMVar is handwritten bytecode */
     , { "primPutMVar",               "ra", "",   MONAD_IO, i_PRIMOP2, i_putMVar } 
     , { "primSameMVar",              "rr", "B",  MONAD_Id, i_PRIMOP2, i_sameMVar }
-    , { "primGetThreadId",           "",   "T",  MONAD_IO, i_PRIMOP2, i_getThreadId }
-    , { "primCmpThreadIds",          "TT", "I",  MONAD_Id, i_PRIMOP2, i_cmpThreadIds }
-    , { "primForkIO",                 "a", "T",  MONAD_IO, i_PRIMOP2, i_forkIO }
+
   
     /* Ccall is polyadic - so it's excluded from this table */
 
@@ -1427,6 +1429,16 @@ AsmPrim ccall_stdcall_Id
 AsmPrim ccall_stdcall_IO 
    = { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_IO };
 
+#ifdef DEBUG
+void checkBytecodeCount( void ) {
+  if (MAX_Primop1 >= 255) {
+    printf("Too many Primop1 bytecodes (%d)\n",MAX_Primop1);
+  }
+  if (MAX_Primop2 >= 255) {
+    printf("Too many Primop2 bytecodes (%d)\n",MAX_Primop2);
+  }
+}
+#endif
 
 AsmPrim* asmFindPrim( char* s )
 {

ghc/rts/Bytecodes.h

 
 /* -----------------------------------------------------------------------------
- * $Id: Bytecodes.h,v 1.13 1999/12/07 11:49:10 sewardj Exp $
+ * $Id: Bytecodes.h,v 1.14 2000/03/20 04:26:24 andy Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -420,19 +420,21 @@ typedef enum
 
 #ifdef PROVIDE_CONCURRENT
     /* Concurrency operations */
-    , i_fork
+    , i_forkIO
     , i_killThread
+    , i_raiseInThread
     , i_delay
     , i_waitRead
     , i_waitWrite
+    , i_yield
+    , i_getThreadId
+    , i_cmpThreadIds
 #endif
     , i_sameMVar
     , i_newMVar
     , i_takeMVar
     , i_putMVar
-    , i_getThreadId
-    , i_cmpThreadIds
-    , i_forkIO
+
 
     /* CCall! */
     , i_ccall_ccall_Id

ghc/rts/Evaluator.c

@@ -5,8 +5,8 @@
  * Copyright (c) 1994-1998.
  *
  * $RCSfile: Evaluator.c,v $
- * $Revision: 1.42 $
- * $Date: 2000/03/17 14:37:21 $
+ * $Revision: 1.43 $
+ * $Date: 2000/03/20 04:26:24 $
  * ---------------------------------------------------------------------------*/
 
 #include "Rts.h"
@@ -41,8 +41,10 @@
 #include <ieee754.h> /* These are for primops */
 #endif
 
-/* Allegedly useful macro */
+
+/* Allegedly useful macro, taken from ClosureMacros.h */
 #define payloadWord( c, i )   (*stgCast(StgWord*,      ((c)->payload+(i))))
+#define payloadPtr( c, i )    (*stgCast(StgPtr*,       ((c)->payload+(i))))
 
 /* An incredibly useful abbreviation.
  * Interestingly, there are some uses of END_TSO_QUEUE_closure that
@@ -104,6 +106,7 @@ void cp_init ( void )
 }
 
 
+
 void cp_enter ( StgBCO* b )
 {
    int is_ret_cont;
@@ -255,6 +258,12 @@ void setRtsFlags( int x )
 }
 
 
+typedef struct { 
+  StgTSOBlockReason reason;
+  unsigned int delay;
+} HugsBlock;
+
+
 /* --------------------------------------------------------------------------
  * Entering-objects and bytecode interpreter part of evaluator
  * ------------------------------------------------------------------------*/
@@ -284,7 +293,7 @@ void setRtsFlags( int x )
 /* Forward decls ... */
 static        void* enterBCO_primop1 ( int );
 static        void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */, 
-                                       StgBCO**, Capability* );
+                                       StgBCO**, Capability*, HugsBlock * );
 static inline void PopUpdateFrame ( StgClosure* obj );
 static inline void PopCatchFrame  ( void );
 static inline void PopSeqFrame    ( void );
@@ -453,6 +462,10 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
     register StgClosure*      obj;    /* object currently under evaluation */
              char             eCount; /* enter counter, for context switching */
 
+
+   HugsBlock hugsBlock = { NotBlocked, 0 };
+
+
 #ifdef DEBUG
     StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
 #endif
@@ -504,8 +517,30 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
 #endif
        ) {
        if (context_switch) {
-          xPushCPtr(obj); /* code to restart with */
-          RETURN(ThreadYielding);
+	 switch(hugsBlock.reason) {
+	 case NotBlocked: {
+	   xPushCPtr(obj); /* code to restart with */
+	   RETURN(ThreadYielding);
+	 }
+	 case BlockedOnDelay: /* fall through */
+	 case BlockedOnRead:  /* fall through */
+	 case BlockedOnWrite: {
+	   ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
+	   cap->rCurrentTSO->why_blocked = BlockedOnDelay;
+	   ACQUIRE_LOCK(&sched_mutex);
+	   
+	   cap->rCurrentTSO->block_info.delay 
+	     = hugsBlock.delay + ticks_since_select;
+	   APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
+	   
+	   RELEASE_LOCK(&sched_mutex);
+	   
+	   xPushCPtr(obj); /* code to restart with */
+	   RETURN(ThreadBlocked);
+	 }
+	 default:
+	   barf("Unknown context switch reasoning");
+	 }
        }
     }
 
@@ -1186,7 +1221,8 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
                     pc_saved = PC; 
                     bco_tmp  = bco;
                     SSS;
-                    p        = enterBCO_primop2 ( i, &trc, &bco_tmp, cap ); 
+                    p        = enterBCO_primop2 ( i, &trc, &bco_tmp, cap, 
+						  &hugsBlock ); 
                     LLL;
                     bco      = bco_tmp;
                     bciPtr   = &(bcoInstr(bco,pc_saved));
@@ -1195,8 +1231,9 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
                           /* we want to enter p */
                           obj = p; goto enterLoop;
                        } else {
-                          /* trc is the the StgThreadReturnCode for this thread */
-                          RETURN((StgThreadReturnCode)trc);
+                          /* trc is the the StgThreadReturnCode for 
+			   * this thread */
+			 RETURN((StgThreadReturnCode)trc);
                        };
                     }
                     Continue;
@@ -2645,11 +2682,14 @@ static void* enterBCO_primop1 ( int primop1code )
       return the address of it and leave *return2 unchanged.
    To return a StgThreadReturnCode to the scheduler,
       set *return2 to it and return a non-NULL value.
+   To cause a context switch, set context_switch (its a global),
+   and optionally set hugsBlock to your rational.
 */
 static void* enterBCO_primop2 ( int primop2code, 
                                 int* /*StgThreadReturnCode* */ return2,
                                 StgBCO** bco,
-                                Capability* cap )
+                                Capability* cap,
+				HugsBlock *hugsBlock )
 {
         if (combined) {
 	   /* A small concession: we need to allow ccalls, 
@@ -3016,21 +3056,7 @@ static void* enterBCO_primop2 ( int primop2code,
                 PushTaggedBool(x==y);
                 break;
             }
-        case i_getThreadId:
-            {
-                StgWord tid = cap->rCurrentTSO->id;
-                PushTaggedWord(tid);
-                break;
-            }
-        case i_cmpThreadIds:
-            {
-                StgWord tid1 = PopTaggedWord();
-                StgWord tid2 = PopTaggedWord();
-                if (tid1 < tid2) PushTaggedInt(-1);
-                else if (tid1 > tid2) PushTaggedInt(1);
-                else PushTaggedInt(0);
-                break;
-            }
+#ifdef PROVIDE_CONCURRENT
         case i_forkIO:
             {
                 StgClosure* closure;
@@ -3041,14 +3067,31 @@ static void* enterBCO_primop2 ( int primop2code,
                 tid     = tso->id;
                 scheduleThread(tso);
                 context_switch = 1;
+		/* Later: Change to use tso as the ThreadId */
                 PushTaggedWord(tid);
                 break;
             }
 
-#ifdef PROVIDE_CONCURRENT
         case i_killThread:
             {
-                StgTSO* tso = stgCast(StgTSO*,PopPtr());
+                StgWord n = PopTaggedWord();
+		StgTSO* tso = 0;
+		StgTSO *t;
+
+		// Map from ThreadId to Thread Structure */
+		for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
+		  if (n == t->id)
+		    tso = t;
+		}
+		if (tso == 0) {
+		  // Already dead
+		  break;
+		}
+
+		while (tso->what_next == ThreadRelocated) {
+		  tso = tso->link;
+		}
+
                 deleteThread(tso);
                 if (tso == cap->rCurrentTSO) { /* suicide */
                     *return2 = ThreadFinished;
@@ -3056,13 +3099,55 @@ static void* enterBCO_primop2 ( int primop2code,
                 }
                 break;
             }
-
+        case i_raiseInThread:
+	  ASSERT(0); /* not (yet) supported */
         case i_delay:
+	  {
+	    StgInt  n = PopTaggedInt();
+	    context_switch = 1;
+	    hugsBlock->reason = BlockedOnDelay;
+	    hugsBlock->delay = n;
+	    break;
+	  }
         case i_waitRead:
+	  {
+	    StgInt  n = PopTaggedInt();
+	    context_switch = 1;
+	    hugsBlock->reason = BlockedOnRead;
+	    hugsBlock->delay = n;
+	    break;
+	  }
         case i_waitWrite:
-                /* As PrimOps.h says: Hmm, I'll think about these later. */
-                ASSERT(0);
+	  {
+	    StgInt  n = PopTaggedInt();
+	    context_switch = 1;
+	    hugsBlock->reason = BlockedOnWrite;
+	    hugsBlock->delay = n;
+	    break;
+	  }
+	case i_yield:
+	  {
+	    /* The definition of yield include an enter right after
+	     * the primYield, at which time context_switch is tested.
+	     */
+	    context_switch = 1;
+	    break;
+	  }
+        case i_getThreadId:
+            {
+                StgWord tid = cap->rCurrentTSO->id;
+                PushTaggedWord(tid);
                 break;
+            }
+        case i_cmpThreadIds:
+            {
+                StgWord tid1 = PopTaggedWord();
+                StgWord tid2 = PopTaggedWord();
+                if (tid1 < tid2) PushTaggedInt(-1);
+                else if (tid1 > tid2) PushTaggedInt(1);
+                else PushTaggedInt(0);
+                break;
+            }
 #endif /* PROVIDE_CONCURRENT */
 
         case i_ccall_ccall_Id: