[project @ 1996-05-17 16:02:43 by partain]

Sansom 1.3 changes through 960507

8 files changed, 247 insertions, 136 deletions

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 85f58f16b6..2d0f3aebd1 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -30,21 +30,21 @@ import CgBindery	( getVolatileRegs, getArgAmode, getArgAmodes,
 			  idInfoToAmode
 			)
 import CgCon		( buildDynCon, bindConArgs )
-import CgHeapery	( heapCheck )
+import CgHeapery	( heapCheck, yield )
 import CgRetConv	( dataReturnConvAlg, dataReturnConvPrim,
 			  ctrlReturnConvAlg,
 			  DataReturnConvention(..), CtrlReturnConvention(..),
 			  assignPrimOpResultRegs,
 			  makePrimOpArgsRobust
 			)
-import CgStackery	( allocAStack, allocBStack )
+import CgStackery	( allocAStack, allocBStack, allocAStackTop, allocBStackTop )
 import CgTailCall	( tailCallBusiness, performReturn )
 import CgUsages		( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
 import CLabel		( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
 			  mkAltLabel, mkClosureLabel
 			)
 import ClosureInfo	( mkConLFInfo, mkLFArgument, layOutDynCon )
-import CmdLineOpts	( opt_SccProfilingOn )
+import CmdLineOpts	( opt_SccProfilingOn, opt_GranMacros )
 import CostCentre	( useCurrentCostCentre )
 import HeapOffs		( VirtualSpBOffset(..), VirtualHeapOffset(..) )
 import Id		( idPrimRep, toplevelishId,
@@ -55,7 +55,9 @@ import Id		( idPrimRep, toplevelishId,
 import Maybes		( catMaybes )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance Outputable-} )
-import PrimOp		( primOpCanTriggerGC, PrimOp(..) )
+import PrimOp		( primOpCanTriggerGC, PrimOp(..),
+			  primOpStackRequired, StackRequirement(..)
+			)
 import PrimRep		( getPrimRepSize, isFollowableRep, retPrimRepSize,
 			  PrimRep(..)
 			)
@@ -173,10 +175,6 @@ cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
     	panic "cgCase: case on PrimOp with default *and* alts\n"
 	-- For now, die if alts are non-empty
     else
-#if 0
-	pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $
-	-- See above TO DO TO DO
-#endif
 	cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
   where
     scrut_rhs       = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
@@ -199,6 +197,8 @@ cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
 	-- Perform the operation
     getVolatileRegs live_in_alts		        `thenFC` \ vol_regs ->
 
+    -- seq cannot happen here => no additional B Stack alloc
+
     absC (COpStmt result_amodes op
 		 arg_amodes -- note: no liveness arg
 		 liveness_mask vol_regs) 		`thenC`
@@ -231,9 +231,29 @@ cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
     nukeDeadBindings live_in_whole_case	`thenC`
     saveVolatileVars live_in_alts	`thenFC` \ volatile_var_save_assts ->
 
-    getEndOfBlockInfo                 	`thenFC` \ eob_info ->
-    forkEval eob_info nopC
-	     (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
+    -- Allocate stack words for the prim-op itself,
+    -- these are guaranteed to be ON TOP OF the stack.
+    -- Currently this is used *only* by the seq# primitive op.
+    let 
+      (a_req,b_req) = case (primOpStackRequired op) of
+    			   NoStackRequired        -> (0, 0)
+    			   FixedStackRequired a b -> (a, b)
+    			   VariableStackRequired  -> (0, 0) -- i.e. don't care
+    in
+    allocAStackTop a_req 		`thenFC` \ a_slot ->
+    allocBStackTop b_req 		`thenFC` \ b_slot ->
+
+    getEndOfBlockInfo                 	`thenFC` \ eob_info@(EndOfBlockInfo args_spa args_spb sequel) ->
+    -- a_req and b_req allocate stack space that is taken care of by the
+    -- macros generated for the primops; thus, we there is no need to adjust
+    -- this part of the stacks later on (=> +a_req in EndOfBlockInfo)
+    -- currently all this is only used for SeqOp
+    forkEval (if True {- a_req==0 && b_req==0 -}
+                then eob_info
+                else (EndOfBlockInfo (args_spa+a_req) 
+	                             (args_spb+b_req) sequel)) nopC 
+	     (
+	      getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
 	      absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
     	    	    	    	    	`thenC`
 	      returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
@@ -461,7 +481,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
 	    else
 		cgSemiTaggedAlts uniq alts deflt -- Just <something>
     in
-    cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
+    cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
 					`thenFC` \ (tagged_alt_absCs, deflt_absC) ->
 
     mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
@@ -493,6 +513,12 @@ cgInlineAlts :: GCFlag -> Unique
     	     -> Code
 \end{code}
 
+HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
+we  do  an inlining of the  case  no separate  functions  for returning are
+created, so we don't have to generate a GRAN_YIELD in that case.  This info
+must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
+emitted). Hence, the new Bool arg to cgAlgAltRhs.
+
 First case: algebraic case, exactly one alternative, no default.
 In this case the primitive op will not have set a temporary to the
 tag, so we shouldn't generate a switch statment.  Instead we just
@@ -500,7 +526,7 @@ do the right thing.
 
 \begin{code}
 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
-  = cgAlgAltRhs gc_flag con args use_mask rhs
+  = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
 \end{code}
 
 Second case: algebraic case, several alternatives.
@@ -509,7 +535,8 @@ Tag is held in a temporary.
 \begin{code}
 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
   = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
-		ty alts deflt	`thenFC` \ (tagged_alts, deflt_c) ->
+		ty alts deflt
+                False{-don't emit yield-}  `thenFC` \ (tagged_alts, deflt_c) ->
 
 	-- Do the switch
     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
@@ -536,6 +563,11 @@ cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
 In @cgAlgAlts@, none of the binders in the alternatives are
 assumed to be yet bound.
 
+HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
+last   arg of  cgAlgAlts  indicates  if we  want  a context   switch at the
+beginning of  each alternative. Normally we  want that. The  only exception
+are inlined alternatives.
+
 \begin{code}
 cgAlgAlts :: GCFlag
 	  -> Unique
@@ -544,6 +576,7 @@ cgAlgAlts :: GCFlag
 	  -> Type	    	    	    	-- From the case statement
 	  -> [(Id, [Id], [Bool], StgExpr)]	-- The alternatives
 	  -> StgCaseDefault		-- The default
+          -> Bool                               -- Context switch at alts?
 	  -> FCode ([(ConTag, AbstractC)],	-- The branches
 		    AbstractC			-- The default case
 	     )
@@ -571,15 +604,16 @@ It's all pretty turgid anyway.
 \begin{code}
 cgAlgAlts gc_flag uniq restore_cc semi_tagging
 	ty alts deflt@(StgBindDefault binder True{-used-} _)
+        emit_yield{-should a yield macro be emitted?-}
   = let
 	extra_branches :: [FCode (ConTag, AbstractC)]
 	extra_branches = catMaybes (map mk_extra_branch default_cons)
 
 	must_label_default = semi_tagging || not (null extra_branches)
     in
-    forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
+    forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
 	     extra_branches
-	     (cgAlgDefault  gc_flag uniq restore_cc must_label_default deflt)
+	     (cgAlgDefault  gc_flag uniq restore_cc must_label_default deflt emit_yield)
   where
 
     default_join_lbl = mkDefaultLabel uniq
@@ -636,25 +670,36 @@ Now comes the general case
 \begin{code}
 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
 	{- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
-  = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
+          emit_yield{-should a yield macro be emitted?-}
+
+  = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
 	     [{- No "extra branches" -}]
-	     (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt)
+	     (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
 \end{code}
 
 \begin{code}
 cgAlgDefault :: GCFlag
 	     -> Unique -> AbstractC -> Bool -- turgid state...
 	     -> StgCaseDefault	    -- input
-	     -> FCode AbstractC		    -- output
+	     -> Bool
+	     -> FCode AbstractC	    -- output
 
 cgAlgDefault gc_flag uniq restore_cc must_label_branch
-	     StgNoDefault
+	     StgNoDefault _
   = returnFC AbsCNop
 
 cgAlgDefault gc_flag uniq restore_cc must_label_branch
 	     (StgBindDefault _ False{-binder not used-} rhs)
+             emit_yield{-should a yield macro be emitted?-}
 
   = getAbsC (absC restore_cc `thenC`
+	     let
+		emit_gran_macros = opt_GranMacros
+	     in
+             (if emit_gran_macros && emit_yield 
+                then yield [] False 
+                else absC AbsCNop)                            `thenC`     
+    -- liveness same as in possibleHeapCheck below
 	     possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
     let
 	final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
@@ -667,11 +712,19 @@ cgAlgDefault gc_flag uniq restore_cc must_label_branch
 
 cgAlgDefault gc_flag uniq restore_cc must_label_branch
 	     (StgBindDefault binder True{-binder used-} rhs)
+          emit_yield{-should a yield macro be emitted?-}
 
   = 	-- We have arranged that Node points to the thing, even
     	-- even if we return in registers
     bindNewToReg binder node mkLFArgument `thenC`
     getAbsC (absC restore_cc `thenC`
+	     let
+		emit_gran_macros = opt_GranMacros
+	     in
+             (if emit_gran_macros && emit_yield
+                then yield [node] False
+                else absC AbsCNop)                            `thenC`     
+		-- liveness same as in possibleHeapCheck below
 	     possibleHeapCheck gc_flag [node] False (cgExpr rhs)
 	-- Node is live, but doesn't need to point at the thing itself;
 	-- it's ok for Node to point to an indirection or FETCH_ME
@@ -686,15 +739,21 @@ cgAlgDefault gc_flag uniq restore_cc must_label_branch
   where
     lbl = mkDefaultLabel uniq
 
+-- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
 
 cgAlgAlt :: GCFlag
 	 -> Unique -> AbstractC -> Bool		-- turgid state
+	 -> Bool                               -- Context switch at alts?
 	 -> (Id, [Id], [Bool], StgExpr)
 	 -> FCode (ConTag, AbstractC)
 
-cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
+cgAlgAlt gc_flag uniq restore_cc must_label_branch 
+         emit_yield{-should a yield macro be emitted?-}
+         (con, args, use_mask, rhs)
   = getAbsC (absC restore_cc `thenC`
-	     cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
+	     cgAlgAltRhs gc_flag con args use_mask rhs 
+             emit_yield
+            ) `thenFC` \ abs_c -> 
     let
 	final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
 		    | otherwise	        = abs_c
@@ -704,9 +763,14 @@ cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
     tag	= dataConTag con
     lbl = mkAltLabel uniq tag
 
-cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code
-
-cgAlgAltRhs gc_flag con args use_mask rhs
+cgAlgAltRhs :: GCFlag 
+	    -> Id 
+	    -> [Id] 
+	    -> [Bool] 
+	    -> StgExpr 
+	    -> Bool              -- context switch?
+	    -> Code
+cgAlgAltRhs gc_flag con args use_mask rhs emit_yield
   = let
       (live_regs, node_reqd)
 	= case (dataReturnConvAlg con) of
@@ -717,6 +781,13 @@ cgAlgAltRhs gc_flag con args use_mask rhs
 				-- enabled only the live registers will have valid
 				-- pointers in them.
     in
+     let
+	emit_gran_macros = opt_GranMacros
+     in
+    (if emit_gran_macros && emit_yield
+      then yield live_regs node_reqd 
+      else absC AbsCNop)                                    `thenC`     
+    -- liveness same as in possibleHeapCheck below
     possibleHeapCheck gc_flag live_regs node_reqd (
     (case gc_flag of
 	NoGC   	    -> mapFCs bindNewToTemp args `thenFC` \ _ ->
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 54875d7fab..81ff55f65c 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -29,9 +29,7 @@ import CgBindery	( getCAddrMode, getArgAmodes,
 import CgCompInfo	( spARelToInt, spBRelToInt )
 import CgUpdate		( pushUpdateFrame )
 import CgHeapery	( allocDynClosure, heapCheck
-#ifdef GRAN
-			  , fetchAndReschedule  -- HWL
-#endif
+			  , heapCheckOnly, fetchAndReschedule, yield  -- HWL
 			)
 import CgRetConv	( mkLiveRegsMask,
 			  ctrlReturnConvAlg, dataReturnConvAlg, 
@@ -49,7 +47,7 @@ import CLabel		( mkClosureLabel, mkConUpdCodePtrVecLabel,
 			  mkErrorStdEntryLabel, mkRednCountsLabel
 			)
 import ClosureInfo	-- lots and lots of stuff
-import CmdLineOpts	( opt_EmitArityChecks, opt_ForConcurrent )
+import CmdLineOpts	( opt_ForConcurrent, opt_GranMacros )
 import CostCentre	( useCurrentCostCentre, currentOrSubsumedCosts,
 			  noCostCentreAttached, costsAreSubsumed,
 			  isCafCC, overheadCostCentre
@@ -432,7 +430,6 @@ closureCodeBody binder_info closure_info cc all_args body
   = getEntryConvention id lf_info
 		       (map idPrimRep all_args)		`thenFC` \ entry_conv ->
     let
-	do_arity_chks = opt_EmitArityChecks
 	is_concurrent = opt_ForConcurrent
 
 	stg_arity = length all_args
@@ -489,12 +486,6 @@ closureCodeBody binder_info closure_info cc all_args body
 	    -- Now adjust real stack pointers
 	    adjustRealSps spA_stk_args spB_stk_args		`thenC`
 
-	    -- set the arity checker, if asked
-	    absC (
-		if do_arity_chks
-		then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
-		else AbsCNop
-	    )							`thenC`
     	    absC (CFallThrough (CLbl fast_label CodePtrRep))
 
 	assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
@@ -515,11 +506,6 @@ closureCodeBody binder_info closure_info cc all_args body
 		    CString (_PK_ (show_wrapper_name wrapper_maybe)),
 		    CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
 		]			`thenC`
-	    absC (
-		if do_arity_chks
-		then CMacroStmt CHK_ARITY [mkIntCLit stg_arity]
-		else AbsCNop
-	    )				`thenC`
 
 		-- Bind args to regs/stack as appropriate, and
 		-- record expected position of sps
@@ -659,35 +645,43 @@ argSatisfactionCheck closure_info args
 
     nodeMustPointToIt (closureLFInfo closure_info) 	`thenFC` \ node_points ->
 
-#ifdef GRAN
-    -- HWL:
+    let
+       emit_gran_macros = opt_GranMacros
+    in
+
+    -- HWL  ngo' ngoq:
     -- absC (CMacroStmt GRAN_FETCH []) 			`thenC`
-    -- forceHeapCheck [] node_points (absC AbsCNop)	`thenC`
-    (if node_points
-	then fetchAndReschedule  [] node_points
-	else absC AbsCNop)				`thenC`
-#endif  {- GRAN -}
+    -- forceHeapCheck [] node_points (absC AbsCNop)			`thenC`
+    (if emit_gran_macros 
+      then if node_points 
+             then fetchAndReschedule  [] node_points 
+             else yield [] node_points
+      else absC AbsCNop)                       `thenC`
 
     getCAddrMode (last args) 				`thenFC` \ last_amode ->
 
     if (isFollowableRep (getAmodeRep last_amode)) then
 	getSpARelOffset 0 	`thenFC` \ (SpARel spA off) ->
 	let
-	    lit = mkIntCLit (spARelToInt spA off)
+	    a_rel_int = spARelToInt spA off
+	    a_rel_arg = mkIntCLit a_rel_int
 	in
+	ASSERT(a_rel_int /= 0)
 	if node_points then
-	    absC (CMacroStmt ARGS_CHK_A [lit])
+	    absC (CMacroStmt ARGS_CHK_A [a_rel_arg])
 	else
-	    absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [lit, set_Node_to_this])
+	    absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [a_rel_arg, set_Node_to_this])
     else
 	getSpBRelOffset 0 	`thenFC` \ (SpBRel spB off) ->
 	let
-	    lit = mkIntCLit (spBRelToInt spB off)
+	    b_rel_int = spBRelToInt spB off
+	    b_rel_arg = mkIntCLit b_rel_int
 	in
+	ASSERT(b_rel_int /= 0)
 	if node_points then
-	    absC (CMacroStmt ARGS_CHK_B [lit])
+	    absC (CMacroStmt ARGS_CHK_B [b_rel_arg])
 	else
-	    absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [lit, set_Node_to_this])
+	    absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [b_rel_arg, set_Node_to_this])
   where
     -- We must tell the arg-satis macro whether Node is pointing to
     -- the closure or not.  If it isn't so pointing, then we give to
@@ -708,12 +702,16 @@ thunkWrapper closure_info thunk_code
   = 	-- Stack and heap overflow checks
     nodeMustPointToIt (closureLFInfo closure_info)  	`thenFC` \ node_points ->
 
-#ifdef GRAN
-    -- HWL insert macros for GrAnSim if node is live here
-    (if node_points
-       then fetchAndReschedule [] node_points
-       else absC AbsCNop)              			`thenC`
-#endif  {- GRAN -}
+    let
+       emit_gran_macros = opt_GranMacros
+    in
+    -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
+    -- (we prefer fetchAndReschedule-style context switches to yield ones)
+    (if emit_gran_macros 
+      then if node_points 
+             then fetchAndReschedule  [] node_points 
+             else yield [] node_points
+      else absC AbsCNop)                       `thenC`
 
     stackCheck closure_info [] node_points (	-- stackCheck *encloses* the rest
 
@@ -739,6 +737,14 @@ funWrapper :: ClosureInfo 	-- Closure whose code body this is
 funWrapper closure_info arg_regs fun_body
   = 	-- Stack overflow check
     nodeMustPointToIt (closureLFInfo closure_info)  	`thenFC` \ node_points ->
+    let
+       emit_gran_macros = opt_GranMacros
+    in
+    -- HWL   chu' ngoq:
+    (if emit_gran_macros
+      then yield  arg_regs node_points
+      else absC AbsCNop)                                 `thenC`
+
     stackCheck closure_info arg_regs node_points (	-- stackCheck *encloses* the rest
 
 	-- Heap overflow check
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index 29a89a57f4..98c5a1deed 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -246,6 +246,25 @@ genConInfo comp_info tycon data_con
     closure_label   = mkClosureLabel  data_con
 \end{code}
 
+The entry code for a constructor now loads the info ptr by indirecting
+node.  The alternative is to load the info ptr in the enter-via-node
+sequence.  There's is a trade-off here:
+
+	* If the architecture can perform an indirect jump through a
+	  register in one instruction, or if the info ptr is not a
+	  real register, then *not* loading the info ptr on an enter
+	  is a win.
+
+	* If the enter-via-node code is identical whether we load the
+	  info ptr or not, then doing it is a win (it means we don't
+	  have to do it here).
+
+However, the gratuitous load here is miniscule compared to the
+gratuitous loads of the info ptr on each enter, so we go for the first
+option.
+
+-- Simon M. (6/5/96)
+
 \begin{code}
 mkConCodeAndInfo :: Id 			-- Data constructor
 		 -> (ClosureInfo, Code)	-- The info table
@@ -261,7 +280,7 @@ mkConCodeAndInfo con
 	    body_code
 	      = profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC`
 
-		performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
+		performReturn (mkAbstractCs (load_infoptr : map move_to_reg regs_w_offsets))
 			      (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
 			      emptyIdSet{-no live vars-}
 	in
@@ -278,7 +297,7 @@ mkConCodeAndInfo con
 		= -- NB: We don't set CC when entering data (WDP 94/06)
 		  profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
 
-		  performReturn AbsCNop	-- Ptr to thing already in Node
+		  performReturn (mkAbstractCs [load_infoptr])	-- Ptr to thing already in Node
 				(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
 				emptyIdSet{-no live vars-}
 	in
@@ -288,6 +307,9 @@ mkConCodeAndInfo con
     move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
     move_to_reg (reg, offset)
       = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
+
+    load_infoptr 
+      = CAssign (CReg infoptr) (CMacroExpr DataPtrRep INFO_PTR [CReg node])
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 6fed112402..dd0b7f4d4f 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -44,7 +44,7 @@ import PrimOp		( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
 			)
 import PrimRep		( getPrimRepSize, PrimRep(..) )
 import TyCon		( tyConDataCons )
-import Util		( panic, pprPanic )
+import Util		( panic, pprPanic, assertPanic )
 \end{code}
 
 This module provides the support code for @StgToAbstractC@ to deal
@@ -94,7 +94,8 @@ Here is where we insert real live machine instructions.
 
 \begin{code}
 cgExpr x@(StgPrim op args live_vars)
-  = getPrimOpArgAmodes op args	`thenFC` \ arg_amodes ->
+  = ASSERT(op /= SeqOp) -- can't handle SeqOp
+    getPrimOpArgAmodes op args	`thenFC` \ arg_amodes ->
     let
 	result_regs   = assignPrimOpResultRegs op
 	result_amodes = map CReg result_regs
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index 798c6ba16e..fa8f1e0bdb 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -10,10 +10,8 @@ module CgHeapery (
 	heapCheck,
 	allocHeap, allocDynClosure
 
-#ifdef GRAN
-	-- new for GrAnSim    HWL
-	, heapCheckOnly, fetchAndReschedule
-#endif  {- GRAN -}
+        -- new functions, basically inserting macro calls into Code -- HWL
+        , heapCheckOnly, fetchAndReschedule, yield
     ) where
 
 import Ubiq{-uitous-}
@@ -41,56 +39,15 @@ import PrimRep		( PrimRep(..) )
 %*									*
 %************************************************************************
 
-This is std code we replaced by the bits below for GrAnSim. -- HWL
+The new code  for heapChecks. For GrAnSim the code for doing a heap check
+and doing a context switch has been separated. Especially, the HEAP_CHK
+macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
+doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
+beginning of every slow entry code in order to simulate the fetching of
+closures. If fetching is necessary (i.e. current closure is not local) then
+an automatic context switch is done.
 
 \begin{code}
-#ifndef GRAN
-
-heapCheck :: [MagicId] 		-- Live registers
-	  -> Bool 		-- Node reqd after GC?
-	  -> Code
-	  -> Code
-
-heapCheck regs node_reqd code
-  = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
-  where
-
-    do_heap_chk :: HeapOffset -> Code
-    do_heap_chk words_required
-      = absC (if isZeroOff(words_required) then AbsCNop else checking_code) `thenC`
-	    -- The test is *inside* the absC, to avoid black holes!
-
-	-- Now we have set up the real heap pointer and checked there is
-	-- enough space. It remains only to reflect this in the environment
-
-	setRealHp words_required
-
-	    -- The "word_required" here is a fudge.
-	    -- *** IT DEPENDS ON THE DIRECTION ***, and on
-	    -- whether the Hp is moved the whole way all
-	    -- at once or not.
-      where
-	all_regs = if node_reqd then node:regs else regs
-	liveness_mask = mkLiveRegsMask all_regs
-
-	checking_code = CMacroStmt HEAP_CHK [
-			mkIntCLit liveness_mask,
-			COffset words_required,
-    	    	    	mkIntCLit (if node_reqd then 1 else 0)]
-#endif  {- GRAN -}
-\end{code}
-
-The GrAnSim code for heapChecks. The code for doing a heap check and
-doing a context switch has been separated. Especially, the HEAP_CHK
-macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used
-for doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at
-the beginning of every slow entry code in order to simulate the
-fetching of closures. If fetching is necessary (i.e. current closure
-is not local) then an automatic context switch is done.
-
-\begin{code}
-#ifdef GRAN
-
 heapCheck :: [MagicId]          -- Live registers
 	  -> Bool               -- Node reqd after GC?
 	  -> Code
@@ -169,10 +126,10 @@ heapCheck' do_context_switch regs node_reqd code
 -- Emit macro for simulating a fetch and then reschedule
 
 fetchAndReschedule ::   [MagicId]               -- Live registers
-			-> Bool                 -- Node reqd
+			-> Bool                 -- Node reqd?
 			-> Code
 
-fetchAndReschedule regs node_reqd =
+fetchAndReschedule regs node_reqd  =
       if (node `elem` regs || node_reqd)
 	then fetch_code `thenC` reschedule_code
 	else absC AbsCNop
@@ -187,8 +144,35 @@ fetchAndReschedule regs node_reqd =
 	 --HWL: generate GRAN_FETCH macro for GrAnSim
 	 --     currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
 	fetch_code = absC (CMacroStmt GRAN_FETCH [])
+\end{code}
+
+The @GRAN_YIELD@ macro is taken from JSM's  code for Concurrent Haskell. It
+allows to context-switch at  places where @node@ is  not alive (it uses the
+@Continue@ rather  than the @EnterNodeCode@  function in the  RTS). We emit
+this kind of macro at the beginning of the following kinds of basic bocks:
+\begin{itemize}
+ \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally 
+       we use @fetchAndReschedule@ at a slow entry code.
+ \item Fast entry code (see @CgClosure.lhs@).
+ \item Alternatives in case expressions (@CLabelledCode@ structures), provided
+       that they are not inlined (see @CgCases.lhs@). These alternatives will 
+       be turned into separate functions.
+\end{itemize}
+
+\begin{code}
+yield ::   [MagicId]               -- Live registers
+             -> Bool                 -- Node reqd?
+             -> Code 
+
+yield regs node_reqd =
+      -- NB: node is not alive; that's why we use DO_YIELD rather than 
+      --     GRAN_RESCHEDULE 
+      yield_code
+      where
+        all_regs = if node_reqd then node:regs else regs
+        liveness_mask = mkLiveRegsMask all_regs
 
-#endif  {- GRAN -}
+        yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs
index 856a119cd2..14e59f4526 100644
--- a/ghc/compiler/codeGen/CgRetConv.lhs
+++ b/ghc/compiler/codeGen/CgRetConv.lhs
@@ -42,7 +42,6 @@ import Id		( isDataCon, dataConSig,
 import Maybes		( catMaybes )
 import PprStyle		( PprStyle(..) )
 import PprType		( TyCon{-instance Outputable-} )
-import PrelInfo		( integerDataCon )
 import PrimOp		( primOpCanTriggerGC,
 			  getPrimOpResultInfo, PrimOpResultInfo(..),
 			  PrimOp{-instance Outputable-}
@@ -129,8 +128,6 @@ dataReturnConvAlg data_con
     (reg_assignment, leftover_kinds)
       = assignRegs [node, infoptr] -- taken...
 		   (map typePrimRep arg_tys)
-
-    is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11)
 \end{code}
 
 %************************************************************************
@@ -158,7 +155,7 @@ dataReturnConvPrim ArrayRep     = VanillaReg ArrayRep ILIT(1)
 dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep ILIT(1)
 
 dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1)
-dataReturnConvPrim MallocPtrRep = VanillaReg MallocPtrRep ILIT(1)
+dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep ILIT(1)
 
 #ifdef DEBUG
 dataReturnConvPrim PtrRep	= panic "dataReturnConvPrim: PtrRep"
@@ -207,8 +204,8 @@ argument into it).
 
 Bug: it is assumed that robust amodes cannot contain pointers.  This
 seems reasonable but isn't true.  For example, \tr{Array#}'s
-\tr{MallocPtr#}'s are pointers.  (This is only known to bite on
-\tr{_ccall_GC_} with a MallocPtr argument.)
+\tr{ForeignObj#}'s are pointers.  (This is only known to bite on
+\tr{_ccall_GC_} with a ForeignObj argument.)
 
 See after for some ADR comments...
 
diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
index 0ad6fc52fb..8e1c90a58e 100644
--- a/ghc/compiler/codeGen/CgStackery.lhs
+++ b/ghc/compiler/codeGen/CgStackery.lhs
@@ -10,7 +10,8 @@ Stack-twiddling operations, which are pretty low-down and grimy.
 #include "HsVersions.h"
 
 module CgStackery (
-	allocAStack, allocBStack, allocUpdateFrame,
+	allocAStack, allocBStack, allocAStackTop, allocBStackTop,
+	allocUpdateFrame,
 	adjustRealSps, getFinalStackHW,
 	mkVirtStkOffsets, mkStkAmodes
     ) where
@@ -59,7 +60,20 @@ mkVirtStkOffsets init_SpA_offset init_SpB_offset kind_fun things
 	(last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets)
   where
     computeOffset offset thing
-      = (offset + (getPrimRepSize . kind_fun) thing, (thing, offset+(1::Int)))
+      = (offset + (max 1 . getPrimRepSize . kind_fun) thing, (thing, offset+(1::Int)))
+	-- The "max 1" bit is ULTRA important
+	-- Why?  mkVirtStkOffsets is the unique function that lays out function
+	-- arguments on the stack. The "max 1" ensures that every argument takes
+	-- at least one stack slot, even if it's of kind VoidKind that actually
+	-- takes no space at all.
+	-- This is important to make sure that argument satisfaction checks work
+	-- properly.  Consider
+	--	f a b s# = (a,b)
+	-- where s# is a VoidKind.  f's argument satisfaction check will check
+	-- that s# is on the B stack above SuB; but if s# takes zero space, the
+	-- check will be ARGS_B_CHK(0), which always succeeds.  As a result, even
+	-- if a,b aren't available either, the PAP update won't trigger and
+	-- we are throughly hosed. (SLPJ 96/05)
 \end{code}
 
 @mkStackAmodes@ is a higher-level version of @mkStackOffsets@.
@@ -166,6 +180,28 @@ allocBStack size info_down (MkCgState absC binds
     delete_block free_b slot = [s | s <- free_b, (s<slot) || (s>=slot+size)]
 			      -- Retain slots which are not in the range
 			      -- slot..slot+size-1
+
+-- Allocate a chunk ON TOP OF the stack
+allocAStackTop :: Int -> FCode VirtualSpAOffset
+allocAStackTop size info_down (MkCgState absC binds
+	                     ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
+  = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
+  where
+    push_virt_a = virt_a + size
+    chosen_slot = virt_a + 1
+    new_a_usage = (push_virt_a, free_a, real_a, hw_a `max` push_virt_a)
+				                -- Adjust high water mark
+
+-- Allocate a chunk ON TOP OF the stack
+allocBStackTop :: Int -> FCode VirtualSpBOffset
+allocBStackTop size info_down (MkCgState absC binds
+	                     (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
+  = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
+  where
+    push_virt_b = virt_b + size
+    chosen_slot = virt_b+1
+    new_b_usage = (push_virt_b, free_b, real_b, hw_b `max` push_virt_b)
+				                -- Adjust high water mark
 \end{code}
 
 @allocUpdateFrame@ allocates enough space for an update frame
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index 8b3c23e5cc..15b2ae249b 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -36,7 +36,7 @@ import CLabel		( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
 import ClosureInfo	( nodeMustPointToIt,
 			  getEntryConvention, EntryConvention(..)
 			)
-import CmdLineOpts	( opt_EmitArityChecks, opt_DoSemiTagging )
+import CmdLineOpts	( opt_DoSemiTagging )
 import HeapOffs		( zeroOff, VirtualSpAOffset(..) )
 import Id		( idType, dataConTyCon, dataConTag,
 			  fIRST_TAG
@@ -314,10 +314,7 @@ tailCallBusiness :: Id -> CAddrMode	-- Function and its amode
 		 -> Code
 
 tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
-  = let
-	do_arity_chks = opt_EmitArityChecks
-    in
-    nodeMustPointToIt lf_info			`thenFC` \ node_points ->
+  = nodeMustPointToIt lf_info			`thenFC` \ node_points ->
     getEntryConvention fun lf_info
 	(map getAmodeRep arg_amodes)		`thenFC` \ entry_conv ->
 
@@ -346,10 +343,7 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
 						     `mkAbsCStmts`
 						  CJump (CLbl lbl CodePtrRep))
 	      DirectEntry lbl arity regs  ->
-		(regs,	 (if do_arity_chks
-			  then CMacroStmt SET_ARITY [mkIntCLit arity]
-			  else AbsCNop)
-			 `mkAbsCStmts` CJump (CLbl lbl CodePtrRep))
+		(regs,	 CJump (CLbl lbl CodePtrRep))
 
 	no_of_args = length arg_amodes