From: andy Date: Mon, 20 Mar 2000 04:26:24 +0000 (+0000) Subject: [project @ 2000-03-20 04:26:23 by andy] X-Git-Tag: Approximately_9120_patches~4947 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b32b2d43b67c42f45105df40ae8af42eeb58078f;p=ghc-hetmet.git [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. --- diff --git a/ghc/includes/options.h b/ghc/includes/options.h index 4b48294..61c01c4 100644 --- a/ghc/includes/options.h +++ b/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 diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index cbcff7b..f5f121d 100644 --- a/ghc/interpreter/connect.h +++ b/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 /*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 8634d41..8e3002c 100644 --- a/ghc/interpreter/hugs.c +++ b/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 @@ -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)) { diff --git a/ghc/interpreter/lib/Makefile b/ghc/interpreter/lib/Makefile index d49c380..aab3e2d 100644 --- a/ghc/interpreter/lib/Makefile +++ b/ghc/interpreter/lib/Makefile @@ -1,5 +1,5 @@ # -------------------------------------------------------------------------- # -# $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) diff --git a/ghc/interpreter/machdep.c b/ghc/interpreter/machdep.c index 823b5b7..ff5ddd1 100644 --- a/ghc/interpreter/machdep.c +++ b/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) { diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index 8f1d3cd..9d7cdf0 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/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 diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index b0a42cc..b167f0d 100644 --- a/ghc/rts/Assembler.c +++ b/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 ) { diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h index b66fcc7..e502b8f 100644 --- a/ghc/rts/Bytecodes.h +++ b/ghc/rts/Bytecodes.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $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 diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index 0d07a96..dba69d3 100644 --- a/ghc/rts/Evaluator.c +++ b/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 /* 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: