/* -----------------------------------------------------------------------------
- * $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
*
*/
void deleteThread(StgTSO *tso);
+void deleteAllThreads ( void );
/*
* Reverting CAFs
* 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"
/* 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);
default:
internal("evalExp: Unrecognised SchedulerStatus");
}
+ deleteAllThreads();
fflush(stdout);
fflush(stderr);
}
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!
-- 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
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))
------------------------------------------------------------------------------
--- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar -------------------------
+-- Word, Addr, StablePtr, Prim*Array -----------------------------------------
------------------------------------------------------------------------------
data Addr
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
-- 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 ------------------------------------------------------------------
* 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"
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
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
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!
-- 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
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))
------------------------------------------------------------------------------
--- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar -------------------------
+-- Word, Addr, StablePtr, Prim*Array -----------------------------------------
------------------------------------------------------------------------------
data Addr
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
-- 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 ------------------------------------------------------------------
* 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.
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
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);
case INT_REP:
emit_i_VAR_INT(bco,offset);
break;
+ case THREADID_REP:
case WORD_REP:
emit_i_VAR_WORD(bco,offset);
break;
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);
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);
case INT_REP:
emiti_(bco,i_UNPACK_INT);
break;
+ case THREADID_REP:
case WORD_REP:
emiti_(bco,i_UNPACK_WORD);
break;
/* 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 }
/* -----------------------------------------------------------------------------
- * $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
*
/* 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
* 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"
/* 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;
if (
#ifdef DEBUG
- 1 ||
+ ((++eCount) & 0x0F) == 0
+#else
+ ++eCount == 0
#endif
- ++eCount == 0) {
+ ) {
if (context_switch) {
xPushCPtr(obj); /* code to restart with */
RETURN(ThreadYielding);
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;
StgClosure *handler = fp->handler;
gSu = fp->link;
gSp += sizeofW(StgCatchFrame); /* Pop */
- PushCPtr(errObj);
+ PushCPtr(exception);
return handler;
}
case STOP_FRAME:
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));
}
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());
}
break;
}
- case i_sameMVar:
- { /* identical to i_sameRef */
- StgPtr x = PopPtr();
- StgPtr y = PopPtr();
- PushTaggedBool(x==y);
- break;
- }
#if 1
#if 0
/* -----------------------------------------------------------------------------
- * $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
*
} /* 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.
*
projects / ghc-hetmet.git / commitdiff