Refactoring: reduce usage of mkConInfo, with a view to killing it

4 files changed, 87 insertions, 59 deletions

diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index c4ba409734..f88541a023 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -245,21 +245,18 @@ cgDataCon :: DataCon -> FCode ()
 -- the static closure, for a constructor.
 cgDataCon data_con
   = do	{ let
-	    -- To allow the debuggers, interpreters, etc to cope with
-	    -- static data structures (ie those built at compile
-	    -- time), we take care that info-table contains the
-	    -- information we need.
-	    static_cl_info = mkConInfo True  no_cafs   data_con tot_wds ptr_wds
-	    dyn_cl_info    = mkConInfo False NoCafRefs data_con tot_wds ptr_wds
-            no_cafs = pprPanic "cgDataCon: CAF field should not be reqd" (ppr data_con)
-
-    	    (tot_wds, --  #ptr_wds + #nonptr_wds
+            (tot_wds, --  #ptr_wds + #nonptr_wds
     	     ptr_wds, --  #ptr_wds
     	     arg_things) = mkVirtConstrOffsets arg_reps
 
-	    emit_info cl_info ticky_code
-		= emitClosureAndInfoTable cl_info NativeDirectCall []
-                                        $ mk_code ticky_code
+            nonptr_wds   = tot_wds - ptr_wds
+
+            sta_info_tbl = mkDataConInfoTable data_con True  ptr_wds nonptr_wds
+            dyn_info_tbl = mkDataConInfoTable data_con False ptr_wds nonptr_wds
+
+            emit_info info_tbl ticky_code
+                = emitClosureAndInfoTable info_tbl NativeDirectCall []
+                             $ mk_code ticky_code
 
 	    mk_code ticky_code
 	      = 	-- NB: We don't set CC when entering data (WDP 94/06)
@@ -275,10 +272,10 @@ cgDataCon data_con
 
 	    -- Dynamic closure code for non-nullary constructors only
 	; whenC (not (isNullaryRepDataCon data_con))
-	 	(emit_info dyn_cl_info tickyEnterDynCon)
+                (emit_info dyn_info_tbl tickyEnterDynCon)
 
 		-- Dynamic-Closure first, to reduce forward references
-	; emit_info static_cl_info tickyEnterStaticCon }
+        ; emit_info sta_info_tbl tickyEnterStaticCon }
 
 
 ---------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 3823fa15b0..281ad31fa2 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -379,8 +379,11 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
 
 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
   | length args == 0 -- No args i.e. thunk
-  = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
+  = emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
       \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
+   where
+     lf_info  = closureLFInfo cl_info
+     info_tbl = mkCmmInfo cl_info
 
 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
   = ASSERT( length args > 0 )
@@ -392,8 +395,12 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
         ; emitTickyCounter cl_info (map stripNV args)
         ; setTickyCtrLabel ticky_ctr_lbl $ do
 
+        ; let
+             lf_info  = closureLFInfo cl_info
+             info_tbl = mkCmmInfo cl_info
+
         -- Emit the main entry code
-        ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $
+        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
             \(offset, node, arg_regs) -> do
                 -- Emit slow-entry code (for entering a closure through a PAP)
                 { mkSlowEntryCode cl_info arg_regs
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 498aea8c55..bbf884bfc4 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -33,6 +33,7 @@ module StgCmmClosure (
 	-----------------------------------
 	ClosureInfo,
 	mkClosureInfo, mkConInfo, 
+        mkCmmInfo,
 
         closureSize,
         closureName, infoTableLabelFromCI, entryLabelFromCI,
@@ -43,7 +44,7 @@ module StgCmmClosure (
 	closureFunInfo,	isStandardFormThunk, isKnownFun,
         funTag, tagForArity, 
 
-	enterIdLabel, enterLocalIdLabel, 
+        enterIdLabel, enterLocalIdLabel,
 
 	nodeMustPointToIt, 
 	CallMethod(..), getCallMethod,
@@ -55,6 +56,8 @@ module StgCmmClosure (
 	cafBlackHoleClosureInfo, 
 
         staticClosureNeedsLink, clHasCafRefs, clProfInfo,
+
+        mkDataConInfoTable,
     ) where
 
 #include "../includes/MachDeps.h"
@@ -360,8 +363,8 @@ isLFReEntrant _                = False
 
 lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
 lfClosureType (LFReEntrant _ arity _ argd) = Fun (fromIntegral arity) argd
-lfClosureType (LFCon con)                  =  Constr (fromIntegral (dataConTagZ con))
-                			              (dataConIdentity con)
+lfClosureType (LFCon con)                  = Constr (fromIntegral (dataConTagZ con))
+                                                      (dataConIdentity con)
 lfClosureType (LFThunk _ _ _ is_sel _) 	   = thunkClosureType is_sel
 lfClosureType _                 	   = panic "lfClosureType"
 
@@ -743,6 +746,15 @@ cafBlackHoleClosureInfo cl_info@(ClosureInfo {})
 	    , closureInfLcl = False }
 cafBlackHoleClosureInfo (ConInfo {}) = panic "cafBlackHoleClosureInfo"
 
+-- Convert from 'ClosureInfo' to 'CmmInfoTable'.
+-- Not used for return points.
+mkCmmInfo :: ClosureInfo -> CmmInfoTable
+mkCmmInfo cl_info
+  = CmmInfoTable { cit_lbl  = infoTableLabelFromCI cl_info,
+                   cit_rep  = closureSMRep cl_info,
+                   cit_prof = clProfInfo cl_info,
+                   cit_srt  = closureSRT cl_info }
+
 
 --------------------------------------
 --   Functions about closure *sizes*
@@ -856,45 +868,39 @@ isToplevClosure _ = False
 --   Label generation
 --------------------------------------
 
-infoTableLabelFromCI :: ClosureInfo -> CLabel
-infoTableLabelFromCI = fst . labelsFromCI
-
 entryLabelFromCI :: ClosureInfo -> CLabel
-entryLabelFromCI = snd . labelsFromCI
+entryLabelFromCI = infoLblToEntryLbl . infoTableLabelFromCI
 
-labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry)
-labelsFromCI (ClosureInfo { closureName = name,
+infoTableLabelFromCI :: ClosureInfo -> CLabel
+infoTableLabelFromCI (ClosureInfo { closureName = name,
 			    closureLFInfo = lf_info,
 			    closureCafs = cafs,
 			    closureInfLcl = is_lcl })
   = case lf_info of
-	LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel)
+        LFBlackHole -> mkCAFBlackHoleInfoTableLabel
 
 	LFThunk _ _ upd_flag (SelectorThunk offset) _ 
-		      -> bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset
+                      -> mkSelectorInfoLabel upd_flag offset
 
 	LFThunk _ _ upd_flag (ApThunk arity) _ 
-		      -> bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity
+                      -> mkApInfoTableLabel upd_flag arity
 
-	LFThunk{}     -> bothL std_mk_lbls name cafs
-	LFReEntrant{} -> bothL std_mk_lbls name cafs
+        LFThunk{}     -> std_mk_lbl name cafs
+        LFReEntrant{} -> std_mk_lbl name cafs
 	_other        -> panic "labelsFromCI"
 
   where 
-    std_mk_lbls | is_lcl    = (mkLocalInfoTableLabel, mkLocalEntryLabel)
-                | otherwise = (mkInfoTableLabel, mkEntryLabel)
-
-labelsFromCI (ConInfo { closureCon = con, closureSMRep = rep, closureCafs = cafs })
-  | isStaticRep rep 
-  = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel) name cafs
-  | otherwise	    
-  = bothL (mkConInfoTableLabel,    mkConEntryLabel)       name cafs
+    std_mk_lbl | is_lcl    = mkLocalInfoTableLabel
+               | otherwise = mkInfoTableLabel
+
+infoTableLabelFromCI (ConInfo { closureCon = con,
+                                closureSMRep = rep,
+                                closureCafs = cafs })
+  | isStaticRep rep = mkStaticInfoTableLabel name cafs
+  | otherwise       = mkConInfoTableLabel name cafs
   where
     name = dataConName con
 
-bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c)
-bothL (f, g) x y = (f x y, g x y)
-
 -- ClosureInfo for a closure (as opposed to a constructor) is always local
 closureLabelFromCI :: ClosureInfo -> CLabel
 closureLabelFromCI cl@(ClosureInfo { closureName = nm }) =
@@ -973,3 +979,29 @@ getPredTyDescription (ClassP cl _) = getOccString cl
 getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)
 getPredTyDescription (EqPred {})   = "Type equality"
 
+--------------------------------------
+--   Misc things
+--------------------------------------
+
+mkDataConInfoTable :: DataCon -> Bool -> Int -> Int -> CmmInfoTable
+mkDataConInfoTable data_con is_static ptr_wds nonptr_wds
+ = CmmInfoTable { cit_lbl  = info_lbl
+                , cit_rep  = sm_rep
+                , cit_prof = prof
+                , cit_srt  = NoC_SRT }
+ where
+   name = dataConName data_con
+
+   info_lbl | is_static = mkStaticInfoTableLabel name NoCafRefs
+            | otherwise = mkConInfoTableLabel    name NoCafRefs
+
+   sm_rep = mkHeapRep is_static ptr_wds nonptr_wds cl_type
+
+   cl_type = Constr (fromIntegral (dataConTagZ data_con))
+                   (dataConIdentity data_con)
+
+   prof | not opt_SccProfilingOn = NoProfilingInfo
+        | otherwise              = ProfilingInfo ty_descr val_descr
+
+   ty_descr  = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
+   val_descr = stringToWord8s $ occNameString $ getOccName data_con
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 953aa1cdd2..8b94abf828 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -369,12 +369,13 @@ stdPattern reps
 
 emitClosureProcAndInfoTable :: Bool                    -- top-level? 
                             -> Id                      -- name of the closure
-                            -> ClosureInfo             -- lots of info abt the closure
+                            -> LambdaFormInfo
+                            -> CmmInfoTable
                             -> [NonVoid Id]            -- incoming arguments
                             -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
                             -> FCode ()
-emitClosureProcAndInfoTable top_lvl bndr cl_info args body
- = do	{ let lf_info = closureLFInfo cl_info
+emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
+ = do   {
         -- Bind the binder itself, but only if it's not a top-level
         -- binding. We need non-top let-bindings to refer to the
         -- top-level binding, which this binding would incorrectly shadow.
@@ -386,28 +387,19 @@ emitClosureProcAndInfoTable top_lvl bndr cl_info args body
               conv  = if nodeMustPointToIt lf_info then NativeNodeCall
                                                    else NativeDirectCall
               (offset, _) = mkCallEntry conv args'
-        ; emitClosureAndInfoTable cl_info conv args' $ body (offset, node, arg_regs)
+        ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
         }
 
 -- Data constructors need closures, but not with all the argument handling
 -- needed for functions. The shared part goes here.
 emitClosureAndInfoTable ::
-  ClosureInfo -> Convention -> [LocalReg] -> FCode () -> FCode ()
-emitClosureAndInfoTable cl_info conv args body
-  = do { let info = mkCmmInfo cl_info
-       ; blks <- getCode body
-       ; emitProcWithConvention conv info (entryLabelFromCI cl_info) args blks
+  CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
+emitClosureAndInfoTable info_tbl conv args body
+  = do { blks <- getCode body
+       ; let entry_lbl = infoLblToEntryLbl (cit_lbl info_tbl)
+       ; emitProcWithConvention conv info_tbl entry_lbl args blks
        }
 
--- Convert from 'ClosureInfo' to 'CmmInfoTable'.
--- Not used for return points.
-mkCmmInfo :: ClosureInfo -> CmmInfoTable
-mkCmmInfo cl_info
-  = CmmInfoTable { cit_lbl  = infoTableLabelFromCI cl_info,
-                   cit_rep  = closureSMRep cl_info,
-                   cit_prof = clProfInfo cl_info,
-                   cit_srt  = closureSRT cl_info }
-
 -----------------------------------------------------------------------------
 --
 --	Info table offsets