diff options
author | Norman Ramsey <nr@cs.tufts.edu> | 2022-10-21 13:37:09 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-11-11 00:26:55 -0500 |
commit | 3633a5f5b001c3519b78c956cff4657f5ddde445 (patch) | |
tree | 17cf9edea5a8feb259f812a77cd923677601a85b | |
parent | b2035823daa804d7bc83f4a4b8d51c7ed14da9a0 (diff) | |
download | haskell-3633a5f5b001c3519b78c956cff4657f5ddde445.tar.gz |
add new modules for reducibility and WebAssembly translation
-rw-r--r-- | compiler/GHC/Cmm/Reducibility.hs | 224 | ||||
-rw-r--r-- | compiler/GHC/Data/Graph/Collapse.hs | 264 | ||||
-rw-r--r-- | compiler/GHC/Wasm/ControlFlow.hs | 53 | ||||
-rw-r--r-- | compiler/GHC/Wasm/ControlFlow/FromCmm.hs | 353 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 4 |
5 files changed, 898 insertions, 0 deletions
diff --git a/compiler/GHC/Cmm/Reducibility.hs b/compiler/GHC/Cmm/Reducibility.hs new file mode 100644 index 0000000000..0ab8524f30 --- /dev/null +++ b/compiler/GHC/Cmm/Reducibility.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| +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] +-} + +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 + +-- | 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 diff --git a/compiler/GHC/Data/Graph/Collapse.hs b/compiler/GHC/Data/Graph/Collapse.hs new file mode 100644 index 0000000000..a19b5fa4b7 --- /dev/null +++ b/compiler/GHC/Data/Graph/Collapse.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Data.Graph.Collapse + ( PureSupernode(..) + , Supernode(..) + , collapseInductiveGraph + , VizCollapseMonad(..) + , NullCollapseViz(..) + , runNullCollapse + , MonadUniqSM(..) + ) +where + +import GHC.Prelude + +import Control.Exception +import Control.Monad +import Data.List (delete, union, insert, intersect) +import Data.Semigroup + +import GHC.Cmm.Dataflow.Label +import GHC.Data.Graph.Inductive.Graph +import GHC.Types.Unique.Supply +import GHC.Utils.Panic + + +{-| +Module : GHC.Data.Graph.Collapse +Description : Implement the "collapsing" algorithm Hecht and Ullman + +A control-flow graph is reducible if and only if it is collapsible +according to the definition of Hecht and Ullman (1972). This module +implements the collapsing algorithm of Hecht and Ullman, and if it +encounters a graph that is not collapsible, it splits nodes until the +graph is fully collapsed. It then reports what nodes (if any) had to +be split in order to collapse the graph. The information is used +upstream to node-split Cmm graphs. + +The module uses the inductive graph representation cloned from the +Functional Graph Library (Hackage package `fgl`, modules +`GHC.Data.Graph.Inductive.*`.) + +-} + +-- Full reference to paper: Matthew S. Hecht and Jeffrey D. Ullman +-- (1972). Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202. +-- https://doi.org/10.1137/0201014 + + +------------------ Graph-splitting monad ----------------------- + +-- | If you want to visualize the graph-collapsing algorithm, create +-- an instance of monad `VizCollapseMonad`. Each step in the +-- algorithm is announced to the monad as a side effect. If you don't +-- care about visualization, you would use the `NullCollapseViz` +-- monad, in which these operations are no-ops. + +class (Monad m) => MonadUniqSM m where + liftUniqSM :: UniqSM a -> m a + +class (MonadUniqSM m, Graph gr, Supernode s m) => VizCollapseMonad m gr s where + consumeByInGraph :: Node -> Node -> gr s () -> m () + splitGraphAt :: gr s () -> LNode s -> m () + finalGraph :: gr s () -> m () + + + +-- | The identity monad as a `VizCollapseMonad`. Use this monad when +-- you want efficiency in graph collapse. +newtype NullCollapseViz a = NullCollapseViz { unNCV :: UniqSM a } + deriving (Functor, Applicative, Monad, MonadUnique) + +instance MonadUniqSM NullCollapseViz where + liftUniqSM = NullCollapseViz + +instance (Graph gr, Supernode s NullCollapseViz) => + VizCollapseMonad NullCollapseViz gr s where + consumeByInGraph _ _ _ = return () + splitGraphAt _ _ = return () + finalGraph _ = return () + +runNullCollapse :: NullCollapseViz a -> UniqSM a +runNullCollapse = unNCV + + +------------------ Utility functions on graphs ----------------------- + + +-- | Tell if a `Node` has a single predecessor. +singlePred :: Graph gr => gr a b -> Node -> Bool +singlePred gr n + | ([_], _, _, _) <- context gr n = True + | otherwise = False + +-- | Use this function to extract information about a `Node` that you +-- know is in a `Graph`. It's like `match` from `Graph`, but it must +-- succeed. +forceMatch :: (Graph gr) + => Node -> gr s b -> (Context s b, gr s b) +forceMatch node g = case match node g of (Just c, g') -> (c, g') + _ -> panicDump node g + where panicDump :: Graph gr => Node -> gr s b -> any + panicDump k _g = + panic $ "GHC.Data.Graph.Collapse failed to match node " ++ show k + +-- | Rewrite the label of a given node. +updateNode :: DynGraph gr => (s -> s) -> Node -> gr s b -> gr s b +updateNode relabel node g = (preds, n, relabel this, succs) & g' + where ((preds, n, this, succs), g') = forceMatch node g + + +-- | Test if a graph has but a single node. +singletonGraph :: Graph gr => gr a b -> Bool +singletonGraph g = case labNodes g of [_] -> True + _ -> False + + +---------------- Supernodes ------------------------------------ + +-- | A "supernode" stands for a collection of one or more nodes (basic +-- blocks) that have been coalesced by the Hecht-Ullman algorithm. +-- A collection in a supernode constitutes a /reducible/ subgraph of a +-- control-flow graph. (When an entire control-flow graph is collapsed +-- to a single supernode, the flow graph is reducible.) +-- +-- The idea of node splitting is to collapse a control-flow graph down +-- to a single supernode, then materialize (``inflate'') the reducible +-- equivalent graph from that supernode. The `Supernode` class +-- defines only the methods needed to collapse; rematerialization is +-- the responsiblity of the client. +-- +-- During the Hecht-Ullman algorithm, every supernode has a unique +-- entry point, which is given by `superLabel`. But this invariant is +-- not guaranteed by the class methods and is not a law of the class. +-- The `mapLabels` function rewrites all labels that appear in a +-- supernode (both definitions and uses). The `freshen` function +-- replaces every appearance of a /defined/ label with a fresh label. +-- (Appearances include both definitions and uses.) +-- +-- Laws: +-- @ +-- superLabel (n <> n') == superLabel n +-- blocks (n <> n') == blocks n `union` blocks n' +-- mapLabels f (n <> n') = mapLabels f n <> mapLabels f n' +-- mapLabels id == id +-- mapLabels (f . g) == mapLabels f . mapLabels g +-- @ +-- +-- (We expect `freshen` to distribute over `<>`, but because of +-- the fresh names involved, formulating a precise law is a bit +-- challenging.) + +class (Semigroup node) => PureSupernode node where + superLabel :: node -> Label + mapLabels :: (Label -> Label) -> (node -> node) + +class (MonadUnique m, PureSupernode node) => Supernode node m where + freshen :: node -> m node + + -- ghost method + -- blocks :: node -> Set Block + +------------------ Functions specific to the algorithm ----------------------- + +-- | Merge two nodes, return new graph plus list of nodes that newly have a single +-- predecessor. This function implements transformation $T_2$ from +-- the Hecht and Ullman paper (merge the node into its unique +-- predecessor). It then also removes self-edges (transformation $T_1$ from +-- the Hecht and Ullman paper). There is no need for a separate +-- implementation of $T_1$. +-- +-- `consumeBy v u g` returns the graph that results when node v is +-- consumed by node u in graph g. Both v and u are replaced with a new node u' +-- with these properties: +-- +-- LABELS(u') = LABELS(u) `union` LABELS(v) +-- SUCC(u') = SUCC(u) `union` SUCC(v) - { u } +-- every node that previously points to u now points to u' +-- +-- It also returns a list of nodes in the result graph that +-- are *newly* single-predecessor nodes. + +consumeBy :: (DynGraph gr, PureSupernode s) + => Node -> Node -> gr s () -> (gr s (), [Node]) +consumeBy toNode fromNode g = + assert (toPreds == [((), fromNode)]) $ + (newGraph, newCandidates) + where ((toPreds, _, to, toSuccs), g') = forceMatch toNode g + ((fromPreds, _, from, fromSuccs), g'') = forceMatch fromNode g' + context = ( fromPreds -- by construction, can't have `toNode` + , fromNode + , from <> to + , delete ((), fromNode) toSuccs `union` fromSuccs + ) + newGraph = context & g'' + newCandidates = filter (singlePred newGraph) changedNodes + changedNodes = fromNode `insert` map snd (toSuccs `intersect` fromSuccs) + +-- | Split a given node. The node is replaced with a collection of replicas, +-- one for each predecessor. After the split, every predecessor +-- points to a unique replica. +split :: forall gr s b m . (DynGraph gr, Supernode s m) + => Node -> gr s b -> m (gr s b) +split node g = assert (isMultiple preds) $ foldM addReplica g' newNodes + where ((preds, _, this, succs), g') = forceMatch node g + newNodes :: [((b, Node), Node)] + newNodes = zip preds [maxNode+1..] + (_, maxNode) = nodeRange g + thisLabel = superLabel this + addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b) + addReplica g ((b, pred), newNode) = do + newSuper <- freshen this + return $ add newSuper + where add newSuper = + updateNode (thisLabel `replacedWith` superLabel newSuper) pred $ + ([(b, pred)], newNode, newSuper, succs) & g + +replacedWith :: PureSupernode s => Label -> Label -> s -> s +replacedWith old new = mapLabels (\l -> if l == old then new else l) + + +-- | Does a list have more than one element? (in constant time). +isMultiple :: [a] -> Bool +isMultiple [] = False +isMultiple [_] = False +isMultiple (_:_:_) = True + +-- | Find a candidate for splitting by finding a node that has multiple predecessors. + +anySplittable :: forall gr a b . Graph gr => gr a b -> LNode a +anySplittable g = case splittable of + n : _ -> n + [] -> panic "anySplittable found no splittable nodes" + where splittable = filter (isMultiple . pre g . fst) $ labNodes g + splittable :: [LNode a] + + +------------------ The collapsing algorithm ----------------------- + +-- | Using the algorithm of Hecht and Ullman (1972), collapse a graph +-- into a single node, splitting nodes as needed. Record +-- visualization events in monad `m`. +collapseInductiveGraph :: (DynGraph gr, Supernode s m, VizCollapseMonad m gr s) + => gr s () -> m (gr s ()) +collapseInductiveGraph g = drain g worklist + where worklist :: [[Node]] -- nodes with exactly one predecessor + worklist = [filter (singlePred g) $ nodes g] + + drain g [] = if singletonGraph g then finalGraph g >> return g + else let (n, super) = anySplittable g + in do splitGraphAt g (n, super) + collapseInductiveGraph =<< split n g + drain g ([]:nss) = drain g nss + drain g ((n:ns):nss) = let (g', ns') = consumeBy n (theUniquePred n) g + in do consumeByInGraph n (theUniquePred n) g + drain g' (ns':ns:nss) + where theUniquePred n + | ([(_, p)], _, _, _) <- context g n = p + | otherwise = + panic "node claimed to have a unique predecessor; it doesn't" diff --git a/compiler/GHC/Wasm/ControlFlow.hs b/compiler/GHC/Wasm/ControlFlow.hs new file mode 100644 index 0000000000..97c703597e --- /dev/null +++ b/compiler/GHC/Wasm/ControlFlow.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds, GADTs, RankNTypes, TypeOperators, KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} + +module GHC.Wasm.ControlFlow + ( WasmControl(..), (<>), pattern WasmIf, wasmReturn + , BrTableInterval(..), inclusiveInterval + + , WasmType, WasmTypeTag(..) + , TypeList(..) + , WasmFunctionType(..) + ) +where + +import GHC.Prelude + +import GHC.CmmToAsm.Wasm.Types +import GHC.Utils.Panic + +{-| +Module : GHC.Wasm.ControlFlow +Description : Representation of control-flow portion of the WebAssembly instruction set +-} + +inclusiveInterval :: Integer -> Integer -> BrTableInterval +inclusiveInterval lo hi + | lo <= hi = let count = hi - lo + 1 + in BrTableInterval lo count + | otherwise = panic "GHC.Wasm.ControlFlow: empty interval" + +(<>) :: forall s e pre mid post + . WasmControl s e pre mid + -> WasmControl s e mid post + -> WasmControl s e pre post +(<>) = WasmSeq +-- N.B. Fallthrough can't be optimized away because of type checking. + + + +-- Syntactic sugar. +pattern WasmIf :: WasmFunctionType pre post + -> e + -> WasmControl s e pre post + -> WasmControl s e pre post + -> WasmControl s e pre post + +pattern WasmIf ty e t f = + WasmPush TagI32 e `WasmSeq` WasmIfTop ty t f + +-- More syntactic sugar. +wasmReturn :: WasmTypeTag t -> e -> WasmControl s e (t ': t1star) t2star +wasmReturn tag e = WasmPush tag e `WasmSeq` WasmReturnTop tag diff --git a/compiler/GHC/Wasm/ControlFlow/FromCmm.hs b/compiler/GHC/Wasm/ControlFlow/FromCmm.hs new file mode 100644 index 0000000000..e003fff96a --- /dev/null +++ b/compiler/GHC/Wasm/ControlFlow/FromCmm.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module GHC.Wasm.ControlFlow.FromCmm + ( structuredControl + ) +where + +import GHC.Prelude hiding (succ) + +import Data.Function +import Data.List (sortBy) +import qualified Data.Tree as Tree + +import GHC.Cmm +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dominators +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Switch + +import GHC.CmmToAsm.Wasm.Types + +import GHC.Platform + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr + , pprWithCommas + , showSDocUnsafe + ) + +import GHC.Wasm.ControlFlow + + +{-| +Module : GHC.Wasm.ControlFlow.FromCmm +Description : Translation of (reducible) Cmm control flow to WebAssembly + +Code in this module can translate any _reducible_ Cmm control-flow +graph to the structured control flow that is required by WebAssembly. +The algorithm is subtle and is described in detail in a draft paper +to be found at https://www.cs.tufts.edu/~nr/pubs/relooper.pdf. +-} + +--------------------- Abstraction of Cmm control flow ----------------------- + +-- | Abstracts the kind of control flow we understand how to convert. +-- A block can be left in one of four ways: +-- +-- * Unconditionally +-- +-- * Conditionally on a predicate of type `e` +-- +-- * To a location determined by the value of a scrutinee of type `e` +-- +-- * Not at all. + +data ControlFlow e = Unconditional Label + | Conditional e Label Label + | Switch { _scrutinee :: e + , _range :: BrTableInterval + , _targets :: [Maybe Label] -- from 0 + , _defaultTarget :: Maybe Label + } + | TailCall e + +flowLeaving :: Platform -> CmmBlock -> ControlFlow CmmExpr +flowLeaving platform b = + case lastNode b of + CmmBranch l -> Unconditional l + CmmCondBranch c t f _ -> Conditional c t f + CmmSwitch e targets -> + let (offset, target_labels) = switchTargetsToTable targets + (lo, hi) = switchTargetsRange targets + default_label = switchTargetsDefault targets + scrutinee = smartPlus platform e offset + range = inclusiveInterval (lo+toInteger offset) (hi+toInteger offset) + in Switch scrutinee range target_labels default_label + CmmCall { cml_cont = Nothing, cml_target = e } -> TailCall e + _ -> panic "flowLeaving: unreachable" + +----------------------- Evaluation contexts ------------------------------ + +-- | The syntactic constructs in which Wasm code may be contained. +-- A list of these constructs represents an evaluation context, +-- which is used to determined what level of `br` instruction +-- reaches a given label. + +data ContainingSyntax + = BlockFollowedBy Label + | LoopHeadedBy Label + | IfThenElse (Maybe Label) -- ^ Carries the label that follows `if...end`, if any + +matchesFrame :: Label -> ContainingSyntax -> Bool +matchesFrame label (BlockFollowedBy l) = label == l +matchesFrame label (LoopHeadedBy l) = label == l +matchesFrame label (IfThenElse (Just l)) = label == l +matchesFrame _ _ = False + +data Context = Context { enclosing :: [ContainingSyntax] + , fallthrough :: Maybe Label -- the label can + -- be reached just by "falling through" + -- the hole + } + +instance Outputable Context where + ppr c | Just l <- fallthrough c = + pprWithCommas ppr (enclosing c) <+> text "fallthrough to" <+> ppr l + | otherwise = pprWithCommas ppr (enclosing c) + +emptyContext :: Context +emptyContext = Context [] Nothing + +inside :: ContainingSyntax -> Context -> Context +withFallthrough :: Context -> Label -> Context + +inside frame c = c { enclosing = frame : enclosing c } +withFallthrough c l = c { fallthrough = Just l } + +type CmmActions = Block CmmNode O O + +type FT pre post = WasmFunctionType pre post + +returns :: FT '[] '[ 'I32] +doesn'tReturn :: FT '[] '[] + +returns = WasmFunctionType TypeListNil (TypeListCons TagI32 TypeListNil) +doesn'tReturn = WasmFunctionType TypeListNil TypeListNil + +emptyPost :: FT pre post -> Bool +emptyPost (WasmFunctionType _ TypeListNil) = True +emptyPost _ = False + +----------------------- Translation ------------------------------ + +-- | Convert a Cmm CFG to WebAssembly's structured control flow. + +structuredControl :: forall expr stmt m . + Applicative m + => Platform -- ^ needed for offset calculation + -> (Label -> CmmExpr -> m expr) -- ^ translator for expressions + -> (Label -> CmmActions -> m stmt) -- ^ translator for straight-line code + -> CmmGraph -- ^ CFG to be translated + -> m (WasmControl stmt expr '[] '[ 'I32]) +structuredControl platform txExpr txBlock g = + doTree returns dominatorTree emptyContext + where + gwd :: GraphWithDominators CmmNode + gwd = graphWithDominators g + + dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted + -- with highest reverse-postorder number first + dominatorTree = fmap blockLabeled $ sortTree $ gwdDominatorTree gwd + + doTree :: FT '[] post -> Tree.Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post) + nodeWithin :: forall post . + FT '[] post -> CmmBlock -> [Tree.Tree CmmBlock] -> Maybe Label + -> Context -> m (WasmControl stmt expr '[] post) + doBranch :: FT '[] post -> Label -> Label -> Context -> m (WasmControl stmt expr '[] post) + + doTree fty (Tree.Node x children) context = + let codeForX = nodeWithin fty x selectedChildren Nothing + in if isLoopHeader x then + WasmLoop fty <$> codeForX loopContext + else + codeForX context + where selectedChildren = case lastNode x of + CmmSwitch {} -> children + -- N.B. Unlike `if`, translation of Switch uses only labels. + _ -> filter hasMergeRoot children + loopContext = LoopHeadedBy (entryLabel x) `inside` context + hasMergeRoot = isMergeNode . Tree.rootLabel + + nodeWithin fty x (y_n:ys) (Just zlabel) context = + WasmBlock fty <$> nodeWithin fty x (y_n:ys) Nothing context' + where context' = BlockFollowedBy zlabel `inside` context + nodeWithin fty x (y_n:ys) Nothing context = + nodeWithin doesn'tReturn x ys (Just ylabel) (context `withFallthrough` ylabel) <<>> + doTree fty y_n context + where ylabel = treeEntryLabel y_n + nodeWithin fty x [] (Just zlabel) context + | not (generatesIf x) = + WasmBlock fty <$> nodeWithin fty x [] Nothing context' + where context' = BlockFollowedBy zlabel `inside` context + nodeWithin fty x [] maybeMarks context = + translationOfX context + where xlabel = entryLabel x + + translationOfX :: Context -> m (WasmControl stmt expr '[] post) + translationOfX context = + (WasmActions <$> txBlock xlabel (nodeBody x)) <<>> + case flowLeaving platform x of + Unconditional l -> doBranch fty xlabel l context + Conditional e t f -> + WasmIf fty + <$> txExpr xlabel e + <*> doBranch fty xlabel t (IfThenElse maybeMarks `inside` context) + <*> doBranch fty xlabel f (IfThenElse maybeMarks `inside` context) + TailCall e -> (WasmPush TagI32 <$> txExpr xlabel e) <<>> pure (WasmReturnTop TagI32) + Switch e range targets default' -> + WasmBrTable <$> txExpr xlabel e + <$~> range + <$~> map switchIndex targets + <$~> switchIndex default' + where switchIndex :: Maybe Label -> Int + switchIndex Nothing = 0 -- arbitrary; GHC won't go here + switchIndex (Just lbl) = index lbl (enclosing context) + + doBranch fty from to context + | to `elem` fallthrough context && emptyPost fty = pure WasmFallthrough + -- optimization: `br` is not needed, but it typechecks + -- only if nothing is expected to be left on the stack + + | isBackward from to = pure $ WasmBr i -- continue + | isMergeLabel to = pure $ WasmBr i -- exit + | otherwise = doTree fty (subtreeAt to) context -- inline the code here + where i = index to (enclosing context) + + generatesIf :: CmmBlock -> Bool + generatesIf x = case flowLeaving platform x of Conditional {} -> True + _ -> False + + ---- everything else is utility functions + + treeEntryLabel :: Tree.Tree CmmBlock -> Label + treeEntryLabel = entryLabel . Tree.rootLabel + + sortTree :: Tree.Tree Label -> Tree.Tree Label + -- Sort highest rpnum first + sortTree (Tree.Node label children) = + Tree.Node label $ sortBy (flip compare `on` (rpnum . Tree.rootLabel)) $ + map sortTree children + + subtreeAt :: Label -> Tree.Tree CmmBlock + blockLabeled :: Label -> CmmBlock + rpnum :: Label -> RPNum-- reverse postorder number of the labeled block + isMergeLabel :: Label -> Bool + isMergeNode :: CmmBlock -> Bool + isLoopHeader :: CmmBlock -> Bool-- identify loop headers + -- all nodes whose immediate dominator is the given block. + -- They are produced with the largest RP number first, + -- so the largest RP number is pushed on the context first. + dominates :: Label -> Label -> Bool + -- Domination relation (not just immediate domination) + + blockmap :: LabelMap CmmBlock + GMany NothingO blockmap NothingO = g_graph g + + blockLabeled l = findLabelIn l blockmap + + rpblocks :: [CmmBlock] + rpblocks = revPostorderFrom blockmap (g_entry g) + + foldEdges :: forall a . (Label -> Label -> a -> a) -> a -> a + foldEdges f a = + foldl (\a (from, to) -> f from to a) + a + [(entryLabel from, to) | from <- rpblocks, to <- successors from] + + isMergeLabel l = setMember l mergeBlockLabels + isMergeNode = isMergeLabel . entryLabel + + isBackward :: Label -> Label -> Bool + isBackward from to = rpnum to <= rpnum from -- self-edge counts as a backward edge + + subtreeAt label = findLabelIn label subtrees + subtrees :: LabelMap (Tree.Tree CmmBlock) + subtrees = addSubtree mapEmpty dominatorTree + where addSubtree map t@(Tree.Node root children) = + foldl addSubtree (mapInsert (entryLabel root) t map) children + + mergeBlockLabels :: LabelSet + -- N.B. A block is a merge node if it is where control flow merges. + -- That means it is entered by multiple control-flow edges, _except_ + -- back edges don't count. There must be multiple paths that enter the + -- block _without_ passing through the block itself. + mergeBlockLabels = + setFromList [entryLabel n | n <- rpblocks, big (forwardPreds (entryLabel n))] + where big [] = False + big [_] = False + big (_ : _ : _) = True + + forwardPreds :: Label -> [Label] -- reachable predecessors of reachable blocks, + -- via forward edges only + forwardPreds = \l -> mapFindWithDefault [] l predmap + where predmap :: LabelMap [Label] + predmap = foldEdges addForwardEdge mapEmpty + addForwardEdge from to pm + | isBackward from to = pm + | otherwise = addToList (from :) to pm + + isLoopHeader = isHeaderLabel . entryLabel + isHeaderLabel = (`setMember` headers) -- loop headers + where headers :: LabelSet + headers = foldMap headersPointedTo blockmap + headersPointedTo block = + setFromList [label | label <- successors block, + dominates label (entryLabel block)] + + index :: Label -> [ContainingSyntax] -> Int + index _ [] = panic "destination label not in evaluation context" + index label (frame : context) + | label `matchesFrame` frame = 0 + | otherwise = 1 + index label context + + rpnum = gwdRPNumber gwd + dominates lbl blockname = + lbl == blockname || dominatorsMember lbl (gwdDominatorsOf gwd blockname) + + + +nodeBody :: CmmBlock -> CmmActions +nodeBody (BlockCC _first middle _last) = middle + + +smartPlus :: Platform -> CmmExpr -> Int -> CmmExpr +smartPlus _ e 0 = e +smartPlus platform e k = + CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger k) width)] + where width = cmmExprWidth platform e + +addToList :: (IsMap map) => ([a] -> [a]) -> KeyOf map -> map [a] -> map [a] +addToList consx = mapAlter add + where add Nothing = Just (consx []) + add (Just xs) = Just (consx xs) + +------------------------------------------------------------------ +--- everything below here is for diagnostics in case of panic + +instance Outputable ContainingSyntax where + ppr (BlockFollowedBy l) = text "node" <+> ppr l + ppr (LoopHeadedBy l) = text "loop" <+> ppr l + ppr (IfThenElse l) = text "if-then-else" <+> ppr l + +findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a +findLabelIn lbl = mapFindWithDefault failed lbl + where failed = + panic $ "label " ++ showSDocUnsafe (ppr lbl) ++ " not found in control-flow graph" + + +infixl 4 <$~> +(<$~>) :: Functor m => m (a -> b) -> a -> m b +(<$~>) f x = fmap ($ x) f + +(<<>>) :: forall m s e pre mid post + . Applicative m + => m (WasmControl s e pre mid) + -> m (WasmControl s e mid post) + -> m (WasmControl s e pre post) +(<<>>) = liftA2 (<>) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 28a472a24e..b1777c73d3 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -285,6 +285,7 @@ Library GHC.CmmToLlvm.Ppr GHC.CmmToLlvm.Regs GHC.Cmm.Dominators + GHC.Cmm.Reducibility GHC.Cmm.Type GHC.Cmm.Utils GHC.Core @@ -373,6 +374,7 @@ Library GHC.Data.FiniteMap GHC.Data.Graph.Base GHC.Data.Graph.Color + GHC.Data.Graph.Collapse GHC.Data.Graph.Directed GHC.Data.Graph.Inductive.Graph GHC.Data.Graph.Inductive.PatriciaTree @@ -811,6 +813,8 @@ Library GHC.Utils.Ppr.Colour GHC.Utils.TmpFs GHC.Utils.Trace + GHC.Wasm.ControlFlow + GHC.Wasm.ControlFlow.FromCmm Language.Haskell.Syntax Language.Haskell.Syntax.Basic |