Commit b32b2d43 authored by andy's avatar andy

[project @ 2000-03-20 04:26:23 by andy]

Second attack at supporting threads inside STG Hugs.
We now support most of the concurrency primitives.

Also a wibble in Evaluator.c, letting Hugs compile.
parent e1d3748d
......@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: options.h,v $
* $Revision: 1.22 $
* $Date: 2000/03/10 18:28:26 $
* $Revision: 1.23 $
* $Date: 2000/03/20 04:26:24 $
* ------------------------------------------------------------------------*/
......@@ -158,15 +158,13 @@
* without attention. However, standard Haskell 98 is supported
* is supported without needing them.
*/
#undef PROVIDE_STABLE
#undef PROVIDE_FOREIGN
#undef PROVIDE_WEAK
#undef PROVIDE_CONCURRENT
#undef PROVIDE_PTREQUALITY
#undef PROVIDE_COERCE
#define PROVIDE_COERCE 1
#define PROVIDE_STABLE 1
#define PROVIDE_FOREIGN 1
#define PROVIDE_COERCE 1
#define PROVIDE_PTREQUALITY 1
#define PROVIDE_CONCURRENT 1
/* Enable a crude profiler which counts BCO entries, bytes allocated
and bytecode insns executed on a per-fn basis. Used for assessing
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: connect.h,v $
* $Revision: 1.30 $
* $Date: 2000/03/15 23:27:16 $
* $Revision: 1.31 $
* $Date: 2000/03/20 04:26:23 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
......@@ -1025,4 +1025,7 @@ extern Bool sameType ( Type,Int,Type,Int );
extern Bool matchType ( Type,Int,Type,Int );
extern Bool typeMatches ( Type,Type );
#ifdef DEBUG
extern Void checkBytecodeCount ( Void );
#endif
/*-------------------------------------------------------------------------*/
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: hugs.c,v $
* $Revision: 1.44 $
* $Date: 2000/03/15 23:27:16 $
* $Revision: 1.45 $
* $Date: 2000/03/20 04:26:23 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
......@@ -228,6 +228,10 @@ char *argv[]; {
CStackBase = &argc; /* Save stack base for use in gc */
#ifdef DEBUG
checkBytecodeCount(); /* check for too many bytecodes */
#endif
/* If first arg is +Q or -Q, be entirely silent, and automatically run
main after loading scripts. Useful for running the nofib suite. */
if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
......
# -------------------------------------------------------------------------- #
# $Id: Makefile,v 1.7 2000/03/08 22:05:43 andy Exp $
# $Id: Makefile,v 1.8 2000/03/20 04:26:23 andy Exp $
# -------------------------------------------------------------------------- #
TOP = ../..
......@@ -52,12 +52,17 @@ UTIL_LIBS = QuickCheck.hs QuickCheckBatch.hs QuickCheckPoly.hs \
Regex.lhs RegexString.lhs Observe.lhs Memo.lhs Readline.lhs \
Select.lhs
CONC_LIBS = Channel.lhs ChannelVar.lhs Concurrent.lhs Merge.lhs \
Parallel.lhs SampleVar.lhs Semaphore.lhs Strategies.lhs
LIBS = $(PRELUDE) \
$(STD_LIBS) \
$(DATA_LIBS) \
$(LANG_LIBS) \
$(TEXT_LIBS) \
$(UTIL_LIBS)
$(CONC_LIBS) \
$(UTIL_LIBS)
all :: $(LIBS)
......
......@@ -13,8 +13,8 @@
* included in the distribution.
*
* $RCSfile: machdep.c,v $
* $Revision: 1.20 $
* $Date: 2000/03/13 11:37:16 $
* $Revision: 1.21 $
* $Date: 2000/03/20 04:26:23 $
* ------------------------------------------------------------------------*/
#ifdef HAVE_SIGNAL_H
......@@ -251,7 +251,7 @@ static Void local searchChr ( Int );
static Void local searchStr ( String );
static Bool local tryEndings ( String );
#if DOS_FILENAMES
#if (DOS_FILENAMES || __CYGWIN32__)
# define SLASH '\\'
# define isSLASH(c) ((c)=='\\' || (c)=='/')
# define PATHSEP ';'
......@@ -690,7 +690,7 @@ Bool findFilesForModule (
strcat(augdPath, "lib");
strcat(augdPath, PATHSEP_STR);
/* fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
/* fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
peEnd = augdPath-1;
while (1) {
......
......@@ -2049,10 +2049,11 @@ swapMVar mvar new =
putMVar mvar new >>
return old
isEmptyMVar var = error "isEmptyMVar is not (yet) implemented in Hugs"
instance Eq (MVar a) where
m1 == m2 = primSameMVar m1 m2
data ThreadId
instance Eq ThreadId where
......@@ -2081,6 +2082,11 @@ forkIO computation
trace_quiet s x
= (unsafePerformIO (putStr (s ++ "\n"))) `seq` x
-- Foreign ------------------------------------------------------------------
data ForeignObj
-- showFloat ------------------------------------------------------------------
showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
......
......@@ -5,8 +5,8 @@
* Copyright (c) 1994-1998.
*
* $RCSfile: Assembler.c,v $
* $Revision: 1.23 $
* $Date: 2000/03/17 14:37:21 $
* $Revision: 1.24 $
* $Date: 2000/03/20 04:26:24 $
*
* This module provides functions to construct BCOs and other closures
* required by the bytecode compiler.
......@@ -1399,19 +1399,21 @@ AsmPrim asmPrimOps[] = {
#endif
#ifdef PROVIDE_CONCURRENT
/* Concurrency operations */
, { "primFork", "a", "T", MONAD_IO, i_PRIMOP2, i_fork }
, { "primForkIO", "a", "T", MONAD_IO, i_PRIMOP2, i_forkIO }
, { "primKillThread", "T", "", MONAD_IO, i_PRIMOP2, i_killThread }
, { "primDelay", "I", "", MONAD_IO, i_PRIMOP2, i_delay }
, { "primRaiseInThread", "TE", "", MONAD_IO, i_PRIMOP2, i_raiseInThread }
, { "primWaitRead", "I", "", MONAD_IO, i_PRIMOP2, i_waitRead }
, { "primWaitWrite", "I", "", MONAD_IO, i_PRIMOP2, i_waitWrite }
, { "primYield", "", "", MONAD_IO, i_PRIMOP2, i_yield } , { "primDelay", "I", "", MONAD_IO, i_PRIMOP2, i_delay }
, { "primGetThreadId", "", "T", MONAD_IO, i_PRIMOP2, i_getThreadId }
, { "primCmpThreadIds", "TT", "I", MONAD_Id, i_PRIMOP2, i_cmpThreadIds }
#endif
, { "primNewEmptyMVar", "", "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 */
......@@ -1427,6 +1429,16 @@ AsmPrim ccall_stdcall_Id
AsmPrim ccall_stdcall_IO
= { "ccall", 0, 0, MONAD_IO, i_PRIMOP2, i_ccall_stdcall_IO };
#ifdef DEBUG
void checkBytecodeCount( void ) {
if (MAX_Primop1 >= 255) {
printf("Too many Primop1 bytecodes (%d)\n",MAX_Primop1);
}
if (MAX_Primop2 >= 255) {
printf("Too many Primop2 bytecodes (%d)\n",MAX_Primop2);
}
}
#endif
AsmPrim* asmFindPrim( char* s )
{
......
/* -----------------------------------------------------------------------------
* $Id: Bytecodes.h,v 1.13 1999/12/07 11:49:10 sewardj Exp $
* $Id: Bytecodes.h,v 1.14 2000/03/20 04:26:24 andy Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -420,19 +420,21 @@ typedef enum
#ifdef PROVIDE_CONCURRENT
/* Concurrency operations */
, i_fork
, i_forkIO
, i_killThread
, i_raiseInThread
, i_delay
, i_waitRead
, i_waitWrite
, i_yield
, i_getThreadId
, i_cmpThreadIds
#endif
, i_sameMVar
, i_newMVar
, i_takeMVar
, i_putMVar
, i_getThreadId
, i_cmpThreadIds
, i_forkIO
/* CCall! */
, i_ccall_ccall_Id
......
......@@ -5,8 +5,8 @@
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
* $Revision: 1.42 $
* $Date: 2000/03/17 14:37:21 $
* $Revision: 1.43 $
* $Date: 2000/03/20 04:26:24 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
......@@ -41,8 +41,10 @@
#include <ieee754.h> /* These are for primops */
#endif
/* Allegedly useful macro */
/* Allegedly useful macro, taken from ClosureMacros.h */
#define payloadWord( c, i ) (*stgCast(StgWord*, ((c)->payload+(i))))
#define payloadPtr( c, i ) (*stgCast(StgPtr*, ((c)->payload+(i))))
/* An incredibly useful abbreviation.
* Interestingly, there are some uses of END_TSO_QUEUE_closure that
......@@ -104,6 +106,7 @@ void cp_init ( void )
}
void cp_enter ( StgBCO* b )
{
int is_ret_cont;
......@@ -255,6 +258,12 @@ void setRtsFlags( int x )
}
typedef struct {
StgTSOBlockReason reason;
unsigned int delay;
} HugsBlock;
/* --------------------------------------------------------------------------
* Entering-objects and bytecode interpreter part of evaluator
* ------------------------------------------------------------------------*/
......@@ -284,7 +293,7 @@ void setRtsFlags( int x )
/* Forward decls ... */
static void* enterBCO_primop1 ( int );
static void* enterBCO_primop2 ( int , int* /*StgThreadReturnCode* */,
StgBCO**, Capability* );
StgBCO**, Capability*, HugsBlock * );
static inline void PopUpdateFrame ( StgClosure* obj );
static inline void PopCatchFrame ( void );
static inline void PopSeqFrame ( void );
......@@ -453,6 +462,10 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
register StgClosure* obj; /* object currently under evaluation */
char eCount; /* enter counter, for context switching */
HugsBlock hugsBlock = { NotBlocked, 0 };
#ifdef DEBUG
StgPtr tSp; StgUpdateFrame* tSu; StgPtr tSpLim;
#endif
......@@ -504,8 +517,30 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
#endif
) {
if (context_switch) {
xPushCPtr(obj); /* code to restart with */
RETURN(ThreadYielding);
switch(hugsBlock.reason) {
case NotBlocked: {
xPushCPtr(obj); /* code to restart with */
RETURN(ThreadYielding);
}
case BlockedOnDelay: /* fall through */
case BlockedOnRead: /* fall through */
case BlockedOnWrite: {
ASSERT(cap->rCurrentTSO->why_blocked == NotBlocked);
cap->rCurrentTSO->why_blocked = BlockedOnDelay;
ACQUIRE_LOCK(&sched_mutex);
cap->rCurrentTSO->block_info.delay
= hugsBlock.delay + ticks_since_select;
APPEND_TO_BLOCKED_QUEUE(cap->rCurrentTSO);
RELEASE_LOCK(&sched_mutex);
xPushCPtr(obj); /* code to restart with */
RETURN(ThreadBlocked);
}
default:
barf("Unknown context switch reasoning");
}
}
}
......@@ -1186,7 +1221,8 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
pc_saved = PC;
bco_tmp = bco;
SSS;
p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap );
p = enterBCO_primop2 ( i, &trc, &bco_tmp, cap,
&hugsBlock );
LLL;
bco = bco_tmp;
bciPtr = &(bcoInstr(bco,pc_saved));
......@@ -1195,8 +1231,9 @@ StgThreadReturnCode enter( Capability* cap, StgClosure* obj0 )
/* we want to enter p */
obj = p; goto enterLoop;
} else {
/* trc is the the StgThreadReturnCode for this thread */
RETURN((StgThreadReturnCode)trc);
/* trc is the the StgThreadReturnCode for
* this thread */
RETURN((StgThreadReturnCode)trc);
};
}
Continue;
......@@ -2645,11 +2682,14 @@ static void* enterBCO_primop1 ( int primop1code )
return the address of it and leave *return2 unchanged.
To return a StgThreadReturnCode to the scheduler,
set *return2 to it and return a non-NULL value.
To cause a context switch, set context_switch (its a global),
and optionally set hugsBlock to your rational.
*/
static void* enterBCO_primop2 ( int primop2code,
int* /*StgThreadReturnCode* */ return2,
StgBCO** bco,
Capability* cap )
Capability* cap,
HugsBlock *hugsBlock )
{
if (combined) {
/* A small concession: we need to allow ccalls,
......@@ -3016,21 +3056,7 @@ static void* enterBCO_primop2 ( int primop2code,
PushTaggedBool(x==y);
break;
}
case i_getThreadId:
{
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;
}
#ifdef PROVIDE_CONCURRENT
case i_forkIO:
{
StgClosure* closure;
......@@ -3041,14 +3067,31 @@ static void* enterBCO_primop2 ( int primop2code,
tid = tso->id;
scheduleThread(tso);
context_switch = 1;
/* Later: Change to use tso as the ThreadId */
PushTaggedWord(tid);
break;
}
#ifdef PROVIDE_CONCURRENT
case i_killThread:
{
StgTSO* tso = stgCast(StgTSO*,PopPtr());
StgWord n = PopTaggedWord();
StgTSO* tso = 0;
StgTSO *t;
// Map from ThreadId to Thread Structure */
for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
if (n == t->id)
tso = t;
}
if (tso == 0) {
// Already dead
break;
}
while (tso->what_next == ThreadRelocated) {
tso = tso->link;
}
deleteThread(tso);
if (tso == cap->rCurrentTSO) { /* suicide */
*return2 = ThreadFinished;
......@@ -3056,13 +3099,55 @@ static void* enterBCO_primop2 ( int primop2code,
}
break;
}
case i_raiseInThread:
ASSERT(0); /* not (yet) supported */
case i_delay:
{
StgInt n = PopTaggedInt();
context_switch = 1;
hugsBlock->reason = BlockedOnDelay;
hugsBlock->delay = n;
break;
}
case i_waitRead:
{
StgInt n = PopTaggedInt();
context_switch = 1;
hugsBlock->reason = BlockedOnRead;
hugsBlock->delay = n;
break;
}
case i_waitWrite:
/* As PrimOps.h says: Hmm, I'll think about these later. */
ASSERT(0);
{
StgInt n = PopTaggedInt();
context_switch = 1;
hugsBlock->reason = BlockedOnWrite;
hugsBlock->delay = n;
break;
}
case i_yield:
{
/* The definition of yield include an enter right after
* the primYield, at which time context_switch is tested.
*/
context_switch = 1;
break;
}
case i_getThreadId:
{
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;
}
#endif /* PROVIDE_CONCURRENT */
case i_ccall_ccall_Id:
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment