Revert "Revert "Fix a bug in SRT generation""
authorBen Gamari <ben@smart-cactus.org>
Tue, 18 Sep 2018 15:45:26 +0000 (11:45 -0400)
committerBen Gamari <ben@smart-cactus.org>
Tue, 18 Sep 2018 15:45:26 +0000 (11:45 -0400)
This reverts commit d82e8af82d4be11252294290564044ef956ec2a4.

compiler/cmm/CmmBuildInfoTables.hs

index bef4d98..ecbe89d 100644 (file)
@@ -30,6 +30,7 @@ import CostCentre
 import StgCmmHeap
 
 import PprCmm()
+import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
@@ -445,20 +446,44 @@ getLabelledBlocks (CmmProc top_info _ _ _) =
   ]
 
 
--- | Get (Label,CLabel) pairs for each block that represents a CAF.
+-- | Put the labelled blocks that we will be annotating with SRTs into
+-- dependency order.  This is so that we can process them one at a
+-- time, resolving references to earlier blocks to point to their
+-- SRTs. CAFs themselves are not included here; see getCAFs below.
+depAnalSRTs
+  :: CAFEnv
+  -> [CmmDecl]
+  -> [SCC (Label, CAFLabel, Set CAFLabel)]
+depAnalSRTs cafEnv decls =
+  srtTrace "depAnalSRTs" (ppr graph) graph
+ where
+  labelledBlocks = concatMap getLabelledBlocks decls
+  labelToBlock = Map.fromList (map swap labelledBlocks)
+  graph = stronglyConnCompFromEdgedVerticesOrd
+             [ let cafs' = Set.delete lbl cafs in
+               DigraphNode (l,lbl,cafs') l
+                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
+             | (l, lbl) <- labelledBlocks
+             , Just cafs <- [mapLookup l cafEnv] ]
+
+
+-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.
 -- These are treated differently from other labelled blocks:
---  - we never resolve a reference to a CAF to the contents of its SRT, since
---    the point of SRTs is to keep CAFs alive.
+--  - we never [Shortcut] a reference to a CAF to the contents of its
+--    SRT, since the point of SRTs is to keep CAFs alive.
 --  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
 --    instead we generate their SRTs after everything else, so that we can
---    resolve references in the CAF's SRT.
-getCAFs :: CmmDecl -> [(Label, CAFLabel)]
-getCAFs (CmmData _ _) = []
-getCAFs (CmmProc top_info topLbl _ g)
-  | Just info <- mapLookup (g_entry g) (info_tbls top_info)
+--    [Shortcut] references from the CAF's SRT.
+getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
+getCAFs cafEnv decls =
+  [ (g_entry g, mkCAFLabel topLbl, cafs)
+  | CmmProc top_info topLbl _ g <- decls
+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
   , let rep = cit_rep info
-  , isStaticRep rep && isThunkRep rep = [(g_entry g, mkCAFLabel topLbl)]
-  | otherwise = []
+  , isStaticRep rep && isThunkRep rep
+  , Just cafs <- [mapLookup (g_entry g) cafEnv]
+  ]
+
 
 -- | Get the list of blocks that correspond to the entry points for
 -- FUN_STATIC closures.  These are the blocks for which if we have an
@@ -475,35 +500,6 @@ getStaticFuns decls =
   ]
 
 
--- | Put the labelled blocks that we will be annotating with SRTs into
--- dependency order.  This is so that we can process them one at a
--- time, resolving references to earlier blocks to point to their
--- SRTs.
-depAnalSRTs
-  :: CAFEnv
-  -> [CmmDecl]
-  -> [SCC (Label, CAFLabel, Set CAFLabel)]
-
-depAnalSRTs cafEnv decls =
-  srtTrace "depAnalSRTs" (ppr blockToLabel $$ ppr (graph ++ cafSCCs)) $
-  (graph ++ cafSCCs)
- where
-  cafs = concatMap getCAFs decls
-  cafSCCs = [ AcyclicSCC (blockid, lbl, cafs)
-            | (blockid, lbl) <- cafs
-            , Just cafs <- [mapLookup blockid cafEnv] ]
-  labelledBlocks = concatMap getLabelledBlocks decls
-  blockToLabel :: LabelMap CAFLabel
-  blockToLabel = mapFromList (cafs ++ labelledBlocks)
-  labelToBlock = Map.fromList (map swap labelledBlocks)
-  graph = stronglyConnCompFromEdgedVerticesOrd
-             [ let cafs' = Set.delete lbl cafs in
-               DigraphNode (l,lbl,cafs') l
-                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
-             | (l, lbl) <- labelledBlocks
-             , Just cafs <- [mapLookup l cafEnv] ]
-
-
 -- | Maps labels from 'cafAnal' to the final CLabel that will appear
 -- in the SRT.
 --   - closures with singleton SRTs resolve to their single entry
@@ -544,7 +540,9 @@ doSRTs dflags moduleSRTInfo tops = do
   -- don't need to generate the singleton SRT in the first place.  But
   -- to do this we need to process blocks before things that depend on
   -- them.
-  let sccs = depAnalSRTs cafEnv decls
+  let
+    sccs = depAnalSRTs cafEnv decls
+    cafsWithSRTs = getCAFs cafEnv decls
 
   -- On each strongly-connected group of decls, construct the SRT
   -- closures and the SRT fields for info tables.
@@ -556,8 +554,11 @@ doSRTs dflags moduleSRTInfo tops = do
       ((result, _srtMap), moduleSRTInfo') =
         initUs_ us $
         flip runStateT moduleSRTInfo $
-        flip runStateT Map.empty $
-        mapM (doSCC dflags staticFuns) sccs
+        flip runStateT Map.empty $ do
+          nonCAFs <- mapM (doSCC dflags staticFuns) sccs
+          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
+            oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs
+          return (nonCAFs ++ cAFs)
 
       (declss, pairs, funSRTs) = unzip3 result
 
@@ -583,13 +584,13 @@ doSCC
         )
 
 doSCC dflags staticFuns  (AcyclicSCC (l, cafLbl, cafs)) =
-  oneSRT dflags staticFuns [l] [cafLbl] cafs
+  oneSRT dflags staticFuns [l] [cafLbl] False cafs
 
 doSCC dflags staticFuns (CyclicSCC nodes) = do
   -- build a single SRT for the whole cycle
   let (blockids, lbls, cafsets) = unzip3 nodes
       cafs = Set.unions cafsets `Set.difference` Set.fromList lbls
-  oneSRT dflags staticFuns blockids lbls cafs
+  oneSRT dflags staticFuns blockids lbls False cafs
 
 
 -- | Build an SRT for a set of blocks
@@ -598,6 +599,7 @@ oneSRT
   -> LabelMap CLabel            -- which blocks are static function entry points
   -> [Label]                    -- blocks in this set
   -> [CAFLabel]                 -- labels for those blocks
+  -> Bool                       -- True <=> this SRT is for a CAF
   -> Set CAFLabel               -- SRT for this set
   -> StateT SRTMap
        (StateT ModuleSRTInfo UniqSM)
@@ -606,7 +608,7 @@ oneSRT
        , [(Label, [SRTEntry])]        -- SRTs to attach to static functions
        )
 
-oneSRT dflags staticFuns blockids lbls cafs = do
+oneSRT dflags staticFuns blockids lbls isCAF cafs = do
   srtMap <- get
   topSRT <- lift get
   let
@@ -629,9 +631,10 @@ oneSRT dflags staticFuns blockids lbls cafs = do
      (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()
 
   let
-    updateSRTMap srtEntry = do
-      let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
-      put (Map.union newSRTMap srtMap)
+    updateSRTMap srtEntry =
+      when (not isCAF) $ do   -- NB. no [Shortcut] for CAFs
+        let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
+        put (Map.union newSRTMap srtMap)
 
   case Set.toList filtered of
     [] -> do