[commit: ghc] master: Fix discarding of unreachable code in the register allocator (#9155) (e577a52)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/e577a52363ee7ee8a07f1d863988332ae8fbf2e4/ghc

>---------------------------------------------------------------

commit e577a52363ee7ee8a07f1d863988332ae8fbf2e4
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Fri Jun 6 09:52:13 2014 +0100

    Fix discarding of unreachable code in the register allocator (#9155)
    
    A previous fix to this was wrong: f5879acd018494b84233f26fba828ce376d0f81d
    and left some unreachable code behind.  So rather than try to be clever and
    do this at the same time as the strongly-connected-component analysis, I'm
    doing a separate reachability pass first.


>---------------------------------------------------------------

e577a52363ee7ee8a07f1d863988332ae8fbf2e4
 compiler/nativeGen/RegAlloc/Liveness.hs         | 14 +++++++----
 compiler/utils/Digraph.lhs                      | 32 ++++++++++---------------
 testsuite/tests/codeGen/should_compile/T9155.hs | 30 +++++++++++++++++++++++
 testsuite/tests/codeGen/should_compile/all.T    |  1 +
 4 files changed, 53 insertions(+), 24 deletions(-)

diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index e5e80b2..1cb6dc8 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -671,14 +671,20 @@ sccBlocks
 
 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 ]
 
+        g1 = graphFromEdgedVertices nodes
+
+        reachable :: BlockSet
+        reachable = setFromList [ id | (_,id,_) <- reachablesG g1 roots ]
+
+        g2 = graphFromEdgedVertices [ node | node@(_,id,_) <- nodes
+                                           , id `setMember` reachable ]
+
+        sccs = stronglyConnCompG g2
+
         get_node (n, _, _) = n
 
         getOutEdges :: Instruction instr => [instr] -> [BlockId]
diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs
index a89eb71..d22380f 100644
--- a/compiler/utils/Digraph.lhs
+++ b/compiler/utils/Digraph.lhs
@@ -15,10 +15,10 @@ module Digraph(
         Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices,
 
         SCC(..), Node, flattenSCC, flattenSCCs,
-        stronglyConnCompG, stronglyConnCompFromG,
+        stronglyConnCompG,
         topologicalSortG, dfsTopSortG,
         verticesG, edgesG, hasVertexG,
-        reachableG, transposeG,
+        reachableG, reachablesG, transposeG,
         outdegreeG, indegreeG,
         vertexGroupsG, emptyG,
         componentsG,
@@ -258,14 +258,6 @@ stronglyConnCompG :: Graph node -> [SCC node]
 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
@@ -315,7 +307,13 @@ dfsTopSortG graph =
 reachableG :: Graph node -> node -> [node]
 reachableG graph from = map (gr_vertex_to_node graph) result
   where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
-        result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) from_vertex
+        result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]
+
+reachablesG :: Graph node -> [node] -> [node]
+reachablesG graph froms = map (gr_vertex_to_node graph) result
+  where result = {-# SCC "Digraph.reachable" #-} 
+                 reachable (gr_int_graph graph) vs
+        vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
 
 hasVertexG :: Graph node -> node -> Bool
 hasVertexG graph node = isJust $ gr_node_to_vertex graph node
@@ -548,9 +546,6 @@ 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}
@@ -574,9 +569,6 @@ 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}
 
 ------------------------------------------------------------
@@ -602,11 +594,11 @@ forward g tree pre = mapT select g
 ------------------------------------------------------------
 
 \begin{code}
-reachable    :: IntGraph -> Vertex -> [Vertex]
-reachable g v = preorderF (dfs g [v])
+reachable    :: IntGraph -> [Vertex] -> [Vertex]
+reachable g vs = preorderF (dfs g vs)
 
 path         :: IntGraph -> Vertex -> Vertex -> Bool
-path g v w    = w `elem` (reachable g v)
+path g v w    = w `elem` (reachable g [v])
 \end{code}
 
 ------------------------------------------------------------
diff --git a/testsuite/tests/codeGen/should_compile/T9155.hs b/testsuite/tests/codeGen/should_compile/T9155.hs
new file mode 100644
index 0000000..6fac0bc
--- /dev/null
+++ b/testsuite/tests/codeGen/should_compile/T9155.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module M () where
+
+import Data.Bits ((.&.))
+
+bitsSet :: Int -> Int -> Bool
+bitsSet mask i
+  = (i .&. mask == mask)
+
+class Eq b => BitMask b where
+  assocBitMask :: [(b,Int)]
+
+  fromBitMask  :: Int -> b
+  fromBitMask i
+    = walk assocBitMask
+    where
+      walk []         = error "Graphics.UI.WX.Types.fromBitMask: empty list"
+      walk [(x,0)]    = x
+      walk ((x,m):xs) | bitsSet m i = x
+                      | otherwise   = walk xs
+
+data Align   = AlignLeft
+             | AlignCentre
+             deriving Eq
+
+instance BitMask Align where
+  assocBitMask
+    = [(AlignCentre,512)
+      ,(AlignLeft,  256)
+      ]
diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T
index 487b6b6..ae8d0dd 100644
--- a/testsuite/tests/codeGen/should_compile/all.T
+++ b/testsuite/tests/codeGen/should_compile/all.T
@@ -22,3 +22,4 @@ test('massive_array',
 test('T7237', normal, compile, [''])
 test('T7574', [cmm_src, omit_ways(['llvm', 'optllvm'])], compile, [''])
 test('T8205', normal, compile, ['-O0'])
+test('T9155', normal, compile, ['-O2'])