Commit 4b69a23d authored by sewardj's avatar sewardj
Browse files

[project @ 1999-11-16 17:38:54 by sewardj]

Added basic support for MVars: data MVar, and newMVar, putMVar and
getMVar.
parent 61eff6b3
/* -----------------------------------------------------------------------------
* $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 );
/* --------------------------------------------------------------------------
......
......@@ -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 ------------------------------------------------------------------
......
......@@ -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;
}
}
......
......@@ -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;
......
......@@ -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)");
......
......@@ -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,28 +565,26 @@ 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;
}
......
......@@ -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");
......
......@@ -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 ------------------------------------------------------------------
......
......@@ -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
* ------------------------------------------------------------------------*/
......
/* -----------------------------------------------------------------------------
* $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