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

5 files changed, 134 insertions, 75 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 68f13c937e..14aa1837c7 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -104,8 +104,9 @@ module CLabel (
 	needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
         isMathFun,
  	isCFunctionLabel, isGcPtrLabel, labelDynamic,
+        infoLblToEntryLbl, entryLblToInfoLbl,
 
-	pprCLabel
+        pprCLabel
     ) where
 
 #include "HsVersions.h"
@@ -285,11 +286,14 @@ type IsLocal = Bool
 data IdLabelInfo
   = Closure		-- ^ Label for closure
   | SRT                 -- ^ Static reference table
-  | InfoTable IsLocal	-- ^ Info tables for closures; always read-only
+  | InfoTable           -- ^ Info tables for closures; always read-only
   | Entry	        -- ^ Entry point
-  | Slow		-- ^ Slow entry point
+  | Slow                -- ^ Slow entry point
 
-  | RednCounts		-- ^ Label of place to keep Ticky-ticky  info for this Id
+  | LocalInfoTable      -- ^ Like InfoTable but not externally visible
+  | LocalEntry          -- ^ Like Entry but not externally visible
+
+  | RednCounts          -- ^ Label of place to keep Ticky-ticky  info for this Id
 
   | ConEntry	  	-- ^ Constructor entry point
   | ConInfoTable 	-- ^ Corresponding info table
@@ -362,12 +366,12 @@ mkRednCountsLabel     	name c 	= IdLabel name  c RednCounts
 
 -- These have local & (possibly) external variants:
 mkLocalClosureLabel	name c 	= IdLabel name  c Closure
-mkLocalInfoTableLabel  	name c 	= IdLabel name  c (InfoTable True)
-mkLocalEntryLabel	name c 	= IdLabel name  c Entry
+mkLocalInfoTableLabel   name c  = IdLabel name  c LocalInfoTable
+mkLocalEntryLabel       name c  = IdLabel name  c LocalEntry
 mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable
 
 mkClosureLabel name         c     = IdLabel name c Closure
-mkInfoTableLabel name       c     = IdLabel name c (InfoTable False)
+mkInfoTableLabel name       c     = IdLabel name c InfoTable
 mkEntryLabel name           c     = IdLabel name c Entry
 mkClosureTableLabel name    c     = IdLabel name c ClosureTable
 mkLocalConInfoTableLabel    c con = IdLabel con c ConInfoTable
@@ -504,14 +508,37 @@ mkPlainModuleInitLabel mod	= PlainModuleInitLabel mod
 -- -----------------------------------------------------------------------------
 -- Brutal method of obtaining a closure label
 
-cvtToClosureLbl   (IdLabel n c (InfoTable _))	= IdLabel n c Closure
-cvtToClosureLbl   (IdLabel n c Entry)	        = IdLabel n c Closure
-cvtToClosureLbl   (IdLabel n c ConEntry)	= IdLabel n c Closure
+cvtToClosureLbl   (IdLabel n c InfoTable)       = IdLabel n c Closure
+cvtToClosureLbl   (IdLabel n c LocalInfoTable)  = IdLabel n c Closure -- XXX?
+cvtToClosureLbl   (IdLabel n c Entry)           = IdLabel n c Closure
+cvtToClosureLbl   (IdLabel n c LocalEntry)      = IdLabel n c Closure -- XXX?
+cvtToClosureLbl   (IdLabel n c ConEntry)        = IdLabel n c Closure
 cvtToClosureLbl   (IdLabel n c RednCounts)	= IdLabel n c Closure
 cvtToClosureLbl l@(IdLabel n c Closure)		= l
 cvtToClosureLbl l 
 	= pprPanic "cvtToClosureLbl" (pprCLabel l)
 
+infoLblToEntryLbl :: CLabel -> CLabel 
+infoLblToEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry
+infoLblToEntryLbl (IdLabel n c InfoTable)      = IdLabel n c Entry
+infoLblToEntryLbl (IdLabel n c ConInfoTable)   = IdLabel n c ConEntry
+infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry
+infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
+infoLblToEntryLbl (CmmLabel m str CmmInfo)     = CmmLabel m str CmmEntry
+infoLblToEntryLbl (CmmLabel m str CmmRetInfo)  = CmmLabel m str CmmRet
+infoLblToEntryLbl _
+       = panic "CLabel.infoLblToEntryLbl"
+
+entryLblToInfoLbl :: CLabel -> CLabel 
+entryLblToInfoLbl (IdLabel n c Entry)          = IdLabel n c InfoTable
+entryLblToInfoLbl (IdLabel n c LocalEntry)     = IdLabel n c LocalInfoTable
+entryLblToInfoLbl (IdLabel n c ConEntry)       = IdLabel n c ConInfoTable
+entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable
+entryLblToInfoLbl (CaseLabel n CaseReturnPt)   = CaseLabel n CaseReturnInfo
+entryLblToInfoLbl (CmmLabel m str CmmEntry)    = CmmLabel m str CmmInfo
+entryLblToInfoLbl (CmmLabel m str CmmRet)      = CmmLabel m str CmmRetInfo
+entryLblToInfoLbl l                            
+       = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
 
 -- -----------------------------------------------------------------------------
 -- Does a CLabel refer to a CAF?
@@ -678,7 +705,8 @@ externallyVisibleCLabel (LargeSRTLabel _)	= False
 
 externallyVisibleIdLabel :: IdLabelInfo -> Bool
 externallyVisibleIdLabel SRT             = False
-externallyVisibleIdLabel (InfoTable lcl) = not lcl
+externallyVisibleIdLabel LocalInfoTable  = False
+externallyVisibleIdLabel LocalEntry      = False
 externallyVisibleIdLabel _               = True
 
 -- -----------------------------------------------------------------------------
@@ -726,8 +754,9 @@ labelType _                                     = DataLabel
 
 idInfoLabelType info =
   case info of
-    InfoTable _   -> DataLabel
-    Closure    	  -> GcPtrLabel
+    InfoTable     -> DataLabel
+    LocalInfoTable -> DataLabel
+    Closure       -> GcPtrLabel
     ConInfoTable  -> DataLabel
     StaticInfoTable -> DataLabel
     ClosureTable  -> DataLabel
@@ -991,9 +1020,11 @@ ppIdFlavor x = pp_cSEP <>
 	       (case x of
 		       Closure	    	-> ptext (sLit "closure")
 		       SRT		-> ptext (sLit "srt")
-		       InfoTable _	-> ptext (sLit "info")
-		       Entry	    	-> ptext (sLit "entry")
-		       Slow	    	-> ptext (sLit "slow")
+                       InfoTable        -> ptext (sLit "info")
+                       LocalInfoTable   -> ptext (sLit "info")
+                       Entry            -> ptext (sLit "entry")
+                       LocalEntry       -> ptext (sLit "entry")
+                       Slow             -> ptext (sLit "slow")
 		       RednCounts	-> ptext (sLit "ct")
 		       ConEntry	    	-> ptext (sLit "con_entry")
 		       ConInfoTable    	-> ptext (sLit "con_info")
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