diff options
| -rw-r--r-- | compiler/nativeGen/Instruction.hs | 13 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Liveness.hs | 40 | ||||
| -rw-r--r-- | compiler/nativeGen/X86/Instr.hs | 10 | ||||
| -rw-r--r-- | compiler/utils/Digraph.lhs | 30 |
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} ------------------------------------------------------------ |