[project @ 1999-05-11 16:44:02 by keithw]

(this is number 7 of 9 commits to be applied together)

  The code generator now incorporates the update avoidance
  optimisation: a thunk of __o type is now made SingleEntry rather
  than Updatable.

  We want to verify that SingleEntry thunks are indeed entered at most
  once.  In order to do this, -ticky turns on eager blackholing.
  Ordinary thunks will be dealt with by the RTS, but CAFs are
  blackholed by the code generator.  We blackhole with new blackholes:
  SE_CAF_BLACKHOLE.  We will enter one of these if we attempt to enter
  a SingleEntry thunk twice.

2 files changed, 88 insertions, 58 deletions

diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 0348f8f282..86f90af8ca 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.28 1999/04/23 09:51:24 simonm Exp $
+% $Id: CgClosure.lhs,v 1.29 1999/05/11 16:44:02 keithw Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -44,7 +44,7 @@ import CLabel		( CLabel, mkClosureLabel, mkFastEntryLabel,
 			  mkRednCountsLabel, mkStdEntryLabel
 			)
 import ClosureInfo	-- lots and lots of stuff
-import CmdLineOpts	( opt_GranMacros, opt_SccProfilingOn )
+import CmdLineOpts	( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
 import CostCentre	
 import Id		( Id, idName, idType, idPrimRep )
 import Name		( Name )
@@ -56,6 +56,9 @@ import Util		( isIn )
 import CmdLineOpts	( opt_SccProfilingOn )
 import Outputable
 
+import Name             ( nameOccName )
+import OccName          ( occNameFS )
+
 getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
 \end{code}
 
@@ -600,7 +603,8 @@ funWrapper closure_info arg_regs stk_tags slow_label fun_body
 
 
 \begin{code}
-blackHoleIt :: ClosureInfo -> Bool -> Code	-- Only called for thunks
+blackHoleIt :: ClosureInfo -> Bool -> Code	-- Only called for closures with no args
+
 blackHoleIt closure_info node_points
   = if blackHoleOnEntry closure_info && node_points
     then
@@ -613,42 +617,59 @@ blackHoleIt closure_info node_points
 \end{code}
 
 \begin{code}
-setupUpdate :: ClosureInfo -> Code -> Code	-- Only called for thunks
+setupUpdate :: ClosureInfo -> Code -> Code	-- Only called for closures with no args
 	-- Nota Bene: this function does not change Node (even if it's a CAF),
 	-- so that the cost centre in the original closure can still be
 	-- extracted by a subsequent ENTER_CC_TCL
 
+-- I've tidied up the code for this function, but it should still do the same as
+-- it did before (modulo ticky stuff).  KSW 1999-04.
 setupUpdate closure_info code
- = if (closureUpdReqd closure_info) then
-	link_caf_if_needed	`thenFC` \ update_closure ->
-    	pushUpdateFrame update_closure code
+ = if closureReEntrant closure_info
+   then
+     code
    else
-	profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
-	code
+     case (closureUpdReqd closure_info, isStaticClosure closure_info) of
+       (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
+	                code
+       (False,True ) -> (if opt_DoTickyProfiling
+                         then
+                         -- blackhole the SE CAF
+                           link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
+                         else
+                           nopC)                                                       `thenC`
+                        profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [CString cl_name] `thenC`
+                        profCtrC SLIT("TICK_UPDF_OMITTED") []                           `thenC`
+	                code
+       (True ,False) -> pushUpdateFrame (CReg node) code
+       (True ,True ) -> -- blackhole the (updatable) CAF:
+                        link_caf cafBlackHoleClosureInfo           `thenFC` \ update_closure ->
+                        profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [CString cl_name]    `thenC`
+                        pushUpdateFrame update_closure code
  where
-   link_caf_if_needed :: FCode CAddrMode	-- Returns amode for closure to be updated
-   link_caf_if_needed
-     = if not (isStaticClosure closure_info) then
-	  returnFC (CReg node)
-       else
-
-	  -- First we must allocate a black hole, and link the
-	  -- CAF onto the CAF list
-
-		-- Alloc black hole specifying CC_HDR(Node) as the cost centre
-		--   Hack Warning: Using a CLitLit to get CAddrMode !
-	  let
-	      use_cc   = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
-	      blame_cc = use_cc
-	  in
-	  allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
-							`thenFC` \ heap_offset ->
-	  getHpRelOffset heap_offset			`thenFC` \ hp_rel ->
-	  let  amode = CAddr hp_rel
-	  in
-	  absC (CMacroStmt UPD_CAF [CReg node, amode])
-						  	`thenC`
-	  returnFC amode
+   cl_name :: FAST_STRING
+   cl_name  = (occNameFS . nameOccName . closureName) closure_info
+
+   link_caf :: (ClosureInfo -> ClosureInfo)  -- function yielding BH closure_info
+            -> FCode CAddrMode	             -- Returns amode for closure to be updated
+   link_caf bhCI
+     = -- To update a CAF we must allocate a black hole, link the CAF onto the
+       -- CAF list, then update the CAF to point to the fresh black hole.
+       -- This function returns the address of the black hole, so it can be
+       -- updated with the new value when available.
+
+             -- Alloc black hole specifying CC_HDR(Node) as the cost centre
+             --   Hack Warning: Using a CLitLit to get CAddrMode !
+       let
+           use_cc   = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
+           blame_cc = use_cc
+       in
+       allocDynClosure (bhCI closure_info) use_cc blame_cc []  `thenFC` \ heap_offset ->
+       getHpRelOffset heap_offset                              `thenFC` \ hp_rel ->
+       let  amode = CAddr hp_rel
+       in
+       absC (CMacroStmt UPD_CAF [CReg node, amode])            `thenC`
+       returnFC amode
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index c81bafbb1a..986bfd29ee 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.36 1999/03/22 16:58:20 simonm Exp $
+% $Id: ClosureInfo.lhs,v 1.37 1999/05/11 16:44:02 keithw Exp $
 %
 \section[ClosureInfo]{Data structures which describe closures}
 
@@ -48,7 +48,7 @@ module ClosureInfo (
 
 	isStaticClosure,
 	allocProfilingMsg,
-	blackHoleClosureInfo,
+	cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
 	maybeSelectorInfo,
 
 	infoTblNeedsSRT,
@@ -68,7 +68,8 @@ import CgRetConv	( assignRegs )
 import CLabel		( CLabel, mkStdEntryLabel, mkFastEntryLabel,
 			  mkInfoTableLabel,
 			  mkConInfoTableLabel, mkStaticClosureLabel, 
-			  mkBlackHoleInfoTableLabel, 
+			  mkCAFBlackHoleInfoTableLabel, 
+			  mkSECAFBlackHoleInfoTableLabel, 
 			  mkStaticInfoTableLabel, mkStaticConEntryLabel,
 			  mkConEntryLabel, mkClosureLabel,
 			  mkSelectorInfoLabel, mkSelectorEntryLabel,
@@ -76,7 +77,7 @@ import CLabel		( CLabel, mkStdEntryLabel, mkFastEntryLabel,
 			  mkReturnPtLabel
 			)
 import CmdLineOpts	( opt_SccProfilingOn, opt_OmitBlackHoling,
-			  opt_Parallel )
+			  opt_Parallel, opt_DoTickyProfiling )
 import Id		( Id, idType, getIdArity )
 import DataCon		( DataCon, dataConTag, fIRST_TAG,
 			  isNullaryDataCon, isTupleCon, dataConName
@@ -155,9 +156,9 @@ data LambdaFormInfo
 	Int		-- arity;
 
   | LFBlackHole		-- Used for the closures allocated to hold the result
-
 			-- of a CAF.  We want the target of the update frame to
 			-- be in the heap, so we make a black hole to hold it.
+        CLabel          -- Flavour (info label, eg CAF_BLACKHOLE_info).
 
 
 data StandardFormInfo	-- Tells whether this thunk has one of a small number
@@ -252,7 +253,6 @@ Miscellaneous LF-infos.
 
 \begin{code}
 mkLFArgument	= LFArgument
-mkLFBlackHole	= LFBlackHole
 mkLFLetNoEscape = LFLetNoEscape
 
 mkLFImported :: Id -> LambdaFormInfo
@@ -582,9 +582,9 @@ nodeMustPointToIt lf_info
 	  -> returnFC True
 	  -- Node must point to any standard-form thunk.
 
-	LFArgument  -> returnFC True
-	LFImported  -> returnFC True
-	LFBlackHole -> returnFC True
+	LFArgument    -> returnFC True
+	LFImported    -> returnFC True
+	LFBlackHole _ -> returnFC True
 		    -- BH entry may require Node to point
 
 	LFLetNoEscape _ -> returnFC False
@@ -678,15 +678,15 @@ getEntryConvention name lf_info arg_kinds
 			     StdEntry (mkConEntryLabel (dataConName tup))
 
 	LFThunk _ _ _ updatable std_form_info _ _
-	  -> if updatable
+	  -> if updatable || opt_DoTickyProfiling  -- to catch double entry
 	     then ViaNode
-	     else StdEntry (thunkEntryLabel name std_form_info updatable)
+             else StdEntry (thunkEntryLabel name std_form_info updatable)
 
-	LFArgument  -> ViaNode
-	LFImported  -> ViaNode
-	LFBlackHole -> ViaNode	-- Presumably the black hole has by now
-				-- been updated, but we don't know with
-				-- what, so we enter via Node
+	LFArgument    -> ViaNode
+	LFImported    -> ViaNode
+	LFBlackHole _ -> ViaNode -- Presumably the black hole has by now
+				 -- been updated, but we don't know with
+				 -- what, so we enter via Node
 
 	LFLetNoEscape 0
 	  -> StdEntry (mkReturnPtLabel (nameUnique name))
@@ -717,7 +717,10 @@ blackHoleOnEntry (MkClosureInfo _ lf_info _)
 	LFThunk _ _ no_fvs updatable _ _ _
 	  -> if updatable
 	     then not opt_OmitBlackHoling
-	     else not no_fvs
+	     else opt_DoTickyProfiling || not no_fvs
+                  -- the former to catch double entry,
+                  -- and the latter to plug space-leaks.  KSW/SDM 1999-04.
+
 	other -> panic "blackHoleOnEntry"	-- Should never happen
 
 isStandardFormThunk :: LambdaFormInfo -> Bool
@@ -892,7 +895,7 @@ closureLFInfo (MkClosureInfo _ lf_info _) = lf_info
 
 closureUpdReqd :: ClosureInfo -> Bool
 closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = upd
-closureUpdReqd (MkClosureInfo _ LFBlackHole _)         = True
+closureUpdReqd (MkClosureInfo _ (LFBlackHole _) _)           = True
 	-- Black-hole closures are allocated to receive the results of an
 	-- alg case with a named default... so they need to be updated.
 closureUpdReqd other_closure			       = False
@@ -945,10 +948,10 @@ fastLabelFromCI (MkClosureInfo name _ _)
 infoTableLabelFromCI :: ClosureInfo -> CLabel
 infoTableLabelFromCI (MkClosureInfo id lf_info rep)
   = case lf_info of
-	LFCon con _ 	-> mkConInfoPtr con rep
-	LFTuple tup _	-> mkConInfoPtr tup rep
+	LFCon con _ 	 -> mkConInfoPtr con rep
+	LFTuple tup _	 -> mkConInfoPtr tup rep
 
-	LFBlackHole     -> mkBlackHoleInfoTableLabel
+	LFBlackHole info -> info
 
 	LFThunk _ _ _ upd_flag (SelectorThunk offset) _ _ -> 
 		mkSelectorInfoLabel upd_flag offset
@@ -1010,17 +1013,23 @@ allocProfilingMsg (MkClosureInfo _ lf_info _)
       LFReEntrant _ _ _ _ _ _	-> SLIT("TICK_ALLOC_FUN")
       LFCon _ _			-> SLIT("TICK_ALLOC_CON")
       LFTuple _ _		-> SLIT("TICK_ALLOC_CON")
-      LFThunk _ _ _ _ _ _ _     -> SLIT("TICK_ALLOC_THK")
-      LFBlackHole		-> SLIT("TICK_ALLOC_BH")
+      LFThunk _ _ _ True _ _ _  -> SLIT("TICK_ALLOC_UP_THK")  -- updatable
+      LFThunk _ _ _ False _ _ _ -> SLIT("TICK_ALLOC_SE_THK")  -- nonupdatable
+      LFBlackHole _		-> SLIT("TICK_ALLOC_BH")
       LFImported		-> panic "TICK_ALLOC_IMP"
 \end{code}
 
 We need a black-hole closure info to pass to @allocDynClosure@ when we
-want to allocate the black hole on entry to a CAF.
+want to allocate the black hole on entry to a CAF.  These are the only
+ways to build an LFBlackHole, maintaining the invariant that it really
+is a black hole and not something else.
 
 \begin{code}
-blackHoleClosureInfo (MkClosureInfo name _ _)
-  = MkClosureInfo name LFBlackHole BlackHoleRep
+cafBlackHoleClosureInfo (MkClosureInfo name _ _)
+  = MkClosureInfo name (LFBlackHole mkCAFBlackHoleInfoTableLabel) BlackHoleRep
+
+seCafBlackHoleClosureInfo (MkClosureInfo name _ _)
+  = MkClosureInfo name (LFBlackHole mkSECAFBlackHoleInfoTableLabel) BlackHoleRep
 \end{code}
 
 %************************************************************************