/* -----------------------------------------------------------------------------
- * $Id: Assembler.h,v 1.10 1999/10/26 17:27:35 sewardj Exp $
+ * $Id: Assembler.h,v 1.11 1999/11/16 17:38:54 sewardj Exp $
*
* (c) The GHC Team 1994-1998.
*
ALPHA_REP = 'a', /* a */
BETA_REP = 'b', /* b */
GAMMA_REP = 'c', /* c */
+ DELTA_REP = 'd', /* d */
BOOL_REP = 'B', /* Bool */
IO_REP = 'i', /* IO a */
HANDLER_REP = 'H', /* Exception -> IO a */
ARR_REP = 'X', /* PrimArray a */
REF_REP = 'R', /* Ref s a */
MUTARR_REP = 'M', /* PrimMutableArray s a */
-#ifdef PROVIDE_CONCURRENT
THREADID_REP = 'T', /* ThreadId */
MVAR_REP = 'r', /* MVar a */
-#endif
/* Allegedly used in the IO monad */
VOID_REP = 'v'
extern AsmSp asmBeginPrim ( AsmBCO bco );
extern void asmEndPrim ( AsmBCO bco, const AsmPrim* prim, AsmSp base );
-extern AsmBCO asm_BCO_catch ( void );
-extern AsmBCO asm_BCO_raise ( void );
-extern AsmBCO asm_BCO_seq ( void );
+extern AsmBCO asm_BCO_catch ( void );
+extern AsmBCO asm_BCO_raise ( void );
+extern AsmBCO asm_BCO_seq ( void );
+extern AsmBCO asm_BCO_takeMVar ( void );
/* --------------------------------------------------------------------------
asTypeOf, error, undefined,
seq, ($!)
+ , MVar, newMVar, putMVar, takeMVar
+
,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
------------------------------------------------------------------------------
--- Word, Addr, StablePtr, Prim*Array -----------------------------------------
+-- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar -------------------------
------------------------------------------------------------------------------
data Addr
data PrimMutableArray s a -- mutable arrays with Int indices
data PrimMutableByteArray s
+data ThreadId
+
+data MVar a
+
+
+newMVar :: IO (MVar a)
+newMVar = primNewMVar
+
+putMVar :: MVar a -> a -> IO ()
+putMVar = primPutMVar
+
+takeMVar :: MVar a -> IO a
+takeMVar m
+ = ST (\world -> primTakeMVar m cont world)
+ where
+ -- cont :: a -> RealWorld -> (a,RealWorld)
+ -- where 'a' is as in the top-level signature
+ cont x world = (x,world)
+
+ -- the type of the handwritten BCO (threesome) primTakeMVar is
+ -- primTakeMVar :: MVar a
+ -- -> (a -> RealWorld -> (a,RealWorld))
+ -- -> RealWorld
+ -- -> (a,RealWorld)
+ --
+ -- primTakeMVar behaves like this:
+ --
+ -- primTakeMVar (MVar# m#) cont world
+ -- = primTakeMVar_wrk m# cont world
+ --
+ -- primTakeMVar_wrk m# cont world
+ -- = cont (takeMVar# m#) world
+ --
+ -- primTakeMVar_wrk has the special property that it is
+ -- restartable by the scheduler, should the MVar be empty.
-- showFloat ------------------------------------------------------------------
* included in the distribution.
*
* $RCSfile: link.c,v $
- * $Revision: 1.12 $
- * $Date: 1999/11/12 17:32:40 $
+ * $Revision: 1.13 $
+ * $Date: 1999/11/16 17:38:55 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
Type typeFloat;
Type typeDouble;
Type typeStable;
+Type typeThreadId;
+Type typeMVar;
#ifdef PROVIDE_WEAK
Type typeWeak;
#endif
#ifdef PROVIDE_FOREIGN
Type typeForeign;
#endif
-#ifdef PROVIDE_CONCURRENT
-Type typeThreadId;
-Type typeMVar;
-#endif
Type typeList;
Type typeUnit;
Name namePrimSeq;
Name namePrimCatch;
Name namePrimRaise;
+Name namePrimTakeMVar;
Name nameFromTo;
Name nameFromThen;
Name nameMkPrimMutableArray;
Name nameMkPrimMutableByteArray;
Name nameMkStable; /* StablePtr# a -> StablePtr a */
+Name nameMkThreadId; /* ThreadId# -> ThreadId */
+Name nameMkPrimMVar; /* MVar# a -> MVar a */
#ifdef PROVIDE_WEAK
Name nameMkWeak; /* Weak# a -> Weak a */
#endif
#ifdef PROVIDE_FOREIGN
Name nameMkForeign; /* ForeignObj# -> ForeignObj */
#endif
-#ifdef PROVIDE_CONCURRENT
-Name nameMkThreadId; /* ThreadId# -> ThreadId */
-Name nameMkMVar; /* MVar# -> MVar */
-#endif
#ifdef PROVIDE_FOREIGN
typeForeign = linkTycon("ForeignObj");
#endif
-#ifdef PROVIDE_CONCURRENT
typeThreadId = linkTycon("ThreadId");
typeMVar = linkTycon("MVar");
-#endif
-
typeBool = linkTycon("Bool");
typeST = linkTycon("ST");
typeIO = linkTycon("IO");
nameMkRef = addPrimCfunREP(findText("Ref#"),1,0,0);
nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
-#ifdef PROVIDE_CONCURRENT
- nameMkThreadId = addPrimCfun(findTextREP("ThreadId#"),1,0,0);
- nameMkMVar = addPrimCfun(findTextREP("MVar#"),1,0,0);
-#endif
+ nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,0);
+ nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
+
/* The following primitives are referred to in derived instances and
* hence require types; the following types are a little more general
* than we might like, but they are the closest we can get without a
name(namePrimRaise).type
= primType(MONAD_Id, "E", "a");
+ /* This is a lie. For a more accurate type of primTakeMVar
+ see ghc/interpreter/lib/Prelude.hs.
+ */
+ name(namePrimTakeMVar).type
+ = primType(MONAD_Id, "rbc", "d");
+
for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
addTupInst(classEq,i);
addTupInst(classOrd,i);
pFun(namePrimSeq, "primSeq");
pFun(namePrimCatch, "primCatch");
pFun(namePrimRaise, "primRaise");
+ pFun(namePrimTakeMVar, "primTakeMVar");
{
StgVar vv = mkStgVar(NIL,NIL);
Name n = namePrimSeq;
name(n).stgVar = vv;
stgGlobals=cons(pair(n,vv),stgGlobals);
}
-
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Name n = namePrimTakeMVar;
+ name(n).line = 0;
+ name(n).arity = 2;
+ name(n).type = NIL;
+ stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ }
break;
}
}
extern Name nameMkRef;
extern Name nameMkPrimMutableArray;
extern Name nameMkPrimMutableByteArray;
+extern Name nameMkThreadId;
+extern Name nameMkPrimMVar;
#ifdef PROVIDE_FOREIGN
extern Name nameMkForeign;
#endif
#ifdef PROVIDE_WEAK
extern Name nameMkWeak;
#endif
-#ifdef PROVIDE_CONCURRENT
-extern Name nameMkThreadId;
-extern Name nameMkMVar;
-#endif
+
/* For every primitive type provided by the runtime system,
* we construct a Haskell type using a declaration of the form:
extern Type typeFloat;
extern Type typeDouble;
extern Type typeStable;
+extern Type typeThreadId;
+extern Type typeMVar;
#ifdef PROVIDE_WEAK
extern Type typeWeak;
#endif
#ifdef PROVIDE_FOREIGN
extern Type typeForeign;
#endif
-#ifdef PROVIDE_CONCURRENT
-extern Type typeThreadId;
-extern Type typeMVar;
-#endif
/* And a smaller number of types defined in plain Haskell */
extern Type typeList;
* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.15 $
- * $Date: 1999/11/12 17:32:46 $
+ * $Revision: 1.16 $
+ * $Date: 1999/11/16 17:38:56 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
void* getHugs_AsmObject_for ( char* s )
{
StgVar v;
- Name n = findName(findText(s));
- if (isNull(n)) internal("getHugs_AsmObject_for(1)");
+ Text t = findText(s);
+ Name n = NIL;
+ for (n = NAMEMIN; n < nameHw; n++)
+ if (name(n).text == t) break;
+ if (n == nameHw) internal("getHugs_AsmObject_for(1)");
v = name(n).stgVar;
if (!isStgVar(v) || !isPtr(stgVarInfo(v)))
internal("getHugs_AsmObject_for(2)");
* included in the distribution.
*
* $RCSfile: translate.c,v $
- * $Revision: 1.15 $
- * $Date: 1999/11/12 17:32:48 $
+ * $Revision: 1.16 $
+ * $Date: 1999/11/16 17:38:58 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Name repToBox( char c )
{
switch (c) {
- case CHAR_REP: return nameMkC;
- case INT_REP: return nameMkI;
- case INTEGER_REP: return nameMkInteger;
- case WORD_REP: return nameMkW;
- case ADDR_REP: return nameMkA;
- case FLOAT_REP: return nameMkF;
- case DOUBLE_REP: return nameMkD;
- case ARR_REP: return nameMkPrimArray;
- case BARR_REP: return nameMkPrimByteArray;
- case REF_REP: return nameMkRef;
- case MUTARR_REP: return nameMkPrimMutableArray;
- case MUTBARR_REP: return nameMkPrimMutableByteArray;
- case STABLE_REP: return nameMkStable;
+ case CHAR_REP: return nameMkC;
+ case INT_REP: return nameMkI;
+ case INTEGER_REP: return nameMkInteger;
+ case WORD_REP: return nameMkW;
+ case ADDR_REP: return nameMkA;
+ case FLOAT_REP: return nameMkF;
+ case DOUBLE_REP: return nameMkD;
+ case ARR_REP: return nameMkPrimArray;
+ case BARR_REP: return nameMkPrimByteArray;
+ case REF_REP: return nameMkRef;
+ case MUTARR_REP: return nameMkPrimMutableArray;
+ case MUTBARR_REP: return nameMkPrimMutableByteArray;
+ case STABLE_REP: return nameMkStable;
+ case THREADID_REP: return nameMkThreadId;
+ case MVAR_REP: return nameMkPrimMVar;
#ifdef PROVIDE_WEAK
case WEAK_REP: return nameMkWeak;
#endif
#ifdef PROVIDE_FOREIGN
case FOREIGN_REP: return nameMkForeign;
#endif
-#ifdef PROVIDE_CONCURRENT
- case THREADID_REP: return nameMkThreadId;
- case MVAR_REP: return nameMkMVar;
-#endif
default: return NIL;
}
}
* included in the distribution.
*
* $RCSfile: type.c,v $
- * $Revision: 1.11 $
- * $Date: 1999/11/12 17:32:48 $
+ * $Revision: 1.12 $
+ * $Date: 1999/11/16 17:39:00 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Type alphaVar = NIL;
static Type betaVar = NIL;
static Type gammaVar = NIL;
+static Type deltaVar = NIL;
static Int nextVar = 0;
static Void clearTyVars( void )
alphaVar = NIL;
betaVar = NIL;
gammaVar = NIL;
+ deltaVar = NIL;
nextVar = 0;
}
return gammaVar;
}
+static Type mkDeltaVar( void )
+{
+ if (isNull(deltaVar)) {
+ deltaVar = mkOffset(nextVar++);
+ }
+ return deltaVar;
+}
+
static Type local basicType(k)
Char k; {
switch (k) {
return typeFloat;
case DOUBLE_REP:
return typeDouble;
- case ARR_REP: return ap(typePrimArray,mkAlphaVar());
- case BARR_REP: return typePrimByteArray;
- case REF_REP: return ap2(typeRef,mkStateVar(),mkAlphaVar());
- case MUTARR_REP: return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());
- case MUTBARR_REP: return ap(typePrimMutableByteArray,mkStateVar());
- case STABLE_REP: return ap(typeStable,mkAlphaVar());
+ case ARR_REP:
+ return ap(typePrimArray,mkAlphaVar());
+ case BARR_REP:
+ return typePrimByteArray;
+ case REF_REP:
+ return ap2(typeRef,mkStateVar(),mkAlphaVar());
+ case MUTARR_REP:
+ return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());
+ case MUTBARR_REP:
+ return ap(typePrimMutableByteArray,mkStateVar());
+ case STABLE_REP:
+ return ap(typeStable,mkAlphaVar());
#ifdef PROVIDE_WEAK
case WEAK_REP:
return ap(typeWeak,mkAlphaVar());
case FOREIGN_REP:
return typeForeign;
#endif
-#ifdef PROVIDE_CONCURRENT
case THREADID_REP:
return typeThreadId;
case MVAR_REP:
return ap(typeMVar,mkAlphaVar());
-#endif
case BOOL_REP:
return typeBool;
case HANDLER_REP:
return mkBetaVar(); /* polymorphic */
case GAMMA_REP:
return mkGammaVar(); /* polymorphic */
+ case DELTA_REP:
+ return mkDeltaVar(); /* polymorphic */
default:
printf("Kind: '%c'\n",k);
internal("basicType");
asTypeOf, error, undefined,
seq, ($!)
+ , MVar, newMVar, putMVar, takeMVar
+
,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
------------------------------------------------------------------------------
--- Word, Addr, StablePtr, Prim*Array -----------------------------------------
+-- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar -------------------------
------------------------------------------------------------------------------
data Addr
data PrimMutableArray s a -- mutable arrays with Int indices
data PrimMutableByteArray s
+data ThreadId
+
+data MVar a
+
+
+newMVar :: IO (MVar a)
+newMVar = primNewMVar
+
+putMVar :: MVar a -> a -> IO ()
+putMVar = primPutMVar
+
+takeMVar :: MVar a -> IO a
+takeMVar m
+ = ST (\world -> primTakeMVar m cont world)
+ where
+ -- cont :: a -> RealWorld -> (a,RealWorld)
+ -- where 'a' is as in the top-level signature
+ cont x world = (x,world)
+
+ -- the type of the handwritten BCO (threesome) primTakeMVar is
+ -- primTakeMVar :: MVar a
+ -- -> (a -> RealWorld -> (a,RealWorld))
+ -- -> RealWorld
+ -- -> (a,RealWorld)
+ --
+ -- primTakeMVar behaves like this:
+ --
+ -- primTakeMVar (MVar# m#) cont world
+ -- = primTakeMVar_wrk m# cont world
+ --
+ -- primTakeMVar_wrk m# cont world
+ -- = cont (takeMVar# m#) world
+ --
+ -- primTakeMVar_wrk has the special property that it is
+ -- restartable by the scheduler, should the MVar be empty.
-- showFloat ------------------------------------------------------------------
* Copyright (c) 1994-1998.
*
* $RCSfile: Assembler.c,v $
- * $Revision: 1.14 $
- * $Date: 1999/11/08 15:30:32 $
+ * $Revision: 1.15 $
+ * $Date: 1999/11/16 17:39:07 $
*
* This module provides functions to construct BCOs and other closures
* required by the bytecode compiler.
case ALPHA_REP: /* a */
case BETA_REP: /* b */
case GAMMA_REP: /* c */
+ case DELTA_REP: /* d */
case HANDLER_REP: /* IOError -> IO a */
case ERROR_REP: /* IOError */
case ARR_REP : /* PrimArray a */
case REF_REP : /* Ref s a */
case MUTARR_REP : /* PrimMutableArray s a */
case MUTBARR_REP: /* PrimMutableByteArray s a */
-#ifdef PROVIDE_CONCURRENT
case THREADID_REP: /* ThreadId */
case MVAR_REP: /* MVar a */
-#endif
case PTR_REP: return sizeofW(StgPtr);
case VOID_REP: return sizeofW(StgWord);
case ALPHA_REP: /* a */
case BETA_REP: /* b */
case GAMMA_REP: /* c */
+ case DELTA_REP: /* d */
case HANDLER_REP: /* IOError -> IO a */
case ERROR_REP: /* IOError */
case ARR_REP : /* PrimArray a */
case REF_REP : /* Ref s a */
case MUTARR_REP : /* PrimMutableArray s a */
case MUTBARR_REP: /* PrimMutableByteArray s a */
-#ifdef PROVIDE_CONCURRENT
case THREADID_REP: /* ThreadId */
case MVAR_REP: /* MVar a */
-#endif
case PTR_REP:
emit_i_VAR(bco,offset);
break;
, { "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 }
- , { "primNewMVar", "", "r", MONAD_IO, i_PRIMOP2, i_newMVar }
- , { "primTakeMVar", "r", "a", MONAD_IO, i_PRIMOP2, i_takeMVar }
- , { "primPutMVar", "ra", "", MONAD_IO, i_PRIMOP2, i_putMVar }
, { "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 }
+ /* primTakeMVar is handwritten bytecode */
+ , { "primPutMVar", "ra", "", MONAD_IO, i_PRIMOP2, i_putMVar }
/* Ccall is polyadic - so it's excluded from this table */
AsmBCO eval, cont;
cont = asmBeginBCO(0 /*NIL*/);
- emiti_8(cont,i_ARG_CHECK,2);
+ emiti_8(cont,i_ARG_CHECK,2); /* should never fail */
emit_i_VAR(cont,1);
emit_i_SLIDE(cont,1,2);
emiti_(cont,i_ENTER);
return eval;
}
+AsmBCO asm_BCO_takeMVar ( void )
+{
+ AsmBCO kase, casecont, take;
+
+ take = asmBeginBCO(0 /*NIL*/);
+ emit_i_VAR(take,0);
+ emiti_8(take,i_PRIMOP2,i_takeMVar);
+ emit_i_VAR(take,3);
+ emit_i_VAR(take,1);
+ emit_i_VAR(take,4);
+ emit_i_SLIDE(take,3,4);
+ emiti_(take,i_ENTER);
+ incSp(take,20);
+ asmEndBCO(take);
+
+ casecont = asmBeginBCO(0 /*NIL*/);
+ emiti_(casecont,i_UNPACK);
+ emit_i_VAR(casecont,4);
+ emit_i_VAR(casecont,4);
+ emit_i_VAR(casecont,2);
+ emit_i_CONST(casecont,casecont->object.ptrs.len);
+ asmPtr(casecont,&(take->object));
+ emit_i_SLIDE(casecont,4,5);
+ emiti_(casecont,i_ENTER);
+ incSp(casecont,20);
+ asmEndBCO(casecont);
+
+ kase = asmBeginBCO(0 /*NIL*/);
+ emiti_8(kase,i_ARG_CHECK,3);
+ emit_i_RETADDR(kase,kase->object.ptrs.len);
+ asmPtr(kase,&(casecont->object));
+ emit_i_VAR(kase,2);
+ emiti_(kase,i_ENTER);
+ incSp(kase,20);
+ asmEndBCO(kase);
+
+ return kase;
+}
+
+
/* --------------------------------------------------------------------------
* Heap manipulation
* ------------------------------------------------------------------------*/
/* -----------------------------------------------------------------------------
- * $Id: Bytecodes.h,v 1.10 1999/11/01 18:19:39 sewardj Exp $
+ * $Id: Bytecodes.h,v 1.11 1999/11/16 17:39:09 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
, i_fork
, i_killThread
, i_sameMVar
- , i_newMVar
- , i_takeMVar
- , i_putMVar
, i_delay
, i_waitRead
, i_waitWrite
#endif
+ , i_newMVar
+ , i_takeMVar
+ , i_putMVar
/* CCall! */
, i_ccall_ccall_Id
* Copyright (c) 1994-1998.
*
* $RCSfile: Disassembler.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/11/01 18:19:40 $
+ * $Revision: 1.11 $
+ * $Date: 1999/11/16 17:39:10 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
return disNone(bco,pc,"ccall_stdcall_IO");
case i_raise:
return disNone(bco,pc,"primRaise");
+ case i_takeMVar:
+ return disNone(bco,pc,"primTakeMVar");
default:
{
const AsmPrim* p = asmFindPrimop(i_PRIMOP2,op);
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.26 $
- * $Date: 1999/11/12 17:50:04 $
+ * $Revision: 1.27 $
+ * $Date: 1999/11/16 17:39:10 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
}
Case(i_PRIMOP2):
{
- /* Remember to save */
int i, trc, pc_saved;
void* p;
StgBCO* bco_tmp;
/* we want to enter p */
obj = p; goto enterLoop;
} else {
- /* p is the the StgThreadReturnCode for this thread */
- RETURN((StgThreadReturnCode)p);
+ /* trc is the the StgThreadReturnCode for this thread */
+ RETURN((StgThreadReturnCode)trc);
};
}
Continue;
*/
raise_closure = (StgClosure *)allocate(sizeofW(StgClosure)+1);
raise_closure->header.info = &raise_info;
- raise_closure->payload[0] = 0xdeadbeef; /*R1.cl;*/
+ raise_closure->payload[0] = (StgPtr)0xdead10c6; /*R1.cl;*/
while (1) {
switch (get_itbl(gSu)->type) {
break;
}
- /* Most of these generate alignment warnings on gSparcs and similar architectures.
+ /* Most of these generate alignment warnings on Sparcs and similar architectures.
* These are harmless and are caused by the cast to C* in BYTE_ARR_CTS.
*/
case i_indexCharArray:
break;
}
+ case i_newMVar:
+ {
+ StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
+ SET_INFO(mvar,&EMPTY_MVAR_info);
+ mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
+ mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
+ PushPtr(stgCast(StgPtr,mvar));
+ break;
+ }
+ case i_takeMVar:
+ {
+ StgMVar *mvar = (StgMVar*)PopCPtr();
+ if (GET_INFO(mvar) == &EMPTY_MVAR_info) {
+
+ /* The MVar is empty. Attach ourselves to the TSO's
+ blocking queue.
+ */
+ if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
+ mvar->head = cap->rCurrentTSO;
+ } else {
+ mvar->tail->link = cap->rCurrentTSO;
+ }
+ cap->rCurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
+ cap->rCurrentTSO->why_blocked = BlockedOnMVar;
+ cap->rCurrentTSO->block_info.closure = (StgClosure *)mvar;
+ mvar->tail = cap->rCurrentTSO;
+
+ /* At this point, the top-of-stack holds the MVar,
+ and underneath is the world token (). So the
+ stack is in the same state as when primTakeMVar
+ was entered (primTakeMVar is handwritten bytecode).
+ Push obj, which is this BCO, and return to the
+ scheduler. When the MVar is filled, the scheduler
+ will re-enter primTakeMVar, with the args still on
+ the top of the stack.
+ */
+ PushCPtr(*bco);
+ *return2 = ThreadBlocked;
+ return (void*)(1+(NULL));
+
+ } else {
+ PushCPtr(mvar->value);
+ mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+ SET_INFO(mvar,&EMPTY_MVAR_info);
+ }
+ break;
+ }
+ case i_putMVar:
+ {
+ StgMVar* mvar = stgCast(StgMVar*,PopPtr());
+ StgClosure* value = PopCPtr();
+ if (GET_INFO(mvar) == &FULL_MVAR_info) {
+ return (makeErrorCall("putMVar {full MVar}"));
+ } else {
+ /* wake up the first thread on the
+ * queue, it will continue with the
+ * takeMVar operation and mark the
+ * MVar empty again.
+ */
+ mvar->value = value;
+
+ if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
+ ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+ mvar->head = unblockOne(mvar->head);
+ if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
+ mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
+ }
+ }
+
+ /* unlocks the MVar in the SMP case */
+ SET_INFO(mvar,&FULL_MVAR_info);
+
+ /* yield for better communication performance */
+ context_switch = 1;
+ }
+ break;
+ }
+
#ifdef PROVIDE_CONCURRENT
case i_fork:
{
PushTaggedBool(x==y);
break;
}
- case i_newMVar:
- {
- StgMVar *mvar = stgCast(StgMVar*,allocate(sizeofW(StgMVar)));
- SET_INFO(mvar,&EMPTY_MVAR_info);
- mvar->head = mvar->tail = EndTSOQueue;
- /* ToDo: this is a little strange */
- mvar->value = stgCast(StgClosure*,&END_TSO_QUEUE_closure);
- PushPtr(stgCast(StgPtr,mvar));
- break;
- }
+
#if 1
#if 0
ToDo: another way out of the problem might be to add an explicit
The problem with this plan is that now I dont know how much to chop
off the stack.
#endif
- case i_takeMVar:
- {
- StgMVar *mvar = stgCast(StgMVar*,PopPtr());
- /* If the MVar is empty, put ourselves
- * on its blocking queue, and wait
- * until we're woken up.
- */
- if (GET_INFO(mvar) != &FULL_MVAR_info) {
- if (mvar->head == EndTSOQueue) {
- mvar->head = cap->rCurrentTSO;
- } else {
- mvar->tail->link = cap->rCurrentTSO;
- }
- cap->rCurrentTSO->link = EndTSOQueue;
- mvar->tail = cap->rCurrentTSO;
-
- /* Hack, hack, hack.
- * When we block, we push a restart closure
- * on the stack - but which closure?
- * We happen to know that the BCO we're
- * executing looks like this:
- *
- * 0: STK_CHECK 4
- * 2: HP_CHECK 3
- * 4: TEST 0 29
- * 7: UNPACK
- * 8: VAR 3
- * 10: VAR 1
- * 12: primTakeMVar
- * 14: ALLOC_CONSTR 0x8213a80
- * 16: VAR 2
- * 18: VAR 2
- * 20: PACK 2
- * 22: VAR 0
- * 24: SLIDE 1 7
- * 27: ENTER
- * 28: PANIC
- * 29: PANIC
- *
- * so we rearrange the stack to look the
- * way it did when we entered this BCO
- * and push ths BCO.
- * What a disgusting hack!
- */
-
- PopPtr();
- PopPtr();
- PushCPtr(obj);
- *return2 = ThreadBlocked;
- return (void*)(1+(NULL));
-
- } else {
- PushCPtr(mvar->value);
- SET_INFO(mvar,&EMPTY_MVAR_info);
- /* ToDo: this is a little strange */
- mvar->value = (StgClosure*)&END_TSO_QUEUE_closure;
- }
- break;
- }
#endif
- case i_putMVar:
- {
- StgMVar* mvar = stgCast(StgMVar*,PopPtr());
- StgClosure* value = PopCPtr();
- if (GET_INFO(mvar) == &FULL_MVAR_info) {
- return (raisePrim("putMVar {full MVar}"));
- } else {
- /* wake up the first thread on the
- * queue, it will continue with the
- * takeMVar operation and mark the
- * MVar empty again.
- */
- StgTSO* tso = mvar->head;
- SET_INFO(mvar,&FULL_MVAR_info);
- mvar->value = value;
- if (tso != EndTSOQueue) {
- PUSH_ON_RUN_QUEUE(tso);
- mvar->head = tso->link;
- tso->link = EndTSOQueue;
- if (mvar->head == EndTSOQueue) {
- mvar->tail = EndTSOQueue;
- }
- }
- }
- /* yield for better communication performance */
- context_switch = 1;
- break;
- }
case i_delay:
case i_waitRead:
case i_waitWrite:
ASSERT(0);
break;
#endif /* PROVIDE_CONCURRENT */
+
case i_ccall_ccall_Id:
case i_ccall_ccall_IO:
case i_ccall_stdcall_Id: