Clarify the SRT building process

Before: building a closure that would build an SRT given the top-level
SRT. It was somewhat difficult to understand the control flow, and it
may have had held onto some data structures long after they should be dead.
Now, I just bundle the info we need about CAFs along with the procedure
and directly call a new top-level function to build the SRTs later.

diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index f24aceb..fa3d920 100644 (file)
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -1,7 +1,8 @@
 module CmmBuildInfoTables
-    ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
+    ( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
     , setInfoTableSRT, setInfoTableStackMap
     , TopSRT, emptySRT, srtToData
+    , bundleCAFs
     , finishInfoTables, lowerSafeForeignCalls, extendEnvsForSafeForeignCalls )
 where
 
@@ -331,6 +332,8 @@ to_SRT top_srt off len bmp
 -- doesn't have a static closure.
 -- (If it has a static closure, it will already have an SRT to
 --  keep its CAFs live.)
+-- Any procedure referring to a non-static CAF c must keep live the
+-- any CAF that is reachable from c.
 localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
 localCAFInfo _    t@(CmmData _ _) = Nothing
 localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (LGraph entry _ _)) =
@@ -369,23 +372,33 @@ mkTopCAFInfo localCAFs = foldl addToTop emptyFM g
 
 type StackLayout = [Maybe LocalReg]
 
+-- Bundle the CAFs used at a procpoint.
+bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables)
+bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) =
+  case blockSetToList procpoints of
+    [bid] -> (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)
+    _     -> panic "setInfoTableStackMap: unexpect number of procpoints"
+             -- until we stop splitting the graphs at procpoints in the native path
+bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) =
+  (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)
+bundleCAFs _ t@(NoInfoTable _) = (emptyFM, t)
+
 -- Construct the SRTs for the given procedure.
-setInfoTableSRT :: CAFEnv -> FiniteMap CLabel CAFSet -> TopSRT ->
-                   CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables])
-setInfoTableSRT cafEnv topCAFMap topSRT t@(ProcInfoTable p procpoints) =
+setInfoTableSRT :: FiniteMap CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) ->
+                   FuelMonad (TopSRT, [CmmTopForInfoTables])
+setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable p procpoints)) =
   case blockSetToList procpoints of
-    [bid] -> setSRT cafEnv topCAFMap topSRT t bid
-    _ -> panic "setInfoTableStackMap: unexpect number of procpoints"
-           -- until we stop splitting the graphs at procpoints in the native path
-setInfoTableSRT cafEnv topCAFMap topSRT t@(FloatingInfoTable info bid _) =
-  setSRT cafEnv topCAFMap topSRT t bid
-setInfoTableSRT _ _ topSRT t@(NoInfoTable _) = return (topSRT, [t])
-
-setSRT :: CAFEnv -> FiniteMap CLabel CAFSet -> TopSRT ->
-          CmmTopForInfoTables -> BlockId -> FuelMonad (TopSRT, [CmmTopForInfoTables])
-setSRT cafEnv topCAFMap topSRT t bid =
-  do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap
-                                  (expectJust "sub_srt" $ lookupBlockEnv cafEnv bid)
+    [bid] -> setSRT cafs topCAFMap topSRT t
+    _     -> panic "setInfoTableStackMap: unexpect number of procpoints"
+             -- until we stop splitting the graphs at procpoints in the native path
+setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable info bid _)) =
+  setSRT cafs topCAFMap topSRT t
+setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t])
+
+setSRT :: CAFSet -> FiniteMap CLabel CAFSet -> TopSRT ->
+          CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables])
+setSRT cafs topCAFMap topSRT t =
+  do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
      let t' = updInfo id (const srt) t
      case cafTable of
        Just tbl -> return (topSRT, [t', NoInfoTable tbl])

diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index 6dcc5c5..7db4eed 100644 (file)
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -52,9 +52,10 @@ protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops)
   | otherwise
   = do let dflags = hsc_dflags hsc_env
         showPass dflags "CPSZ"
-        (cafEnvs, toTops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
+        (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
         let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
-        (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops 
+        (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
+        -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops 
         let cmms = Cmm (reverse (concat tops))
         dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
         return (topSRT, cmms : rst)
@@ -68,9 +69,8 @@ global to one compiler session.
 
 cpsTop :: HscEnv -> CmmTopZ ->
           IO ([(CLabel, CAFSet)],
-              (FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) -> IO (TopSRT, [[CmmTopZ]])))
-cpsTop _ p@(CmmData {}) =
-  return ([], (\ _ (topSRT, tops) -> return (topSRT, [p] : tops)))
+              [(CAFSet, CmmTopForInfoTables)])
+cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)])
 cpsTop hsc_env (CmmProc h l args g) =
     do 
        dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
@@ -122,6 +122,10 @@ cpsTop hsc_env (CmmProc h l args g) =
        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
        let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
        mapM (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
+       let gs'' = map (bundleCAFs cafEnv) gs'
+       mapM (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
+       return (localCAFs, gs'')
+{-
        -- Return: (a) CAFs used by this proc (b) a closure that will compute
        --  a new SRT for the procedure.
        let toTops topCAFEnv (topSRT, tops) =
@@ -130,9 +134,9 @@ cpsTop hsc_env (CmmProc h l args g) =
                          return (topSRT, gs : rst)
                 (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs'
                 gs' <- mapM finishInfoTables (concat gs')
-                pprTrace "localCAFs" (ppr localCAFs <+> ppr topSRT) $
-                  return (topSRT, concat gs' : tops)
+                return (topSRT, concat gs' : tops)
        return (localCAFs, toTops)
+-}
   where dflags = hsc_dflags hsc_env
         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
@@ -142,3 +146,18 @@ cpsTop hsc_env (CmmProc h l args g) =
              g <- run $ pass g
              dump flag ("Post " ++ txt) $ g
              return g
+
+-- This probably belongs in CmmBuildInfoTables?
+-- We're just finishing the job here: once we know what CAFs are defined
+-- in non-static closures, we can build the SRTs.
+toTops :: HscEnv -> FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]])
+                 -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
+
+toTops hsc_env topCAFEnv (topSRT, tops) gs =
+  do let setSRT (topSRT, rst) g =
+           do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
+              return (topSRT, gs : rst)
+     (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs
+     gs' <- mapM finishInfoTables (concat gs')
+     return (topSRT, concat gs' : tops)
+  where run = runFuelIO (hsc_OptFuel hsc_env)