[project @ 2005-04-21 15:28:20 by simonmar]

SMP: thunks get an extra header word so that the payload doesn't
occupy the same space as the updated value.  This is the sum total of
the changes to compiler/, which are pleasingly few.

4 files changed, 96 insertions, 63 deletions

diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 401da80103..b7cef4012f 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.68 2005/03/31 10:16:34 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.69 2005/04/21 15:28:20 simonmar Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -119,7 +119,8 @@ cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload
   {	-- LAY OUT THE OBJECT
     amodes <- getArgAmodes payload
   ; mod_name <- moduleName
-  ; let (tot_wds, ptr_wds, amodes_w_offsets) = mkVirtHeapOffsets amodes
+  ; let (tot_wds, ptr_wds, amodes_w_offsets) 
+	    = mkVirtHeapOffsets (isLFThunk lf_info) amodes
 
 	descr	     = closureDescription mod_name (idName bndr)
 	closure_info = mkClosureInfo False 	-- Not static
@@ -170,7 +171,9 @@ cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
   ; srt_info <- getSRTInfo name srt
   ; mod_name <- moduleName
   ; let	bind_details :: [(CgIdInfo, VirtualHpOffset)]
-	(tot_wds, ptr_wds, bind_details) = mkVirtHeapOffsets (map add_rep fv_infos)
+	(tot_wds, ptr_wds, bind_details) 
+	   = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
+
 	add_rep info = (cgIdInfoArgRep info, info)
 
 	descr	     = closureDescription mod_name name
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index 82276898bc..66bc6f5dcc 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgHeapery.lhs,v 1.45 2005/03/31 10:16:34 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.46 2005/04/21 15:28:20 simonmar Exp $
 %
 \section[CgHeapery]{Heap management functions}
 
@@ -40,7 +40,8 @@ import ClosureInfo	( closureSize, staticClosureNeedsLink,
 			  nodeMustPointToIt, closureLFInfo, 			
 			  ClosureInfo )
 import SMRep		( CgRep(..), cgRepSizeW, separateByPtrFollowness,
-			  WordOff, fixedHdrSize, isVoidArg, primRepToCgRep )
+			  WordOff, fixedHdrSize, thunkHdrSize,
+			  isVoidArg, primRepToCgRep )
 
 import Cmm		( CmmLit(..), CmmStmt(..), CmmExpr(..), GlobalReg(..),
 			  CmmReg(..), hpReg, nodeReg, spReg )
@@ -140,7 +141,7 @@ layOutConstr  is_static dflags data_con args
   where
     (tot_wds,		 --  #ptr_wds + #nonptr_wds
      ptr_wds,		 --  #ptr_wds
-     things_w_offsets) = mkVirtHeapOffsets args
+     things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args
 \end{code}
 
 @mkVirtHeapOffsets@ always returns boxed things with smaller offsets
@@ -149,7 +150,8 @@ list
 
 \begin{code}
 mkVirtHeapOffsets
-	  :: [(CgRep,a)]	-- Things to make offsets for
+	  :: Bool		-- True <=> is a thunk
+	  -> [(CgRep,a)]	-- Things to make offsets for
 	  -> (WordOff,		-- _Total_ number of words allocated
 	      WordOff,		-- Number of words allocated for *pointers*
 	      [(a, VirtualHpOffset)])
@@ -158,7 +160,7 @@ mkVirtHeapOffsets
 
 -- First in list gets lowest offset, which is initial offset + 1.
 
-mkVirtHeapOffsets things
+mkVirtHeapOffsets is_thunk things
   = let non_void_things		      = filterOut (isVoidArg . fst) things
 	(ptrs, non_ptrs)    	      = separateByPtrFollowness non_void_things
     	(wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
@@ -166,8 +168,11 @@ mkVirtHeapOffsets things
     in
     (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
   where
+    hdr_size 	| is_thunk   = thunkHdrSize
+		| otherwise  = fixedHdrSize
+
     computeOffset wds_so_far (rep, thing)
-      = (wds_so_far + cgRepSizeW rep, (thing, fixedHdrSize + wds_so_far))
+      = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + wds_so_far))
 \end{code}
 
 
@@ -227,6 +232,7 @@ mkStaticClosureFields cl_info ccs caf_refs payload
 	| caf_refs	= mkIntCLit 0
 	| otherwise	= mkIntCLit 1
 
+
 mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
   -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
 mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index a0b18ebc99..423f429ded 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -29,8 +29,8 @@ module ClosureInfo (
 
 	closureName, infoTableLabelFromCI,
 	closureLabelFromCI, closureSRT,
-	closureLFInfo, closureSMRep, closureUpdReqd, 
-	closureNeedsUpdSpace,
+	closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd, 
+	closureNeedsUpdSpace, closureIsThunk,
 	closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
 	closureFunInfo,	isStandardFormThunk, isKnownFun,
 
@@ -297,6 +297,16 @@ mkLFImported id
       other -> mkLFArgument id -- Not sure of exact arity
 \end{code}
 
+\begin{code}
+isLFThunk :: LambdaFormInfo -> Bool
+isLFThunk (LFThunk _ _ _ _ _)  = True
+isLFThunk (LFBlackHole _)      = True
+	-- return True for a blackhole: this function is used to determine
+	-- whether to use the thunk header in SMP mode, and a blackhole
+	-- must have one.
+isLFThunk _ = False
+\end{code}
+
 %************************************************************************
 %*									*
 	Building ClosureInfos
@@ -343,30 +353,21 @@ mkConInfo dflags is_static data_con tot_wds ptr_wds
 
 \begin{code}
 closureSize :: ClosureInfo -> WordOff
-closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info
+closureSize cl_info = hdr_size + closureNonHdrSize cl_info
+  where hdr_size  | closureIsThunk cl_info = thunkHdrSize
+  		  | otherwise      	   = fixedHdrSize
+	-- All thunks use thunkHdrSize, even if they are non-updatable.
+	-- this is because we don't have separate closure types for
+	-- updatable vs. non-updatable thunks, so the GC can't tell the
+	-- difference.  If we ever have significant numbers of non-
+	-- updatable thunks, it might be worth fixing this.
 
 closureNonHdrSize :: ClosureInfo -> WordOff
 closureNonHdrSize cl_info
-  = tot_wds + computeSlopSize tot_wds 
-			      (closureSMRep cl_info)
-			      (closureNeedsUpdSpace cl_info) 
+  = tot_wds + computeSlopSize tot_wds cl_info
   where
     tot_wds = closureGoodStuffSize cl_info
 
--- we leave space for an update if either (a) the closure is updatable
--- or (b) it is a static thunk.  This is because a static thunk needs
--- a static link field in a predictable place (after the slop), regardless
--- of whether it is updatable or not.
-closureNeedsUpdSpace (ClosureInfo { closureLFInfo = 
-					LFThunk TopLevel _ _ _ _ }) = True
-closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
-
-slopSize :: ClosureInfo -> WordOff
-slopSize cl_info
-  = computeSlopSize (closureGoodStuffSize cl_info)
-		    (closureSMRep cl_info)
-		    (closureNeedsUpdSpace cl_info)
-
 closureGoodStuffSize :: ClosureInfo -> WordOff
 closureGoodStuffSize cl_info
   = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
@@ -388,43 +389,51 @@ knowledge of what the storage manager does with the various
 representations...
 
 Slop Requirements:
-\begin{itemize}
-\item
-Updateable closures must be @mIN_UPD_SIZE@.
-	\begin{itemize}
-	\item
-	Indirections require 1 word
-	\item
-	Appels collector indirections 2 words
-	\end{itemize}
-THEREFORE: @mIN_UPD_SIZE = 2@.
-
-\item
-Collectable closures which are allocated in the heap
-must be	@mIN_SIZE_NonUpdHeapObject@.
 
-Copying collector forward pointer requires 1 word
+ - Updatable closures must be mIN_UPD_SIZE.
 
-THEREFORE: @mIN_SIZE_NonUpdHeapObject = 1@
-\end{itemize}
+ - Heap-resident Closures must be mIN_SIZE_NonUpdHeapObject
+   (to make room for an StgEvacuated during GC).
 
-Static closures have an extra ``static link field'' at the end, but we
-don't bother taking that into account here.
+In SMP mode, we don't play the mIN_UPD_SIZE game.  Instead, every
+thunk gets an extra padding word in the header, which takes the
+the updated value.
 
 \begin{code}
-computeSlopSize :: WordOff -> SMRep -> Bool -> WordOff
+slopSize cl_info = computeSlopSize payload_size cl_info
+  where payload_size = closureGoodStuffSize cl_info
 
-computeSlopSize tot_wds (GenericRep _ _ _ _) True		-- Updatable
-  = max 0 (mIN_UPD_SIZE - tot_wds)
-
-computeSlopSize tot_wds (GenericRep True _ _ _) False	-- Non updatable
-  = 0							-- Static
+computeSlopSize :: WordOff -> ClosureInfo -> WordOff
+computeSlopSize payload_size cl_info
+  = max 0 (minPayloadSize smrep updatable - payload_size)
+  where
+	smrep        = closureSMRep cl_info
+	updatable    = closureNeedsUpdSpace cl_info
 
-computeSlopSize tot_wds (GenericRep False _ _ _) False	-- Non updatable
-  = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds)		-- Dynamic
+-- we leave space for an update if either (a) the closure is updatable
+-- or (b) it is a static thunk.  This is because a static thunk needs
+-- a static link field in a predictable place (after the slop), regardless
+-- of whether it is updatable or not.
+closureNeedsUpdSpace (ClosureInfo { closureLFInfo = 
+					LFThunk TopLevel _ _ _ _ }) = True
+closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
 
-computeSlopSize tot_wds BlackHoleRep _			-- Updatable
-  = max 0 (mIN_UPD_SIZE - tot_wds)
+minPayloadSize :: SMRep -> Bool -> WordOff
+minPayloadSize smrep updatable
+  = case smrep of
+	BlackHoleRep		 		-> min_upd_size
+	GenericRep _ _ _ _      | updatable     -> min_upd_size
+	GenericRep True _ _ _                   -> 0 -- static
+	GenericRep False _ _ _                  -> mIN_SIZE_NonUpdHeapObject
+          --       ^^^^^___ dynamic
+  where
+   min_upd_size
+	| opt_SMP   = ASSERT(mIN_SIZE_NonUpdHeapObject <= 
+				sIZEOF_StgSMPThunkHeader)
+		      0 	-- check that we already have enough
+				-- room for mIN_SIZE_NonUpdHeapObject,
+				-- due to the extra header word in SMP
+	| otherwise = mIN_UPD_SIZE
 \end{code}
 
 %************************************************************************
@@ -766,11 +775,19 @@ isStaticClosure :: ClosureInfo -> Bool
 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
 
 closureUpdReqd :: ClosureInfo -> Bool
-closureUpdReqd (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _ }) = upd
-closureUpdReqd (ClosureInfo { closureLFInfo = LFBlackHole _ })     = True
+closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
+closureUpdReqd ConInfo{} = False
+
+lfUpdatable :: LambdaFormInfo -> Bool
+lfUpdatable (LFThunk _ _ upd _ _)  = upd
+lfUpdatable (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
+lfUpdatable _ = False
+
+closureIsThunk :: ClosureInfo -> Bool
+closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info
+closureIsThunk ConInfo{} = False
 
 closureSingleEntry :: ClosureInfo -> Bool
 closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs
index da446b6c54..b0b1b140f7 100644
--- a/ghc/compiler/codeGen/SMRep.lhs
+++ b/ghc/compiler/codeGen/SMRep.lhs
@@ -28,7 +28,7 @@ module SMRep (
 	SMRep(..), ClosureType(..),
 	isStaticRep,
 	fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize,
-	profHdrSize,
+	profHdrSize, thunkHdrSize,
 	tablesNextToCode,
 	smRepClosureType, smRepClosureTypeInt,
 
@@ -43,7 +43,7 @@ import Type		( Type, typePrimRep, PrimRep(..) )
 import TyCon		( TyCon, tyConPrimRep )
 import MachOp--		( MachRep(..), MachHint(..), wordRep )
 import StaticFlags	( opt_SccProfilingOn, opt_GranMacros,
-			  opt_Unregisterised )
+			  opt_Unregisterised, opt_SMP )
 import Constants
 import Outputable
 
@@ -285,6 +285,13 @@ arrWordsHdrSize   = fixedHdrSize*wORD_SIZE + sIZEOF_StgArrWords_NoHdr
 
 arrPtrsHdrSize    :: ByteOff
 arrPtrsHdrSize    = fixedHdrSize*wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr
+
+-- Thunks have an extra header word on SMP, so the update doesn't 
+-- splat the payload.
+thunkHdrSize :: WordOff
+thunkHdrSize | opt_SMP 	 = fixedHdrSize + smp_hdr
+	     | otherwise = fixedHdrSize
+	where smp_hdr = sIZEOF_StgSMPThunkHeader `quot` wORD_SIZE
 \end{code}
 
 \begin{code}