From 4b69a23d0535a9cc2c04737b773677ee9e401f93 Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 16 Nov 1999 17:39:10 +0000 Subject: [PATCH] [project @ 1999-11-16 17:38:54 by sewardj] Added basic support for MVars: data MVar, and newMVar, putMVar and getMVar. --- ghc/includes/Assembler.h | 12 +-- ghc/interpreter/lib/Prelude.hs | 42 ++++++++- ghc/interpreter/link.c | 45 ++++++---- ghc/interpreter/link.h | 13 ++- ghc/interpreter/storage.c | 11 ++- ghc/interpreter/translate.c | 36 ++++---- ghc/interpreter/type.c | 36 +++++--- ghc/lib/hugs/Prelude.hs | 42 ++++++++- ghc/rts/Assembler.c | 58 +++++++++--- ghc/rts/Bytecodes.h | 8 +- ghc/rts/Disassembler.c | 6 +- ghc/rts/Evaluator.c | 190 ++++++++++++++++++---------------------- 12 files changed, 312 insertions(+), 187 deletions(-) diff --git a/ghc/includes/Assembler.h b/ghc/includes/Assembler.h index 2cc9dd1..ce553f4 100644 --- a/ghc/includes/Assembler.h +++ b/ghc/includes/Assembler.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -104,6 +104,7 @@ typedef enum { 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 */ @@ -111,10 +112,8 @@ typedef enum { 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' @@ -211,9 +210,10 @@ extern const AsmPrim* asmFindPrimop ( AsmInstr prefix, AsmInstr op ); 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 ); /* -------------------------------------------------------------------------- diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs index 1533c07..5a342ad 100644 --- a/ghc/interpreter/lib/Prelude.hs +++ b/ghc/interpreter/lib/Prelude.hs @@ -103,6 +103,8 @@ module Prelude ( asTypeOf, error, undefined, seq, ($!) + , MVar, newMVar, putMVar, takeMVar + ,trace -- Arrrggghhh!!! Help! Help! Help! -- What?! Prelude.hs doesn't even _define_ most of these things! @@ -1774,6 +1776,9 @@ 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 @@ -1820,7 +1825,7 @@ unsafeInterleaveIO = unsafeInterleaveST ------------------------------------------------------------------------------ --- Word, Addr, StablePtr, Prim*Array ----------------------------------------- +-- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar ------------------------- ------------------------------------------------------------------------------ data Addr @@ -1870,6 +1875,41 @@ data Ref s a -- mutable variables 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 ------------------------------------------------------------------ diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 3ac5f76..9106dcc 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.12 $ - * $Date: 1999/11/12 17:32:40 $ + * $Revision: 1.13 $ + * $Date: 1999/11/16 17:38:55 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -38,16 +38,14 @@ Type typePrimMutableByteArray; 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; @@ -140,6 +138,7 @@ Name nameFlip; Name namePrimSeq; Name namePrimCatch; Name namePrimRaise; +Name namePrimTakeMVar; Name nameFromTo; Name nameFromThen; @@ -165,16 +164,14 @@ Name nameMkRef; 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 @@ -294,11 +291,8 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ #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"); @@ -350,10 +344,9 @@ 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); -#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 @@ -384,6 +377,12 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ 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); @@ -564,6 +563,7 @@ Int what; { pFun(namePrimSeq, "primSeq"); pFun(namePrimCatch, "primCatch"); pFun(namePrimRaise, "primRaise"); + pFun(namePrimTakeMVar, "primTakeMVar"); { StgVar vv = mkStgVar(NIL,NIL); Name n = namePrimSeq; @@ -596,7 +596,16 @@ Int what; { 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; } } diff --git a/ghc/interpreter/link.h b/ghc/interpreter/link.h index ce766b4..f52fdeb 100644 --- a/ghc/interpreter/link.h +++ b/ghc/interpreter/link.h @@ -28,16 +28,15 @@ extern Name nameMkPrimByteArray; 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: @@ -57,16 +56,14 @@ extern Type typePrimMutableByteArray; 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; diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 90bb906..87f0775 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * 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" @@ -529,8 +529,11 @@ Name nameFromStgVar ( StgVar v ) 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)"); diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index f54cf20..4cac5b0 100644 --- a/ghc/interpreter/translate.c +++ b/ghc/interpreter/translate.c @@ -10,8 +10,8 @@ * 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" @@ -565,29 +565,27 @@ static Cell foreignInboundTy ( Type t ) 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; } } diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index 69c227f..8f12154 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -9,8 +9,8 @@ * 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" @@ -2488,6 +2488,7 @@ static Type stateVar = NIL; static Type alphaVar = NIL; static Type betaVar = NIL; static Type gammaVar = NIL; +static Type deltaVar = NIL; static Int nextVar = 0; static Void clearTyVars( void ) @@ -2496,6 +2497,7 @@ static Void clearTyVars( void ) alphaVar = NIL; betaVar = NIL; gammaVar = NIL; + deltaVar = NIL; nextVar = 0; } @@ -2531,6 +2533,14 @@ static Type mkGammaVar( void ) return gammaVar; } +static Type mkDeltaVar( void ) +{ + if (isNull(deltaVar)) { + deltaVar = mkOffset(nextVar++); + } + return deltaVar; +} + static Type local basicType(k) Char k; { switch (k) { @@ -2548,12 +2558,18 @@ Char 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()); @@ -2564,12 +2580,10 @@ Char k; { 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: @@ -2582,6 +2596,8 @@ Char k; { return mkBetaVar(); /* polymorphic */ case GAMMA_REP: return mkGammaVar(); /* polymorphic */ + case DELTA_REP: + return mkDeltaVar(); /* polymorphic */ default: printf("Kind: '%c'\n",k); internal("basicType"); diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index 1533c07..5a342ad 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -103,6 +103,8 @@ module Prelude ( asTypeOf, error, undefined, seq, ($!) + , MVar, newMVar, putMVar, takeMVar + ,trace -- Arrrggghhh!!! Help! Help! Help! -- What?! Prelude.hs doesn't even _define_ most of these things! @@ -1774,6 +1776,9 @@ 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 @@ -1820,7 +1825,7 @@ unsafeInterleaveIO = unsafeInterleaveST ------------------------------------------------------------------------------ --- Word, Addr, StablePtr, Prim*Array ----------------------------------------- +-- Word, Addr, StablePtr, Prim*Array, ThreadId, MVar ------------------------- ------------------------------------------------------------------------------ data Addr @@ -1870,6 +1875,41 @@ data Ref s a -- mutable variables 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 ------------------------------------------------------------------ diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index 74cd9e5..59faa16 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.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. @@ -501,6 +501,7 @@ static StgWord repSizeW( AsmRep rep ) 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 */ @@ -508,10 +509,8 @@ static StgWord repSizeW( AsmRep rep ) 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); @@ -841,6 +840,7 @@ void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep ) 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 */ @@ -848,10 +848,8 @@ 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 */ -#ifdef PROVIDE_CONCURRENT case THREADID_REP: /* ThreadId */ case MVAR_REP: /* MVar a */ -#endif case PTR_REP: emit_i_VAR(bco,offset); break; @@ -1409,13 +1407,13 @@ const AsmPrim asmPrimOps[] = { , { "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 */ @@ -1485,7 +1483,7 @@ AsmBCO asm_BCO_seq ( void ) 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); @@ -1506,6 +1504,46 @@ AsmBCO asm_BCO_seq ( void ) 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 * ------------------------------------------------------------------------*/ diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h index ecb53b5..7f4e985 100644 --- a/ghc/rts/Bytecodes.h +++ b/ghc/rts/Bytecodes.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -422,13 +422,13 @@ typedef enum , 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 diff --git a/ghc/rts/Disassembler.c b/ghc/rts/Disassembler.c index 5fcdb08..4a4d99b 100644 --- a/ghc/rts/Disassembler.c +++ b/ghc/rts/Disassembler.c @@ -5,8 +5,8 @@ * 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" @@ -381,6 +381,8 @@ InstrPtr disInstr( StgBCO *bco, InstrPtr pc ) 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); diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index aece2e3..cfe90ea 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.26 $ - * $Date: 1999/11/12 17:50:04 $ + * $Revision: 1.27 $ + * $Date: 1999/11/16 17:39:10 $ * ---------------------------------------------------------------------------*/ #include "Rts.h" @@ -1157,7 +1157,6 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) } Case(i_PRIMOP2): { - /* Remember to save */ int i, trc, pc_saved; void* p; StgBCO* bco_tmp; @@ -1175,8 +1174,8 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 ) /* 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; @@ -1731,7 +1730,7 @@ static inline StgClosure* raiseAnError ( StgClosure* errObj ) */ 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) { @@ -2760,7 +2759,7 @@ static void* enterBCO_primop2 ( int primop2code, 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: @@ -2915,6 +2914,84 @@ static void* enterBCO_primop2 ( int primop2code, 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: { @@ -2951,16 +3028,7 @@ static void* enterBCO_primop2 ( int primop2code, 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 @@ -2968,94 +3036,7 @@ continuation to primTakeMVar: takeMVar v = primTakeMVar v takeMVar. 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: @@ -3063,6 +3044,7 @@ off the stack. ASSERT(0); break; #endif /* PROVIDE_CONCURRENT */ + case i_ccall_ccall_Id: case i_ccall_ccall_IO: case i_ccall_stdcall_Id: -- 1.7.10.4