From 1b39436bdf0dbc46008460669d1ac81a98df6c84 Mon Sep 17 00:00:00 2001 From: sewardj Date: Thu, 18 Nov 1999 12:10:29 +0000 Subject: [PATCH] [project @ 1999-11-18 12:10:17 by sewardj] In hugs, implement ThreadId(..), instance Eq/Ord ThreadId, and forkIO. Add deleteAllThreads() to scheduler so Hugs can clean up after evaluation. --- ghc/includes/SchedAPI.h | 3 +- ghc/interpreter/compiler.c | 14 +++--- ghc/interpreter/lib/Prelude.hs | 72 +++++++++++++++++++++++++------ ghc/interpreter/link.c | 9 ++-- ghc/lib/hugs/Prelude.hs | 72 +++++++++++++++++++++++++------ ghc/rts/Assembler.c | 31 ++++++++------ ghc/rts/Bytecodes.h | 7 ++- ghc/rts/Evaluator.c | 92 +++++++++++++++++++++++----------------- ghc/rts/Schedule.c | 19 ++++++++- 9 files changed, 229 insertions(+), 90 deletions(-) diff --git a/ghc/includes/SchedAPI.h b/ghc/includes/SchedAPI.h index 02c308d..317a177 100644 --- a/ghc/includes/SchedAPI.h +++ b/ghc/includes/SchedAPI.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: SchedAPI.h,v 1.7 1999/11/02 15:05:52 simonmar Exp $ + * $Id: SchedAPI.h,v 1.8 1999/11/18 12:10:17 sewardj Exp $ * * (c) The GHC Team 1998 * @@ -72,6 +72,7 @@ createStrictIOThread(nat stack_size, StgClosure *closure) { */ void deleteThread(StgTSO *tso); +void deleteAllThreads ( void ); /* * Reverting CAFs diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index 784d8aa..07d0fc4 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -11,8 +11,8 @@ * included in the distribution. * * $RCSfile: compiler.c,v $ - * $Revision: 1.12 $ - * $Date: 1999/11/12 17:32:37 $ + * $Revision: 1.13 $ + * $Date: 1999/11/18 12:10:18 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1486,17 +1486,20 @@ Void evalExp() { /* compile and run input expression */ /* Run thread (and any other runnable threads) */ /* Re-initialise the scheduler - ToDo: do I need this? */ - initScheduler(); + /* JRS, 991118: on SM's advice, don't call initScheduler every time. + This causes an assertion failure in GC.c(revert_dead_cafs) + unless doRevertCAFs below is permanently TRUE. + */ + /* initScheduler(); */ #ifdef CRUDE_PROFILING cp_init(); #endif - /* ToDo: don't really initScheduler every time. fix */ { HaskellObj result; /* ignored */ sighandler_t old_ctrlbrk; SchedulerStatus status; - Bool doRevertCAFs = FALSE; + Bool doRevertCAFs = TRUE; /* do not change -- comment above */ old_ctrlbrk = signal(SIGINT, eval_ctrlbrk); ASSERT(old_ctrlbrk != SIG_ERR); status = rts_eval_(closureOfVar(v),10000,&result); @@ -1523,6 +1526,7 @@ Void evalExp() { /* compile and run input expression */ default: internal("evalExp: Unrecognised SchedulerStatus"); } + deleteAllThreads(); fflush(stdout); fflush(stderr); } diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs index 91dc813..77e7883 100644 --- a/ghc/interpreter/lib/Prelude.hs +++ b/ghc/interpreter/lib/Prelude.hs @@ -103,8 +103,8 @@ module Prelude ( asTypeOf, error, undefined, seq, ($!) - , MVar, newMVar, putMVar, takeMVar - + , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar + , ThreadId, forkIO ,trace -- Arrrggghhh!!! Help! Help! Help! -- What?! Prelude.hs doesn't even _define_ most of these things! @@ -1791,9 +1791,6 @@ primGetEnv v -- ST, IO -------------------------------------------------------------------- ------------------------------------------------------------------------------ --- Do not change this newtype to a data, or MVars will stop --- working. In general the MVar stuff is pretty fragile: do --- not mess with it. newtype ST s a = ST (s -> (a,s)) data RealWorld @@ -1828,9 +1825,11 @@ primRunIO m protect comp = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld)) -trace :: String -> a -> a +trace, trace_quiet :: String -> a -> a trace s x - = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x + = trace_quiet ("trace: " ++ s) x +trace_quiet s x + = (primRunST (putStr (s ++ "\n"))) `seq` x unsafeInterleaveST :: ST s a -> ST s a unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s)) @@ -1840,7 +1839,7 @@ unsafeInterleaveIO = unsafeInterleaveST ------------------------------------------------------------------------------ --- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar ------------------------- +-- Word, Addr, StablePtr, Prim*Array ----------------------------------------- ------------------------------------------------------------------------------ data Addr @@ -1888,13 +1887,15 @@ data Ref s a -- mutable variables data PrimMutableArray s a -- mutable arrays with Int indices data PrimMutableByteArray s -data ThreadId -data MVar a +------------------------------------------------------------------------------ +-- ThreadId, MVar, concurrency stuff ----------------------------------------- +------------------------------------------------------------------------------ +data MVar a -newMVar :: IO (MVar a) -newMVar = primNewMVar +newEmptyMVar :: IO (MVar a) +newEmptyMVar = primNewEmptyMVar putMVar :: MVar a -> a -> IO () putMVar = primPutMVar @@ -1924,6 +1925,53 @@ takeMVar m -- primTakeMVar_wrk has the special property that it is -- restartable by the scheduler, should the MVar be empty. +newMVar :: a -> IO (MVar a) +newMVar value = + newEmptyMVar >>= \ mvar -> + putMVar mvar value >> + return mvar + +readMVar :: MVar a -> IO a +readMVar mvar = + takeMVar mvar >>= \ value -> + putMVar mvar value >> + return value + +swapMVar :: MVar a -> a -> IO a +swapMVar mvar new = + takeMVar mvar >>= \ old -> + putMVar mvar new >> + return old + +instance Eq (MVar a) where + m1 == m2 = primSameMVar m1 m2 + + +data ThreadId + +instance Eq ThreadId where + tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0 + +instance Ord ThreadId where + compare tid1 tid2 + = let r = primCmpThreadIds tid1 tid2 + in if r < 0 then LT else if r > 0 then GT else EQ + + +forkIO :: IO a -> IO ThreadId +-- Simple version; doesn't catch exceptions in computation +-- forkIO computation +-- = primForkIO (primRunST computation) + +forkIO computation + = primForkIO ( + primCatch + (unST computation realWorld `primSeq` ()) + (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ()) + ) + where + realWorld = error "primForkIO: entered the RealWorld" + -- showFloat ------------------------------------------------------------------ diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 9106dcc..5a660b0 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: link.c,v $ - * $Revision: 1.13 $ - * $Date: 1999/11/16 17:38:55 $ + * $Revision: 1.14 $ + * $Date: 1999/11/18 12:10:19 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -332,7 +332,8 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP); nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP); nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP); - nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0); + nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP); + #ifdef PROVIDE_FOREIGN nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0); #endif @@ -344,8 +345,8 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ nameMkRef = addPrimCfunREP(findText("Ref#"),1,0,0); nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0); nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0); - nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,0); nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0); + nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0); /* The following primitives are referred to in derived instances and * hence require types; the following types are a little more general diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index 91dc813..77e7883 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -103,8 +103,8 @@ module Prelude ( asTypeOf, error, undefined, seq, ($!) - , MVar, newMVar, putMVar, takeMVar - + , MVar, newEmptyMVar, newMVar, putMVar, takeMVar, readMVar, swapMVar + , ThreadId, forkIO ,trace -- Arrrggghhh!!! Help! Help! Help! -- What?! Prelude.hs doesn't even _define_ most of these things! @@ -1791,9 +1791,6 @@ primGetEnv v -- ST, IO -------------------------------------------------------------------- ------------------------------------------------------------------------------ --- Do not change this newtype to a data, or MVars will stop --- working. In general the MVar stuff is pretty fragile: do --- not mess with it. newtype ST s a = ST (s -> (a,s)) data RealWorld @@ -1828,9 +1825,11 @@ primRunIO m protect comp = primCatch comp (\e -> fst (unST (putStr (show e ++ "\n")) realWorld)) -trace :: String -> a -> a +trace, trace_quiet :: String -> a -> a trace s x - = (primRunST (putStr ("trace: " ++ s ++ "\n"))) `seq` x + = trace_quiet ("trace: " ++ s) x +trace_quiet s x + = (primRunST (putStr (s ++ "\n"))) `seq` x unsafeInterleaveST :: ST s a -> ST s a unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s)) @@ -1840,7 +1839,7 @@ unsafeInterleaveIO = unsafeInterleaveST ------------------------------------------------------------------------------ --- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar ------------------------- +-- Word, Addr, StablePtr, Prim*Array ----------------------------------------- ------------------------------------------------------------------------------ data Addr @@ -1888,13 +1887,15 @@ data Ref s a -- mutable variables data PrimMutableArray s a -- mutable arrays with Int indices data PrimMutableByteArray s -data ThreadId -data MVar a +------------------------------------------------------------------------------ +-- ThreadId, MVar, concurrency stuff ----------------------------------------- +------------------------------------------------------------------------------ +data MVar a -newMVar :: IO (MVar a) -newMVar = primNewMVar +newEmptyMVar :: IO (MVar a) +newEmptyMVar = primNewEmptyMVar putMVar :: MVar a -> a -> IO () putMVar = primPutMVar @@ -1924,6 +1925,53 @@ takeMVar m -- primTakeMVar_wrk has the special property that it is -- restartable by the scheduler, should the MVar be empty. +newMVar :: a -> IO (MVar a) +newMVar value = + newEmptyMVar >>= \ mvar -> + putMVar mvar value >> + return mvar + +readMVar :: MVar a -> IO a +readMVar mvar = + takeMVar mvar >>= \ value -> + putMVar mvar value >> + return value + +swapMVar :: MVar a -> a -> IO a +swapMVar mvar new = + takeMVar mvar >>= \ old -> + putMVar mvar new >> + return old + +instance Eq (MVar a) where + m1 == m2 = primSameMVar m1 m2 + + +data ThreadId + +instance Eq ThreadId where + tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0 + +instance Ord ThreadId where + compare tid1 tid2 + = let r = primCmpThreadIds tid1 tid2 + in if r < 0 then LT else if r > 0 then GT else EQ + + +forkIO :: IO a -> IO ThreadId +-- Simple version; doesn't catch exceptions in computation +-- forkIO computation +-- = primForkIO (primRunST computation) + +forkIO computation + = primForkIO ( + primCatch + (unST computation realWorld `primSeq` ()) + (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ()) + ) + where + realWorld = error "primForkIO: entered the RealWorld" + -- showFloat ------------------------------------------------------------------ diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index 59faa16..b5bec41 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.15 $ - * $Date: 1999/11/16 17:39:07 $ + * $Revision: 1.16 $ + * $Date: 1999/11/18 12:10:24 $ * * This module provides functions to construct BCOs and other closures * required by the bytecode compiler. @@ -484,12 +484,13 @@ static StgWord repSizeW( AsmRep rep ) case CHAR_REP: return sizeofW(StgWord) + sizeofW(StgChar); case BOOL_REP: - case INT_REP: return sizeofW(StgWord) + sizeofW(StgInt); - case WORD_REP: return sizeofW(StgWord) + sizeofW(StgWord); - case ADDR_REP: return sizeofW(StgWord) + sizeofW(StgAddr); - case FLOAT_REP: return sizeofW(StgWord) + sizeofW(StgFloat); - case DOUBLE_REP: return sizeofW(StgWord) + sizeofW(StgDouble); - case STABLE_REP: return sizeofW(StgWord) + sizeofW(StgWord); + case INT_REP: return sizeofW(StgWord) + sizeofW(StgInt); + case THREADID_REP: + case WORD_REP: return sizeofW(StgWord) + sizeofW(StgWord); + case ADDR_REP: return sizeofW(StgWord) + sizeofW(StgAddr); + case FLOAT_REP: return sizeofW(StgWord) + sizeofW(StgFloat); + case DOUBLE_REP: return sizeofW(StgWord) + sizeofW(StgDouble); + case STABLE_REP: return sizeofW(StgWord) + sizeofW(StgWord); case INTEGER_REP: #ifdef PROVIDE_WEAK @@ -509,7 +510,6 @@ static StgWord repSizeW( AsmRep rep ) case REF_REP : /* Ref s a */ case MUTARR_REP : /* PrimMutableArray s a */ case MUTBARR_REP: /* PrimMutableByteArray s a */ - case THREADID_REP: /* ThreadId */ case MVAR_REP: /* MVar a */ case PTR_REP: return sizeofW(StgPtr); @@ -811,6 +811,7 @@ void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) case INT_REP: emit_i_VAR_INT(bco,offset); break; + case THREADID_REP: case WORD_REP: emit_i_VAR_WORD(bco,offset); break; @@ -848,7 +849,6 @@ void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) case REF_REP : /* Ref s a */ case MUTARR_REP : /* PrimMutableArray s a */ case MUTBARR_REP: /* PrimMutableByteArray s a */ - case THREADID_REP: /* ThreadId */ case MVAR_REP: /* MVar a */ case PTR_REP: emit_i_VAR(bco,offset); @@ -896,6 +896,7 @@ AsmVar asmBox( AsmBCO bco, AsmRep rep ) emiti_(bco,i_PACK_INT); grabHpNonUpd(bco,Izh_sizeW); break; + case THREADID_REP: case WORD_REP: emiti_(bco,i_PACK_WORD); grabHpNonUpd(bco,Wzh_sizeW); @@ -936,6 +937,7 @@ AsmVar asmUnbox( AsmBCO bco, AsmRep rep ) case INT_REP: emiti_(bco,i_UNPACK_INT); break; + case THREADID_REP: case WORD_REP: emiti_(bco,i_UNPACK_WORD); break; @@ -1406,15 +1408,18 @@ const AsmPrim asmPrimOps[] = { /* Concurrency operations */ , { "primFork", "a", "T", MONAD_IO, i_PRIMOP2, i_fork } , { "primKillThread", "T", "", MONAD_IO, i_PRIMOP2, i_killThread } - , { "primSameMVar", "rr", "B", MONAD_Id, i_PRIMOP2, i_sameMVar } , { "primDelay", "I", "", MONAD_IO, i_PRIMOP2, i_delay } , { "primWaitRead", "I", "", MONAD_IO, i_PRIMOP2, i_waitRead } , { "primWaitWrite", "I", "", MONAD_IO, i_PRIMOP2, i_waitWrite } #endif - , { "primNewMVar", "", "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 */ , { 0,0,0,0,0,0 } diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h index 7f4e985..8fdc784 100644 --- a/ghc/rts/Bytecodes.h +++ b/ghc/rts/Bytecodes.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: Bytecodes.h,v 1.11 1999/11/16 17:39:09 sewardj Exp $ + * $Id: Bytecodes.h,v 1.12 1999/11/18 12:10:25 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -421,14 +421,17 @@ typedef enum /* Concurrency operations */ , i_fork , i_killThread - , i_sameMVar , i_delay , i_waitRead , i_waitWrite #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 cfe90ea..e27447b 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.27 $ - * $Date: 1999/11/16 17:39:10 $ + * $Revision: 1.28 $ + * $Date: 1999/11/18 12:10:26 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -294,7 +294,7 @@ static inline void PushTaggedRealWorld( void ); /* static inline void PushTaggedInteger ( mpz_ptr ); */ static inline StgPtr grabHpUpd( nat size ); static inline StgPtr grabHpNonUpd( nat size ); -static StgClosure* raiseAnError ( StgClosure* errObj ); +static StgClosure* raiseAnError ( StgClosure* exception ); static int enterCountI = 0; @@ -501,9 +501,11 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) if ( #ifdef DEBUG - 1 || + ((++eCount) & 0x0F) == 0 +#else + ++eCount == 0 #endif - ++eCount == 0) { + ) { if (context_switch) { xPushCPtr(obj); /* code to restart with */ RETURN(ThreadYielding); @@ -1720,22 +1722,22 @@ static inline void PopSeqFrame ( void ) gSu = stgCast(StgSeqFrame*,gSu)->link; } -static inline StgClosure* raiseAnError ( StgClosure* errObj ) +static inline StgClosure* raiseAnError ( StgClosure* exception ) { - StgClosure *raise_closure; - - /* This closure represents the expression 'raise# E' where E - * is the exception raised. It is used to overwrite all the + /* This closure represents the expression 'primRaise E' where E + * is the exception raised (:: Exception). + * It is used to overwrite all the * thunks which are currently under evaluation. */ - raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1); - raise_closure->header.info = &raise_info; - raise_closure->payload[0] = (StgPtr)0xdead10c6; /*R1.cl;*/ - + HaskellObj primRaiseClosure + = asmClosureOfObject(getHugs_AsmObject_for("primRaise")); + HaskellObj reraiseClosure + = rts_apply ( primRaiseClosure, exception ); + while (1) { switch (get_itbl(gSu)->type) { case UPDATE_FRAME: - UPD_IND(gSu->updatee,raise_closure); + UPD_IND(gSu->updatee,reraiseClosure); gSp = stgCast(StgStackPtr,gSu) + sizeofW(StgUpdateFrame); gSu = gSu->link; break; @@ -1748,7 +1750,7 @@ static inline StgClosure* raiseAnError ( StgClosure* errObj ) StgClosure *handler = fp->handler; gSu = fp->link; gSp += sizeofW(StgCatchFrame); /* Pop */ - PushCPtr(errObj); + PushCPtr(exception); return handler; } case STOP_FRAME: @@ -2950,7 +2952,7 @@ static void* enterBCO_primop2 ( int primop2code, will re-enter primTakeMVar, with the args still on the top of the stack. */ - PushCPtr(*bco); + PushCPtr((StgClosure*)(*bco)); *return2 = ThreadBlocked; return (void*)(1+(NULL)); @@ -2991,26 +2993,43 @@ static void* enterBCO_primop2 ( int primop2code, } break; } - -#ifdef PROVIDE_CONCURRENT - case i_fork: + case i_sameMVar: + { /* identical to i_sameRef */ + StgMVar* x = (StgMVar*)PopPtr(); + StgMVar* y = (StgMVar*)PopPtr(); + PushTaggedBool(x==y); + break; + } + case i_getThreadId: { - StgClosure* c = PopCPtr(); - StgTSO* t = createGenThread(RtsFlags.GcFlags.initialStkSize,c); - PushPtr(stgCast(StgPtr,t)); - - /* switch at the earliest opportunity */ + 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; + } + case i_forkIO: + { + StgClosure* closure; + StgTSO* tso; + StgWord tid; + closure = PopCPtr(); + tso = createGenThread (RtsFlags.GcFlags.initialStkSize,closure); + tid = tso->id; + scheduleThread(tso); context_switch = 1; - /* but don't automatically switch to GHC - or you'll waste your - * time slice switching back. - * - * Actually, there's more to it than that: the default - * (ThreadEnterGHC) causes the thread to crash - don't - * understand why. - ADR - */ - t->whatNext = ThreadEnterHugs; + PushTaggedWord(tid); break; } + +#ifdef PROVIDE_CONCURRENT case i_killThread: { StgTSO* tso = stgCast(StgTSO*,PopPtr()); @@ -3021,13 +3040,6 @@ static void* enterBCO_primop2 ( int primop2code, } break; } - case i_sameMVar: - { /* identical to i_sameRef */ - StgPtr x = PopPtr(); - StgPtr y = PopPtr(); - PushTaggedBool(x==y); - break; - } #if 1 #if 0 diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 32e18b4..27bc1c5 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Schedule.c,v 1.33 1999/11/15 14:14:43 simonmar Exp $ + * $Id: Schedule.c,v 1.34 1999/11/18 12:10:29 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -514,6 +514,23 @@ schedule( void ) } /* end of while(1) */ } + +/* A hack for Hugs concurrency support. Needs sanitisation (?) */ +void deleteAllThreads ( void ) +{ + StgTSO* t; + IF_DEBUG(scheduler,belch("deleteAllThreads()")); + for (t = run_queue_hd; t != END_TSO_QUEUE; t = t->link) { + deleteThread(t); + } + for (t = blocked_queue_hd; t != END_TSO_QUEUE; t = t->link) { + deleteThread(t); + } + run_queue_hd = run_queue_tl = END_TSO_QUEUE; + blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE; +} + + /* ----------------------------------------------------------------------------- * Suspending & resuming Haskell threads. * -- 1.7.10.4