[project @ 1999-11-02 15:05:38 by simonmar]

This commit adds in the current state of our SMP support. Notably, this allows the new way 's' to be built, providing support for running multiple Haskell threads simultaneously on top of any pthreads implementation, the idea being to take advantage of commodity SMP boxes. Don't expect to get much of a speedup yet; due to the excessive locking required to synchronise access to mutable heap objects, you'll see a slowdown in most cases, even on a UP machine. The best I've seen is a 1.6-1.7 speedup on an example that did no locking (two optimised nfibs in parallel). - new RTS -N flag specifies how many pthreads to start. - new driver -smp flag, tells the driver to use way 's'. - new compiler -fsmp option (not for user comsumption) tells the compiler not to generate direct jumps to thunk entry code. - largely rewritten scheduler - _ccall_GC is now done by handing back a "token" to the RTS before executing the ccall; it should now be possible to execute blocking ccalls in the current thread while allowing the RTS to continue running Haskell threads as normal. - you can only call thread-safe C libraries from a way 's' build, of course. Pthread support is still incomplete, and weird things (including deadlocks) are likely to happen.
author: simonmar <unknown> 1999-11-02 15:06:05 +0000
committer: simonmar <unknown> 1999-11-02 15:06:05 +0000
commit: f6692611aad945e46ffb615bde1df7def3fc742f (patch)
tree: 04e2e2af9c43eba1b60312b89eb3ac8f34209e2c
parent: 947d2e363f75e9e230d535c876ecdafba45174b5 (diff)
download: haskell-f6692611aad945e46ffb615bde1df7def3fc742f.tar.gz
42 files changed, 1770 insertions, 420 deletions
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index cb65a7f239..6caa9c50be 100644
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: AbsCSyn.lhs,v 1.25 1999/10/31 15:35:32 sof Exp $
+% $Id: AbsCSyn.lhs,v 1.26 1999/11/02 15:05:39 simonmar Exp $
 %
 \section[AbstractC]{Abstract C: the last stop before machine code}
 
@@ -473,6 +473,7 @@ data MagicId
 node 	= VanillaReg PtrRep     ILIT(1) -- A convenient alias for Node
 tagreg  = VanillaReg WordRep    ILIT(2) -- A convenient alias for TagReg
 
+nodeReg = CReg node
 \end{code}
 
 We need magical @Eq@ because @VanillaReg@s come in multiple flavors.
diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs
index 636a2f3f99..644a13d364 100644
--- a/ghc/compiler/absCSyn/CLabel.lhs
+++ b/ghc/compiler/absCSyn/CLabel.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CLabel.lhs,v 1.28 1999/10/13 16:39:10 simonmar Exp $
+% $Id: CLabel.lhs,v 1.29 1999/11/02 15:05:40 simonmar Exp $
 %
 \section[CLabel]{@CLabel@: Information to make C Labels}
 
@@ -37,6 +37,7 @@ module CLabel (
 	mkErrorStdEntryLabel,
 	mkUpdInfoLabel,
 	mkTopTickyCtrLabel,
+	mkBlackHoleInfoTableLabel,
         mkCAFBlackHoleInfoTableLabel,
         mkSECAFBlackHoleInfoTableLabel,
 	mkRtsPrimOpLabel,
@@ -215,6 +216,7 @@ mkAsmTempLabel 			= AsmTempLabel
 mkErrorStdEntryLabel		= RtsLabel RtsShouldNeverHappenCode
 mkUpdInfoLabel			= RtsLabel RtsUpdInfo
 mkTopTickyCtrLabel		= RtsLabel RtsTopTickyCtr
+mkBlackHoleInfoTableLabel	= RtsLabel (RtsBlackHoleInfoTbl SLIT("BLACKHOLE_info"))
 mkCAFBlackHoleInfoTableLabel	= RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info"))
 mkSECAFBlackHoleInfoTableLabel	= if opt_DoTickyProfiling then
                                     RtsLabel (RtsBlackHoleInfoTbl SLIT("SE_CAF_BLACKHOLE_info"))
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index b708742ad1..ae61d06fd6 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -787,8 +787,8 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs
   where
     (pp_saves, pp_restores) = ppr_vol_regs vol_regs
     (pp_save_context, pp_restore_context)
-	| may_gc  = ( text "do { SaveThreadState();"
-		    , text "LoadThreadState();} while(0);"
+	| may_gc  = ( text "do { I_ id; SaveThreadState(); id = suspendThread(BaseReg);"
+		    , text "BaseReg = resumeThread(id); LoadThreadState();} while(0);"
 		    )
 	| otherwise = (	pp_basic_saves $$ pp_saves,
 			pp_basic_restores $$ pp_restores)
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index dc326087c9..38c88dd999 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgClosure.lhs,v 1.36 1999/11/01 17:10:07 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.37 1999/11/02 15:05:43 simonmar Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -269,6 +269,7 @@ closureCodeBody binder_info closure_info cc [] body
     cl_descr mod_name = closureDescription mod_name (closureName closure_info)
 
     body_label   = entryLabelFromCI closure_info
+    
     is_box  = case body of { StgApp fun [] -> True; _ -> False }
 
     body_code   = profCtrC SLIT("TICK_ENT_THK") []		`thenC`
@@ -577,7 +578,7 @@ thunkWrapper closure_info lbl thunk_code
     thunkChecks lbl node_points (
 
 	-- Overwrite with black hole if necessary
-    blackHoleIt closure_info node_points	`thenC`
+    blackHoleIt closure_info node_points  `thenC`
 
     setupUpdate closure_info (			-- setupUpdate *encloses* the rest
 
@@ -624,10 +625,14 @@ blackHoleIt :: ClosureInfo -> Bool -> Code	-- Only called for closures with no a
 blackHoleIt closure_info node_points
   = if blackHoleOnEntry closure_info && node_points
     then
+	let
+	  info_label = infoTableLabelFromCI closure_info
+	  args = [ CLbl info_label DataPtrRep ]
+	in
 	absC (if closureSingleEntry(closure_info) then
-		CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
+		CMacroStmt UPD_BH_SINGLE_ENTRY args
 	      else
-		CMacroStmt UPD_BH_UPDATABLE [CReg node])
+		CMacroStmt UPD_BH_UPDATABLE args)
     else
 	nopC
 \end{code}
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index c33c649d92..46e3b0219f 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgTailCall.lhs,v 1.22 1999/06/22 08:00:00 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.23 1999/11/02 15:05:43 simonmar Exp $
 %
 %********************************************************
 %*							*
@@ -39,7 +39,8 @@ import CgRetConv	( dataReturnConvPrim,
 import CgStackery	( mkTaggedStkAmodes, adjustStackHW )
 import CgUsages		( getSpRelOffset, adjustSpAndHp )
 import CgUpdate		( pushSeqFrame )
-import CLabel		( mkUpdInfoLabel, mkRtsPrimOpLabel )
+import CLabel		( mkUpdInfoLabel, mkRtsPrimOpLabel, 
+			  mkBlackHoleInfoTableLabel )
 import ClosureInfo	( nodeMustPointToIt,
 			  getEntryConvention, EntryConvention(..),
 			  LambdaFormInfo
@@ -55,6 +56,7 @@ import Type		( isUnLiftedType )
 import TyCon            ( TyCon )
 import PrimOp		( PrimOp )
 import Util		( zipWithEqual )
+import Unique		( mkPseudoUnique1 )
 import Outputable
 import Panic		( panic, assertPanic )
 \end{code}
@@ -425,6 +427,23 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
 
 	(fast_stk_amodes, tagged_stk_amodes) = 
 		splitAt arity stk_arg_amodes
+
+	-- eager blackholing, at the end of the basic block.
+	node_save = CTemp (mkPseudoUnique1 2) DataPtrRep
+	(r1_tmp_asst, bh_asst)
+	 = case sequel of
+#if 0
+	-- no: UpdateCode doesn't tell us that we're in a thunk's entry code.
+	-- we might be in a case continuation later down the line.  Also,
+	-- we might have pushed a return address on the stack, if we're in
+	-- a case scrut, and still be in the thunk's entry code.
+		UpdateCode -> 
+		   (CAssign node_save nodeReg,
+		    CAssign (CVal (CIndex node_save (mkIntCLit 0) PtrRep) 
+				  PtrRep)
+			    (CLbl mkBlackHoleInfoTableLabel DataPtrRep))
+#endif
+		_ -> (AbsCNop, AbsCNop)
     in
 	-- We can omit tags on the arguments passed to the fast entry point, 
 	-- but we have to be careful to fill in the tags on any *extra*
@@ -442,12 +461,14 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
 		-- The stack space for the pushed return addess, 
 		-- with any args pushed on top, is recorded in final_sp.
 	
-		-- Do the simultaneous assignments,
-	doSimAssts (mkAbstractCs [pending_assts,
+			-- Do the simultaneous assignments,
+	doSimAssts (mkAbstractCs [r1_tmp_asst,
+				  pending_assts,
 			          reg_arg_assts, 
 				  fast_arg_assts, 
 				  tagged_arg_assts,
 			          tag_assts])	`thenC`
+	absC bh_asst `thenC`
 	
 		-- push a return address if necessary
 		-- (after the assignments above, in case we clobber a live
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 3b7b5a1b1b..157a6b70e2 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: ClosureInfo.lhs,v 1.38 1999/05/18 15:03:50 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.39 1999/11/02 15:05:44 simonmar Exp $
 %
 \section[ClosureInfo]{Data structures which describe closures}
 
@@ -77,7 +77,8 @@ import CLabel		( CLabel, mkStdEntryLabel, mkFastEntryLabel,
 			  mkReturnPtLabel
 			)
 import CmdLineOpts	( opt_SccProfilingOn, opt_OmitBlackHoling,
-			  opt_Parallel, opt_DoTickyProfiling )
+			  opt_Parallel, opt_DoTickyProfiling,
+			  opt_SMP )
 import Id		( Id, idType, getIdArity )
 import DataCon		( DataCon, dataConTag, fIRST_TAG,
 			  isNullaryDataCon, isTupleCon, dataConName
@@ -679,6 +680,9 @@ getEntryConvention name lf_info arg_kinds
 
 	LFThunk _ _ _ updatable std_form_info _ _
 	  -> if updatable || opt_DoTickyProfiling  -- to catch double entry
+		|| opt_SMP  -- always enter via node on SMP, since the
+			    -- thunk might have been blackholed in the 
+			    -- meantime.
 	     then ViaNode
              else StdEntry (thunkEntryLabel name std_form_info updatable)
 
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 3101d027ec..e3a5f22672 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -87,6 +87,7 @@ module CmdLineOpts (
 	opt_IrrefutableTuples,
 	opt_NumbersStrict,
 	opt_Parallel,
+	opt_SMP,
 
 	-- optimisation opts
 	opt_DoEtaReduction,
@@ -375,6 +376,7 @@ opt_IrrefutableTuples		= lookUp  SLIT("-firrefutable-tuples")
 opt_MaxContextReductionDepth	= lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
 opt_NumbersStrict		= lookUp  SLIT("-fnumbers-strict")
 opt_Parallel			= lookUp  SLIT("-fparallel")
+opt_SMP				= lookUp  SLIT("-fsmp")
 
 -- optimisation opts
 opt_DoEtaReduction		= lookUp  SLIT("-fdo-eta-reduction")
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index cacd94f49f..71795af4eb 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -352,7 +352,7 @@ $BuildTag	= ''; # default is sequential build w/ Appel-style GC
 	'_p',  "-fscc-profiling -DPROFILING -optc-DPROFILING",
 	'_t',  "-fticky-ticky -DTICKY_TICKY -optc-DTICKY_TICKY",
 	'_u',  "-optc-DNO_REGS -optc-DUSE_MINIINTERPRETER -fno-asm-mangling -funregisterised",
-	'_s',  "-fparallel -optc-pthread -optl-pthread -optc-DSMP",
+	'_s',  "-fsmp -optc-pthread -optl-pthread -optc-DSMP",
 	'_mp', "-fparallel -D__PARALLEL_HASKELL__ -optc-DPAR",
 	'_mg', "-fgransim -D__GRANSIM__ -optc-DGRAN");
 
@@ -3054,6 +3054,7 @@ arg: while($_ = $Args[0]) {
     /^-fticky-ticky$/     && do { push(@HsC_flags,$_); next arg; };
     /^-fgransim$/ 	  && do { push(@HsC_flags,$_); next arg; };
     /^-fparallel$/        && do { push(@HsC_flags,$_); next arg; };
+    /^-fsmp$/             && do { push(@HsC_flags,$_); next arg; };
 
     /^-split-objs$/	&& do {
 			if ( $TargetPlatform !~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|rs6000|sparc)-/ ) {
diff --git a/ghc/includes/MachRegs.h b/ghc/includes/MachRegs.h
index 35db1c0f28..16d429ad63 100644
--- a/ghc/includes/MachRegs.h
+++ b/ghc/includes/MachRegs.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: MachRegs.h,v 1.5 1999/06/25 09:13:38 simonmar Exp $
+ * $Id: MachRegs.h,v 1.6 1999/11/02 15:05:50 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -206,6 +206,7 @@
 #define REG_Base    ebx
 #endif
 #define REG_Sp	    ebp
+/* #define REG_Su      ebx*/
 
 #if STOLEN_X86_REGS >= 3
 # define REG_R1	    esi
diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h
index 77e74c3d40..0991482276 100644
--- a/ghc/includes/PrimOps.h
+++ b/ghc/includes/PrimOps.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.37 1999/08/25 16:11:43 simonmar Exp $
+ * $Id: PrimOps.h,v 1.38 1999/11/02 15:05:51 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -710,6 +710,12 @@ EF_(forkzh_fast);
 EF_(yieldzh_fast);
 EF_(killThreadzh_fast);
 EF_(seqzh_fast);
+EF_(unblockExceptionszh_fast);
+
+#define blockExceptionszh_fast						\
+  if (CurrentTSO->pending_exceptions == NULL) {				\
+     CurrentTSO->pending_exceptions = &END_EXCEPTION_LIST_closure;	\
+  }
 
 #define myThreadIdzh(t) (t = CurrentTSO)
 
diff --git a/ghc/includes/Regs.h b/ghc/includes/Regs.h
index df44cc9008..e7a9213ea8 100644
--- a/ghc/includes/Regs.h
+++ b/ghc/includes/Regs.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Regs.h,v 1.4 1999/03/02 19:44:14 sof Exp $
+ * $Id: Regs.h,v 1.5 1999/11/02 15:05:51 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -25,7 +25,7 @@
  *     2) caller-saves registers are saved across a CCall
  */
 
-typedef struct {
+typedef struct StgRegTable_ {
   StgUnion 	  rR1;
   StgUnion   	  rR2;
   StgUnion   	  rR3;
@@ -48,9 +48,22 @@ typedef struct {
   StgPtr 	  rSpLim;
   StgPtr 	  rHp;
   StgPtr 	  rHpLim;
+  StgTSO         *rCurrentTSO;
+  bdescr         *rNursery;
+  bdescr         *rCurrentNursery;
+#ifdef SMP
+  struct StgRegTable_ *link;
+#endif
 } StgRegTable;
 
+/* No such thing as a MainRegTable under SMP - each thread must
+ * have its own MainRegTable.
+ */
+#ifndef SMP
 extern DLL_IMPORT_RTS StgRegTable  MainRegTable;
+#endif
+
+#ifdef IN_STG_CODE
 
 /*
  * Registers Hp and HpLim are global across the entire system, and are
@@ -85,32 +98,35 @@ extern DLL_IMPORT_RTS StgRegTable  MainRegTable;
 #define SAVE_Su    	    (CurrentTSO->su)
 #define SAVE_SpLim    	    (CurrentTSO->splim)
 
-#define SAVE_Hp	    	    (MainRegTable.rHp)
-#define SAVE_HpLim	    (MainRegTable.rHpLim)
+#define SAVE_Hp	    	    (BaseReg->rHp)
+#define SAVE_HpLim	    (BaseReg->rHpLim)
+
+#define SAVE_CurrentTSO     (BaseReg->rCurrentTSO)
+#define SAVE_CurrentNursery (BaseReg->rCurrentNursery)
 
 /* We sometimes need to save registers across a C-call, eg. if they
  * are clobbered in the standard calling convention.  We define the
  * save locations for all registers in the register table.
  */
 
-#define SAVE_R1             (MainRegTable.rR1)
-#define SAVE_R2             (MainRegTable.rR2)
-#define SAVE_R3             (MainRegTable.rR3)
-#define SAVE_R4             (MainRegTable.rR4)
-#define SAVE_R5             (MainRegTable.rR5)
-#define SAVE_R6             (MainRegTable.rR6)
-#define SAVE_R7             (MainRegTable.rR7)
-#define SAVE_R8             (MainRegTable.rR8)
+#define SAVE_R1             (BaseReg->rR1)
+#define SAVE_R2             (BaseReg->rR2)
+#define SAVE_R3             (BaseReg->rR3)
+#define SAVE_R4             (BaseReg->rR4)
+#define SAVE_R5             (BaseReg->rR5)
+#define SAVE_R6             (BaseReg->rR6)
+#define SAVE_R7             (BaseReg->rR7)
+#define SAVE_R8             (BaseReg->rR8)
  
-#define SAVE_F1             (MainRegTable.rF1)
-#define SAVE_F2             (MainRegTable.rF2)
-#define SAVE_F3             (MainRegTable.rF3)
-#define SAVE_F4             (MainRegTable.rF4)
+#define SAVE_F1             (BaseReg->rF1)
+#define SAVE_F2             (BaseReg->rF2)
+#define SAVE_F3             (BaseReg->rF3)
+#define SAVE_F4             (BaseReg->rF4)
 
-#define SAVE_D1             (MainRegTable.rD1)
-#define SAVE_D2             (MainRegTable.rD2)
+#define SAVE_D1             (BaseReg->rD1)
+#define SAVE_D2             (BaseReg->rD2)
 
-#define SAVE_L1             (MainRegTable.rL1)
+#define SAVE_L1             (BaseReg->rL1)
 
 /* -----------------------------------------------------------------------------
  * Emit the GCC-specific register declarations for each machine
@@ -240,6 +256,9 @@ GLOBAL_REG_DECL(StgWord64,L1,REG_L1)
 #ifdef REG_Base
 GLOBAL_REG_DECL(StgRegTable *,BaseReg,REG_Base)
 #else
+#ifdef SMP
+#error BaseReg must be in a register for SMP
+#endif
 #define BaseReg (&MainRegTable)
 #endif
 
@@ -273,6 +292,18 @@ GLOBAL_REG_DECL(P_,HpLim,REG_HpLim)
 #define HpLim (BaseReg->rHpLim)
 #endif
 
+#ifdef REG_CurrentTSO
+GLOBAL_REG_DECL(StgTSO *,CurrentTSO,REG_CurrentTSO)
+#else
+#define CurrentTSO (BaseReg->rCurrentTSO)
+#endif
+
+#ifdef REG_CurrentNursery
+GLOBAL_REG_DECL(bdescr *,CurrentNursery,REG_CurrentNursery)
+#else
+#define CurrentNursery (BaseReg->rCurrentNursery)
+#endif
+
 /* -----------------------------------------------------------------------------
    For any registers which are denoted "caller-saves" by the C calling
    convention, we have to emit code to save and restore them across C
@@ -456,6 +487,9 @@ GLOBAL_REG_DECL(P_,HpLim,REG_HpLim)
 #endif
 
 #ifdef CALLER_SAVES_Base
+#ifdef SMP
+#error "Can't have caller-saved BaseReg with SMP"
+#endif
 #define CALLER_SAVE_Base	/* nothing */
 #define CALLER_RESTORE_Base	BaseReg = &MainRegTable;
 #else
@@ -463,10 +497,30 @@ GLOBAL_REG_DECL(P_,HpLim,REG_HpLim)
 #define CALLER_RESTORE_Base	/* nothing */
 #endif
 
+#ifdef CALLER_SAVES_CurrentTSO
+#define CALLER_SAVE_CurrentTSO   	SAVE_CurrentTSO = CurrentTSO;
+#define CALLER_RESTORE_CurrentTSO	CurrentTSO = SAVE_CurrentTSO;
+#else
+#define CALLER_SAVE_CurrentTSO   	/* nothing */
+#define CALLER_RESTORE_CurrentTSO   	/* nothing */
+#endif
+
+#ifdef CALLER_SAVES_CurrentNursery
+#define CALLER_SAVE_CurrentNursery   	SAVE_CurrentNursery = CurrentNursery;
+#define CALLER_RESTORE_CurrentNursery	CurrentNursery = SAVE_CurrentNursery;
+#else
+#define CALLER_SAVE_CurrentNursery   	/* nothing */
+#define CALLER_RESTORE_CurrentNursery   /* nothing */
+#endif
+
+#endif /* IN_STG_CODE */
+
 /* ----------------------------------------------------------------------------
    Handy bunches of saves/restores 
    ------------------------------------------------------------------------  */
 
+#ifdef IN_STG_CODE
+
 #define CALLER_SAVE_USER			\
   CALLER_SAVE_R1				\
   CALLER_SAVE_R2				\
@@ -489,7 +543,9 @@ GLOBAL_REG_DECL(P_,HpLim,REG_HpLim)
   CALLER_SAVE_Su				\
   CALLER_SAVE_SpLim				\
   CALLER_SAVE_Hp				\
-  CALLER_SAVE_HpLim
+  CALLER_SAVE_HpLim				\
+  CALLER_SAVE_CurrentTSO			\
+  CALLER_SAVE_CurrentNursery
 
 #define CALLER_RESTORE_USER			\
   CALLER_RESTORE_R1				\
@@ -514,7 +570,18 @@ GLOBAL_REG_DECL(P_,HpLim,REG_HpLim)
   CALLER_RESTORE_Su				\
   CALLER_RESTORE_SpLim				\
   CALLER_RESTORE_Hp				\
-  CALLER_RESTORE_HpLim
+  CALLER_RESTORE_HpLim				\
+  CALLER_RESTORE_CurrentTSO			\
+  CALLER_RESTORE_CurrentNursery
+
+#else /* not IN_STG_CODE */
+
+#define CALLER_SAVE_USER       /* nothing */
+#define CALLER_SAVE_SYSTEM     /* nothing */
+#define CALLER_RESTORE_USER    /* nothing */
+#define CALLER_RESTORE_SYSTEM  /* nothing */
+
+#endif /* IN_STG_CODE */
 
 #define CALLER_SAVE_ALL				\
   CALLER_SAVE_SYSTEM				\
diff --git a/ghc/includes/Rts.h b/ghc/includes/Rts.h
index 1dc23dd374..dd233886e0 100644
--- a/ghc/includes/Rts.h
+++ b/ghc/includes/Rts.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Rts.h,v 1.7 1999/08/25 16:11:44 simonmar Exp $
+ * $Id: Rts.h,v 1.8 1999/11/02 15:05:52 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -10,8 +10,8 @@
 #ifndef RTS_H
 #define RTS_H
 
-#ifndef NO_REGS
-#define NO_REGS			/* don't define fixed registers */
+#ifndef IN_STG_CODE
+#define NOT_IN_STG_CODE
 #endif
 #include "Stg.h"
 
diff --git a/ghc/includes/RtsAPI.h b/ghc/includes/RtsAPI.h
index 0e7883d8ef..aeccc7c3fd 100644
--- a/ghc/includes/RtsAPI.h
+++ b/ghc/includes/RtsAPI.h
@@ -1,5 +1,5 @@
 /* ----------------------------------------------------------------------------
- * $Id: RtsAPI.h,v 1.7 1999/07/06 09:42:39 sof Exp $
+ * $Id: RtsAPI.h,v 1.8 1999/11/02 15:05:52 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -14,6 +14,7 @@
  * Running the scheduler
  */
 typedef enum {
+    NoStatus,    /* not finished yet                                   */
     Success,      
     Killed,	 /* another thread killed us                           */
     Interrupted, /* stopped in response to a call to interruptStgRts   */
diff --git a/ghc/includes/SMP.h b/ghc/includes/SMP.h
new file mode 100644
index 0000000000..fa247988cf
--- /dev/null
+++ b/ghc/includes/SMP.h
@@ -0,0 +1,91 @@
+/* ----------------------------------------------------------------------------
+ * $Id: SMP.h,v 1.1 1999/11/02 15:05:52 simonmar Exp $
+ *
+ * (c) The GHC Team, 1999
+ *
+ * Macros for SMP support
+ *
+ * -------------------------------------------------------------------------- */
+
+#ifndef SMP_H
+#define SMP_H
+
+/* SMP is currently not compatible with the following options:
+ *
+ *      INTERPRETER
+ *      PROFILING
+ *      TICKY_TICKY
+ *      and unregisterised builds.
+ */
+
+#if defined(SMP)
+
+#if    defined(INTERPRETER) \
+     || defined(PROFILING)  \
+     || defined(TICKY_TICKY)
+#error Build options incompatible with SMP.
+#endif
+
+/*
+ * CMPXCHG - this instruction is the standard "test & set".  We use it
+ * for locking closures in the thunk and blackhole entry code.  If the
+ * closure is already locked, or has an unexpected info pointer
+ * (because another thread is altering it in parallel), we just jump
+ * to the new entry point.
+ */
+#if defined(i386_TARGET_ARCH) && defined(TABLES_NEXT_TO_CODE)
+#define CMPXCHG(p, cmp, new)			\
+  __asm__ __volatile__ (  			\
+	  "lock ; cmpxchg %1, %0\n"		\
+          "\tje 1f\n"				\
+          "\tjmp *%%eax\n"			\
+          "\t1:\n"				\
+	  : /* no outputs */			\
+	  : "m" (p), "r" (new), "r" (cmp)	\
+	  )
+
+/* 
+ * XCHG - the atomic exchange instruction.  Used for locking closures
+ * during updates (see LOCK_CLOSURE below) and the MVar primops.
+ */
+#define XCHG(reg, obj)				\
+  __asm__ __volatile__ (			\
+ 	  "xchgl %1,%0"				\
+          :"+r" (reg), "+m" (obj)		\
+          : /* no input-only operands */	\
+	  )
+
+#else
+#error SMP macros not defined for this architecture
+#endif
+
+/*
+ * LOCK_CLOSURE locks the specified closure, busy waiting for any
+ * existing locks to be cleared.
+ */
+#define LOCK_CLOSURE(c)					\
+  ({							\
+    const StgInfoTable *__info;				\
+    __info = &WHITEHOLE_info;				\
+    do {						\
+      XCHG(__info,((StgClosure *)(c))->header.info);	\
+    } while (__info == &WHITEHOLE_info);		\
+    __info;						\
+  })
+
+#define LOCK_THUNK(__info)				\
+  CMPXCHG(R1.cl->header.info, __info, &WHITEHOLE_info);
+
+#define ACQUIRE_LOCK(mutex) pthread_mutex_lock(mutex);
+#define RELEASE_LOCK(mutex) pthread_mutex_unlock(mutex);
+
+#else /* !SMP */
+
+#define LOCK_CLOSURE(c)     /* nothing */
+#define LOCK_THUNK(__info)  /* nothing */
+#define ACQUIRE_LOCK(mutex) /* nothing */
+#define RELEASE_LOCK(mutex) /* nothing */
+
+#endif /* SMP */
+
+#endif /* SMP_H */
diff --git a/ghc/includes/SchedAPI.h b/ghc/includes/SchedAPI.h
index b682dfd686..02c308d661 100644
--- a/ghc/includes/SchedAPI.h
+++ b/ghc/includes/SchedAPI.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: SchedAPI.h,v 1.6 1999/07/06 09:42:39 sof Exp $
+ * $Id: SchedAPI.h,v 1.7 1999/11/02 15:05:52 simonmar Exp $
  *
  * (c) The GHC Team 1998
  *
@@ -17,13 +17,14 @@
  * not compiling rts/ bits.   -- sof 7/99
  * 
  */
-SchedulerStatus schedule(StgTSO *main_thread, /*out*/StgClosure **ret);
+SchedulerStatus waitThread(StgTSO *main_thread, /*out*/StgClosure **ret);
 
 /* 
  * Creating threads
  */
 
-StgTSO *createThread   (nat stack_size);
+StgTSO *createThread(nat stack_size);
+void scheduleThread(StgTSO *tso);
 
 static inline void pushClosure   (StgTSO *tso, StgClosure *c) {
   tso->sp--;
diff --git a/ghc/includes/Stg.h b/ghc/includes/Stg.h
index 9b2ab0d5c0..756e8fb51a 100644
--- a/ghc/includes/Stg.h
+++ b/ghc/includes/Stg.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Stg.h,v 1.17 1999/07/06 09:42:39 sof Exp $
+ * $Id: Stg.h,v 1.18 1999/11/02 15:05:52 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -16,6 +16,17 @@
 #define _POSIX_SOURCE
 #endif
 
+/* If we include "Stg.h" directly, we're in STG code, and we therefore
+ * get all the global register variables, macros etc. that go along
+ * with that.  If "Stg.h" is included via "Rts.h", we're assumed to
+ * be in vanilla C.
+ */
+#ifdef NOT_IN_STG_CODE
+#define NO_REGS			/* don't define fixed registers */
+#else
+#define IN_STG_CODE
+#endif
+
 /* Configuration */
 #include "config.h"
 #ifdef __HUGS__ /* vile hack till the GHC folks come on board */
@@ -33,13 +44,17 @@
  * For now, do lazy and not eager.
  */
 
-#define LAZY_BLACKHOLING
-/* #define EAGER_BLACKHOLING */
-
-#ifdef TICKY_TICKY
-/* TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of single-entry thunks. */
-# undef  LAZY_BLACKHOLING 
-# define EAGER_BLACKHOLING
+/* TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of
+ * single-entry thunks.
+ *
+ * SMP needs EAGER_BLACKHOLING because it has to lock thunks
+ * synchronously, in case another thread is trying to evaluate the
+ * same thunk simultaneously.
+ */
+#if defined(SMP) || defined(TICKY_TICKY)
+#  define EAGER_BLACKHOLING
+#else
+#  define LAZY_BLACKHOLING
 #endif
 
 /* ToDo: Set this flag properly: COMPILER and INTERPRETER should not be mutually exclusive. */
@@ -96,8 +111,10 @@ void _stgAssert (char *, unsigned int);
 #include "ClosureTypes.h"
 #include "InfoTables.h"
 #include "TSO.h"
+#include "Block.h"
 
 /* STG/Optimised-C related stuff */
+#include "SMP.h"
 #include "MachRegs.h"
 #include "Regs.h"
 #include "TailCalls.h"
@@ -121,6 +138,10 @@ void _stgAssert (char *, unsigned int);
 #include <unistd.h>
 #endif
 
+#ifdef SMP
+#include <pthread.h>
+#endif
+
 /* GNU mp library */
 #include "gmp.h"
 
diff --git a/ghc/includes/StgMacros.h b/ghc/includes/StgMacros.h
index 3dec7513b0..b14ab43a82 100644
--- a/ghc/includes/StgMacros.h
+++ b/ghc/includes/StgMacros.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: StgMacros.h,v 1.13 1999/10/13 16:39:21 simonmar Exp $
+ * $Id: StgMacros.h,v 1.14 1999/11/02 15:05:52 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -416,12 +416,23 @@ EDI_(stg_gen_chk_info);
 #define SET_TAG(t)  /* nothing */
 
 #ifdef EAGER_BLACKHOLING
-#  define UPD_BH_UPDATABLE(thunk)                        \
-        TICK_UPD_BH_UPDATABLE();                         \
-        SET_INFO((StgClosure *)thunk,&BLACKHOLE_info)
-#  define UPD_BH_SINGLE_ENTRY(thunk)                     \
-        TICK_UPD_BH_SINGLE_ENTRY();                      \
-        SET_INFO((StgClosure *)thunk,&SE_BLACKHOLE_info)
+#  ifdef SMP
+#    define UPD_BH_UPDATABLE(info)		\
+        TICK_UPD_BH_UPDATABLE();		\
+        LOCK_THUNK(info);			\
+        SET_INFO(R1.cl,&BLACKHOLE_info)
+#    define UPD_BH_SINGLE_ENTRY(info)		\
+        TICK_UPD_BH_SINGLE_ENTRY();		\
+        LOCK_THUNK(info);			\
+        SET_INFO(R1.cl,&BLACKHOLE_info)
+#  else
+#    define UPD_BH_UPDATABLE(info)		\
+        TICK_UPD_BH_UPDATABLE();		\
+        SET_INFO(R1.cl,&BLACKHOLE_info)
+#    define UPD_BH_SINGLE_ENTRY(info)		\
+        TICK_UPD_BH_SINGLE_ENTRY();		\
+        SET_INFO(R1.cl,&SE_BLACKHOLE_info)
+#  endif
 #else /* !EAGER_BLACKHOLING */
 #  define UPD_BH_UPDATABLE(thunk)    /* nothing */
 #  define UPD_BH_SINGLE_ENTRY(thunk) /* nothing */
@@ -642,10 +653,15 @@ extern DLL_IMPORT_DATA const StgPolyInfoTable seq_frame_info;
    We save all the STG registers (that is, the ones that are mapped to
    machine registers) in their places in the TSO.  
 
-   The stack registers go into the current stack object, and the heap
-   registers are saved in global locations.
+   The stack registers go into the current stack object, and the
+   current nursery is updated from the heap pointer.
+
+   These functions assume that BaseReg is loaded appropriately (if
+   we have one).
    -------------------------------------------------------------------------- */
 
+#ifndef NO_REGS
+
 static __inline__ void
 SaveThreadState(void)
 {
@@ -656,6 +672,12 @@ SaveThreadState(void)
   CurrentTSO->splim    = SpLim;
   CloseNursery(Hp);
 
+#ifdef REG_CurrentTSO
+  SAVE_CurrentTSO = CurrentTSO;
+#endif
+#ifdef REG_CurrentNursery
+  SAVE_CurrentNursery = CurrentNursery;
+#endif
 #if defined(PROFILING)
   CurrentTSO->prof.CCCS = CCCS;
 #endif
@@ -664,19 +686,30 @@ SaveThreadState(void)
 static __inline__ void 
 LoadThreadState (void)
 {
-#ifdef REG_Base
-  BaseReg = (StgRegTable*)&MainRegTable;
-#endif
-
   Sp    = CurrentTSO->sp;
   Su    = CurrentTSO->su;
   SpLim = CurrentTSO->splim;
   OpenNursery(Hp,HpLim);
 
+#ifdef REG_CurrentTSO
+  CurrentTSO = SAVE_CurrentTSO;
+#endif
+#ifdef REG_CurrentNursery
+  CurrentNursery = SAVE_CurrentNursery;
+#endif
 # if defined(PROFILING)
   CCCS = CurrentTSO->prof.CCCS;
 # endif
 }
 
+/* 
+ * Suspending/resuming threads for doing external C-calls (_ccall_GC).
+ * These functions are defined in rts/Schedule.c.
+ */
+StgInt        suspendThread ( StgRegTable *cap );
+StgRegTable * resumeThread  ( StgInt );
+
+#endif /* NO_REGS */
+
 #endif /* STGMACROS_H */
 
diff --git a/ghc/includes/StgMiscClosures.h b/ghc/includes/StgMiscClosures.h
index c1ac9f078e..d9c3489fd1 100644
--- a/ghc/includes/StgMiscClosures.h
+++ b/ghc/includes/StgMiscClosures.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.14 1999/07/06 16:17:40 sewardj Exp $
+ * $Id: StgMiscClosures.h,v 1.15 1999/11/02 15:05:53 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -24,6 +24,9 @@ STGFUN(CAF_ENTERED_entry);
 STGFUN(CAF_BLACKHOLE_entry);
 STGFUN(BLACKHOLE_entry);
 STGFUN(BLACKHOLE_BQ_entry);
+#ifdef SMP
+STGFUN(WHITEHOLE_entry);
+#endif
 #ifdef TICKY_TICKY
 STGFUN(SE_BLACKHOLE_entry);
 STGFUN(SE_CAF_BLACKHOLE_entry);
@@ -59,6 +62,9 @@ extern DLL_IMPORT_RTS const StgInfoTable CAF_ENTERED_info;
 extern DLL_IMPORT_RTS const StgInfoTable CAF_BLACKHOLE_info;
 extern DLL_IMPORT_RTS const StgInfoTable BLACKHOLE_info;
 extern DLL_IMPORT_RTS const StgInfoTable BLACKHOLE_BQ_info;
+#ifdef SMP
+extern DLL_IMPORT_RTS const StgInfoTable WHITEHOLE_info;
+#endif
 #ifdef TICKY_TICKY
 extern DLL_IMPORT_RTS const StgInfoTable SE_BLACKHOLE_info;
 extern DLL_IMPORT_RTS const StgInfoTable SE_CAF_BLACKHOLE_info;
diff --git a/ghc/includes/StgStorage.h b/ghc/includes/StgStorage.h
index 6b1237e384..6c9b0d3503 100644
--- a/ghc/includes/StgStorage.h
+++ b/ghc/includes/StgStorage.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: StgStorage.h,v 1.4 1999/03/02 19:44:21 sof Exp $
+ * $Id: StgStorage.h,v 1.5 1999/11/02 15:05:53 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -10,10 +10,6 @@
 #ifndef STGSTORAGE_H
 #define STGSTORAGE_H
 
-#include "Block.h"
-
-extern DLL_IMPORT_RTS bdescr *current_nursery;
-
 /* -----------------------------------------------------------------------------
    Allocation area for compiled code
 
@@ -29,10 +25,10 @@ extern DLL_IMPORT_RTS bdescr *current_nursery;
    -------------------------------------------------------------------------- */
 
 #define OpenNursery(hp,hplim)				\
-  (hp    = current_nursery->free-1,			\
-   hplim = current_nursery->start + BLOCK_SIZE_W - 1)
+  (hp    = CurrentNursery->free-1,			\
+   hplim = CurrentNursery->start + BLOCK_SIZE_W - 1)
   
-#define CloseNursery(hp)  (current_nursery->free = (P_)(hp)+1)
+#define CloseNursery(hp)  (CurrentNursery->free = (P_)(hp)+1)
 
 /* -----------------------------------------------------------------------------
    Trigger a GC from Haskell land.
diff --git a/ghc/includes/Updates.h b/ghc/includes/Updates.h
index e33b4b3d28..cf8eabce17 100644
--- a/ghc/includes/Updates.h
+++ b/ghc/includes/Updates.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Updates.h,v 1.13 1999/10/20 10:14:47 simonmar Exp $
+ * $Id: Updates.h,v 1.14 1999/11/02 15:05:53 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -35,10 +35,25 @@
 /* UPD_IND actually does a PERM_IND if TICKY_TICKY is on;
    if you *really* need an IND use UPD_REAL_IND
  */
-#define UPD_REAL_IND(updclosure, heapptr)                       \
-        AWAKEN_BQ(updclosure);                                  \
+#ifdef SMP
+#define UPD_REAL_IND(updclosure, heapptr)		\
+   {							\
+	const StgInfoTable *info;			\
+	info = LOCK_CLOSURE(updclosure);		\
+							\
+     	if (info == &BLACKHOLE_BQ_info) {				\
+	   STGCALL1(awakenBlockedQueue, 				\
+		    ((StgBlockingQueue *)updclosure)->blocking_queue); 	\
+	}						\
 	updateWithIndirection((StgClosure *)updclosure,         \
+			      (StgClosure *)heapptr);		\
+   }
+#else
+#define UPD_REAL_IND(updclosure, heapptr)		\
+        AWAKEN_BQ(updclosure);				\
+	updateWithIndirection((StgClosure *)updclosure,	\
 			      (StgClosure *)heapptr);
+#endif
 
 #if defined(PROFILING) || defined(TICKY_TICKY)
 #define UPD_PERM_IND(updclosure, heapptr)                       \
@@ -110,11 +125,12 @@ extern DLL_IMPORT_DATA const StgPolyInfoTable Upd_frame_info;
 
 extern void newCAF(StgClosure*);
 
-#define UPD_CAF(cafptr, bhptr)					\
-  {								\
-    SET_INFO((StgInd *)cafptr,(const StgInfoTable*)&IND_STATIC_info);	        \
-    ((StgInd *)cafptr)->indirectee   = (StgClosure *)(bhptr);	\
-    STGCALL1(newCAF,(StgClosure *)cafptr);			\
+#define UPD_CAF(cafptr, bhptr)						\
+  {									\
+    LOCK_CLOSURE(cafptr);						\
+    ((StgInd *)cafptr)->indirectee   = (StgClosure *)(bhptr);		\
+    SET_INFO((StgInd *)cafptr,(const StgInfoTable*)&IND_STATIC_info);	\
+    STGCALL1(newCAF,(StgClosure *)cafptr);				\
   }
 
 /* -----------------------------------------------------------------------------
diff --git a/ghc/rts/BlockAlloc.h b/ghc/rts/BlockAlloc.h
index ab6b199740..a2c9b2b594 100644
--- a/ghc/rts/BlockAlloc.h
+++ b/ghc/rts/BlockAlloc.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: BlockAlloc.h,v 1.5 1999/02/05 16:02:36 simonm Exp $
+ * $Id: BlockAlloc.h,v 1.6 1999/11/02 15:05:56 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -26,7 +26,7 @@ extern void freeChain(bdescr *p);
 
 /* Finding the block descriptor for a given block -------------------------- */
 
-static inline bdescr *Bdescr(StgPtr p)
+extern inline bdescr *Bdescr(StgPtr p)
 {
   return (bdescr *)
     ((((W_)p &  MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT)) 
diff --git a/ghc/rts/ClosureFlags.c b/ghc/rts/ClosureFlags.c
index b3101d0ab6..439e1b7e22 100644
--- a/ghc/rts/ClosureFlags.c
+++ b/ghc/rts/ClosureFlags.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: ClosureFlags.c,v 1.2 1999/05/11 16:47:49 keithw Exp $
+ * $Id: ClosureFlags.c,v 1.3 1999/11/02 15:05:56 simonmar Exp $
  *
  * (c) The GHC Team 1998-1999
  *
@@ -54,7 +54,7 @@ StgWord16 closure_flags[] = {
 /* IND_STATIC	   	*/ (              _STA                   ),
 /* CAF_UNENTERED        */ ( 0                                   ),
 /* CAF_ENTERED          */ ( 0                                   ),
-/* CAF_BLACKHOLE        */ ( 	 _BTM|_NS|              _UPT     ),
+/* BLACKHOLE_BQ	   	*/ ( 	 _BTM|_NS|         _MUT|_UPT     ),
 /* RET_BCO		*/ (     _BTM                            ),
 /* RET_SMALL		*/ (     _BTM|                       _SRT),
 /* RET_VEC_SMALL	*/ (     _BTM|                       _SRT),
diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index 124e22001c..02daeec1e2 100644
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.64 1999/11/01 18:17:45 sewardj Exp $
+ * $Id: GC.c,v 1.65 1999/11/02 15:05:56 simonmar Exp $
  *
  * (c) The GHC Team 1998-1999
  *
@@ -162,25 +162,8 @@ void GarbageCollect(void (*get_roots)(void))
   CCCS = CCS_GC;
 #endif
 
-  /* We might have been called from Haskell land by _ccall_GC, in
-   * which case we need to call threadPaused() because the scheduler
-   * won't have done it.
-   */
-  if (CurrentTSO) { threadPaused(CurrentTSO); }
-
-  /* Approximate how much we allocated: number of blocks in the
-   * nursery + blocks allocated via allocate() - unused nusery blocks.
-   * This leaves a little slop at the end of each block, and doesn't
-   * take into account large objects (ToDo).
-   */
-  allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
-  for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
-    allocated -= BLOCK_SIZE_W;
-  }
-  if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
-    allocated -= (current_nursery->start + BLOCK_SIZE_W)
-      - current_nursery->free;
-  }
+  /* Approximate how much we allocated */
+  allocated = calcAllocated();
 
   /* Figure out which generation to collect
    */
@@ -334,12 +317,6 @@ void GarbageCollect(void (*get_roots)(void))
   evac_gen = 0;
   get_roots();
 
-  /* And don't forget to mark the TSO if we got here direct from
-   * Haskell! */
-  if (CurrentTSO) {
-    CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
-  }
-
   /* Mark the weak pointer list, and prepare to detect dead weak
    * pointers.
    */
@@ -669,13 +646,7 @@ void GarbageCollect(void (*get_roots)(void))
 
   /* Reset the nursery
    */
-  for (bd = g0s0->blocks; bd; bd = bd->link) {
-    bd->free = bd->start;
-    ASSERT(bd->gen == g0);
-    ASSERT(bd->step == g0s0);
-    IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
-  }
-  current_nursery = g0s0->blocks;
+  resetNurseries();
 
   /* start any pending finalizers */
   scheduleFinalizers(old_weak_ptr_list);
@@ -2919,9 +2890,10 @@ threadSqueezeStack(StgTSO *tso)
 #endif
 
       TICK_UPD_SQUEEZED();
-      /* wasn't there something about update squeezing and ticky to be sorted out?
-       * oh yes: we aren't counting each enter properly in this case.  See the log somewhere.
-       * KSW 1999-04-21 */
+      /* wasn't there something about update squeezing and ticky to be
+       * sorted out?  oh yes: we aren't counting each enter properly
+       * in this case.  See the log somewhere.  KSW 1999-04-21
+       */
       UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
       
       sp = (P_)frame - 1;	/* sp = stuff to slide */
diff --git a/ghc/rts/Main.c b/ghc/rts/Main.c
index 01c05e6089..a15a0375b1 100644
--- a/ghc/rts/Main.c
+++ b/ghc/rts/Main.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Main.c,v 1.11 1999/09/16 08:29:01 sof Exp $
+ * $Id: Main.c,v 1.12 1999/11/02 15:05:58 simonmar Exp $
  *
  * (c) The GHC Team 1998-1999
  *
@@ -13,7 +13,6 @@
 #include "RtsAPI.h"
 #include "SchedAPI.h"
 #include "RtsFlags.h"
-#include "Schedule.h"  /* for MainTSO */
 #include "RtsUtils.h"
 
 #ifdef DEBUG
@@ -45,19 +44,14 @@ int main(int argc, char *argv[])
     startupHaskell(argc,argv);
 
 #  ifndef PAR
-    MainTSO = createIOThread(stg_max(BLOCK_SIZE_W,
-				     RtsFlags.GcFlags.initialStkSize),
-			     (StgClosure *)&mainIO_closure);
-    status = schedule(MainTSO,NULL);
+    /* ToDo: want to start with a larger stack size */
+    status = rts_evalIO((StgClosure *)&mainIO_closure, NULL);
 #  else
     if (IAmMainThread == rtsTrue) {
     /*Just to show we're alive */
       fprintf(stderr, "Main Thread Started ...\n");
      
-      MainTSO = createIOThread(stg_max(BLOCK_SIZE_W,
-				       RtsFlags.GcFlags.initialStkSize),
-			       (StgClosure *)&mainIO_closure);
-      status = schedule(MainTSO,NULL);
+      status = rts_evalIO((StgClosure *)&mainIO_closure, NULL);
     } else {
       WaitForPEOp(PP_FINISH,SysManTask);
       exit(EXIT_SUCCESS);
diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index f1e521d0db..72a9584c62 100644
--- a/ghc/rts/PrimOps.hc
+++ b/ghc/rts/PrimOps.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.32 1999/10/15 09:50:22 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.33 1999/11/02 15:05:58 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -790,6 +790,7 @@ FN_(forkzh_fast)
   /* create it right now, return ThreadID in R1 */
   R1.t = RET_STGCALL2(StgTSO *, createIOThread, 
 		      RtsFlags.GcFlags.initialStkSize, R1.cl);
+  STGCALL1(scheduleThread, R1.t);
       
   /* switch at the earliest opportunity */ 
   context_switch = 1;
@@ -868,16 +869,23 @@ FN_(takeMVarzh_fast)
 {
   StgMVar *mvar;
   StgClosure *val;
+  const StgInfoTable *info;
 
   FB_
   /* args: R1 = MVar closure */
 
   mvar = (StgMVar *)R1.p;
 
+#ifdef SMP
+  info = LOCK_CLOSURE(mvar);
+#else
+  info = GET_INFO(mvar);
+#endif
+
   /* 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 (info == &EMPTY_MVAR_info) {
     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
       mvar->head = CurrentTSO;
     } else {
@@ -888,13 +896,21 @@ FN_(takeMVarzh_fast)
     CurrentTSO->block_info.closure = (StgClosure *)mvar;
     mvar->tail = CurrentTSO;
 
+#ifdef SMP
+    /* unlock the MVar */
+    mvar->header.info = &EMPTY_MVAR_info;
+#endif
     BLOCK(R1_PTR, takeMVarzh_fast);
   }
 
-  SET_INFO(mvar,&EMPTY_MVAR_info);
   val = mvar->value;
   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 
+  /* do this last... we might have locked the MVar in the SMP case,
+   * and writing the info pointer will unlock it.
+   */
+  SET_INFO(mvar,&EMPTY_MVAR_info);
+
   TICK_RET_UNBOXED_TUP(1);
   RET_P(val);
   FE_
@@ -903,17 +919,24 @@ FN_(takeMVarzh_fast)
 FN_(putMVarzh_fast)
 {
   StgMVar *mvar;
+  const StgInfoTable *info;
 
   FB_
   /* args: R1 = MVar, R2 = value */
 
   mvar = (StgMVar *)R1.p;
-  if (GET_INFO(mvar) == &FULL_MVAR_info) {
+
+#ifdef SMP
+  info = LOCK_CLOSURE(mvar);
+#else
+  info = GET_INFO(mvar);
+#endif
+
+  if (info == &FULL_MVAR_info) {
     fprintf(stderr, "putMVar#: MVar already full.\n");
     stg_exit(EXIT_FAILURE);
   }
   
-  SET_INFO(mvar,&FULL_MVAR_info);
   mvar->value = R2.cl;
 
   /* wake up the first thread on the queue, it will continue with the
@@ -927,6 +950,9 @@ FN_(putMVarzh_fast)
     }
   }
 
+  /* unlocks the MVar in the SMP case */
+  SET_INFO(mvar,&FULL_MVAR_info);
+
   /* ToDo: yield here for better communication performance? */
   JMP_(ENTRY_CODE(Sp[0]));
   FE_
@@ -974,7 +1000,9 @@ FN_(waitReadzh_fast)
     ASSERT(CurrentTSO->why_blocked == NotBlocked);
     CurrentTSO->why_blocked = BlockedOnRead;
     CurrentTSO->block_info.fd = R1.i;
-    PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
+    ACQUIRE_LOCK(&sched_mutex);
+    APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+    RELEASE_LOCK(&sched_mutex);
     JMP_(stg_block_noregs);
   FE_
 }
@@ -986,7 +1014,9 @@ FN_(waitWritezh_fast)
     ASSERT(CurrentTSO->why_blocked == NotBlocked);
     CurrentTSO->why_blocked = BlockedOnWrite;
     CurrentTSO->block_info.fd = R1.i;
-    PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
+    ACQUIRE_LOCK(&sched_mutex);
+    APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+    RELEASE_LOCK(&sched_mutex);
     JMP_(stg_block_noregs);
   FE_
 }
@@ -1003,7 +1033,9 @@ FN_(delayzh_fast)
      */
     CurrentTSO->block_info.delay = R1.i + ticks_since_select;
 
-    PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
+    ACQUIRE_LOCK(&sched_mutex);
+    APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+    RELEASE_LOCK(&sched_mutex);
     JMP_(stg_block_noregs);
   FE_
 }
diff --git a/ghc/rts/Profiling.c b/ghc/rts/Profiling.c
index fdd26c2250..e6b5734b2d 100644
--- a/ghc/rts/Profiling.c
+++ b/ghc/rts/Profiling.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Profiling.c,v 1.9 1999/09/15 13:45:18 simonmar Exp $
+ * $Id: Profiling.c,v 1.10 1999/11/02 15:05:59 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -356,8 +356,10 @@ AppendCCS ( CostCentreStack *ccs1, CostCentreStack *ccs2 )
     return ccs1;
   }
   
-  ASSERT(ccs2->prevStack != NULL);
-  ccs = AppendCCS(ccs1, ccs2->prevStack);
+  if (ccs2->prevStack != NULL) {
+    ccs = AppendCCS(ccs1, ccs2->prevStack);
+  }
+
   return PushCostCentre(ccs,ccs2->cc);
 }
 
diff --git a/ghc/rts/RtsAPI.c b/ghc/rts/RtsAPI.c
index 79c33a8861..fb4df6ced2 100644
--- a/ghc/rts/RtsAPI.c
+++ b/ghc/rts/RtsAPI.c
@@ -1,5 +1,5 @@
 /* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.9 1999/10/15 11:03:10 sewardj Exp $
+ * $Id: RtsAPI.c,v 1.10 1999/11/02 15:05:59 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -331,14 +331,16 @@ SchedulerStatus
 rts_eval (HaskellObj p, /*out*/HaskellObj *ret)
 {
   StgTSO *tso = createGenThread(RtsFlags.GcFlags.initialStkSize, p);
-  return schedule(tso, ret);
+  scheduleThread(tso);
+  return waitThread(tso, ret);
 }
 
 SchedulerStatus
 rts_eval_ (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 {
   StgTSO *tso = createGenThread(stack_size, p);
-  return schedule(tso, ret);
+  scheduleThread(tso);
+  return waitThread(tso, ret);
 }
 
 /*
@@ -349,7 +351,8 @@ SchedulerStatus
 rts_evalIO (HaskellObj p, /*out*/HaskellObj *ret)
 {
   StgTSO* tso = createStrictIOThread(RtsFlags.GcFlags.initialStkSize, p);
-  return schedule(tso, ret);
+  scheduleThread(tso);
+  return waitThread(tso, ret);
 }
 
 /*
@@ -359,7 +362,8 @@ SchedulerStatus
 rts_evalLazyIO (HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret)
 {
   StgTSO *tso = createIOThread(stack_size, p);
-  return schedule(tso, ret);
+  scheduleThread(tso);
+  return waitThread(tso, ret);
 }
 
 /* Convenience function for decoding the returned status. */
diff --git a/ghc/rts/RtsFlags.c b/ghc/rts/RtsFlags.c
index 65cf5019b0..eac04b1d3e 100644
--- a/ghc/rts/RtsFlags.c
+++ b/ghc/rts/RtsFlags.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.19 1999/09/15 13:45:19 simonmar Exp $
+ * $Id: RtsFlags.c,v 1.20 1999/11/02 15:06:00 simonmar Exp $
  *
  * (c) The AQUA Project, Glasgow University, 1994-1997
  * (c) The GHC Team, 1998-1999
@@ -102,6 +102,9 @@ void initRtsFlagsDefaults(void)
 #endif
 
     RtsFlags.ConcFlags.ctxtSwitchTime	= CS_MIN_MILLISECS;  /* In milliseconds */
+#ifdef SMP
+    RtsFlags.ConcFlags.nNodes	= 1;
+#endif
 #ifdef PAR
     RtsFlags.ParFlags.parallelStats	= rtsFalse;
     RtsFlags.ParFlags.granSimStats	= rtsFalse;
@@ -267,6 +270,9 @@ usage_text[] = {
 "  -C<secs>  Context-switch interval in seconds",
 "                (0 or no argument means switch as often as possible)",
 "                the default is .01 sec; resolution is .01 sec",
+# ifdef SMP
+"  -N<n>     Use <n> OS threads (default: 1)",
+# endif
 # ifdef PAR
 "  -q        Enable activity profile (output files in ~/<program>*.gr)",
 "  -qb       Enable binary activity profile (output file /tmp/<program>.gb)",
@@ -718,6 +724,18 @@ error = rtsTrue;
 		}
     	    	break;
 
+#ifdef SMP
+	      case 'N':
+		if (rts_argv[arg][2] != '\0') {
+		    RtsFlags.ConcFlags.nNodes
+		      = strtol(rts_argv[arg]+2, (char **) NULL, 10);
+		    if (RtsFlags.ConcFlags.nNodes <= 0) {
+			fprintf(stderr, "setupRtsFlags: bad value for -N\n");
+			error = rtsTrue;
+		    }
+		}
+		break;
+#endif
 	      /* =========== PARALLEL =========================== */
 	      case 'e':
 		PAR_BUILD_ONLY(
diff --git a/ghc/rts/RtsFlags.h b/ghc/rts/RtsFlags.h
index 01caf04813..4e2443bcd0 100644
--- a/ghc/rts/RtsFlags.h
+++ b/ghc/rts/RtsFlags.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.16 1999/09/15 13:45:19 simonmar Exp $
+ * $Id: RtsFlags.h,v 1.17 1999/11/02 15:06:00 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -118,7 +118,10 @@ struct PROFILING_FLAGS {
 #endif /* DEBUG || PROFILING */
 
 struct CONCURRENT_FLAGS {
-    int	    ctxtSwitchTime; /* in milliseconds */
+  int	  ctxtSwitchTime; /* in milliseconds */
+#ifdef SMP
+  nat     nNodes;         /* number of threads to run simultaneously */
+#endif
 };
 
 #ifdef PAR
diff --git a/ghc/rts/RtsStartup.c b/ghc/rts/RtsStartup.c
index 7b91e403c3..9d3c99cd2c 100644
--- a/ghc/rts/RtsStartup.c
+++ b/ghc/rts/RtsStartup.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.21 1999/09/22 11:53:33 sof Exp $
+ * $Id: RtsStartup.c,v 1.22 1999/11/02 15:06:01 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -101,6 +101,11 @@ startupHaskell(int argc, char *argv[])
     */
 #endif	/* PAR */
 
+    /* initialise scheduler data structures (needs to be done before
+     * initStorage()).
+     */
+    initScheduler();
+
     /* initialize the storage manager */
     initStorage();
 
@@ -115,8 +120,10 @@ startupHaskell(int argc, char *argv[])
     install_vtalrm_handler();
     initialize_virtual_timer(TICK_MILLISECS);
 
-    /* Initialise the scheduler */
-    initScheduler();
+    /* start our haskell execution tasks */
+#ifdef SMP
+    startTasks();
+#endif
 
     /* Initialise the stats department */
     initStats();
@@ -176,6 +183,9 @@ shutdownHaskell(void)
     end_gr_simulation();
 #endif
 
+  /* stop all running tasks */
+  exitScheduler();
+
   /* clean up things from the storage manager's point of view */
   exitStorage();
 
diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c
index 9ad20d106f..720386d8c7 100644
--- a/ghc/rts/Schedule.c
+++ b/ghc/rts/Schedule.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.27 1999/10/19 15:41:18 simonmar Exp $
+ * $Id: Schedule.c,v 1.28 1999/11/02 15:06:01 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -7,6 +7,26 @@
  *
  * ---------------------------------------------------------------------------*/
 
+/* Version with scheduler monitor support for SMPs.
+
+   This design provides a high-level API to create and schedule threads etc.
+   as documented in the SMP design document.
+
+   It uses a monitor design controlled by a single mutex to exercise control
+   over accesses to shared data structures, and builds on the Posix threads
+   library.
+
+   The majority of state is shared.  In order to keep essential per-task state,
+   there is a Capability structure, which contains all the information
+   needed to run a thread: its STG registers, a pointer to its TSO, a
+   nursery etc.  During STG execution, a pointer to the capability is
+   kept in a register (BaseReg).
+
+   In a non-SMP build, there is one global capability, namely MainRegTable.
+
+   SDM & KH, 10/99
+*/
+
 #include "Rts.h"
 #include "SchedAPI.h"
 #include "RtsUtils.h"
@@ -25,24 +45,68 @@
 #include "Signals.h"
 #include "Profiling.h"
 #include "Sanity.h"
+#include "Stats.h"
 
+/* Main threads:
+ *
+ * These are the threads which clients have requested that we run.  
+ *
+ * In an SMP build, we might have several concurrent clients all
+ * waiting for results, and each one will wait on a condition variable
+ * until the result is available.
+ *
+ * In non-SMP, clients are strictly nested: the first client calls
+ * into the RTS, which might call out again to C with a _ccall_GC, and
+ * eventually re-enter the RTS.
+ *
+ * Main threads information is kept in a linked list:
+ */
+typedef struct StgMainThread_ {
+  StgTSO *         tso;
+  SchedulerStatus  stat;
+  StgClosure **    ret;
+#ifdef SMP
+  pthread_cond_t wakeup;
+#endif
+  struct StgMainThread_ *link;
+} StgMainThread;
+
+/* Main thread queue.
+ * Locks required: sched_mutex.
+ */
+static StgMainThread *main_threads;
+
+/* Thread queues.
+ * Locks required: sched_mutex.
+ */
 StgTSO *run_queue_hd, *run_queue_tl;
 StgTSO *blocked_queue_hd, *blocked_queue_tl;
-StgTSO *ccalling_threads;
 
-#define MAX_SCHEDULE_NESTING 256
-nat next_main_thread;
-StgTSO *main_threads[MAX_SCHEDULE_NESTING];
+/* Threads suspended in _ccall_GC.
+ * Locks required: sched_mutex.
+ */
+static StgTSO *suspended_ccalling_threads;
+
+#ifndef SMP
+static rtsBool in_ccall_gc;
+#endif
 
 static void GetRoots(void);
 static StgTSO *threadStackOverflow(StgTSO *tso);
 
+/* KH: The following two flags are shared memory locations.  There is no need
+       to lock them, since they are only unset at the end of a scheduler
+       operation.
+*/
+
 /* flag set by signal handler to precipitate a context switch */
 nat context_switch;
 /* if this flag is set as well, give up execution */
 static nat interrupted;
 
-/* Next thread ID to allocate */
+/* Next thread ID to allocate.
+ * Locks required: sched_mutex
+ */
 StgThreadID next_thread_id = 1;
 
 /*
@@ -50,14 +114,7 @@ StgThreadID next_thread_id = 1;
  * Rule of thumb: if CurrentTSO != NULL, then we're running a Haskell
  * thread.  If CurrentTSO == NULL, then we're at the scheduler level.
  */
-StgTSO      *CurrentTSO;
-StgRegTable  MainRegTable;
-
-/*
- * The thread state for the main thread.
- */
-StgTSO   *MainTSO;
-
+ 
 /* The smallest stack size that makes any sense is:
  *    RESERVED_STACK_WORDS    (so we can get back from the stack overflow)
  *  + sizeofW(StgStopFrame)   (the stg_stop_thread_info frame)
@@ -70,6 +127,440 @@ StgTSO   *MainTSO;
 
 #define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 2)
 
+/* Free capability list.
+ * Locks required: sched_mutex.
+ */
+#ifdef SMP
+Capability *free_capabilities;	/* Available capabilities for running threads */
+nat n_free_capabilities;        /* total number of available capabilities */
+#else
+Capability MainRegTable;	/* for non-SMP, we have one global capability */
+#endif
+
+rtsBool ready_to_gc;
+
+/* All our current task ids, saved in case we need to kill them later.
+ */
+#ifdef SMP
+task_info *task_ids;
+#endif
+
+void            addToBlockedQueue ( StgTSO *tso );
+
+static void     schedule          ( void );
+static void     initThread        ( StgTSO *tso, nat stack_size );
+static void     interruptStgRts   ( void );
+
+#ifdef SMP
+pthread_mutex_t sched_mutex       = PTHREAD_MUTEX_INITIALIZER;
+pthread_mutex_t term_mutex        = PTHREAD_MUTEX_INITIALIZER;
+pthread_cond_t  thread_ready_cond = PTHREAD_COND_INITIALIZER;
+pthread_cond_t  gc_pending_cond   = PTHREAD_COND_INITIALIZER;
+
+nat await_death;
+#endif
+
+/* -----------------------------------------------------------------------------
+   Main scheduling loop.
+
+   We use round-robin scheduling, each thread returning to the
+   scheduler loop when one of these conditions is detected:
+
+      * out of heap space
+      * timer expires (thread yields)
+      * thread blocks
+      * thread ends
+      * stack overflow
+
+   Locking notes:  we acquire the scheduler lock once at the beginning
+   of the scheduler loop, and release it when
+    
+      * running a thread, or
+      * waiting for work, or
+      * waiting for a GC to complete.
+
+   -------------------------------------------------------------------------- */
+
+static void
+schedule( void )
+{
+  StgTSO *t;
+  Capability *cap;
+  StgThreadReturnCode ret;
+  
+  ACQUIRE_LOCK(&sched_mutex);
+
+  while (1) {
+
+    /* Check whether any waiting threads need to be woken up.
+     * If the run queue is empty, we can wait indefinitely for
+     * something to happen.
+     */
+    if (blocked_queue_hd != END_TSO_QUEUE) {
+      awaitEvent(run_queue_hd == END_TSO_QUEUE);
+    }
+    
+    /* check for signals each time around the scheduler */
+#ifndef __MINGW32__
+    if (signals_pending()) {
+      start_signal_handlers();
+    }
+#endif
+
+#ifdef SMP
+    /* If there's a GC pending, don't do anything until it has
+     * completed.
+     */
+    if (ready_to_gc) {
+      IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): waiting for GC\n",
+				 pthread_self()););
+      pthread_cond_wait(&gc_pending_cond, &sched_mutex);
+    }
+    
+    /* block until we've got a thread on the run queue and a free
+     * capability.
+     */
+    while (run_queue_hd == END_TSO_QUEUE || free_capabilities == NULL) {
+      IF_DEBUG(scheduler,
+	       fprintf(stderr, "schedule (task %ld): waiting for work\n",
+		       pthread_self()););
+      pthread_cond_wait(&thread_ready_cond, &sched_mutex);
+      IF_DEBUG(scheduler,
+	       fprintf(stderr, "schedule (task %ld): work now available\n",
+		       pthread_self()););
+    }
+#endif
+  
+    /* grab a thread from the run queue
+     */
+    t = POP_RUN_QUEUE();
+    
+    /* grab a capability
+     */
+#ifdef SMP
+    cap = free_capabilities;
+    free_capabilities = cap->link;
+    n_free_capabilities--;
+#else
+    cap = &MainRegTable;
+#endif
+    
+    cap->rCurrentTSO = t;
+    
+    /* set the context_switch flag
+     */
+    if (run_queue_hd == END_TSO_QUEUE) 
+      context_switch = 0;
+    else
+      context_switch = 1;
+    
+    RELEASE_LOCK(&sched_mutex);
+    
+    /* Run the current thread 
+     */
+    switch (cap->rCurrentTSO->whatNext) {
+    case ThreadKilled:
+    case ThreadComplete:
+      /* Thread already finished, return to scheduler. */
+      ret = ThreadFinished;
+      break;
+    case ThreadEnterGHC:
+      ret = StgRun((StgFunPtr) stg_enterStackTop, cap);
+      break;
+    case ThreadRunGHC:
+      ret = StgRun((StgFunPtr) stg_returnToStackTop, cap);
+      break;
+    case ThreadEnterHugs:
+#ifdef INTERPRETER
+      {  
+	IF_DEBUG(scheduler,belch("schedule: entering Hugs"));	  
+	LoadThreadState();
+	/* CHECK_SENSIBLE_REGS(); */
+	{
+	  StgClosure* c = (StgClosure *)Sp[0];
+	  Sp += 1;
+	  ret = enter(c);
+	}	
+	SaveThreadState();
+	break;
+      }
+#else
+      barf("Panic: entered a BCO but no bytecode interpreter in this build");
+#endif
+    default:
+      barf("schedule: invalid whatNext field");
+    }
+    
+    /* Costs for the scheduler are assigned to CCS_SYSTEM */
+#ifdef PROFILING
+    CCCS = CCS_SYSTEM;
+#endif
+    
+    ACQUIRE_LOCK(&sched_mutex);
+
+#ifdef SMP
+    IF_DEBUG(scheduler,fprintf(stderr,"schedule (task %ld): ", pthread_self()););
+#else
+    IF_DEBUG(scheduler,fprintf(stderr,"schedule: "););
+#endif
+    t = cap->rCurrentTSO;
+    
+    switch (ret) {
+    case HeapOverflow:
+      /* make all the running tasks block on a condition variable,
+       * maybe set context_switch and wait till they all pile in,
+       * then have them wait on a GC condition variable.
+       */
+      IF_DEBUG(scheduler,belch("thread %ld stopped: HeapOverflow", t->id));
+      threadPaused(t);
+      
+      ready_to_gc = rtsTrue;
+      context_switch = 1;		/* stop other threads ASAP */
+      PUSH_ON_RUN_QUEUE(t);
+      break;
+      
+    case StackOverflow:
+      /* just adjust the stack for this thread, then pop it back
+       * on the run queue.
+       */
+      IF_DEBUG(scheduler,belch("thread %ld stopped, StackOverflow", t->id));
+      threadPaused(t);
+      { 
+	StgMainThread *m;
+	/* enlarge the stack */
+	StgTSO *new_t = threadStackOverflow(t);
+	
+	/* This TSO has moved, so update any pointers to it from the
+	 * main thread stack.  It better not be on any other queues...
+	 * (it shouldn't be)
+	 */
+	for (m = main_threads; m != NULL; m = m->link) {
+	  if (m->tso == t) {
+	    m->tso = new_t;
+	  }
+	}
+	PUSH_ON_RUN_QUEUE(new_t);
+      }
+      break;
+
+    case ThreadYielding:
+      /* put the thread back on the run queue.  Then, if we're ready to
+       * GC, check whether this is the last task to stop.  If so, wake
+       * up the GC thread.  getThread will block during a GC until the
+       * GC is finished.
+       */
+      IF_DEBUG(scheduler,
+	       if (t->whatNext == ThreadEnterHugs) {
+		 /* ToDo: or maybe a timer expired when we were in Hugs?
+		  * or maybe someone hit ctrl-C
+		  */
+		 belch("thread %ld stopped to switch to Hugs", t->id);
+	       } else {
+		 belch("thread %ld stopped, yielding", t->id);
+	       }
+	       );
+      threadPaused(t);
+      APPEND_TO_RUN_QUEUE(t);
+      break;
+      
+    case ThreadBlocked:
+      /* don't need to do anything.  Either the thread is blocked on
+       * I/O, in which case we'll have called addToBlockedQueue
+       * previously, or it's blocked on an MVar or Blackhole, in which
+       * case it'll be on the relevant queue already.
+       */
+      IF_DEBUG(scheduler,
+	       fprintf(stderr, "thread %d stopped, ", t->id);
+	       printThreadBlockage(t);
+	       fprintf(stderr, "\n"));
+      threadPaused(t);
+      break;
+      
+    case ThreadFinished:
+      /* Need to check whether this was a main thread, and if so, signal
+       * the task that started it with the return value.  If we have no
+       * more main threads, we probably need to stop all the tasks until
+       * we get a new one.
+       */
+      IF_DEBUG(scheduler,belch("thread %ld finished", t->id));
+      t->whatNext = ThreadComplete;
+      break;
+      
+    default:
+      barf("doneThread: invalid thread return code");
+    }
+    
+#ifdef SMP
+    cap->link = free_capabilities;
+    free_capabilities = cap;
+    n_free_capabilities++;
+#endif
+
+#ifdef SMP
+    if (ready_to_gc && n_free_capabilities == RtsFlags.ConcFlags.nNodes) {
+#else
+    if (ready_to_gc) {
+#endif
+      /* everybody back, start the GC.
+       * Could do it in this thread, or signal a condition var
+       * to do it in another thread.  Either way, we need to
+       * broadcast on gc_pending_cond afterward.
+       */
+#ifdef SMP
+      IF_DEBUG(scheduler,belch("schedule (task %ld): doing GC", pthread_self()));
+#endif
+      GarbageCollect(GetRoots);
+      ready_to_gc = rtsFalse;
+#ifdef SMP
+      pthread_cond_broadcast(&gc_pending_cond);
+#endif
+    }
+    
+    /* Go through the list of main threads and wake up any
+     * clients whose computations have finished.  ToDo: this
+     * should be done more efficiently without a linear scan
+     * of the main threads list, somehow...
+     */
+#ifdef SMP
+    { 
+      StgMainThread *m, **prev;
+      prev = &main_threads;
+      for (m = main_threads; m != NULL; m = m->link) {
+	if (m->tso->whatNext == ThreadComplete) {
+	  if (m->ret) {
+	    *(m->ret) = (StgClosure *)m->tso->sp[0];
+	  }
+	  *prev = m->link;
+	  m->stat = Success;
+	  pthread_cond_broadcast(&m->wakeup);
+	}
+	if (m->tso->whatNext == ThreadKilled) {
+	  *prev = m->link;
+	  m->stat = Killed;
+	  pthread_cond_broadcast(&m->wakeup);
+	}
+      }
+    }
+#else
+    /* If our main thread has finished or been killed, return.
+     * If we were re-entered as a result of a _ccall_gc, then
+     * pop the blocked thread off the ccalling_threads stack back
+     * into CurrentTSO.
+     */
+    {
+      StgMainThread *m = main_threads;
+      if (m->tso->whatNext == ThreadComplete
+	  || m->tso->whatNext == ThreadKilled) {
+	main_threads = main_threads->link;
+	if (m->tso->whatNext == ThreadComplete) {
+	  /* we finished successfully, fill in the return value */
+	  if (m->ret) { *(m->ret) = (StgClosure *)m->tso->sp[0]; };
+	  m->stat = Success;
+	  return;
+	} else {
+	  m->stat = Killed;
+	  return;
+	}
+      }
+    }
+#endif
+
+  } /* end of while(1) */
+}
+
+/* -----------------------------------------------------------------------------
+ * Suspending & resuming Haskell threads.
+ * 
+ * When making a "safe" call to C (aka _ccall_GC), the task gives back
+ * its capability before calling the C function.  This allows another
+ * task to pick up the capability and carry on running Haskell
+ * threads.  It also means that if the C call blocks, it won't lock
+ * the whole system.
+ *
+ * The Haskell thread making the C call is put to sleep for the
+ * duration of the call, on the susepended_ccalling_threads queue.  We
+ * give out a token to the task, which it can use to resume the thread
+ * on return from the C function.
+ * -------------------------------------------------------------------------- */
+   
+StgInt
+suspendThread( Capability *cap )
+{
+  nat tok;
+
+  ACQUIRE_LOCK(&sched_mutex);
+
+#ifdef SMP
+  IF_DEBUG(scheduler,
+	   fprintf(stderr, "schedule (task %ld): thread %d did a _ccall_gc\n", 
+		   pthread_self(), cap->rCurrentTSO->id));
+#else
+  IF_DEBUG(scheduler,
+	   fprintf(stderr, "schedule: thread %d did a _ccall_gc\n", 
+		   cap->rCurrentTSO->id));
+#endif
+
+  threadPaused(cap->rCurrentTSO);
+  cap->rCurrentTSO->link = suspended_ccalling_threads;
+  suspended_ccalling_threads = cap->rCurrentTSO;
+
+  /* Use the thread ID as the token; it should be unique */
+  tok = cap->rCurrentTSO->id;
+
+#ifdef SMP
+  cap->link = free_capabilities;
+  free_capabilities = cap;
+  n_free_capabilities++;
+#endif
+
+  RELEASE_LOCK(&sched_mutex);
+  return tok; 
+}
+
+Capability *
+resumeThread( StgInt tok )
+{
+  StgTSO *tso, **prev;
+  Capability *cap;
+
+  ACQUIRE_LOCK(&sched_mutex);
+
+  prev = &suspended_ccalling_threads;
+  for (tso = suspended_ccalling_threads; 
+       tso != END_TSO_QUEUE; 
+       prev = &tso->link, tso = tso->link) {
+    if (tso->id == (StgThreadID)tok) {
+      *prev = tso->link;
+      break;
+    }
+  }
+  if (tso == END_TSO_QUEUE) {
+    barf("resumeThread: thread not found");
+  }
+
+#ifdef SMP
+  while (free_capabilities == NULL) {
+    IF_DEBUG(scheduler,
+	     fprintf(stderr,"schedule (task %ld): waiting to resume\n",
+		     pthread_self()));
+    pthread_cond_wait(&thread_ready_cond, &sched_mutex);
+    IF_DEBUG(scheduler,fprintf(stderr,
+			       "schedule (task %ld): resuming thread %d\n",
+			       pthread_self(), tso->id));
+  }
+  cap = free_capabilities;
+  free_capabilities = cap->link;
+  n_free_capabilities--;
+#else  
+  cap = &MainRegTable;
+#endif
+
+  cap->rCurrentTSO = tso;
+
+  RELEASE_LOCK(&sched_mutex);
+  return cap;
+}
+
 /* -----------------------------------------------------------------------------
  * Static functions
  * -------------------------------------------------------------------------- */
@@ -126,7 +617,16 @@ initThread(StgTSO *tso, nat stack_size)
 {
   SET_INFO(tso,&TSO_info);
   tso->whatNext     = ThreadEnterGHC;
-  tso->id           = next_thread_id++;
+  
+  /* tso->id needs to be unique.  For now we use a heavyweight mutex to
+  	 protect the increment operation on next_thread_id.
+  	 In future, we could use an atomic increment instead.
+  */
+  
+  ACQUIRE_LOCK(&sched_mutex); 
+  tso->id = next_thread_id++; 
+  RELEASE_LOCK(&sched_mutex);
+
   tso->why_blocked  = NotBlocked;
 
   tso->splim        = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
@@ -144,58 +644,264 @@ initThread(StgTSO *tso, nat stack_size)
   SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_MAIN);
   tso->su = (StgUpdateFrame*)tso->sp;
 
-  IF_DEBUG(scheduler,belch("Initialised thread %ld, stack size = %lx words\n", 
+  IF_DEBUG(scheduler,belch("schedule: Initialised thread %ld, stack size = %lx words", 
 			   tso->id, tso->stack_size));
 
-  /* Put the new thread on the head of the runnable queue.
-   * The caller of createThread better push an appropriate closure
-   * on this thread's stack before the scheduler is invoked.
+}
+
+
+/* -----------------------------------------------------------------------------
+ * scheduleThread()
+ *
+ * scheduleThread puts a thread on the head of the runnable queue.
+ * This will usually be done immediately after a thread is created.
+ * The caller of scheduleThread must create the thread using e.g.
+ * createThread and push an appropriate closure
+ * on this thread's stack before the scheduler is invoked.
+ * -------------------------------------------------------------------------- */
+
+void
+scheduleThread(StgTSO *tso)
+{
+  ACQUIRE_LOCK(&sched_mutex);
+
+  /* Put the new thread on the head of the runnable queue.  The caller
+   * better push an appropriate closure on this thread's stack
+   * beforehand.  In the SMP case, the thread may start running as
+   * soon as we release the scheduler lock below.
    */
-  tso->link = run_queue_hd;
-  run_queue_hd = tso;
-  if (run_queue_tl == END_TSO_QUEUE) {
-    run_queue_tl = tso;
-  }
+  PUSH_ON_RUN_QUEUE(tso);
+  THREAD_RUNNABLE();
 
   IF_DEBUG(scheduler,printTSO(tso));
+  RELEASE_LOCK(&sched_mutex);
 }
 
+
+/* -----------------------------------------------------------------------------
+ * startTasks()
+ *
+ * Start up Posix threads to run each of the scheduler tasks.
+ * I believe the task ids are not needed in the system as defined.
+  * KH @ 25/10/99
+ * -------------------------------------------------------------------------- */
+
+#ifdef SMP
+static void *
+taskStart( void *arg STG_UNUSED )
+{
+  schedule();
+  return NULL;
+}
+#endif
+
 /* -----------------------------------------------------------------------------
  * initScheduler()
  *
  * Initialise the scheduler.  This resets all the queues - if the
  * queues contained any threads, they'll be garbage collected at the
  * next pass.
+ *
+ * This now calls startTasks(), so should only be called once!  KH @ 25/10/99
  * -------------------------------------------------------------------------- */
 
+#ifdef SMP
+static void
+term_handler(int sig STG_UNUSED)
+{
+  nat i;
+  pthread_t me = pthread_self();
+
+  for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+    if (task_ids[i].id == me) {
+      task_ids[i].mut_time = usertime() - task_ids[i].gc_time;
+      if (task_ids[i].mut_time < 0.0) {
+	task_ids[i].mut_time = 0.0;
+      }
+    }
+  }
+  ACQUIRE_LOCK(&term_mutex);
+  await_death--;
+  RELEASE_LOCK(&term_mutex);
+  pthread_exit(NULL);
+}
+#endif
+
 void initScheduler(void)
 {
   run_queue_hd      = END_TSO_QUEUE;
   run_queue_tl      = END_TSO_QUEUE;
   blocked_queue_hd  = END_TSO_QUEUE;
   blocked_queue_tl  = END_TSO_QUEUE;
-  ccalling_threads  = END_TSO_QUEUE;
-  next_main_thread  = 0;
+
+  suspended_ccalling_threads  = END_TSO_QUEUE;
+
+  main_threads = NULL;
 
   context_switch = 0;
   interrupted    = 0;
 
   enteredCAFs = END_CAF_LIST;
+
+  /* Install the SIGHUP handler */
+#ifdef SMP
+  {
+    struct sigaction action,oact;
+
+    action.sa_handler = term_handler;
+    sigemptyset(&action.sa_mask);
+    action.sa_flags = 0;
+    if (sigaction(SIGTERM, &action, &oact) != 0) {
+      barf("can't install TERM handler");
+    }
+  }
+#endif
+
+#ifdef SMP
+  /* Allocate N Capabilities */
+  {
+    nat i;
+    Capability *cap, *prev;
+    cap  = NULL;
+    prev = NULL;
+    for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+      cap = stgMallocBytes(sizeof(Capability), "initScheduler:capabilities");
+      cap->link = prev;
+      prev = cap;
+    }
+    free_capabilities = cap;
+    n_free_capabilities = RtsFlags.ConcFlags.nNodes;
+  }
+  IF_DEBUG(scheduler,fprintf(stderr,"schedule: Allocated %d capabilities\n",
+			     n_free_capabilities););
+#endif
 }
 
-/* -----------------------------------------------------------------------------
-   Main scheduling loop.
+#ifdef SMP
+void
+startTasks( void )
+{
+  nat i;
+  int r;
+  pthread_t tid;
+  
+  /* make some space for saving all the thread ids */
+  task_ids = stgMallocBytes(RtsFlags.ConcFlags.nNodes * sizeof(task_info),
+			    "initScheduler:task_ids");
+  
+  /* and create all the threads */
+  for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+    r = pthread_create(&tid,NULL,taskStart,NULL);
+    if (r != 0) {
+      barf("startTasks: Can't create new Posix thread");
+    }
+    task_ids[i].id = tid;
+    IF_DEBUG(scheduler,fprintf(stderr,"schedule: Started task: %ld\n",tid););
+  }
+}
+#endif
 
-   We use round-robin scheduling, each thread returning to the
-   scheduler loop when one of these conditions is detected:
+void
+exitScheduler( void )
+{
+#ifdef SMP
+  nat i; 
 
-      * stack overflow
-      * out of heap space
-      * timer expires (thread yields)
-      * thread blocks
-      * thread ends
+  /* Don't want to use pthread_cancel, since we'd have to install
+   * these silly exception handlers (pthread_cleanup_{push,pop}) around
+   * all our locks.
+   */
+#if 0
+  /* Cancel all our tasks */
+  for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+    pthread_cancel(task_ids[i].id);
+  }
+  
+  /* Wait for all the tasks to terminate */
+  for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+    IF_DEBUG(scheduler,fprintf(stderr,"schedule: waiting for task %ld\n", 
+			       task_ids[i].id));
+    pthread_join(task_ids[i].id, NULL);
+  }
+#endif
+
+  /* Send 'em all a SIGHUP.  That should shut 'em up.
+   */
+  await_death = RtsFlags.ConcFlags.nNodes;
+  for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+    pthread_kill(task_ids[i].id,SIGTERM);
+  }
+  while (await_death > 0) {
+    sched_yield();
+  }
+#endif
+}
+
+/* -----------------------------------------------------------------------------
+   Managing the per-task allocation areas.
+   
+   Each capability comes with an allocation area.  These are
+   fixed-length block lists into which allocation can be done.
+
+   ToDo: no support for two-space collection at the moment???
    -------------------------------------------------------------------------- */
 
+/* -----------------------------------------------------------------------------
+ * waitThread is the external interface for running a new computataion
+ * and waiting for the result.
+ *
+ * In the non-SMP case, we create a new main thread, push it on the 
+ * main-thread stack, and invoke the scheduler to run it.  The
+ * scheduler will return when the top main thread on the stack has
+ * completed or died, and fill in the necessary fields of the
+ * main_thread structure.
+ *
+ * In the SMP case, we create a main thread as before, but we then
+ * create a new condition variable and sleep on it.  When our new
+ * main thread has completed, we'll be woken up and the status/result
+ * will be in the main_thread struct.
+ * -------------------------------------------------------------------------- */
+
+SchedulerStatus
+waitThread(StgTSO *tso, /*out*/StgClosure **ret)
+{
+  StgMainThread *m;
+  SchedulerStatus stat;
+
+  ACQUIRE_LOCK(&sched_mutex);
+  
+  m = stgMallocBytes(sizeof(StgMainThread), "waitThread");
+
+  m->tso = tso;
+  m->ret = ret;
+  m->stat = NoStatus;
+#ifdef SMP
+  pthread_cond_init(&m->wakeup, NULL);
+#endif
+
+  m->link = main_threads;
+  main_threads = m;
+
+#ifdef SMP
+  pthread_cond_wait(&m->wakeup, &sched_mutex);
+#else
+  schedule();
+#endif
+
+  stat = m->stat;
+  ASSERT(stat != NoStatus);
+
+#ifdef SMP
+  pthread_cond_destroy(&m->wakeup);
+#endif
+  free(m);
+
+  RELEASE_LOCK(&sched_mutex);
+  return stat;
+}
+  
+
+#if 0
 SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
 {
   StgTSO *t;
@@ -245,14 +951,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
 
   /* Take a thread from the run queue.
    */
-  t = run_queue_hd;
-  if (t != END_TSO_QUEUE) {
-    run_queue_hd = t->link;
-    t->link = END_TSO_QUEUE;
-    if (run_queue_hd == END_TSO_QUEUE) {
-      run_queue_tl = END_TSO_QUEUE;
-    }
-  }
+  t = POP_RUN_QUEUE();
 
   while (t != END_TSO_QUEUE) {
     CurrentTSO = t;
@@ -376,7 +1075,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
       /* Put the thread back on the run queue, at the end.
        * t->link is already set to END_TSO_QUEUE.
        */
-      PUSH_ON_RUN_QUEUE(t);
+      APPEND_TO_RUN_QUEUE(t);
       break;
 
     case ThreadBlocked:
@@ -391,7 +1090,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
       break;
 
     case ThreadFinished:
-      IF_DEBUG(scheduler,belch("Thread %ld finished\n", t->id));
+      IF_DEBUG(scheduler,fprintf(stderr,"thread %ld finished\n", t->id));
       t->whatNext = ThreadComplete;
       break;
 
@@ -437,14 +1136,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
       awaitEvent(run_queue_hd == END_TSO_QUEUE);
     }
 
-    t = run_queue_hd;
-    if (t != END_TSO_QUEUE) {
-      run_queue_hd = t->link;
-      t->link = END_TSO_QUEUE;
-      if (run_queue_hd == END_TSO_QUEUE) {
-	run_queue_tl = END_TSO_QUEUE;
-      }
-    }
+    t = POP_RUN_QUEUE();
   }
 
   /* If we got to here, then we ran out of threads to run, but the
@@ -453,6 +1145,7 @@ SchedulerStatus schedule(StgTSO *main, StgClosure **ret_val)
    */
   return Deadlock;
 }
+#endif
 
 /* -----------------------------------------------------------------------------
    Debugging: why is a thread blocked
@@ -494,9 +1187,14 @@ void printThreadBlockage(StgTSO *tso)
      
    -------------------------------------------------------------------------- */
 
+/* This has to be protected either by the scheduler monitor, or by the
+	garbage collection monitor (probably the latter).
+	KH @ 25/10/99
+*/
+
 static void GetRoots(void)
 {
-  nat i;
+  StgMainThread *m;
 
   run_queue_hd      = (StgTSO *)MarkRoot((StgClosure *)run_queue_hd);
   run_queue_tl      = (StgTSO *)MarkRoot((StgClosure *)run_queue_tl);
@@ -504,11 +1202,11 @@ static void GetRoots(void)
   blocked_queue_hd  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_hd);
   blocked_queue_tl  = (StgTSO *)MarkRoot((StgClosure *)blocked_queue_tl);
 
-  ccalling_threads  = (StgTSO *)MarkRoot((StgClosure *)ccalling_threads);
-
-  for (i = 0; i < next_main_thread; i++) {
-    main_threads[i] = (StgTSO *)MarkRoot((StgClosure *)main_threads[i]);
+  for (m = main_threads; m != NULL; m = m->link) {
+    m->tso = (StgTSO *)MarkRoot((StgClosure *)m->tso);
   }
+  suspended_ccalling_threads = 
+    (StgTSO *)MarkRoot((StgClosure *)suspended_ccalling_threads);
 }
 
 /* -----------------------------------------------------------------------------
@@ -520,6 +1218,8 @@ static void GetRoots(void)
 
    It might be useful to provide an interface whereby the programmer
    can specify more roots (ToDo).
+   
+   This needs to be protected by the GC condition variable above.  KH.
    -------------------------------------------------------------------------- */
 
 void (*extra_roots)(void);
@@ -586,7 +1286,7 @@ threadStackOverflow(StgTSO *tso)
   new_tso_size = round_to_mblocks(new_tso_size);  /* Be MBLOCK-friendly */
   new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
 
-  IF_DEBUG(scheduler, fprintf(stderr,"increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
+  IF_DEBUG(scheduler, fprintf(stderr,"schedule: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
 
   dest = (StgTSO *)allocate(new_tso_size);
   TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
@@ -624,9 +1324,13 @@ threadStackOverflow(StgTSO *tso)
 #if 0
   IF_DEBUG(scheduler,printTSO(dest));
 #endif
+
+#if 0
+  /* This will no longer work: KH */
   if (tso == MainTSO) { /* hack */
       MainTSO = dest;
   }
+#endif
   return dest;
 }
 
@@ -634,7 +1338,8 @@ threadStackOverflow(StgTSO *tso)
    Wake up a queue that was blocked on some resource.
    -------------------------------------------------------------------------- */
 
-StgTSO *unblockOne(StgTSO *tso)
+static StgTSO *
+unblockOneLocked(StgTSO *tso)
 {
   StgTSO *next;
 
@@ -642,17 +1347,34 @@ StgTSO *unblockOne(StgTSO *tso)
   ASSERT(tso->why_blocked != NotBlocked);
   tso->why_blocked = NotBlocked;
   next = tso->link;
-  tso->link = END_TSO_QUEUE;
   PUSH_ON_RUN_QUEUE(tso);
-  IF_DEBUG(scheduler,belch("Waking up thread %ld", tso->id));
+  THREAD_RUNNABLE();
+#ifdef SMP
+  IF_DEBUG(scheduler,belch("schedule (task %ld): waking up thread %ld", 
+			   pthread_self(), tso->id));
+#else
+  IF_DEBUG(scheduler,belch("schedule: waking up thread %ld", tso->id));
+#endif
   return next;
 }
 
-void awakenBlockedQueue(StgTSO *tso)
+inline StgTSO *
+unblockOne(StgTSO *tso)
 {
+  ACQUIRE_LOCK(&sched_mutex);
+  tso = unblockOneLocked(tso);
+  RELEASE_LOCK(&sched_mutex);
+  return tso;
+}
+
+void
+awakenBlockedQueue(StgTSO *tso)
+{
+  ACQUIRE_LOCK(&sched_mutex);
   while (tso != END_TSO_QUEUE) {
-    tso = unblockOne(tso);
+    tso = unblockOneLocked(tso);
   }
+  RELEASE_LOCK(&sched_mutex);
 }
 
 /* -----------------------------------------------------------------------------
@@ -679,6 +1401,7 @@ unblockThread(StgTSO *tso)
 {
   StgTSO *t, **last;
 
+  ACQUIRE_LOCK(&sched_mutex);
   switch (tso->why_blocked) {
 
   case NotBlocked:
@@ -747,6 +1470,7 @@ unblockThread(StgTSO *tso)
   tso->why_blocked = NotBlocked;
   tso->block_info.closure = NULL;
   PUSH_ON_RUN_QUEUE(tso);
+  RELEASE_LOCK(&sched_mutex);
 }
 
 /* -----------------------------------------------------------------------------
@@ -798,7 +1522,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
     return;
   }
 
-  IF_DEBUG(scheduler, belch("Raising exception in thread %ld.", tso->id));
+  IF_DEBUG(scheduler, belch("schedule: Raising exception in thread %ld.", tso->id));
 
   /* Remove it from any blocking queues */
   unblockThread(tso);
@@ -869,7 +1593,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
 	TICK_ALLOC_UP_THK(words+1,0);
 	
 	IF_DEBUG(scheduler,
-		 fprintf(stderr,  "Updating ");
+		 fprintf(stderr,  "schedule: Updating ");
 		 printPtr((P_)su->updatee); 
 		 fprintf(stderr,  " with ");
 		 printObj((StgClosure *)ap);
@@ -905,7 +1629,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
 	o->payload[1] = cf->handler;
 	
 	IF_DEBUG(scheduler,
-		 fprintf(stderr,  "Built ");
+		 fprintf(stderr,  "schedule: Built ");
 		 printObj((StgClosure *)o);
 		 );
 	
@@ -931,7 +1655,7 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
 	payloadCPtr(o,0) = (StgClosure *)ap;
 	
 	IF_DEBUG(scheduler,
-		 fprintf(stderr,  "Built ");
+		 fprintf(stderr,  "schedule: Built ");
 		 printObj((StgClosure *)o);
 		 );
 	
@@ -957,3 +1681,4 @@ raiseAsync(StgTSO *tso, StgClosure *exception)
   }
   barf("raiseAsync");
 }
+
diff --git a/ghc/rts/Schedule.h b/ghc/rts/Schedule.h
index 06ff4cfa32..085ad22db8 100644
--- a/ghc/rts/Schedule.h
+++ b/ghc/rts/Schedule.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Schedule.h,v 1.8 1999/10/19 15:39:08 simonmar Exp $
+ * $Id: Schedule.h,v 1.9 1999/11/02 15:06:02 simonmar Exp $
  *
  * (c) The GHC Team 1998-1999
  *
@@ -8,27 +8,79 @@
  *
  * ---------------------------------------------------------------------------*/
 
-/* 
- * Initialisation
+/* initScheduler(), exitScheduler(), startTasks()
+ * 
+ * Called from STG :  no
+ * Locks assumed   :  none
  */
+void initScheduler( void );
+void exitScheduler( void );
+#ifdef SMP
+void startTasks( void );
+#endif
 
-void    initScheduler(void);
-
-/* 
- * Miscellany
+/* awakenBlockedQueue()
+ *
+ * Takes a pointer to the beginning of a blocked TSO queue, and
+ * wakes up the entire queue.
+ *
+ * Called from STG :  yes
+ * Locks assumed   :  none
  */
+void awakenBlockedQueue(StgTSO *tso);
 
-void    awakenBlockedQueue(StgTSO *tso);
+/* unblockOne()
+ *
+ * Takes a pointer to the beginning of a blocked TSO queue, and
+ * removes the first thread, placing it on the runnable queue.
+ *
+ * Called from STG : yes
+ * Locks assumed   : none
+ */
 StgTSO *unblockOne(StgTSO *tso);
-void    initThread(StgTSO *tso, nat stack_size);
-void    interruptStgRts(void);
-void    raiseAsync(StgTSO *tso, StgClosure *exception);
 
-extern  nat context_switch;
+/* raiseAsync()
+ *
+ * Raises an exception asynchronously in the specified thread.
+ *
+ * Called from STG :  yes
+ * Locks assumed   :  none
+ */
+void raiseAsync(StgTSO *tso, StgClosure *exception);
+
+/* awaitEvent()
+ *
+ * Raises an exception asynchronously in the specified thread.
+ *
+ * Called from STG :  NO
+ * Locks assumed   :  sched_mutex
+ */
+void awaitEvent(rtsBool wait);  /* In Select.c */
+
+/* Context switch flag.
+ * Locks required  : sched_mutex
+ */
+extern nat context_switch;
+
+extern  nat ticks_since_select;
 
-void    awaitEvent(rtsBool wait);  /* In Select.c */
-extern  nat ticks_since_select;	   /* ditto */
+/* Capability type
+ */
+typedef StgRegTable Capability;
+
+/* Free capability list.
+ * Locks required: sched_mutex.
+ */
+#ifdef SMP
+extern Capability *free_capabilities;
+extern nat n_free_capabilities;
+#else
+extern Capability MainRegTable;
+#endif
 
+/* Thread queues.
+ * Locks required  : sched_mutex
+ */
 extern  StgTSO *run_queue_hd, *run_queue_tl;
 extern  StgTSO *blocked_queue_hd, *blocked_queue_tl;
 
@@ -36,17 +88,34 @@ extern  StgTSO *blocked_queue_hd, *blocked_queue_tl;
 extern void printThreadBlockage(StgTSO *tso);
 #endif
 
-#ifdef COMPILING_RTS_MAIN
-extern DLLIMPORT StgTSO *MainTSO; /* temporary hack */
-#else
-extern StgTSO *MainTSO; /* temporary hack */
+#ifdef SMP
+extern pthread_mutex_t sched_mutex;
+extern pthread_cond_t  thread_ready_cond;
+extern pthread_cond_t  gc_pending_cond;
+#endif
+
+#ifdef SMP
+typedef struct {
+  pthread_t id;
+  double    mut_time;
+  double    gc_time;
+  double    gc_etime;
+} task_info;
+
+extern task_info *task_ids;
 #endif
+
+/* -----------------------------------------------------------------------------
+ * Some convenient macros...
+ */
+
 #define END_TSO_QUEUE  ((StgTSO *)(void*)&END_TSO_QUEUE_closure)
+#define END_CAF_LIST   ((StgCAF *)(void*)&END_TSO_QUEUE_closure)
 
 /* Add a thread to the end of the run queue.
  * NOTE: tso->link should be END_TSO_QUEUE before calling this macro.
  */
-#define PUSH_ON_RUN_QUEUE(tso)			\
+#define APPEND_TO_RUN_QUEUE(tso)		\
     ASSERT(tso->link == END_TSO_QUEUE);		\
     if (run_queue_hd == END_TSO_QUEUE) {	\
       run_queue_hd = tso;			\
@@ -55,7 +124,33 @@ extern StgTSO *MainTSO; /* temporary hack */
     }						\
     run_queue_tl = tso;
 
-#define PUSH_ON_BLOCKED_QUEUE(tso)		\
+/* Push a thread on the beginning of the run queue.  Used for
+ * newly awakened threads, so they get run as soon as possible.
+ */
+#define PUSH_ON_RUN_QUEUE(tso)			\
+    tso->link = run_queue_hd;			\
+      run_queue_hd = tso;			\
+    if (run_queue_tl == END_TSO_QUEUE) {	\
+      run_queue_tl = tso;			\
+    }
+    
+/* Pop the first thread off the runnable queue.
+ */
+#define POP_RUN_QUEUE()				\
+  ({ StgTSO *t = run_queue_hd;			\
+    if (t != END_TSO_QUEUE) {			\
+      run_queue_hd = t->link;			\
+      t->link = END_TSO_QUEUE;			\
+      if (run_queue_hd == END_TSO_QUEUE) {	\
+        run_queue_tl = END_TSO_QUEUE;		\
+      }						\
+    }						\
+    t;						\
+  })
+
+/* Add a thread to the end of the blocked queue.
+ */
+#define APPEND_TO_BLOCKED_QUEUE(tso)		\
     ASSERT(tso->link == END_TSO_QUEUE);		\
     if (blocked_queue_hd == END_TSO_QUEUE) {    \
       blocked_queue_hd = tso;			\
@@ -64,4 +159,16 @@ extern StgTSO *MainTSO; /* temporary hack */
     }						\
     blocked_queue_tl = tso;
 
-#define END_CAF_LIST  stgCast(StgCAF*,(void*)&END_TSO_QUEUE_closure)
+/* Signal that a runnable thread has become available, in
+ * case there are any waiting tasks to execute it.
+ */
+#ifdef SMP
+#define THREAD_RUNNABLE()			\
+  if (free_capabilities != NULL) {		\
+     pthread_cond_signal(&thread_ready_cond);	\
+  }						\
+  context_switch = 1;
+#else
+#define THREAD_RUNNABLE()  /* nothing */
+#endif
+
diff --git a/ghc/rts/Signals.c b/ghc/rts/Signals.c
index 6e5d859fda..730ede485b 100644
--- a/ghc/rts/Signals.c
+++ b/ghc/rts/Signals.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Signals.c,v 1.8 1999/09/22 11:53:33 sof Exp $
+ * $Id: Signals.c,v 1.9 1999/11/02 15:06:02 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -245,16 +245,37 @@ start_signal_handlers(void)
 }
 #endif
 
+/* -----------------------------------------------------------------------------
+   SIGINT handler.
+
+   We like to shutdown nicely after receiving a SIGINT, write out the
+   stats, write profiling info, close open files and flush buffers etc.
+   -------------------------------------------------------------------------- */
+
+#ifdef SMP
+pthread_t startup_guy;
+#endif
+
 static void
 shutdown_handler(int sig)
 {
+#ifdef SMP
+  /* if I'm a worker thread, send this signal to the guy who
+   * originally called startupHaskell().  Since we're handling
+   * the signal, it won't be a "send to all threads" type of signal
+   * (according to the POSIX threads spec).
+   */
+  if (pthread_self() != startup_guy) {
+    pthread_kill(startup_guy, sig);
+  } else
+#endif
+
   shutdownHaskellAndExit(EXIT_FAILURE);
 }
 
 /*
  * The RTS installs a default signal handler for catching
- * SIGINT, so that we can perform an orderly shutdown (finalising
- * objects and flushing buffers etc.)
+ * SIGINT, so that we can perform an orderly shutdown.
  *
  * Haskell code may install their own SIGINT handler, which is
  * fine, provided they're so kind as to put back the old one
@@ -265,6 +286,9 @@ init_shutdown_handler()
 {
     struct sigaction action,oact;
 
+#ifdef SMP
+    startup_guy = pthread_self();
+#endif
     action.sa_handler = shutdown_handler;
     sigemptyset(&action.sa_mask);
     action.sa_flags = 0;
diff --git a/ghc/rts/Stats.c b/ghc/rts/Stats.c
index 50985fd1ae..c82827d458 100644
--- a/ghc/rts/Stats.c
+++ b/ghc/rts/Stats.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Stats.c,v 1.14 1999/09/15 13:45:20 simonmar Exp $
+ * $Id: Stats.c,v 1.15 1999/11/02 15:06:03 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -14,41 +14,7 @@
 #include "RtsUtils.h"
 #include "StoragePriv.h"
 #include "MBlock.h"
-
-/**
- *  Ian: For the moment we just want to ignore
- * these on Nemesis
- **/
-#ifdef _NEMESIS_OS_
-#ifdef HAVE_SYS_TIMES_H
-#undef HAVE_SYS_TIMES_H /* <sys/times.h> */
-#endif
-#ifdef HAVE_SYS_RESOURCE_H /* <sys/resource.h> */
-#undef HAVE_SYS_RESOURCE_H
-#endif
-#ifdef HAVE_SYS_TIME_H  /* <sys/time.h> */
-#undef HAVE_SYS_TIME_H
-#endif
-#ifdef HAVE_SYS_TIMEB_H 
-#undef HAVE_SYS_TIMEB_H /* <sys/timeb.h> */
-#endif
-#ifdef HAVE_UNISTD_H
-#undef HAVE_UNISTD_H    /* <unistd.h> */
-#endif
-#ifdef HAVE_TIMES
-#undef HAVE_TIMES
-#endif 
-#ifdef HAVE_FTIME
-#undef HAVE_FTIME
-#endif
-#ifdef HAVE_GETRUSAGE
-#undef HAVE_GETRUSAGE
-#endif
-#ifdef HAVE_SYSCONF
-#undef HAVE_SYSCONF
-#endif
-#endif /* _NEMESIS_OS_ */
-
+#include "Schedule.h"
 #include "Stats.h"
 
 #ifdef HAVE_UNISTD_H
@@ -369,8 +335,10 @@ stat_endGC(lnat alloc, lnat collect, lnat live, lnat copied, lnat gen)
     FILE *sf = RtsFlags.GcFlags.statsFile;
 
     if (sf != NULL) {
-	double time = usertime();
-	double etime = elapsedtime();
+	double time     = usertime();
+	double etime    = elapsedtime();
+	double gc_time  = time-GC_start_time;
+	double gc_etime = etime-GCe_start_time;
 
 	if (RtsFlags.GcFlags.giveStats >= VERBOSE_GC_STATS) {
 	    nat faults = pagefaults();
@@ -378,8 +346,8 @@ stat_endGC(lnat alloc, lnat collect, lnat live, lnat copied, lnat gen)
 	    fprintf(sf, "%9ld %9ld %9ld",
 		    alloc*sizeof(W_), collect*sizeof(W_), live*sizeof(W_));
 	    fprintf(sf, " %5.2f %5.2f %7.2f %7.2f %4ld %4ld  (Gen: %2ld)\n", 
-		    (time-GC_start_time), 
-		    (etime-GCe_start_time), 
+		    gc_time, 
+		    gc_etime,
 		    time,
 		    etime,
 		    faults - GC_start_faults,
@@ -397,6 +365,21 @@ stat_endGC(lnat alloc, lnat collect, lnat live, lnat copied, lnat gen)
 	GC_tot_time   += time-GC_start_time;
 	GCe_tot_time  += etime-GCe_start_time;
 
+#ifdef SMP
+	{
+	  nat i;
+	  pthread_t me = pthread_self();
+
+	  for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+	    if (me == task_ids[i].id) {
+	      task_ids[i].gc_time += gc_time;
+	      task_ids[i].gc_etime += gc_etime;
+	      break;
+	    }
+	  }
+	}
+#endif
+
 	if (gen == RtsFlags.GcFlags.generations-1) { /* major GC? */
 	  if (live > MaxResidency) {
 	    MaxResidency = live;
@@ -434,10 +417,10 @@ stat_exit(int alloc)
 	if (time  == 0.0)  time = 0.0001;
 	if (etime == 0.0) etime = 0.0001;
 	
-
-	fprintf(sf, "%9ld %9.9s %9.9s",
-		(lnat)alloc*sizeof(W_), "", "");
-	fprintf(sf, " %5.2f %5.2f\n\n", 0.0, 0.0);
+	if (RtsFlags.GcFlags.giveStats >= VERBOSE_GC_STATS) {
+	  fprintf(sf, "%9ld %9.9s %9.9s",	(lnat)alloc*sizeof(W_), "", "");
+	  fprintf(sf, " %5.2f %5.2f\n\n", 0.0, 0.0);
+	}
 
 	GC_tot_alloc += alloc;
 
@@ -465,11 +448,30 @@ stat_exit(int alloc)
 	fprintf(sf,"\n%11ld Mb total memory in use\n\n", 
 		mblocks_allocated * MBLOCK_SIZE / (1024 * 1024));
 
-	MutTime = time - GC_tot_time - InitUserTime;
-	if (MutTime < 0) { MutTime = 0; }
 	MutElapsedTime = etime - GCe_tot_time - InitElapsedTime;
 	if (MutElapsedTime < 0) { MutElapsedTime = 0; }	/* sometimes -0.00 */
 
+#ifndef SMP
+	MutTime = time - GC_tot_time - InitUserTime;
+	if (MutTime < 0) { MutTime = 0; }
+
+#else /* SMP */
+	/* For SMP, we have to get the user time from each thread
+	 * and try to work out the total time.
+	 */
+	{
+	  nat i;
+	  MutTime = 0.0;
+	  for (i = 0; i < RtsFlags.ConcFlags.nNodes; i++) {
+	    fprintf(sf, "  Task %2d:  MUT time: %6.2fs,  GC time: %6.2fs\n", 
+		    i, task_ids[i].mut_time, task_ids[i].gc_time);
+	    MutTime += task_ids[i].mut_time;
+	  }
+	}
+	time = MutTime + GC_tot_time + InitUserTime;
+	fprintf(sf,"\n");
+#endif
+
 	fprintf(sf, "  INIT  time  %6.2fs  (%6.2fs elapsed)\n",
 		InitUserTime, InitElapsedTime);
 	fprintf(sf, "  MUT   time  %6.2fs  (%6.2fs elapsed)\n",
diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc
index 671177fef9..6586e10748 100644
--- a/ghc/rts/StgMiscClosures.hc
+++ b/ghc/rts/StgMiscClosures.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.27 1999/08/25 16:11:51 simonmar Exp $
+ * $Id: StgMiscClosures.hc,v 1.28 1999/11/02 15:06:03 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -14,6 +14,7 @@
 #include "Storage.h"
 #include "StoragePriv.h"
 #include "ProfRts.h"
+#include "SMP.h"
 
 #ifdef HAVE_STDIO_H
 #include <stdio.h>
@@ -183,17 +184,20 @@ INFO_TABLE(BLACKHOLE_info, BLACKHOLE_entry,0,2,BLACKHOLE,,EF_,0,0);
 STGFUN(BLACKHOLE_entry)
 {
   FB_
+#ifdef SMP
+    CMPXCHG(R1.cl->header.info, &BLACKHOLE_info, &WHITEHOLE_info);
+#endif
+
     TICK_ENT_BH();
 
-    /* Change the BLACKHOLE into a BLACKHOLE_BQ */
-    ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
     /* Put ourselves on the blocking queue for this black hole */
     CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
     ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
     CurrentTSO->why_blocked = BlockedOnBlackHole;
     CurrentTSO->block_info.closure = R1.cl;
     recordMutable((StgMutClosure *)R1.cl);
-
+    /* Change the BLACKHOLE into a BLACKHOLE_BQ */
+    ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
     /* stg_gen_block is too heavyweight, use a specialised one */
     BLOCK_NP(1);
   FE_
@@ -203,6 +207,10 @@ INFO_TABLE(BLACKHOLE_BQ_info, BLACKHOLE_BQ_entry,1,1,BLACKHOLE_BQ,,EF_,0,0);
 STGFUN(BLACKHOLE_BQ_entry)
 {
   FB_
+#ifdef SMP
+    CMPXCHG(R1.cl->header.info, &BLACKHOLE_info, &WHITEHOLE_info);
+#endif
+
     TICK_ENT_BH();
 
     /* Put ourselves on the blocking queue for this black hole */
@@ -210,6 +218,9 @@ STGFUN(BLACKHOLE_BQ_entry)
     CurrentTSO->block_info.closure = R1.cl;
     CurrentTSO->link = ((StgBlockingQueue *)R1.p)->blocking_queue;
     ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
+#ifdef SMP
+    ((StgBlockingQueue *)R1.p)->header.info = &BLACKHOLE_BQ_info;
+#endif
 
     /* stg_gen_block is too heavyweight, use a specialised one */
     BLOCK_NP(1);
@@ -245,6 +256,16 @@ STGFUN(SE_CAF_BLACKHOLE_entry)
 }
 #endif
 
+#ifdef SMP
+INFO_TABLE(WHITEHOLE_info, WHITEHOLE_entry,0,2,CONSTR_NOCAF_STATIC,,EF_,0,0);
+STGFUN(WHITEHOLE_entry)
+{
+  FB_
+     JMP_(GET_ENTRY(R1.cl));
+  FE_
+}
+#endif
+
 /* -----------------------------------------------------------------------------
    The code for a BCO returns to the scheduler
    -------------------------------------------------------------------------- */
@@ -367,6 +388,19 @@ INFO_TABLE(MUT_CONS_info, MUT_CONS_entry, 1, 1, MUT_VAR, , EF_, 0, 0);
 NON_ENTERABLE_ENTRY_CODE(MUT_CONS);
 
 /* -----------------------------------------------------------------------------
+   Exception lists
+   -------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(END_EXCEPTION_LIST_info,END_EXCEPTION_LIST_entry,0,0,0,CONSTR_NOCAF_STATIC,,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(END_EXCEPTION_LIST);
+
+SET_STATIC_HDR(END_EXCEPTION_LIST_closure,END_EXCEPTION_LIST_info,0/*CC*/,,EI_)
+};
+
+INFO_TABLE(EXCEPTION_CONS_info, EXCEPTION_CONS_entry, 1, 1, CONSTR, , EF_, 0, 0);
+NON_ENTERABLE_ENTRY_CODE(EXCEPTION_CONS);
+
+/* -----------------------------------------------------------------------------
    Arrays
 
    These come in two basic flavours: arrays of data (StgArrWords) and arrays of
diff --git a/ghc/rts/StgRun.S b/ghc/rts/StgRun.S
index 6451567d99..a2ba9efd6d 100644
--- a/ghc/rts/StgRun.S
+++ b/ghc/rts/StgRun.S
@@ -1,13 +1,15 @@
 /* -----------------------------------------------------------------------------
- * $Id: StgRun.S,v 1.2 1998/12/15 09:41:57 simonm Exp $
+ * $Id: StgRun.S,v 1.3 1999/11/02 15:06:04 simonmar Exp $
  *
  * Tiny assembler 'layer' between the C and STG worlds.
  * 
  * To run an STG function from C land, call
  *
- *		rv = StgRun(f);
+ *		rv = StgRun(f,BaseReg);
  *
- * where "f" is the STG function to call.
+ * where "f" is the STG function to call, and BaseReg is the address of the
+ * RegTable for this run (we might have separate RegTables if we're running
+ * multiple threads on an SMP machine).
  *
  * In the end, "f" must JMP to StgReturn (defined below),
  * passing the return-value "rv" in R1,
@@ -69,6 +71,11 @@ StgRun:
         movl %ebp,12(%eax)
 
 	/*
+	 * Set BaseReg
+	 */
+	movl 12(%ebp),%ebx
+	
+	/*
 	 * grab the function argument from the stack, and jump to it.
 	 */
         movl 8(%ebp),%eax
diff --git a/ghc/rts/StgRun.h b/ghc/rts/StgRun.h
index b617581f82..3dc948b6ed 100644
--- a/ghc/rts/StgRun.h
+++ b/ghc/rts/StgRun.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: StgRun.h,v 1.3 1999/02/05 16:02:59 simonm Exp $
+ * $Id: StgRun.h,v 1.4 1999/11/02 15:06:04 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -12,7 +12,7 @@
 
 #include "Storage.h"  /* for {Open,Close}Nursery functions */
 
-extern StgThreadReturnCode StgRun(StgFunPtr f);
+extern StgThreadReturnCode StgRun(StgFunPtr f, StgRegTable *basereg);
 EXTFUN(StgReturn);
 
 #endif STGRUN_H
diff --git a/ghc/rts/StgStdThunks.hc b/ghc/rts/StgStdThunks.hc
index b54148f469..42c06a3dc7 100644
--- a/ghc/rts/StgStdThunks.hc
+++ b/ghc/rts/StgStdThunks.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: StgStdThunks.hc,v 1.8 1999/10/21 09:18:02 simonmar Exp $
+ * $Id: StgStdThunks.hc,v 1.9 1999/11/02 15:06:04 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -46,7 +46,6 @@
       R1.p=(P_)R1.cl->payload[offset];					\
       GET_SAVED_CCCS;							\
       Sp=Sp+sizeofW(StgHeader);						\
-      TICK_ENT_VIA_NODE();						\
       JMP_(ENTRY_CODE(*R1.p));						\
     FE_									\
   }									\
@@ -55,16 +54,14 @@
   INFO_TABLE_SELECTOR(__sel_##offset##_upd_info, __sel_##offset##_upd_entry, offset,, EF_, 0,0);\
   EF_(__sel_##offset##_upd_entry) {					\
     FB_									\
-      TICK_ENT_THK();							\
       STK_CHK_NP(UPD_FRAME_SIZE,1,);					\
-      UPD_BH_UPDATABLE(R1.p);						\
+      UPD_BH_UPDATABLE(&__sel_##offset##_upd_info);			\
       PUSH_UPD_FRAME(R1.p,0);						\
       ENTER_CCS(R1.p);							\
       SAVE_CCCS(UPD_FRAME_SIZE);					\
       Sp[-UPD_FRAME_SIZE]=(W_)&__sel_ret_##offset##_upd_info;		\
       R1.p = (P_)R1.cl->payload[0];					\
       Sp=Sp-UPD_FRAME_SIZE;						\
-      TICK_ENT_VIA_NODE();						\
       JMP_(ENTRY_CODE(*R1.p));						\
     FE_									\
   }
@@ -93,7 +90,6 @@ SELECTOR_CODE_UPD(15);
       R1.p=(P_)R1.cl->payload[offset];					\
       GET_SAVED_CCCS;							\
       Sp=Sp+sizeofW(StgHeader);						\
-      TICK_ENT_VIA_NODE();						\
       JMP_(ENTRY_CODE(*R1.p));						\
     FE_									\
   }									\
@@ -102,14 +98,13 @@ SELECTOR_CODE_UPD(15);
   INFO_TABLE_SELECTOR(__sel_##offset##_noupd_info, __sel_##offset##_noupd_entry, offset,, EF_, 0,0);\
   EF_(__sel_##offset##_noupd_entry) {					\
     FB_									\
-      TICK_ENT_THK();							\
       STK_CHK_NP(NOUPD_FRAME_SIZE,1,)					\
+      UPD_BH_SINGLE_ENTRY(&__sel_##offset##_noupd_info);		\
       ENTER_CCS(R1.p);							\
       SAVE_CCCS(NOUPD_FRAME_SIZE);					\
       Sp[-NOUPD_FRAME_SIZE]=(W_)&__sel_ret_##offset##_noupd_info;	\
       R1.p = (P_)R1.cl->payload[0];					\
       Sp=Sp-NOUPD_FRAME_SIZE;						\
-      TICK_ENT_VIA_NODE();						\
       JMP_(ENTRY_CODE(*R1.p));						\
     FE_									\
   }
@@ -163,14 +158,12 @@ FN_(__ap_8_upd_entry);
 INFO_TABLE_SRT(__ap_1_upd_info,__ap_1_upd_entry,1,0,0,0,0,THUNK,,EF_,0,0);
 FN_(__ap_1_upd_entry) {
   FB_
-  TICK_ENT_THK();
   STK_CHK_NP(sizeofW(StgUpdateFrame),1,);
-  UPD_BH_UPDATABLE(R1.p);
+  UPD_BH_UPDATABLE(&__ap_1_upd_info);
   ENTER_CCS(R1.p);
   PUSH_UPD_FRAME(R1.p,0);
   R1.p=(P_)(R1.cl->payload[0]);
   Sp = Sp - sizeofW(StgUpdateFrame);
-  TICK_ENT_VIA_NODE();
   JMP_(ENTRY_CODE(*R1.p));
   FE_
 }
@@ -178,15 +171,13 @@ FN_(__ap_1_upd_entry) {
 INFO_TABLE_SRT(__ap_2_upd_info,__ap_2_upd_entry,2,0,0,0,0,THUNK,,EF_,0,0);
 FN_(__ap_2_upd_entry) {
   FB_
-  TICK_ENT_THK();
   STK_CHK_NP(sizeofW(StgUpdateFrame)+1,1,);
-  UPD_BH_UPDATABLE(R1.p);
+  UPD_BH_UPDATABLE(&__ap_2_upd_info);
   ENTER_CCS(R1.p);
   PUSH_UPD_FRAME(R1.p,0);
   Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[1]);
   R1.p=(P_)(R1.cl->payload[0]);
   Sp = Sp - (sizeofW(StgUpdateFrame)+1);
-  TICK_ENT_VIA_NODE();
   JMP_(ENTRY_CODE(*R1.p));
   FE_
 }
@@ -194,16 +185,14 @@ FN_(__ap_2_upd_entry) {
 INFO_TABLE_SRT(__ap_3_upd_info,__ap_3_upd_entry,3,0,0,0,0,THUNK,,EF_,0,0);
 FN_(__ap_3_upd_entry) {
   FB_
-  TICK_ENT_THK();
   STK_CHK_NP(sizeofW(StgUpdateFrame)+2,1,);
-  UPD_BH_UPDATABLE(R1.p);
+  UPD_BH_UPDATABLE(&__ap_3_upd_info);
   ENTER_CCS(R1.p);
   PUSH_UPD_FRAME(R1.p,0);
   Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[2]);
   Sp[-UF_SIZE-2]=(W_)(R1.cl->payload[1]);
   R1.p=(P_)(R1.cl->payload[0]);
   Sp = Sp - (sizeofW(StgUpdateFrame)+2);
-  TICK_ENT_VIA_NODE();
   JMP_(ENTRY_CODE(*R1.p));
   FE_
 }
@@ -211,9 +200,8 @@ FN_(__ap_3_upd_entry) {
 INFO_TABLE_SRT(__ap_4_upd_info,__ap_4_upd_entry,4,0,0,0,0,THUNK,,EF_,0,0);
 FN_(__ap_4_upd_entry) {
   FB_
-  TICK_ENT_THK();
   STK_CHK_NP(sizeofW(StgUpdateFrame)+3,1,);
-  UPD_BH_UPDATABLE(R1.p);
+  UPD_BH_UPDATABLE(&__ap_4_upd_info);
   ENTER_CCS(R1.p);
   PUSH_UPD_FRAME(R1.p,0);
   Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[3]);
@@ -221,7 +209,6 @@ FN_(__ap_4_upd_entry) {
   Sp[-UF_SIZE-3]=(W_)(R1.cl->payload[1]);
   R1.p=(P_)(R1.cl->payload[0]);
   Sp = Sp - (sizeofW(StgUpdateFrame)+3);
-  TICK_ENT_VIA_NODE();
   JMP_(ENTRY_CODE(*R1.p));
   FE_
 }
@@ -229,9 +216,8 @@ FN_(__ap_4_upd_entry) {
 INFO_TABLE_SRT(__ap_5_upd_info,__ap_5_upd_entry,5,0,0,0,0,THUNK,,EF_,0,0);
 FN_(__ap_5_upd_entry) {
   FB_
-  TICK_ENT_THK();
   STK_CHK_NP(sizeofW(StgUpdateFrame)+4,1,);
-  UPD_BH_UPDATABLE(R1.p);
+  UPD_BH_UPDATABLE(&__ap_5_upd_info);
   ENTER_CCS(R1.p);
   PUSH_UPD_FRAME(R1.p,0);
   Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[4]);
@@ -240,7 +226,6 @@ FN_(__ap_5_upd_entry) {
   Sp[-UF_SIZE-4]=(W_)(R1.cl->payload[1]);
   R1.p=(P_)(R1.cl->payload[0]);
   Sp = Sp - (sizeofW(StgUpdateFrame)+4);
-  TICK_ENT_VIA_NODE();
   JMP_(ENTRY_CODE(*R1.p));
   FE_
 }
@@ -248,9 +233,8 @@ FN_(__ap_5_upd_entry) {
 INFO_TABLE_SRT(__ap_6_upd_info,__ap_6_upd_entry,6,0,0,0,0,THUNK,,EF_,0,0);
 FN_(__ap_6_upd_entry) {
   FB_
-  TICK_ENT_THK();
   STK_CHK_NP(sizeofW(StgUpdateFrame)+5,1,);
-  UPD_BH_UPDATABLE(R1.p);
+  UPD_BH_UPDATABLE(&__ap_6_upd_info);
   ENTER_CCS(R1.p);
   PUSH_UPD_FRAME(R1.p,0);
   Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[5]);
@@ -260,7 +244,6 @@ FN_(__ap_6_upd_entry) {
   Sp[-UF_SIZE-5]=(W_)(R1.cl->payload[1]);
   R1.p=(P_)(R1.cl->payload[0]);
   Sp = Sp - (sizeofW(StgUpdateFrame)+5);
-  TICK_ENT_VIA_NODE();
   JMP_(ENTRY_CODE(*R1.p));
   FE_
 }
@@ -268,9 +251,8 @@ FN_(__ap_6_upd_entry) {
 INFO_TABLE_SRT(__ap_7_upd_info,__ap_7_upd_entry,7,0,0,0,0,THUNK,,EF_,0,0);
 FN_(__ap_7_upd_entry) {
   FB_
-  TICK_ENT_THK();
   STK_CHK_NP(sizeofW(StgUpdateFrame)+6,1,);
-  UPD_BH_UPDATABLE(R1.p);
+  UPD_BH_UPDATABLE(&__ap_7_upd_info);
   ENTER_CCS(R1.p);
   PUSH_UPD_FRAME(R1.p,0);
   Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[6]);
@@ -281,7 +263,6 @@ FN_(__ap_7_upd_entry) {
   Sp[-UF_SIZE-6]=(W_)(R1.cl->payload[1]);
   R1.p=(P_)(R1.cl->payload[0]);
   Sp = Sp - (sizeofW(StgUpdateFrame)+6);
-  TICK_ENT_VIA_NODE();
   JMP_(ENTRY_CODE(*R1.p));
   FE_
 }
@@ -289,9 +270,8 @@ FN_(__ap_7_upd_entry) {
 INFO_TABLE_SRT(__ap_8_upd_info,__ap_8_upd_entry,8,0,0,0,0,THUNK,,EF_,0,0);
 FN_(__ap_8_upd_entry) {
   FB_
-  TICK_ENT_THK();
   STK_CHK_NP(sizeofW(StgUpdateFrame)+7,1,);
-  UPD_BH_UPDATABLE(R1.p);
+  UPD_BH_UPDATABLE(&__ap_8_upd_info);
   ENTER_CCS(R1.p);
   PUSH_UPD_FRAME(R1.p,0);
   Sp[-UF_SIZE-1]=(W_)(R1.cl->payload[7]);
@@ -303,7 +283,6 @@ FN_(__ap_8_upd_entry) {
   Sp[-UF_SIZE-7]=(W_)(R1.cl->payload[1]);
   R1.p=(P_)(R1.cl->payload[0]);
   Sp=Sp-10;
-  TICK_ENT_VIA_NODE();
   JMP_(ENTRY_CODE(*R1.p));
   FE_
 }
diff --git a/ghc/rts/Storage.c b/ghc/rts/Storage.c
index fc3c409af6..0bf3e21555 100644
--- a/ghc/rts/Storage.c
+++ b/ghc/rts/Storage.c
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.19 1999/10/13 16:39:23 simonmar Exp $
+ * $Id: Storage.c,v 1.20 1999/11/02 15:06:04 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -19,10 +19,12 @@
 #include "Sanity.h"
 
 #include "Storage.h"
+#include "Schedule.h"
 #include "StoragePriv.h"
 
-bdescr *current_nursery;	/* next available nursery block, or NULL */
+#ifndef SMP
 nat nursery_blocks;		/* number of blocks in the nursery */
+#endif
 
 StgClosure    *caf_list         = NULL;
 
@@ -40,6 +42,14 @@ generation *oldest_gen;		/* oldest generation, for convenience */
 step *g0s0;			/* generation 0, step 0, for convenience */
 
 /*
+ * Storage manager mutex:  protects all the above state from
+ * simultaneous access by two STG threads.
+ */
+#ifdef SMP
+pthread_mutex_t sm_mutex = PTHREAD_MUTEX_INITIALIZER;
+#endif
+
+/*
  * Forward references
  */
 static void *stgAllocForGMP   (size_t size_in_bytes);
@@ -156,14 +166,9 @@ initStorage (void)
    * don't want it to be a big one.  This vague idea is borne out by 
    * rigorous experimental evidence.
    */
-  step = &generations[0].steps[0];
-  g0s0 = step;
-  nursery_blocks = RtsFlags.GcFlags.minAllocAreaSize;
-  step->blocks   = allocNursery(NULL, nursery_blocks);
-  step->n_blocks = nursery_blocks;
-  current_nursery = step->blocks;
-  g0s0->to_space = NULL;
-  /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
+  g0s0 = &generations[0].steps[0];
+
+  allocNurseries();
 
   weak_ptr_list = NULL;
   caf_list = NULL;
@@ -179,10 +184,109 @@ initStorage (void)
   mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP);
 #endif
 
+#ifdef SMP
+  pthread_mutex_init(&sm_mutex, NULL);
+#endif
+
   IF_DEBUG(gc, stat_describe_gens());
 }
 
-extern bdescr *
+void
+exitStorage (void)
+{
+  stat_exit(calcAllocated());
+}
+
+void
+newCAF(StgClosure* caf)
+{
+  /* Put this CAF on the mutable list for the old generation.
+   * This is a HACK - the IND_STATIC closure doesn't really have
+   * a mut_link field, but we pretend it has - in fact we re-use
+   * the STATIC_LINK field for the time being, because when we
+   * come to do a major GC we won't need the mut_link field
+   * any more and can use it as a STATIC_LINK.
+   */
+  ACQUIRE_LOCK(&sm_mutex);
+  ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_once_list;
+  oldest_gen->mut_once_list = (StgMutClosure *)caf;
+
+#ifdef DEBUG
+  { 
+    const StgInfoTable *info;
+    
+    info = get_itbl(caf);
+    ASSERT(info->type == IND_STATIC);
+#if 0
+    STATIC_LINK2(info,caf) = caf_list;
+    caf_list = caf;
+#endif
+  }
+#endif
+  RELEASE_LOCK(&sm_mutex);
+}
+
+/* -----------------------------------------------------------------------------
+   Nursery management.
+   -------------------------------------------------------------------------- */
+
+void
+allocNurseries( void )
+{ 
+#ifdef SMP
+  {
+    Capability *cap;
+    
+    g0s0->blocks = NULL;
+    g0s0->n_blocks = 0;
+    for (cap = free_capabilities; cap != NULL; cap = cap->link) {
+      cap->rNursery = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize);
+      cap->rCurrentNursery = cap->rNursery;
+    }
+  }
+#else /* SMP */
+  nursery_blocks  = RtsFlags.GcFlags.minAllocAreaSize;
+  g0s0->blocks    = allocNursery(NULL, nursery_blocks);
+  g0s0->n_blocks  = nursery_blocks;
+  g0s0->to_space  = NULL;
+  MainRegTable.rNursery        = g0s0->blocks;
+  MainRegTable.rCurrentNursery = g0s0->blocks;
+  /* hp, hpLim, hp_bd, to_space etc. aren't used in G0S0 */
+#endif
+}
+      
+void
+resetNurseries( void )
+{
+  bdescr *bd;
+#ifdef SMP
+  Capability *cap;
+  
+  /* All tasks must be stopped */
+  ASSERT(n_free_capabilities == RtsFlags.ConcFlags.nNodes);
+
+  for (cap = free_capabilities; cap != NULL; cap = cap->link) {
+    for (bd = cap->rNursery; bd; bd = bd->link) {
+      bd->free = bd->start;
+      ASSERT(bd->gen == g0);
+      ASSERT(bd->step == g0s0);
+      IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
+    }
+    cap->rCurrentNursery = cap->rNursery;
+  }
+#else
+  for (bd = g0s0->blocks; bd; bd = bd->link) {
+    bd->free = bd->start;
+    ASSERT(bd->gen == g0);
+    ASSERT(bd->step == g0s0);
+    IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
+  }
+  MainRegTable.rNursery = g0s0->blocks;
+  MainRegTable.rCurrentNursery = g0s0->blocks;
+#endif
+}
+
+bdescr *
 allocNursery (bdescr *last_bd, nat blocks)
 {
   bdescr *bd;
@@ -201,11 +305,15 @@ allocNursery (bdescr *last_bd, nat blocks)
   return last_bd;
 }
 
-extern void
+void
 resizeNursery ( nat blocks )
 {
   bdescr *bd;
 
+#ifdef SMP
+  barf("resizeNursery: can't resize in SMP mode");
+#endif
+
   if (nursery_blocks == blocks) {
     ASSERT(g0s0->n_blocks == blocks);
     return;
@@ -233,48 +341,6 @@ resizeNursery ( nat blocks )
   g0s0->n_blocks = nursery_blocks = blocks;
 }
 
-void
-exitStorage (void)
-{
-  lnat allocated;
-  bdescr *bd;
-
-  /* Return code ignored for now */
-  /* ToDo: allocation figure is slightly wrong (see also GarbageCollect()) */
-  allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
-  for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
-    allocated -= BLOCK_SIZE_W;
-  }
-  stat_exit(allocated);
-}
-
-void
-newCAF(StgClosure* caf)
-{
-  /* Put this CAF on the mutable list for the old generation.
-   * This is a HACK - the IND_STATIC closure doesn't really have
-   * a mut_link field, but we pretend it has - in fact we re-use
-   * the STATIC_LINK field for the time being, because when we
-   * come to do a major GC we won't need the mut_link field
-   * any more and can use it as a STATIC_LINK.
-   */
-  ((StgMutClosure *)caf)->mut_link = oldest_gen->mut_once_list;
-  oldest_gen->mut_once_list = (StgMutClosure *)caf;
-
-#ifdef DEBUG
-  { 
-    const StgInfoTable *info;
-    
-    info = get_itbl(caf);
-    ASSERT(info->type == IND_STATIC);
-#if 0
-    STATIC_LINK2(info,caf) = caf_list;
-    caf_list = caf;
-#endif
-  }
-#endif
-}
-
 /* -----------------------------------------------------------------------------
    The allocate() interface
 
@@ -289,6 +355,8 @@ allocate(nat n)
   bdescr *bd;
   StgPtr p;
 
+  ACQUIRE_LOCK(&sm_mutex);
+
   TICK_ALLOC_HEAP_NOCTR(n);
   CCS_ALLOC(CCCS,n);
 
@@ -307,6 +375,7 @@ allocate(nat n)
      * (eg. running threads), so garbage collecting early won't make
      * much difference.
      */
+    RELEASE_LOCK(&sm_mutex);
     return bd->start;
 
   /* small allocation (<LARGE_OBJECT_THRESHOLD) */
@@ -327,6 +396,7 @@ allocate(nat n)
   
   p = alloc_Hp;
   alloc_Hp += n;
+  RELEASE_LOCK(&sm_mutex);
   return p;
 }
 
@@ -389,8 +459,60 @@ stgDeallocForGMP (void *ptr STG_UNUSED,
 }
 
 /* -----------------------------------------------------------------------------
-   Stats and stuff
-   -------------------------------------------------------------------------- */
+ * Stats and stuff
+ * -------------------------------------------------------------------------- */
+
+/* -----------------------------------------------------------------------------
+ * calcAllocated()
+ *
+ * Approximate how much we've allocated: number of blocks in the
+ * nursery + blocks allocated via allocate() - unused nusery blocks.
+ * This leaves a little slop at the end of each block, and doesn't
+ * take into account large objects (ToDo).
+ * -------------------------------------------------------------------------- */
+
+lnat
+calcAllocated( void )
+{
+  nat allocated;
+  bdescr *bd;
+
+#ifdef SMP
+  Capability *cap;
+
+  /* All tasks must be stopped */
+  ASSERT(n_free_capabilities == RtsFlags.ConcFlags.nNodes);
+
+  allocated = 
+    n_free_capabilities * RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W
+    + allocated_bytes();
+
+  for (cap = free_capabilities; cap != NULL; cap = cap->link) {
+    for ( bd = cap->rCurrentNursery->link; bd != NULL; bd = bd->link ) {
+      allocated -= BLOCK_SIZE_W;
+    }
+    if (cap->rCurrentNursery->free < cap->rCurrentNursery->start 
+	+ BLOCK_SIZE_W) {
+      allocated -= (cap->rCurrentNursery->start + BLOCK_SIZE_W)
+	- cap->rCurrentNursery->free;
+    }
+  }
+
+#else /* !SMP */
+  bdescr *current_nursery = MainRegTable.rCurrentNursery;
+
+  allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
+  for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
+    allocated -= BLOCK_SIZE_W;
+  }
+  if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
+    allocated -= (current_nursery->start + BLOCK_SIZE_W)
+      - current_nursery->free;
+  }
+#endif
+
+  return allocated;
+}  
 
 /* Approximate the amount of live data in the heap.  To be called just
  * after garbage collection (see GarbageCollect()).
@@ -488,7 +610,7 @@ memInventory(void)
 	*/
 	if (bd->blocks > BLOCKS_PER_MBLOCK) {
 	  total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
-	                  * bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE);
+	                  * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
 	}
       }
     }
diff --git a/ghc/rts/Storage.h b/ghc/rts/Storage.h
index eb0b241ca5..a1e43dc1d2 100644
--- a/ghc/rts/Storage.h
+++ b/ghc/rts/Storage.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Storage.h,v 1.9 1999/05/11 16:47:59 keithw Exp $
+ * $Id: Storage.h,v 1.10 1999/11/02 15:06:05 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -38,6 +38,9 @@ extern void exitStorage(void);
    lnat  allocated_bytes(void)  Returns the number of bytes allocated
                                 via allocate() since the last GC.
 				Used in the reoprting of statistics.
+
+   SMP: allocate and doYouWantToGC can be used from STG code, they are
+   surrounded by a mutex.
    -------------------------------------------------------------------------- */
 
 extern StgPtr  allocate(nat n);
@@ -56,9 +59,9 @@ extern lnat allocated_bytes(void);
   -------------------------------------------------------------------------- */
 
 #define ExtendNursery(hp,hplim)			\
-  (current_nursery->free = (P_)(hp)+1,		\
-   current_nursery->link == NULL ? rtsFalse :	\
-   (current_nursery = current_nursery->link,	\
+  (CurrentNursery->free = (P_)(hp)+1,		\
+   CurrentNursery->link == NULL ? rtsFalse :	\
+   (CurrentNursery = CurrentNursery->link,	\
     OpenNursery(hp,hplim),			\
     rtsTrue))
 
@@ -100,7 +103,11 @@ recordMutable(StgMutClosure *p)
 {
   bdescr *bd;
 
+#ifdef SMP
+  ASSERT(p->header.info == &WHITEHOLE_info || closure_MUTABLE(p));
+#else
   ASSERT(closure_MUTABLE(p));
+#endif
 
   bd = Bdescr((P_)p);
   if (bd->gen->no > 0) {
@@ -121,24 +128,23 @@ recordOldToNewPtrs(StgMutClosure *p)
   }
 }
 
-static inline void
-updateWithIndirection(StgClosure *p1, StgClosure *p2) 
-{
-  bdescr *bd;
-
-  bd = Bdescr((P_)p1);
-  if (bd->gen->no == 0) {
-    SET_INFO(p1,&IND_info);
-    ((StgInd *)p1)->indirectee = p2;
-    TICK_UPD_NEW_IND();
-  } else {
-    SET_INFO(p1,&IND_OLDGEN_info);
-    ((StgIndOldGen *)p1)->indirectee = p2;
-    ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list;
-    bd->gen->mut_once_list = (StgMutClosure *)p1;
-    TICK_UPD_OLD_IND();
+#define updateWithIndirection(p1, p2)				\
+  {								\
+    bdescr *bd;							\
+								\
+    bd = Bdescr((P_)p1);					\
+    if (bd->gen->no == 0) {					\
+      ((StgInd *)p1)->indirectee = p2;				\
+      SET_INFO(p1,&IND_info);					\
+      TICK_UPD_NEW_IND();					\
+    } else {							\
+      ((StgIndOldGen *)p1)->indirectee = p2;			\
+      ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list;	\
+      bd->gen->mut_once_list = (StgMutClosure *)p1;		\
+      SET_INFO(p1,&IND_OLDGEN_info);				\
+      TICK_UPD_OLD_IND();					\
+    }								\
   }
-}
 
 #if defined(TICKY_TICKY) || defined(PROFILING)
 static inline void
@@ -148,14 +154,14 @@ updateWithPermIndirection(StgClosure *p1, StgClosure *p2)
 
   bd = Bdescr((P_)p1);
   if (bd->gen->no == 0) {
-    SET_INFO(p1,&IND_PERM_info);
     ((StgInd *)p1)->indirectee = p2;
+    SET_INFO(p1,&IND_PERM_info);
     TICK_UPD_NEW_PERM_IND(p1);
   } else {
-    SET_INFO(p1,&IND_OLDGEN_PERM_info);
     ((StgIndOldGen *)p1)->indirectee = p2;
     ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list;
     bd->gen->mut_once_list = (StgMutClosure *)p1;
+    SET_INFO(p1,&IND_OLDGEN_PERM_info);
     TICK_UPD_OLD_PERM_IND();
   }
 }
diff --git a/ghc/rts/StoragePriv.h b/ghc/rts/StoragePriv.h
index 4326550cb6..f88e37ee13 100644
--- a/ghc/rts/StoragePriv.h
+++ b/ghc/rts/StoragePriv.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: StoragePriv.h,v 1.8 1999/02/05 16:03:02 simonm Exp $
+ * $Id: StoragePriv.h,v 1.9 1999/11/02 15:06:05 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -109,11 +109,16 @@ extern nat nursery_blocks;
 extern nat alloc_blocks;
 extern nat alloc_blocks_lim;
 
-extern bdescr *allocNursery ( bdescr *last_bd, nat blocks );
-extern void resizeNursery ( nat blocks );
+/* Nursery manipulation */
+extern void     allocNurseries ( void );
+extern void     resetNurseries ( void );
+extern bdescr * allocNursery   ( bdescr *last_bd, nat blocks );
+extern void     resizeNursery  ( nat blocks );
 
-extern lnat calcLive( void );
-extern lnat calcNeeded( void );
+/* Stats 'n' stuff */
+extern lnat calcAllocated  ( void );
+extern lnat calcLive       ( void );
+extern lnat calcNeeded     ( void );
 
 static inline void
 dbl_link_onto(bdescr *bd, bdescr **list)
diff --git a/ghc/rts/Updates.hc b/ghc/rts/Updates.hc
index aad6dc1629..f09f942b67 100644
--- a/ghc/rts/Updates.hc
+++ b/ghc/rts/Updates.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: Updates.hc,v 1.19 1999/09/14 12:16:36 simonmar Exp $
+ * $Id: Updates.hc,v 1.20 1999/11/02 15:06:05 simonmar Exp $
  *
  * (c) The GHC Team, 1998-1999
  *
@@ -46,6 +46,34 @@
    update code. 
    */
 
+#if defined(REG_Su)
+#define UPD_FRAME_ENTRY_TEMPLATE(label,ret)				\
+        STGFUN(label);							\
+	STGFUN(label)							\
+	{								\
+	  FB_								\
+									\
+          Su = (StgUpdateFrame *)((StgUpdateFrame *)Sp)->updatee;	\
+									\
+	  /* Tick - it must be a con, all the paps are handled		\
+	   * in stg_upd_PAP and PAP_entry below				\
+	   */								\
+	  TICK_UPD_CON_IN_NEW(sizeW_fromITBL(get_itbl(Su)));	\
+									\
+	  /* update the updatee with an indirection to the return value */\
+	  UPD_IND(Su,R1.p);					\
+									\
+	  /* reset Su to the next update frame */			\
+	  Su = ((StgUpdateFrame *)Sp)->link;				\
+									\
+	  /* remove the update frame from the stack */			\
+	  Sp += sizeofW(StgUpdateFrame);				\
+									\
+	  JMP_(ret);							\
+	  FE_								\
+	}
+#else
+
 #define UPD_FRAME_ENTRY_TEMPLATE(label,ret)				\
         STGFUN(label);							\
 	STGFUN(label)							\
@@ -72,6 +100,7 @@
 	  JMP_(ret);							\
 	  FE_								\
 	}
+#endif
 
 UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_entry,ENTRY_CODE(Sp[0]));
 UPD_FRAME_ENTRY_TEMPLATE(Upd_frame_0_entry,RET_VEC(Sp[0],0));
author	simonmar <unknown>	1999-11-02 15:06:05 +0000
committer	simonmar <unknown>	1999-11-02 15:06:05 +0000
commit	f6692611aad945e46ffb615bde1df7def3fc742f (patch)
tree	04e2e2af9c43eba1b60312b89eb3ac8f34209e2c
parent	947d2e363f75e9e230d535c876ecdafba45174b5 (diff)
download	haskell-f6692611aad945e46ffb615bde1df7def3fc742f.tar.gz