Discard unreachable code in the register allocator (#7574)

The problem with unreachable code is that it might refer to undefined
registers.  This happens accidentally: a block can be orphaned by an
optimisation, for example when the result of a comparsion becomes
known.

The register allocator panics when it finds an undefined register,
because they shouldn't occur in generated code.  So we need to also
discard unreachable code to prevent this panic being triggered by
optimisations.

The register alloator already does a strongly-connected component
analysis, so it ought to be easy to make it discard unreachable code
as part of that traversal.  It turns out that we need a different
variant of the scc algorithm to do that (see Digraph), however the new
variant also generates slightly better code by putting the blocks
within a loop in a better order for register allocation.

4 files changed, 73 insertions, 20 deletions

diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs
index 076129f7fa..8ecd2eb304 100644
--- a/compiler/nativeGen/Instruction.hs
+++ b/compiler/nativeGen/Instruction.hs
@@ -8,6 +8,7 @@ module Instruction (
         NatCmmDecl,
         NatBasicBlock,
         topInfoTable,
+        entryBlocks,
         Instruction(..)
 )
 
@@ -64,6 +65,18 @@ topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))
 topInfoTable _
   = Nothing
 
+-- | Return the list of BlockIds in a CmmDecl that are entry points
+-- for this proc (i.e. they may be jumped to from outside this proc).
+entryBlocks :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> [BlockId]
+entryBlocks (CmmProc info _ _ (ListGraph code)) = entries
+  where
+        infos = mapKeys info
+        entries = case code of
+                    [] -> infos
+                    BasicBlock entry _ : _ -- first block is the entry point
+                       | entry `elem` infos -> infos
+                       | otherwise          -> entry : infos
+entryBlocks _ = []
 
 -- | Common things that we can do with instructions, on all architectures.
 --      These are used by the shared parts of the native code generator,
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 41efa18753..6dd4cec0de 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -40,7 +40,6 @@ import Digraph
 import DynFlags
 import Outputable
 import Platform
-import Unique
 import UniqSet
 import UniqFM
 import UniqSupply
@@ -638,9 +637,9 @@ natCmmTopToLive (CmmData i d)
 natCmmTopToLive (CmmProc info lbl live (ListGraph []))
         = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl live []
 
-natCmmTopToLive (CmmProc info lbl live (ListGraph blocks@(first : _)))
+natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
  = let  first_id        = blockId first
-        sccs            = sccBlocks blocks
+        sccs            = sccBlocks blocks (entryBlocks proc)
         sccsLive        = map (fmap (\(BasicBlock l instrs) ->
                                         BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
                         $ sccs
@@ -648,21 +647,48 @@ natCmmTopToLive (CmmProc info lbl live (ListGraph blocks@(first : _)))
    in   CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl live sccsLive
 
 
+--
+-- Compute the liveness graph of the set of basic blocks.  Important:
+-- we also discard any unreachable code here, starting from the entry
+-- points (the first block in the list, and any blocks with info
+-- tables).  Unreachable code arises when code blocks are orphaned in
+-- earlier optimisation passes, and may confuse the register allocator
+-- by referring to registers that are not initialised.  It's easy to
+-- discard the unreachable code as part of the SCC pass, so that's
+-- exactly what we do. (#7574)
+--
 sccBlocks
         :: Instruction instr
         => [NatBasicBlock instr]
+        -> [BlockId]
         -> [SCC (NatBasicBlock instr)]
 
-sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
+sccBlocks blocks entries = map (fmap get_node) sccs
   where
+        sccs = stronglyConnCompFromG graph roots
+
+        graph = graphFromEdgedVertices nodes
+
+        -- nodes :: [(NatBasicBlock instr, Unique, [Unique])]
+        nodes = [ (block, id, getOutEdges instrs)
+                | block@(BasicBlock id instrs) <- blocks ]
+
+        get_node (n, _, _) = n
+
         getOutEdges :: Instruction instr => [instr] -> [BlockId]
         getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
 
-        graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
-                | block@(BasicBlock id instrs) <- blocks ]
+        -- This is truly ugly, but I don't see a good alternative.
+        -- Digraph just has the wrong API.  We want to identify nodes
+        -- by their keys (BlockId), but Digraph requires the whole
+        -- node: (NatBasicBlock, BlockId, [BlockId]).  This takes
+        -- advantage of the fact that Digraph only looks at the key,
+        -- even though it asks for the whole triple.
+        roots = [(panic "sccBlocks",b,panic "sccBlocks") | b <- entries ]
 
 
----------------------------------------------------------------------------------
+
+--------------------------------------------------------------------------------
 -- Annotate code with register liveness information
 --
 regLiveness
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 266a4ea58a..e584ffe8b9 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -871,14 +871,8 @@ allocMoreStack
   -> UniqSM (NatCmmDecl statics X86.Instr.Instr)
 
 allocMoreStack _ _ top@(CmmData _ _) = return top
-allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
-    let
-        infos = mapKeys info
-        entries = case code of
-                    [] -> infos
-                    BasicBlock entry _ : _ -- first block is the entry point
-                       | entry `elem` infos -> infos
-                       | otherwise          -> entry : infos
+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
+    let entries = entryBlocks proc
 
     uniqs <- replicateM (length entries) getUniqueUs
 
diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs
index 9ae84a7897..aefcde59f4 100644
--- a/compiler/utils/Digraph.lhs
+++ b/compiler/utils/Digraph.lhs
@@ -15,7 +15,8 @@ module Digraph(
         Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices,
 
         SCC(..), Node, flattenSCC, flattenSCCs,
-        stronglyConnCompG, topologicalSortG, dfsTopSortG,
+        stronglyConnCompG, stronglyConnCompFromG,
+        topologicalSortG, dfsTopSortG,
         verticesG, edgesG, hasVertexG,
         reachableG, transposeG,
         outdegreeG, indegreeG,
@@ -254,9 +255,21 @@ edges going from them to earlier ones.
 
 \begin{code}
 stronglyConnCompG :: Graph node -> [SCC node]
-stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn }) = map decode forest
+stronglyConnCompG graph = decodeSccs graph forest
+  where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph)
+
+-- Find the set of strongly connected components starting from the
+-- given roots.  This is a good way to discard unreachable nodes at
+-- the same time as computing SCCs.
+stronglyConnCompFromG :: Graph node -> [node] -> [SCC node]
+stronglyConnCompFromG graph roots = decodeSccs graph forest
+  where forest = {-# SCC "Digraph.scc" #-} sccFrom (gr_int_graph graph) vs
+        vs = [ v | Just v <- map (gr_node_to_vertex graph) roots ]
+
+decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
+decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
+  = map decode forest
   where
-    forest             = {-# SCC "Digraph.scc" #-} scc graph
     decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
                        | otherwise         = AcyclicSCC (vertex_fn v)
     decode other = CyclicSCC (dec other [])
@@ -269,11 +282,12 @@ stronglyConnCompFromEdgedVertices
         :: Ord key
         => [Node key payload]
         -> [SCC payload]
-stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
+stronglyConnCompFromEdgedVertices
+  = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
   where get_node (n, _, _) = n
 
 -- The "R" interface is used when you expect to apply SCC to
--- the (some of) the result of SCC, so you dont want to lose the dependency info
+-- (some of) the result of SCC, so you dont want to lose the dependency info
 stronglyConnCompFromEdgedVerticesR
         :: Ord key
         => [Node key payload]
@@ -534,6 +548,9 @@ postorderF ts = foldr (.) id $ map postorder ts
 postOrd :: IntGraph -> [Vertex]
 postOrd g = postorderF (dff g) []
 
+postOrdFrom :: IntGraph -> [Vertex] -> [Vertex]
+postOrdFrom g vs = postorderF (dfs g vs) []
+
 topSort :: IntGraph -> [Vertex]
 topSort = reverse . postOrd
 \end{code}
@@ -557,6 +574,9 @@ undirected g  = buildG (bounds g) (edges g ++ reverseE g)
 \begin{code}
 scc  :: IntGraph -> Forest Vertex
 scc g = dfs g (reverse (postOrd (transpose g)))
+
+sccFrom  :: IntGraph -> [Vertex] -> Forest Vertex
+sccFrom g vs = reverse (dfs (transpose g) (reverse (postOrdFrom g vs)))
 \end{code}
 
 ------------------------------------------------------------