diff options
author | Norman Ramsey <Norman.Ramsey@tweag.io> | 2022-05-17 15:07:05 -0400 |
---|---|---|
committer | Norman Ramsey <Norman.Ramsey@tweag.io> | 2022-05-26 13:13:18 -0400 |
commit | 8aba42f8d97aa9ba56dad9249545126c74714a83 (patch) | |
tree | ef05ec1adba2bdc34dd5ea78c30dcb7b91d28ee6 | |
parent | bbf62b48980b82191a3ae9979a8266222b94d3fe (diff) | |
download | haskell-8aba42f8d97aa9ba56dad9249545126c74714a83.tar.gz |
add new modules for reducibility and WebAssembly translation
-rw-r--r-- | compiler/GHC/Cmm/Reducibility.hs | 229 | ||||
-rw-r--r-- | compiler/GHC/Data/Graph/Collapse.hs | 267 | ||||
-rw-r--r-- | compiler/GHC/Wasm/ControlFlow.hs | 89 | ||||
-rw-r--r-- | compiler/GHC/Wasm/ControlFlow/FromCmm.hs | 332 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 4 |
5 files changed, 921 insertions, 0 deletions
diff --git a/compiler/GHC/Cmm/Reducibility.hs b/compiler/GHC/Cmm/Reducibility.hs new file mode 100644 index 0000000000..fd4e8f0f50 --- /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 + +{-| +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] +-} + + +import GHC.Prelude hiding (splitAt, succ) + +import Control.Monad +import Data.List hiding (splitAt) +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..49da7a7ccc --- /dev/null +++ b/compiler/GHC/Data/Graph/Collapse.hs @@ -0,0 +1,267 @@ +{-# 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 +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 ("/* failed to match node " ++ show k ++ " */" + -- $$ dotGraph pprCollapseInfo (selected k) g + -- for a more informative panic, import DotGraph and turn this on + ) + +-- | 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..4319233be3 --- /dev/null +++ b/compiler/GHC/Wasm/ControlFlow.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Wasm.ControlFlow + ( WasmControl(..) + , BrTableInterval(..), inclusiveInterval + , brTableLimit + ) +where + +import GHC.Prelude + +import Data.Semigroup + +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Panic + +{-| +Module : GHC.Wasm.ControlFlow +Description : Representation of control-flow portion of the WebAssembly instruction set +-} + +-- [Note block types] +-- +-- WebAssembly blocks are normally labeled with a function type, +-- which specifies what values the block expects to find on the +-- WebAssembly evaluation stack and what values it promises to +-- leave there. Those types do not appear in this representation. +-- The representation assumes that either the stack is left +-- unchanged by every block (Wasm type `[] -> []`) or that if +-- other types are needed, they will be computed by running +-- an inference algorithm over the code. + + +data WasmControl s e where + -- ^ Type parameter `s` is the type of (unspecified) statements. + -- It might be instantiated with an open Cmm block or with a sequence + -- of Wasm instructions. + -- Parameter `e` is the type of expressions. + + WasmBlock :: WasmControl s e -> WasmControl s e + WasmLoop :: WasmControl s e -> WasmControl s e + WasmIf :: e -> WasmControl s e -> WasmControl s e -> WasmControl s e + + WasmBr :: Int -> WasmControl s e + WasmBrTable :: e + -> BrTableInterval -- for testing + -> [Int] -- targets + -> Int -- default target + -> WasmControl s e + -- invariant: the table interval is contained + -- within [0 .. pred (length targets)] + WasmReturn :: WasmControl s e + + WasmAction :: s -> WasmControl s e -- basic block: one entry, one exit + WasmSeq :: WasmControl s e -> WasmControl s e -> WasmControl s e + + WasmUnreachable :: WasmControl s e + WasmNop :: WasmControl s e + +data BrTableInterval + = BrTableInterval { bti_lo :: Integer, bti_count :: Integer } + deriving (Show) + +instance Outputable BrTableInterval where + ppr range = brackets $ hcat[integer (bti_lo range), text "..", integer hi] + where hi = bti_lo range + bti_count range - 1 + +inclusiveInterval :: Integer -> Integer -> BrTableInterval +inclusiveInterval lo hi + | lo <= hi = BrTableInterval lo (hi - lo + 1) + | otherwise = panic "GHC.Wasm.ControlFlow: empty interval" + +instance Semigroup (WasmControl s e) where + WasmNop <> a = a + a <> WasmNop = a + a <> b = WasmSeq a b + +instance Monoid (WasmControl s e) where + mempty = WasmNop + + +brTableLimit :: Int +brTableLimit = 65520 + -- ^ Size of the largest table that is deemed acceptable in a `br_table` instruction. + -- + -- Source: https://chromium.googlesource.com/v8/v8/+/master/src/wasm/wasm-limits.h#51 + -- See also discussion at https://github.com/WebAssembly/spec/issues/607, which shows + -- that major browsers agree. diff --git a/compiler/GHC/Wasm/ControlFlow/FromCmm.hs b/compiler/GHC/Wasm/ControlFlow/FromCmm.hs new file mode 100644 index 0000000000..3f6ad7bc84 --- /dev/null +++ b/compiler/GHC/Wasm/ControlFlow/FromCmm.hs @@ -0,0 +1,332 @@ +{-| +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. +-} + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Wasm.ControlFlow.FromCmm + ( structuredControl + ) +where + +import GHC.Prelude hiding (succ) + +import Data.Function +import Data.List +import Data.Semigroup +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.Platform + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr + , pprWithCommas + , showSDocUnsafe + ) + +import GHC.Wasm.ControlFlow + +--------------------- 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 + } + | TerminalFlow + +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 (atMost brTableLimit target_labels) default_label + + CmmCall { cml_cont = Just l } -> Unconditional l + CmmCall { cml_cont = Nothing } -> TerminalFlow + CmmForeignCall { succ = l } -> Unconditional l + + where atMost :: Int -> [a] -> [a] + atMost k xs = if xs `hasAtLeast` k then + panic "switch table is too big for WebAssembly" + else + xs + + hasAtLeast :: [a] -> Int -> Bool + hasAtLeast _ 0 = True + hasAtLeast [] _ = False + hasAtLeast (_:xs) k = hasAtLeast xs (k - 1) + + +----------------------- 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 CmmStmts = Block CmmNode O O +type CfgNode = CmmBlock + + + +----------------------- Translation ------------------------------ + +-- | Convert a Cmm CFG to WebAssembly's structured control flow. + +structuredControl :: forall expr stmt . + Platform -- ^ needed for offset calculation + -> (Label -> CmmExpr -> expr) -- ^ translator for expressions + -> (Label -> CmmStmts -> stmt) -- ^ translator for straight-line code + -> CmmGraph -- ^ CFG to be translated + -> WasmControl stmt expr +structuredControl platform txExpr txBlock g = + doTree dominatorTree emptyContext + where + dominatorTree :: Tree.Tree CfgNode -- ^ Dominator tree in which children are sorted + -- with highest reverse-postorder number first + dominatorTree = fmap blockLabeled $ sortTree $ gwdDominatorTree gwd + + doTree :: Tree.Tree CfgNode -> Context -> WasmControl stmt expr + nodeWithin :: CfgNode -> [Tree.Tree CfgNode] -> Maybe Label + -> Context -> WasmControl stmt expr + doBranch :: Label -> Label -> Context -> WasmControl stmt expr + + doTree (Tree.Node x immediateDominatees) context = + let codeForX = nodeWithin x dominatees Nothing + in if isHeader x then + WasmLoop (codeForX loopContext) + else + codeForX context + where dominatees = case lastNode x of + CmmSwitch {} -> immediateDominatees + -- N.B. Unlike `if`, translation of Switch uses only labels. + _ -> filter isMergeTree $ immediateDominatees + loopContext = LoopHeadedBy (entryLabel x) `inside` + (context `withFallthrough` (entryLabel x)) + + nodeWithin x (y_n:ys) (Just zlabel) context = + WasmBlock $ nodeWithin x (y_n:ys) Nothing context' + where context' = BlockFollowedBy zlabel `inside` context + nodeWithin x (y_n:ys) Nothing context = + nodeWithin x ys (Just ylabel) (context `withFallthrough` ylabel) <> doTree y_n context + where ylabel = treeEntryLabel y_n + nodeWithin x [] (Just zlabel) context + | not (generatesIf x) = + WasmBlock (nodeWithin x [] Nothing context') + where context' = BlockFollowedBy zlabel `inside` context + nodeWithin x [] maybeMarks context = + translationOfX context + where xlabel = entryLabel x + + translationOfX :: Context -> WasmControl stmt expr + translationOfX context = + WasmAction (txBlock xlabel $ nodeBody x) <> + case flowLeaving platform x of + Unconditional l -> doBranch xlabel l context + Conditional e t f -> + WasmIf (txExpr xlabel e) + (doBranch xlabel t (IfThenElse maybeMarks `inside` context)) + (doBranch xlabel f (IfThenElse maybeMarks `inside` context)) + TerminalFlow -> WasmReturn + 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 from to context + | to `elem` fallthrough context = mempty -- optimization: `br` not needed + | isBackward from to = WasmBr i -- continue + | isMergeLabel to = WasmBr i -- exit + | otherwise = doTree (subtreeAt to) context -- inline the code here + where i = index to (enclosing context) + + generatesIf x = case flowLeaving platform x of Conditional {} -> True + _ -> False + + ---- everything else is utility functions + + 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 CfgNode + blockLabeled :: Label -> CfgNode + rpnum :: Label -> RPNum -- ^ reverse postorder number of the labeled block + isMergeTree :: Tree.Tree CfgNode -> Bool + isMergeLabel :: Label -> Bool + isMergeNode :: CfgNode -> Bool + isHeader :: CfgNode -> 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) + + GMany NothingO blockmap NothingO = g_graph g + + blockLabeled l = findLabelIn l blockmap + + rpblocks :: [CfgNode] + 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 + isMergeTree = isMergeNode . Tree.rootLabel + + isBackward from to = rpnum to <= rpnum from -- self-edge counts as a backward edge + + subtreeAt label = findLabelIn label subtrees + subtrees :: LabelMap (Tree.Tree CfgNode) + 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 + + isHeader = isHeaderLabel . entryLabel + isHeaderLabel = \l -> setMember l headers -- loop headers + where headers :: LabelSet + headers = foldMap headersPointedTo blockmap + headersPointedTo block = + setFromList [label | label <- successors block, + dominates label (entryLabel block)] + + index _ [] = panic "destination label not in evaluation context" + index label (frame : context) + | label `matchesFrame` frame = 0 + | otherwise = 1 + index label context + + gwd = graphWithDominators g + rpnum = gwdRPNumber gwd + dominates lbl blockname = + lbl == blockname || dominatorsMember lbl (gwdDominatorsOf gwd blockname) + + + +nodeBody :: CfgNode -> CmmStmts +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 (fromIntegral 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" diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index b9b58b71ac..4815297aed 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -280,6 +280,7 @@ Library GHC.CmmToLlvm.Ppr GHC.CmmToLlvm.Regs GHC.Cmm.Dominators + GHC.Cmm.Reducibility GHC.Cmm.Type GHC.Cmm.Utils GHC.Core @@ -363,6 +364,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 @@ -779,6 +781,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.Binds |