[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.

7 files changed, 49 insertions, 14 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")