diff options
Diffstat (limited to 'compiler/GHC/Cmm/Reducibility.hs')
| -rw-r--r-- | compiler/GHC/Cmm/Reducibility.hs | 229 |
1 files changed, 229 insertions, 0 deletions
diff --git a/compiler/GHC/Cmm/Reducibility.hs b/compiler/GHC/Cmm/Reducibility.hs new file mode 100644 index 0000000000..82a6616f0f --- /dev/null +++ b/compiler/GHC/Cmm/Reducibility.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + + +module GHC.Cmm.Reducibility + ( Reducibility(..) + , reducibility + + , asReducible + ) +where + +import GHC.Prelude hiding (splitAt, succ) + +import Control.Monad +import Data.List (nub) +import Data.Maybe +import Data.Semigroup +import qualified Data.Sequence as Seq + +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dominators +import GHC.Cmm.Dataflow.Graph hiding (addBlock) +import GHC.Cmm.Dataflow.Label +import GHC.Data.Graph.Collapse +import GHC.Data.Graph.Inductive.Graph +import GHC.Data.Graph.Inductive.PatriciaTree +import GHC.Types.Unique.Supply +import GHC.Utils.Panic + +{-| +Module : GHC.Cmm.Reducibility +Description : Tell if a `CmmGraph` is reducible, or make it so + +Test a Cmm control-flow graph for reducibility. And provide a +function that, when given an arbitrary control-flow graph, returns an +equivalent, reducible control-flow graph. The equivalent graph is +obtained by "splitting" (copying) nodes of the original graph. +The resulting equivalent graph has the same dynamic behavior as the +original, but it is larger. + +Documentation uses the language of control-flow analysis, in which a +basic block is called a "node." These "nodes" are `CmmBlock`s or +equivalent; they have nothing to do with a `CmmNode`. + +For more on reducibility and related analyses and algorithms, see +Note [Reducibility resources] +-} + + + + +-- | Represents the result of a reducibility analysis. +data Reducibility = Reducible | Irreducible + deriving (Eq, Show) + +-- | Given a graph, say whether the graph is reducible. The graph must +-- be bundled with a dominator analysis and a reverse postorder +-- numbering, as these results are needed to perform the test. + +reducibility :: NonLocal node + => GraphWithDominators node + -> Reducibility +reducibility gwd = + if all goodBlock blockmap then Reducible else Irreducible + where goodBlock b = all (goodEdge (entryLabel b)) (successors b) + goodEdge from to = rpnum to > rpnum from || to `dominates` from + rpnum = gwdRPNumber gwd + blockmap = graphMap $ gwd_graph gwd + dominators = gwdDominatorsOf gwd + dominates lbl blockname = + lbl == blockname || dominatorsMember lbl (dominators blockname) + +-- | Given a graph, return an equivalent reducible graph, by +-- "splitting" (copying) nodes if necessary. The input +-- graph must be bundled with a dominator analysis and a reverse +-- postorder numbering. The computation is monadic because when a +-- node is split, the new copy needs a fresh label. +-- +-- Use this function whenever a downstream algorithm needs a reducible +-- control-flow graph. + +asReducible :: GraphWithDominators CmmNode + -> UniqSM (GraphWithDominators CmmNode) +asReducible gwd = case reducibility gwd of + Reducible -> return gwd + Irreducible -> assertReducible <$> nodeSplit gwd + +assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode +assertReducible gwd = case reducibility gwd of + Reducible -> gwd + Irreducible -> panic "result not reducible" + +---------------------------------------------------------------- + +-- | Split one or more nodes of the given graph, which must be +-- irreducible. + +nodeSplit :: GraphWithDominators CmmNode + -> UniqSM (GraphWithDominators CmmNode) +nodeSplit gwd = + graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed + where g = gwd_graph gwd + collapsed :: NullCollapseViz (Gr CmmSuper ()) + collapsed = collapseInductiveGraph (cgraphOfCmm g) + +type CGraph = Gr CmmSuper () + +-- | Turn a collapsed supernode back into a control-flow graph +inflate :: Label -> CGraph -> CmmGraph +inflate entry cg = CmmGraph entry graph + where graph = GMany NothingO body NothingO + body :: LabelMap CmmBlock + body = foldl (\map block -> mapInsert (entryLabel block) block map) mapEmpty $ + blocks super + super = case labNodes cg of + [(_, s)] -> s + _ -> panic "graph given to `inflate` is not singleton" + + +-- | Convert a `CmmGraph` into an inductive graph. +-- (The function coalesces duplicate edges into a single edge.) +cgraphOfCmm :: CmmGraph -> CGraph +cgraphOfCmm g = foldl' addSuccEdges (mkGraph cnodes []) blocks + where blocks = zip [0..] $ revPostorderFrom (graphMap g) (g_entry g) + cnodes = [(k, super block) | (k, block) <- blocks] + where super block = Nodes (entryLabel block) (Seq.singleton block) + labelNumber = \lbl -> fromJust $ mapLookup lbl numbers + where numbers :: LabelMap Int + numbers = mapFromList $ map swap blocks + swap (k, block) = (entryLabel block, k) + addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph + addSuccEdges graph (k, block) = + insEdges [(k, labelNumber lbl, ()) | lbl <- nub $ successors block] graph +{- + +Note [Reducibility resources] +----------------------------- + +*Flow Analysis of Computer Programs.* Matthew S. Hecht North Holland, 1977. +Available to borrow from archive.org. + +Matthew S. Hecht and Jeffrey D. Ullman (1972). +Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202. +https://doi.org/10.1137/0201014 + +Johan Janssen and Henk Corporaal. 1997. Making graphs reducible with +controlled node splitting. ACM TOPLAS 19, 6 (Nov. 1997), +1031–1052. DOI:https://doi.org/10.1145/267959.269971 + +Sebastian Unger and Frank Mueller. 2002. Handling irreducible loops: +optimized node splitting versus DJ-graphs. ACM TOPLAS 24, 4 (July +2002), 299–333. https://doi.org/10.1145/567097.567098. (This one +contains the most detailed account of how the Hecht/Ullman algorithm +is used to modify an actual control-flow graph. But still not much detail.) + +https://rgrig.blogspot.com/2009/10/dtfloatleftclearleft-summary-of-some.html + (Nice summary of useful facts) + +-} + + + +type Seq = Seq.Seq + +-- | A "supernode" contains a single-entry, multiple-exit, reducible subgraph. +-- The entry point is the given label, and the block with that label +-- dominates all the other blocks in the supernode. When an entire +-- graph is collapsed into a single supernode, the graph is reducible. +-- More detail can be found in "GHC.Data.Graph.Collapse". + +data CmmSuper + = Nodes { label :: Label + , blocks :: Seq CmmBlock + } + +instance Semigroup CmmSuper where + s <> s' = Nodes (label s) (blocks s <> blocks s') + +instance PureSupernode CmmSuper where + superLabel = label + mapLabels = changeLabels + +instance Supernode CmmSuper NullCollapseViz where + freshen s = liftUniqSM $ relabel s + + +-- | Return all labels defined within a supernode. +definedLabels :: CmmSuper -> Seq Label +definedLabels = fmap entryLabel . blocks + + + +-- | Map the given function over every use and definition of a label +-- in the given supernode. +changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper) +changeLabels f (Nodes l blocks) = Nodes (f l) (fmap (changeBlockLabels f) blocks) + +-- | Map the given function over every use and definition of a label +-- in the given block. +changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock +changeBlockLabels f block = blockJoin entry' middle exit' + where (entry, middle, exit) = blockSplit block + entry' = let CmmEntry l scope = entry + in CmmEntry (f l) scope + exit' = case exit of + -- unclear why mapSuccessors doesn't touch these + CmmCall { cml_cont = Just l } -> exit { cml_cont = Just (f l) } + CmmForeignCall { succ = l } -> exit { succ = f l } + _ -> mapSuccessors f exit + + +-- | Within the given supernode, replace every defined label (and all +-- of its uses) with a fresh label. + +relabel :: CmmSuper -> UniqSM CmmSuper +relabel node = do + finite_map <- foldM addPair mapEmpty $ definedLabels node + return $ changeLabels (labelChanger finite_map) node + where addPair :: LabelMap Label -> Label -> UniqSM (LabelMap Label) + addPair map old = do new <- newBlockId + return $ mapInsert old new map + labelChanger :: LabelMap Label -> (Label -> Label) + labelChanger mapping = \lbl -> mapFindWithDefault lbl lbl mapping |