diff options
50 files changed, 2636 insertions, 1 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 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..2ef025574d --- /dev/null +++ b/compiler/GHC/Wasm/ControlFlow.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds, GADTs, RankNTypes, TypeOperators, KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} + +module GHC.Wasm.ControlFlow + ( WasmControl(..), (<>), pattern WasmIf, wasmReturn + , BrTableInterval(..), inclusiveInterval + , brTableLimit + + , WasmType(..), WasmTypeTag(..) + , TypeList(..) + , WasmFunctionType(..) + ) +where + +import GHC.Prelude + +import Data.Kind + +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Panic + +{-| +Module : GHC.Wasm.ControlFlow +Description : Representation of control-flow portion of the WebAssembly instruction set +-} + +-- | WebAssembly type of a WebAssembly value that WebAssembly code +-- could either expect on the evaluation stack or leave on the evaluation +-- stack. At present we support only 32-bit values. + +data WasmType = I32 | F32 + deriving (Eq, Show) + + +-- | Singleton type useful for programming with `WasmType` at the type level. + +data WasmTypeTag :: WasmType -> Type where + TagI32 :: WasmTypeTag 'I32 + TagF32 :: WasmTypeTag 'F32 + +-- | List of WebAssembly types used to describe the sequence of WebAssembly +-- values that a block of code may expect on the stack or leave on the stack. + +data TypeList :: [WasmType] -> Type where + TypeListNil :: TypeList '[] + TypeListCons :: WasmTypeTag t -> TypeList ts -> TypeList (t : ts) + +-- | The type of a WebAssembly function, loop, block, or conditional. +-- This type says what values the code expects to pop off the stack and +-- what values it promises to push. The WebAssembly standard requires +-- that this type appear explicitly in the code. + +data WasmFunctionType pre post = + WasmFunctionType { ft_pops :: TypeList pre + , ft_pushes :: TypeList post + } + + +-- | Representation of WebAssembly control flow. +-- Normally written as +-- @ +-- WasmControl s e pre post +-- @ +-- 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. +-- Parameter `pre` represents the values that are expected on the +-- WebAssembly stack when the code runs, and `post` represents +-- the state of the stack on completion. + +data WasmControl :: Type -> Type -> [WasmType] -> [WasmType] -> Type where + + WasmPush :: WasmTypeTag t -> e -> WasmControl s e stack (t ': stack) + + WasmBlock :: WasmFunctionType pre post + -> WasmControl s e pre post + -> WasmControl s e pre post + WasmLoop :: WasmFunctionType pre post + -> WasmControl s e pre post + -> WasmControl s e pre post + WasmIfTop :: WasmFunctionType pre post + -> WasmControl s e pre post + -> WasmControl s e pre post + -> WasmControl s e ('I32 ': pre) post + + WasmBr :: Int -> WasmControl s e dropped destination -- not typechecked + WasmFallthrough :: WasmControl s e dropped destination + -- generates no code, but has the same type as a branch + + WasmBrTable :: e + -> BrTableInterval -- for testing + -> [Int] -- targets + -> Int -- default target + -> WasmControl s e dropped destination + -- invariant: the table interval is contained + -- within [0 .. pred (length targets)] + WasmReturnTop :: WasmTypeTag t + -> WasmControl s e (t ': t1star) t2star -- as per type system + + WasmActions :: s -> WasmControl s e stack stack -- basic block: one entry, one exit + WasmSeq :: WasmControl s e pre mid -> WasmControl s e mid post -> WasmControl s e pre post + +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 + +brTableLimit :: Int + -- ^ 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. +brTableLimit = 65520 + +inclusiveInterval :: Integer -> Integer -> BrTableInterval +inclusiveInterval lo hi + | lo <= hi = let count = hi - lo + 1 + in if count > toInteger brTableLimit then + panic "interval too large in br_table instruction" + else + 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..741ab35560 --- /dev/null +++ b/compiler/GHC/Wasm/ControlFlow/FromCmm.hs @@ -0,0 +1,354 @@ +{-# 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.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 (atMost brTableLimit target_labels) default_label + + CmmCall { cml_cont = Just l } -> Unconditional l + CmmCall { cml_cont = Nothing, cml_target = e } -> TailCall e + 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 CmmActions = Block CmmNode O O +type CfgNode = CmmBlock + +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 . + Platform -- ^ needed for offset calculation + -> (Label -> CmmExpr -> expr) -- ^ translator for expressions + -> (Label -> CmmActions -> stmt) -- ^ translator for straight-line code + -> CmmGraph -- ^ CFG to be translated + -> WasmControl stmt expr '[] '[ 'I32] +structuredControl platform txExpr txBlock g = + doTree returns dominatorTree emptyContext + where + gwd :: GraphWithDominators CmmNode + gwd = graphWithDominators g + + dominatorTree :: Tree.Tree CfgNode-- Dominator tree in which children are sorted + -- with highest reverse-postorder number first + dominatorTree = fmap blockLabeled $ sortTree $ gwdDominatorTree gwd + + doTree :: FT '[] post -> Tree.Tree CfgNode -> Context -> WasmControl stmt expr '[] post + nodeWithin :: forall post . + FT '[] post -> CfgNode -> [Tree.Tree CfgNode] -> Maybe Label + -> Context -> WasmControl stmt expr '[] post + doBranch :: FT '[] post -> Label -> Label -> Context -> 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 `withFallthrough` entryLabel x) + 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 -> 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) <> 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 = WasmFallthrough + -- optimization: `br` is not needed, but it typechecks + -- only if nothing is expected to be left on the stack + + | isBackward from to = WasmBr i -- continue + | isMergeLabel to = 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 CfgNode -> 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 CfgNode + blockLabeled :: Label -> CfgNode + rpnum :: Label -> RPNum-- reverse postorder number of the labeled block + isMergeLabel :: Label -> Bool + isMergeNode :: CfgNode -> Bool + isLoopHeader :: 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) + + blockmap :: LabelMap CfgNode + 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 + + 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 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 + + 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 :: CfgNode -> 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 (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/Wasm/ControlFlow/ToAsm.hs b/compiler/GHC/Wasm/ControlFlow/ToAsm.hs new file mode 100644 index 0000000000..fbf387753a --- /dev/null +++ b/compiler/GHC/Wasm/ControlFlow/ToAsm.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GHC.Wasm.ControlFlow.ToAsm + ( toIndentedAsm + , noIndentation + ) +where + +{-| +Module : GHC.Wasm.ControlFlow.ToAsm +Description : Convert WebAssembly control-flow instructions to GNU assembler syntax. +-} + +import GHC.Prelude + +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BS +import Data.List (intersperse) +import Data.Monoid + +import GHC.Utils.Panic + +import GHC.Wasm.ControlFlow hiding ((<>)) + +type Indentation = Builder + +standardIndentation :: Indentation +standardIndentation = " " + +noIndentation :: Indentation +noIndentation = "" + + +-- | Assuming that the type of a construct can be rendered as inline +-- syntax, return the syntax. For every type our translator +-- generates, the assumption should hold. +wasmFunctionType :: WasmFunctionType pre post -> Builder +wasmFunctionType (WasmFunctionType TypeListNil TypeListNil) = "void" +wasmFunctionType (WasmFunctionType TypeListNil (TypeListCons t TypeListNil)) = tagBuilder t +wasmFunctionType _ = panic "function type needs to be externalized" + -- Anything other then [] -> [], [] -> [t] needs to be put into a + -- type table and referred to by number. + +-- | Tag used in GNU assembly to name a WebAssembly type +tagBuilder :: WasmTypeTag a -> Builder +tagBuilder TagI32 = "i32" +tagBuilder TagF32 = "f32" + + +type Printer a = Indentation -> a -> Builder + +-- | Converts WebAssembly control-flow code into GNU (Clang) assembly +-- syntax, indented for readability. For ease of combining with other +-- output, the result does not have a trailing newline or preceding +-- indentation. (The indentation argument simply gives the blank +-- string that follows each emitted newline.) +-- +-- The initial `Indentation` argument specifies the indentation of the +-- entire output; for most use cases it will likely be `mempty`. + +toIndentedAsm :: forall s e pre post + . Printer s -> Printer e -> Printer (WasmControl s e pre post) +toIndentedAsm ps pe indent s = print s + where print, shift :: WasmControl s e pre' post' -> Builder + newline :: Builder -> Builder -> Builder + (<+>) :: Builder -> Builder -> Builder + ty = wasmFunctionType + + -- cases meant to avoid generating any output for `WasmFallthrough` + print (WasmFallthrough `WasmSeq` s) = print s + print (s `WasmSeq` WasmFallthrough) = print s + print (WasmIfTop t s WasmFallthrough) = + "if" <+> ty t `newline` shift s `newline` "end_if" + print (WasmIfTop t WasmFallthrough s) = + "if" <+> ty t `newline` "else" `newline` shift s `newline` "end_if" + + -- all the other cases + print (WasmPush _ e) = pe indent e + print (WasmBlock t s) = "block" <+> ty t `newline` shift s `newline` "end_block" + print (WasmLoop t s) = "loop" <+> ty t `newline` shift s `newline` "end_loop" + print (WasmIfTop t ts fs) = "if" <+> ty t `newline` shift ts `newline` + "else" `newline` shift fs `newline` "end_if" + print (WasmBr l) = "br" <+> BS.intDec l + print (WasmBrTable e _ ts t) = + pe indent e `newline` "br_table {" <+> + mconcat (intersperse ", " [BS.intDec i | i <- ts <> [t]]) <+> + "}" + print (WasmReturnTop _) = "return" + print (WasmActions as) = ps indent as + print (s `WasmSeq` s') = print s `newline` print s' + + print WasmFallthrough = "// fallthrough" -- rare + + newline s s' = s <> "\n" <> indent <> s' + shift s = standardIndentation <> toIndentedAsm ps pe (indent <> standardIndentation) s + s <+> s' = s <> " " <> s' diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 238f992ed6..35b619b8ce 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 @@ -803,6 +805,9 @@ Library GHC.Utils.Ppr.Colour GHC.Utils.TmpFs GHC.Utils.Trace + GHC.Wasm.ControlFlow + GHC.Wasm.ControlFlow.FromCmm + GHC.Wasm.ControlFlow.ToAsm Language.Haskell.Syntax Language.Haskell.Syntax.Basic diff --git a/testsuite/tests/linters/notes.stdout b/testsuite/tests/linters/notes.stdout index c8a9278989..39bc4d7f64 100644 --- a/testsuite/tests/linters/notes.stdout +++ b/testsuite/tests/linters/notes.stdout @@ -1,3 +1,5 @@ +ref compiler/GHC/Cmm/Reducibility.hs:52:1: Note [Reducibility resources] +ref compiler/GHC/Cmm/Reducibility.hs:142:1: Note [Reducibility resources] ref compiler/GHC/Core/Coercion/Axiom.hs:458:2: Note [RoughMap and rm_empty] ref compiler/GHC/Core/Opt/OccurAnal.hs:857:15: Note [Loop breaking] ref compiler/GHC/Core/Opt/SetLevels.hs:1598:30: Note [Top level scope] @@ -77,4 +79,3 @@ ref testsuite/tests/typecheck/should_compile/tc231.hs:12:16: Note [Import ref testsuite/tests/typecheck/should_fail/UnliftedNewtypesMultiFieldGadt.hs:11:28: Note [Kind-checking the field type] ref testsuite/tests/typecheck/should_fail/tcfail093.hs:13:7: Note [Important subtlety in oclose] ref validate:412:14: Note [Why is there no stage1 setup function?] - diff --git a/testsuite/tests/wasm/should_run/control-flow/ActionsAndObservations.hs b/testsuite/tests/wasm/should_run/control-flow/ActionsAndObservations.hs new file mode 100644 index 0000000000..6d398cc88f --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/ActionsAndObservations.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module ActionsAndObservations + ( Stmt, Expr + , stmt, expr + ) +where + +-- used to represent computations (in translation testing) +-- +-- * An action changes the state of a machine. +-- * An expression inspects the state of a machine and observes a value. + + +import GHC.Cmm +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Block +import GHC.Platform +import GHC.Utils.Outputable + + +data Stmt = Stmt { s_label :: Label + , s_rendering :: String + } + +data Expr = Expr { e_label :: Label + , e_rendering :: String + } + +stmt :: Label -> Block CmmNode O O -> Stmt +stmt lbl body = Stmt lbl (showSDocUnsafe $ pdoc genericPlatform $ body) + +expr :: Label -> CmmExpr -> Expr +expr lbl e = Expr lbl (showSDocUnsafe $ pdoc genericPlatform $ e) + +instance Eq Stmt where + s == s' = s_label s == s_label s' || s_rendering s == s_rendering s' + +instance Eq Expr where + e == e' = e_label e == e_label e' || e_rendering e == e_rendering e' + +instance Show Stmt where + show = showSDocUnsafe . ppr . s_label + +instance Show Expr where + show = showSDocUnsafe . ppr . e_label + +instance OutputableP Platform Stmt where + pdoc _ s = text "Stmt" <+> ppr (s_label s) + +instance OutputableP Platform Expr where + pdoc _ e = text "Expr" <+> ppr (e_label e) diff --git a/testsuite/tests/wasm/should_run/control-flow/BitConsumer.hs b/testsuite/tests/wasm/should_run/control-flow/BitConsumer.hs new file mode 100644 index 0000000000..541d06bcab --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/BitConsumer.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module BitConsumer + ( BitConsumer + , ConsumptionResult(..) + , runWithBits + , eventsFromBits + + , rangeSelect + , inverseRangeSelect + ) +where + +-- A "bit consumer" simulates a computation. +-- It can be run by supplying it with a sequence of Booleans. +-- The Booleans determine the results of observations that +-- drive control-flow decisions (a Boolean in an `if` and +-- an integer in a `switch`). + +import ControlTestMonad + +import GHC.Utils.Panic + +data ConsumptionResult stmt exp a + = Produced { pastEvents :: [Event stmt exp], value :: a } + | Halted { pastEvents :: [Event stmt exp] } + | Failed { pastEvents :: [Event stmt exp], msg :: String } + +instance Functor (ConsumptionResult s e) where + fmap f (Produced events a) = Produced events (f a) + fmap _ (Halted events) = Halted events + fmap _ (Failed events msg) = Failed events msg + +instance (Show exp, Show stmt, Show a) => Show (ConsumptionResult stmt exp a) where + show (Produced events a) = show events ++ " -> " ++ show a + show (Halted events) = show events ++ " EXHAUSTS" + show (Failed events msg) = show events ++ " FAILED: " ++ msg + +reverseEvents :: ConsumptionResult stmt exp a -> ConsumptionResult stmt exp a +reverseEvents (Produced events a) = Produced (reverse events) a +reverseEvents (Halted events) = Halted (reverse events) +reverseEvents (Failed events msg) = Failed (reverse events) msg + + +newtype BitConsumer stmt exp a = + BC { unBC :: [Bool] -> [Event stmt exp] -> (ConsumptionResult stmt exp a, [Bool]) } + +instance Functor (BitConsumer stmt exp) where + fmap f ma = BC $ \bits past -> update $ unBC ma bits past + where update (l, r) = (fmap f l, r) + +instance Applicative (BitConsumer stmt exp) where + pure a = BC $ \bits past -> (Produced past a, bits) + mf <*> ma = do { f <- mf; f <$> ma } + +instance Monad (BitConsumer stmt exp) where + m >>= k = BC $ \bits past -> + case unBC m bits past of + (Produced past' a, bits') -> unBC (k a) bits' past' + (Halted past, bits') -> (Halted past, bits') + (Failed past msg, bits') -> (Failed past msg, bits') + +instance MonadFail (BitConsumer stmt exp) where + fail msg = BC $ \bits past -> (Failed past msg, bits) + + +runWithBits :: BitConsumer stmt exp a -> [Bool] -> ConsumptionResult stmt exp a +-- ^ Run with Booleans determining decisions, return final +-- state with oldest event first +runWithBits m bits = reverseEvents $ fst $ unBC m bits [] + +eventsFromBits :: BitConsumer stmt exp () -> [Bool] -> [Event stmt exp] +eventsFromBits bc = pastEvents . runWithBits bc + + +instance ControlTestMonad stmt exp (BitConsumer stmt exp) where + evalPredicate lbl = + BC $ \bits past -> case bits of + bit : bits' -> (Produced (Predicate lbl bit : past) bit, bits') + [] -> (Halted past, bits) + + evalEnum lbl range = + BC $ \bits past -> case rangeSelect range bits of + Just (i, bits') -> (Produced (Switch lbl range i : past) i, bits') + Nothing -> (Halted past, bits) + + takeAction lbl = BC $ \bits past -> (Produced (Action lbl : past) (), bits) + + +rangeSelect :: (Integer, Integer) -> [Bool] -> Maybe (Integer, [Bool]) +rangeSelect (lo, limit) bits | lo == pred limit = Just (lo, bits) +rangeSelect _ [] = Nothing +rangeSelect (lo, limit) (bit : bits) = + rangeSelect (if bit then (lo, mid) else (mid, limit)) bits + where mid = (lo + limit) `div` 2 + +inverseRangeSelect :: (Integer, Integer) -> Integer -> [Bool] +inverseRangeSelect (lo, limit) i + | lo == pred limit = if i == lo then [] else panic "inverseRangeSelect" + | otherwise = if i < mid then True : inverseRangeSelect (lo, mid) i + else False : inverseRangeSelect (mid, limit) i + where mid = (lo + limit) `div` 2 diff --git a/testsuite/tests/wasm/should_run/control-flow/CmmPaths.hs b/testsuite/tests/wasm/should_run/control-flow/CmmPaths.hs new file mode 100644 index 0000000000..0a882b9178 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/CmmPaths.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} + +module CmmPaths + ( cmmPaths + , cmmExits + ) +where + +-- Enumerates paths through a CmmGraph. Paths can then +-- be used to determine a sequence of observations, which +-- is eventually converted into a sequence of Booleans +-- and used to test a translation. + +import Prelude hiding (succ) + +import GHC.Cmm +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Switch + +import GHC.Utils.Panic + +import ActionsAndObservations +import ControlTestMonad + +type CmmPath = [Event Stmt Expr] + +-- | Return all paths that start in the entry node +-- and contain at most one repeated node. + +cmmPaths :: CmmGraph -> [CmmPath] +cmmPaths g = map reverse $ pathsPrefixed (g_entry g) [] setEmpty + where pathsPrefixed :: Label -> CmmPath -> LabelSet -> [CmmPath] + -- ^ returns a list of all _short_ paths that begin with (block : prefix), + -- where a short path is one that contains at most one repeated label, + -- which must be the last one on the path (and so at the head of the list). + -- Precondition: `visited == setFromList prefix`. + pathsPrefixed lbl prefix visited = prefix' : extensions + where prefix' = action lbl : prefix + visited' = setInsert lbl visited + extensions = if setMember lbl visited then [prefix'] + else concatMap extend (cmmExits $ blockLabeled lbl) + extend (Nothing, lbl) = pathsPrefixed lbl prefix' visited' + extend (Just event, lbl) = pathsPrefixed lbl (event : prefix') visited' + + + action lbl = Action (stmt lbl (middle $ blockLabeled lbl)) + blockLabeled lbl = mapFindWithDefault (panic "missing block") lbl blockmap + + middle block = m + where (_, m, _) = blockSplit block + + CmmGraph { g_graph = GMany NothingO blockmap NothingO } = g + +-- | Returns the successors of the given nodes, associating each +-- successor with the event/observation (if any) that causes the +-- computation to transfer control to that successor. + +cmmExits :: CmmBlock -> [(Maybe (Event Stmt Expr), Label)] +cmmExits b = + let thisExp e = expr (entryLabel b) e + in + case lastNode b of + CmmBranch l -> [(Nothing, l)] + CmmCondBranch e t f _ -> [(Just $ Predicate (thisExp e) True, t), + (Just $ Predicate (thisExp e) False, f)] + CmmSwitch e targets -> + let (lo, hi) = switchTargetsRange targets + dests = switchTargetsCases targets + other = switchTargetsDefault targets + caseExit (j, lbl) = (Just $ Switch (thisExp e) (lo, hi + 1) j, lbl) + defaultExits = case other of + Nothing -> [] + Just lbl -> [(Just $ Switch (thisExp e) (lo, hi + 1) defarg, lbl)] + defarg = try lo + where try i | i == hi = i + | i `elem` caseArgs = try (i + 1) + | otherwise = i + caseArgs = map fst dests + labelOf i = case [lbl | (j, lbl) <- dests, j == i] + of [lbl] -> lbl + [] -> case other of + Just lbl -> lbl + Nothing -> panic "GHC.Tests.CmmPaths.exit: no default" + (_ : _ : _) -> panic "GHC.Tests.CmmPaths.exit: too many matches" + in if hi - lo < 10 then + [(Just $ Switch (thisExp e) (lo, hi + 1) i, labelOf i) | i <- [lo..hi]] + else + -- as some switch statements go from minBound :: Int to maxBound :: Int + defaultExits ++ map caseExit dests + + CmmCall { cml_cont = Just l } -> [(Nothing, l)] + CmmCall { cml_cont = Nothing } -> [] + CmmForeignCall { succ = l } -> [(Nothing, l)] diff --git a/testsuite/tests/wasm/should_run/control-flow/ControlTestMonad.hs b/testsuite/tests/wasm/should_run/control-flow/ControlTestMonad.hs new file mode 100644 index 0000000000..936b0bfe7e --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/ControlTestMonad.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +module ControlTestMonad + ( ControlTestMonad(..) + , Event(..) + ) +where + +-- Defines observable events that can occur during a computation. +-- Each event is either an action or an observation. If two +-- computations produce the same events, they are equivalent. + +import GHC.Utils.Outputable + +class (MonadFail m) => ControlTestMonad stmt expr m where + evalPredicate :: expr -> m Bool + evalEnum :: expr -> (Integer,Integer) -> m Integer + -- ^ range is half-open: includes low end but not high + takeAction :: stmt -> m () + +data Event stmt expr = Action stmt + | Predicate expr Bool + | Switch expr (Integer,Integer) Integer + deriving (Eq) + +instance (Outputable e, Outputable s) => Outputable (Event e s) where + ppr (Action l) = ppr l + ppr (Predicate l b) = ppr l <+> parens (if b then "T" else "F") + ppr (Switch l (lo,hi) i) = + ppr l <+> parens (hcat [ text $ show i + , " in [" + , text $ show lo + , ".." + , text $ show hi + , "]" + ]) + +instance (Show e, Show s) => Show (Event e s) where + show (Action l) = show l + show (Predicate l b) = show l ++ "(" ++ (if b then "T" else "F") ++ ")" + show (Switch l (lo,hi) i) = + show l ++ "(" ++ show i ++ " in [" ++ show lo ++ ".." ++ show hi ++ "])" diff --git a/testsuite/tests/wasm/should_run/control-flow/EntropyTransducer.hs b/testsuite/tests/wasm/should_run/control-flow/EntropyTransducer.hs new file mode 100644 index 0000000000..73d21c074b --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/EntropyTransducer.hs @@ -0,0 +1,36 @@ +module EntropyTransducer + ( traceBits + , rangeSelect + ) +where + +-- Convert a sequence of events to a sequence of bits. +-- Also provide an inverse function that converts +-- a sequence of bits to an integer that lies in a +-- known range (for simulating `switch`). + +import ControlTestMonad + +import GHC.Utils.Panic + +traceBits :: [Event a b] -> [Bool] +traceBits (Predicate _ b : events) = b : traceBits events +traceBits (Action _ : events) = traceBits events +traceBits (Switch _ (lo, hi) i : events) = + inverseRangeSelect (lo, hi) i ++ traceBits events +traceBits [] = [] + + +rangeSelect :: (Integer, Integer) -> [Bool] -> Maybe (Integer, [Bool]) +rangeSelect (lo, limit) bits | lo == pred limit = Just (lo, bits) +rangeSelect _ [] = Nothing +rangeSelect (lo, limit) (bit : bits) = + rangeSelect (if bit then (lo, mid) else (mid, limit)) bits + where mid = (lo + limit) `div` 2 + +inverseRangeSelect :: (Integer, Integer) -> Integer -> [Bool] +inverseRangeSelect (lo, limit) i + | lo == pred limit = if i == lo then [] else panic "fault in inverseRangeSelect" + | otherwise = if i < mid then True : inverseRangeSelect (lo, mid) i + else False : inverseRangeSelect (mid, limit) i + where mid = (lo + limit) `div` 2 diff --git a/testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs b/testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs new file mode 100644 index 0000000000..91a01ce457 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module LoadCmmGroup + ( loadPath + , loadCmm + , loadHs + ) +where + +-- Read a .hs or .cmm file and convert it to a list of `CmmGroup`s. + +import Control.Monad.IO.Class +import System.FilePath as FilePath +import System.IO + +import GHC +import GHC.Cmm +import GHC.Cmm.Parser +import GHC.Core.Lint.Interactive +import GHC.Core.TyCon +import GHC.CoreToStg +import GHC.CoreToStg.Prep +import GHC.Data.Stream hiding (mapM, map) +import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig) +import GHC.Driver.Config.CoreToStg.Prep +import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Driver.Main +import GHC.Stg.FVs +import GHC.Stg.Syntax +import GHC.StgToCmm (codeGen) +import GHC.Types.CostCentre (emptyCollectedCCs) +import GHC.Types.HpcInfo (emptyHpcInfo) +import GHC.Types.IPE (emptyInfoTableProvMap) +import GHC.Unit.Home +import GHC.Unit.Module.ModGuts +import GHC.Utils.Error +import GHC.Utils.Misc (fstOf3) +import GHC.Utils.Outputable + + +loadPath :: FilePath -> Ghc [CmmGroup] +loadPath path = + case takeExtension path of + ".hs" -> loadHs path + ".cmm" -> fmap (: []) $ loadCmm path + _ -> do liftIO $ hPutStrLn stderr $ "File with unknown extension: " ++ path + return [] + +loadHs :: FilePath -> Ghc [CmmGroup] +loadHs path = do + target <- guessTarget path Nothing Nothing + setTargets [target] + mgraph <- depanal [] False + fmap concat $ mapM cmmOfSummary $ mgModSummaries mgraph + +cmmOfSummary :: ModSummary -> GHC.Ghc [CmmGroup] +cmmOfSummary summ = do + dflags <- getSessionDynFlags + env <- getSession + guts <- liftIO $ frontend dflags env summ + stg <- stgify summ guts + logger <- getLogger + let infotable = emptyInfoTableProvMap + tycons = [] + ccs = emptyCollectedCCs + stg' = depSortWithAnnotStgPgm (ms_mod summ) stg + hpcinfo = emptyHpcInfo False + tmpfs = hsc_tmpfs env + stg_to_cmm dflags mod = codeGen logger tmpfs (initStgToCmmConfig dflags mod) + (groups, _infos) <- + liftIO $ + collectAll $ + stg_to_cmm dflags (ms_mod summ) infotable tycons ccs stg' hpcinfo + return groups + +frontend :: DynFlags -> HscEnv -> ModSummary -> IO ModGuts +frontend _dflags env summary = do + parsed <- hscParse env summary + (checked, _) <- hscTypecheckRename env summary parsed + hscDesugar env summary checked >>= hscSimplify env [] + +loadCmm :: FilePath -> Ghc CmmGroup +loadCmm path = do + env <- getSession + liftIO (slurpCmm env path) + +stgify :: ModSummary -> ModGuts -> Ghc [StgTopBinding] +stgify summary guts = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + prepd_binds <- liftIO $ do + cp_cfg <- initCorePrepConfig hsc_env + corePrepPgm (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig dflags (interactiveInScope $ hsc_IC hsc_env)) this_mod location core_binds data_tycons + return $ fstOf3 $ coreToStg dflags (ms_mod summary) (ms_location summary) prepd_binds + where this_mod = mg_module guts + location = ms_location summary + core_binds = mg_binds guts + data_tycons = filter isDataTyCon tycons + tycons = mg_tcs guts + + +slurpCmm :: HscEnv -> FilePath -> IO (CmmGroup) +slurpCmm hsc_env filename = runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let home_unit = hsc_home_unit hsc_env + -- Make up a module name to give the NCG. We can't pass bottom here + -- lest we reproduce #11784. + mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename + cmm_mod = mkHomeModule home_unit mod_name + cmmpConfig = initCmmParserConfig dflags + (cmm, _) <- ioMsgMaybe + $ do + (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) + $ parseCmmFile cmmpConfig cmm_mod home_unit filename + let msgs = warns `unionMessages` errs + return (GhcPsMessage <$> msgs, cmm) + return cmm + +collectAll :: Monad m => Stream m a b -> m ([a], b) +collectAll = gobble . runStream + where gobble (Done b) = return ([], b) + gobble (Effect e) = e >>= gobble + gobble (Yield a s) = do (as, b) <- gobble s + return (a:as, b) diff --git a/testsuite/tests/wasm/should_run/control-flow/README.md b/testsuite/tests/wasm/should_run/control-flow/README.md new file mode 100644 index 0000000000..d228c643a9 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/README.md @@ -0,0 +1,12 @@ +Tests the basic infrastructure used to translate Cmm control flow to WebAssembly control flow: + + - Check a Cmm control-flow graph to see if it is reducible. + + - Convert an irreducible control-flow graph to an equivalent reducible control-flow graph. + + - Interpret both Cmm control-flow graphs and WebAssembly programs using a stream of bits to determine the direction of each conditional and `switch`. Confirm that source and target programs take the same actions and make the same decisions. + +The tests dump a lot of information about the code under test, including the number of execution paths tested. Samples in `WasmControlFlow.stdout`. + +The source codes for the tested control-flow graphs are written in a mix of Haskell and Cmm; they are found in directory `src`. + diff --git a/testsuite/tests/wasm/should_run/control-flow/RunCmm.hs b/testsuite/tests/wasm/should_run/control-flow/RunCmm.hs new file mode 100644 index 0000000000..9233d7a66a --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/RunCmm.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} + +module RunCmm + ( evalGraph + ) +where + +-- Using a `ControlTestMonad` to provide observations, +-- simulate the execution of a `CmmGraph`. + +import Prelude hiding (succ) + +import GHC.Cmm +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Switch +import GHC.Utils.Panic + +import ControlTestMonad + +evalGraph :: forall stmt exp m . + ControlTestMonad stmt exp m + => (Label -> Block CmmNode O O -> stmt) + -> (Label -> CmmExpr -> exp) + -> CmmGraph + -> m () +evalGraph stmt exp g = run (g_entry g) + where GMany NothingO blockmap NothingO = g_graph g + run :: Label -> m () + run label = do + takeAction @stmt @exp (stmt label (actionOf label)) + case lastNode (blockOf label) of + CmmBranch l -> run l + CmmCondBranch e t f _ -> do + b <- evalPredicate @stmt @exp (exp label e) + run (if b then t else f) + CmmSwitch e targets -> do + i <- evalEnum @stmt @exp (exp label e) $ + extendRight $ switchTargetsRange targets + run $ labelIn i targets + + CmmCall { cml_cont = Just l } -> run l + CmmCall { cml_cont = Nothing } -> return () + CmmForeignCall { succ = l } -> run l + + blockOf lbl = + mapFindWithDefault (panic "GHC.Cmm.ControlFlow.Run.eval") lbl blockmap + actionOf lbl = middle + where (_, middle, _) = blockSplit $ blockOf lbl + + + +-- | Adapt between different representations of ranges +extendRight :: Integral n => (n, n) -> (n, n) +extendRight (lo, hi) = (lo, hi + 1) + +labelIn :: Integer -> SwitchTargets -> Label +labelIn i targets = + case [lbl | (j, lbl) <- switchTargetsCases targets, j == i] + of [lbl] -> lbl + [] -> case switchTargetsDefault targets of + Just lbl -> lbl + Nothing -> panic "GHC.Cmm.ControlFlow.Run.labelIn: no default" + (_ : _ : _) -> panic "GHC.Cmm.ControlFlow.Run: too many matches" diff --git a/testsuite/tests/wasm/should_run/control-flow/RunWasm.hs b/testsuite/tests/wasm/should_run/control-flow/RunWasm.hs new file mode 100644 index 0000000000..5757348e83 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/RunWasm.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_GHC -Wincomplete-patterns -Werror #-} + +module RunWasm + ( evalWasm + ) +where + +-- Using a `ControlTestMonad` to provide observations, +-- simulate the execution of WebAssembly control flow. + +import GHC.Wasm.ControlFlow + +import ControlTestMonad + +evalWasm :: ControlTestMonad s e m => WasmControl s e pre post -> m () + +-- Evaluation uses a small-step semantics with a control stack. + +type Stack s e = [Frame (UntypedControl s e) e] +data Frame s e = EndLoop s | EndBlock | EndIf | Run s | Pushed e + +data UntypedControl s e = + forall pre post . U (WasmControl s e pre post) + +evalWasm s = run [Run (U s)] + +withPushedValue :: Stack s e -> (e -> Stack s e -> answer) -> answer +withPushedValue (Pushed e : stack) k = k e stack +withPushedValue _ _ = error "looked for pushed value, but did not find one" + + +run :: forall s e m . ControlTestMonad s e m => Stack s e -> m () +run [] = return () +run (EndLoop s : stack) = run (Run s : EndLoop s : stack) +run (EndBlock : stack) = run stack +run (EndIf : stack) = run stack +run (Pushed e : frame : stack) = run (frame : Pushed e : stack) +run (Pushed e : []) = return () +run (Run s : stack) = step s + where step :: UntypedControl s e -> m () + step (U WasmFallthrough) = run stack + step (U (WasmBlock _ s)) = run (Run (U s) : EndBlock : stack) + step (U (WasmLoop _ s)) = run (Run (U s) : EndLoop (U s) : stack) + step (U (WasmBr k)) = br k stack + + step (U (WasmPush _ e)) = run (Pushed e : stack) + step (U (WasmIfTop _ t f)) = withPushedValue stack $ \ e stack -> do + b <- evalPredicate @s @e e + run (Run (U $ if b then t else f) : EndIf : stack) + + step (U (WasmBrTable e range targets default')) = do + n <- fromInteger <$> + evalEnum @s @e e (bti_lo range, bti_lo range + bti_count range) + if n >= 0 && n < length targets then br (targets !! n) stack + else br default' stack + + step (U (WasmReturnTop _)) = withPushedValue stack $ \ _ _ -> return () + + step (U (WasmActions s)) = takeAction @s @e s >> run stack + step (U (WasmSeq s s')) = run (Run (U s) : Run (U s') : stack) + br 0 (EndLoop s : stack) = run (EndLoop s : stack) + br 0 (EndBlock : stack) = run stack + br 0 (EndIf : stack) = run stack + br k ((Run _) : stack) = br k stack + br k ((Pushed _) : stack) = br k stack + br k (_ : stack) = br (pred k) stack + br _ [] = fail "br index too large" + + +instance Show (Frame s e) where + show (EndLoop _) = "end loop" + show EndBlock = "end block" + show EndIf = "end if" + show (Pushed _) = "<pushed value>" + show (Run _) = "run" diff --git a/testsuite/tests/wasm/should_run/control-flow/WasmControlFlow.hs b/testsuite/tests/wasm/should_run/control-flow/WasmControlFlow.hs new file mode 100644 index 0000000000..3144161fa1 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/WasmControlFlow.hs @@ -0,0 +1,255 @@ +module Main where + +import Control.Monad +import Control.Monad.IO.Class +import Data.List (nub) +import Data.Maybe +import System.Environment ( getArgs ) +import System.Exit + +import GHC hiding (Stmt, Match) +import GHC.Cmm hiding (succ) +import GHC.Cmm.ContFlowOpt +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dominators +import GHC.Cmm.Reducibility +import GHC.Cmm.Switch.Implement +import GHC.Driver.Session +import GHC.Platform +import GHC.Types.Unique.Supply +import GHC.Wasm.ControlFlow +import GHC.Wasm.ControlFlow.FromCmm + +import qualified GHC.LanguageExtensions as LangExt + +import ActionsAndObservations +import BitConsumer +import CmmPaths +import ControlTestMonad +import EntropyTransducer +import LoadCmmGroup +import RunCmm +import RunWasm + +main :: IO () +main = do + libdir : modeString : files <- getArgs + defaultErrorHandler defaultFatalMessager defaultFlushOut $ do + runGhc (Just libdir) $ do + raw_dflags <- getSessionDynFlags + let dflags = raw_dflags `xopt_set` LangExt.MagicHash + `xopt_set` LangExt.StandaloneKindSignatures + `xopt_set` LangExt.UnliftedDatatypes + `xopt_set` LangExt.DataKinds + setSessionDynFlags dflags + groups <- mapM loadPath files + liftIO $ do + codes <- mapM (allTests $ targetPlatform dflags) (zip files groups) + exitWith $ foldl combineExits exitZero codes + +allTests :: Platform -> (FilePath, [CmmGroup]) -> IO ExitCode +allTests platform (path, groups) = + foldl combineExits exitZero <$> + sequence [test platform (path, groups) | test <- tests] + +tests :: [Platform -> (FilePath, [CmmGroup]) -> IO ExitCode] +tests = [reducibilityTest, splittingTest, translationTest] + +reducibilityTest, splittingTest, translationTest + :: Platform -> (FilePath, [CmmGroup]) -> IO ExitCode + + + + +---------------------------------------------------------------- + +-- | Counts the number of reducible and irreducible CFGs in each group + +reducibilityTest platform (path, groups) = do + analyses <- runGrouped (return . reducibility . graphWithDominators) platform groups + let dump results = do + putStr $ path ++ ": " + case (number (== Reducible), number (== Irreducible)) of + (0, 0) -> putStrLn $ "no code" + (1, 0) -> putStrLn $ "reducible" + (0, 1) -> putStrLn $ "irreducible" + (0, n) -> putStrLn $ show n ++ " irreducible" + (n, 0) -> putStrLn $ show n ++ " reducible" + (r, i) -> putStrLn $ show r ++ " reducible, " ++ show i ++ " irreducible" + where number p = length $ filter p $ results + dump analyses + return exitZero + +---------------------------------------------------------------- + +-- Convert each input graph to a reducible graph via node splitting, +-- run control-flow--path tests to confirm they behave the same. +-- Run similar tests that compare each graph with a mutilated version, +-- to confirm that the tests do in fact detect when graphs are different. + +splittingTest platform (path, groups) = do + reductions <- catMaybes <$> runGrouped testNodeSplitting platform groups + mutilations <- runGrouped (return . testGraphMutilation path) platform groups + codes <- liftM2 (++) (mapM (analyze "node splitting" path isIdentical) reductions) + (mapM (analyze "mutilation" path isDifferent) mutilations) + return $ foldl combineExits exitZero codes + +testNodeSplitting :: CmmGraph -> IO (Maybe Outcome) +testNodeSplitting original_graph = do + reducible_graph <- fmap gwd_graph $ runUniqSM $ + asReducible $ graphWithDominators original_graph + return $ case reducibility (graphWithDominators original_graph) of + Reducible -> Nothing + Irreducible -> + Just $ + compareWithEntropy (runcfg original_graph) (runcfg reducible_graph) $ + cfgEntropy reducible_graph + +testGraphMutilation :: FilePath -> CmmGraph -> Outcome +testGraphMutilation path graph = + compareWithEntropy (runcfg graph) (runcfg $ mutilate path graph) $ cfgEntropy graph + +-- | Changes the graph's entry point to one of the entry point's successors. +-- Panics if the input graph has only one block. +mutilate :: FilePath -> CmmGraph -> CmmGraph +mutilate path g = + case filter (/= entry_label) $ successors entry_block of + (lbl:_) -> CmmGraph lbl (g_graph g) + [] -> error $ "cannot mutilate control-flow graph in file " ++ path + where entry_label = g_entry g + entry_block = mapFindWithDefault (error "no entry block") entry_label $ graphMap g + +---------------------------------------------------------------- + +-- Translate each input graph to WebAssembly, then run +-- control-flow--path tests to confirm the translation behaves the +-- same as the original. + +translationTest platform (path, groups) = do + txs <- runGrouped (testTranslation platform) platform groups + codes <- mapM (analyze "WebAssembly translation" path isIdentical) txs + return $ foldl combineExits exitZero codes + +testTranslation :: Platform -> CmmGraph -> IO Outcome +testTranslation platform big_switch_graph = do + real_graph <- runUniqSM $ cmmImplementSwitchPlans platform big_switch_graph + reducible_graph <- fmap gwd_graph $ runUniqSM $ + asReducible $ graphWithDominators real_graph + let wasm = structuredControl platform expr stmt reducible_graph + return $ compareWithEntropy (runcfg real_graph) (runwasm wasm) $ + cfgEntropy reducible_graph + +---------------------------------------------------------------- + +-- Outcomes of comparisons + +data Outcome = Identical { npaths :: Int } + | Different { different :: [(Trace, Trace)], nsame :: Int } +type Trace = [Event Stmt Expr] + +isDifferent, isIdentical :: Outcome -> Bool + +isDifferent (Different {}) = True +isDifferent _ = False + +isIdentical (Identical {}) = True +isIdentical _ = False + +---------------------------------------------------------------- + +-- Comparisons of execution paths + +type Entropy = [[Bool]] + +compareWithEntropy :: BitConsumer Stmt Expr () + -> BitConsumer Stmt Expr () + -> Entropy + -> Outcome +compareWithEntropy a b bit_streams = + foldl add (Identical 0) $ map (compareRuns a b) bit_streams + where add (Identical k) Match = Identical (succ k) + add (Different ts k) Match = Different ts (succ k) + add (Identical k) (NoMatch pair) = Different [pair] k + add (Different ts k) (NoMatch pair) = Different (pair:ts) k + +data SingleComparison = Match + | NoMatch (Trace, Trace) + +compareRuns :: BitConsumer Stmt Expr () + -> BitConsumer Stmt Expr () + -> [Bool] + -> SingleComparison +compareRuns a b bits = + if and $ zipWith (==) aEvents bEvents then + Match + else + NoMatch (aEvents, bEvents) + where aEvents = pastEvents $ runWithBits a bits + bEvents = pastEvents $ runWithBits b bits + + +cfgEntropy :: CmmGraph -> Entropy +cfgEntropy = map traceBits . cmmPaths + +analyze :: String -> FilePath -> (Outcome -> Bool) -> Outcome -> IO ExitCode +analyze what path isGood outcome = do + putStrLn $ display $ path ++ ", " ++ what ++ ": " ++ case outcome of + Identical n -> show n ++ " paths are identical" + Different diffs nsame -> + if nsame == 0 then + "all " ++ show (length diffs) ++ " paths are different" + else + show (length diffs) ++ " of " ++ show (length diffs + nsame) ++ " paths are different" + if isGood outcome then + return ExitSuccess + else + return $ ExitFailure 1 + where display s = if isGood outcome then s ++ ", as expected" + else "(FAULT!) " ++ s + +---------------------------------------------------------------- + +-- Other test-running infrastructure + +runGrouped :: (CmmGraph -> IO a) -> Platform -> [CmmGroup] -> IO [a] +runGrouped f platform groups = concat <$> mapM (concatMapGraphs platform (const f)) groups + +concatMapGraphs :: Monad m + => Platform + -> (Platform -> CmmGraph -> m a) + -> CmmGroup + -> m [a] +concatMapGraphs platform f group = + catMaybes <$> mapM (decl . cmmCfgOptsProc False) group + where decl (CmmData {}) = return Nothing + decl (CmmProc _h _entry _registers graph) = + do a <- f platform graph + return $ Just a + +count :: [a] -> String -> String +count xs thing = case length xs of + 1 -> "1 " ++ thing + n -> show n ++ " " ++ thing ++ "s" + +runcfg :: CmmGraph -> BitConsumer Stmt Expr () +runcfg = evalGraph stmt expr + +runwasm :: WasmControl Stmt Expr pre post -> BitConsumer Stmt Expr () +runwasm = evalWasm + +runUniqSM :: UniqSM a -> IO a +runUniqSM m = do + us <- mkSplitUniqSupply 'g' + return (initUs_ us m) + +---------------------------------------------------------------- + +-- ExitCode as monoid + +combineExits :: ExitCode -> ExitCode -> ExitCode +exitZero :: ExitCode + +exitZero = ExitSuccess +combineExits ExitSuccess e = e +combineExits e _ = e diff --git a/testsuite/tests/wasm/should_run/control-flow/WasmControlFlow.stdout b/testsuite/tests/wasm/should_run/control-flow/WasmControlFlow.stdout new file mode 100644 index 0000000000..f18f43c3b0 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/WasmControlFlow.stdout @@ -0,0 +1,149 @@ +src/Church.hs: 3 reducible +src/Church.hs, mutilation: all 3 paths are different, as expected +src/Church.hs, mutilation: all 3 paths are different, as expected +src/Church.hs, mutilation: all 6 paths are different, as expected +src/Church.hs, WebAssembly translation: 3 paths are identical, as expected +src/Church.hs, WebAssembly translation: 3 paths are identical, as expected +src/Church.hs, WebAssembly translation: 6 paths are identical, as expected +src/Closure.hs: 2 reducible +src/Closure.hs, mutilation: all 3 paths are different, as expected +src/Closure.hs, mutilation: all 6 paths are different, as expected +src/Closure.hs, WebAssembly translation: 3 paths are identical, as expected +src/Closure.hs, WebAssembly translation: 6 paths are identical, as expected +src/FailingLint.hs: 1 reducible, 1 irreducible +src/FailingLint.hs, node splitting: 218 paths are identical, as expected +src/FailingLint.hs, mutilation: all 138 paths are different, as expected +src/FailingLint.hs, mutilation: all 6 paths are different, as expected +src/FailingLint.hs, WebAssembly translation: 218 paths are identical, as expected +src/FailingLint.hs, WebAssembly translation: 6 paths are identical, as expected +src/Irr.hs: 1 reducible, 1 irreducible +src/Irr.hs, node splitting: 872 paths are identical, as expected +src/Irr.hs, mutilation: all 552 paths are different, as expected +src/Irr.hs, mutilation: all 6 paths are different, as expected +src/Irr.hs, WebAssembly translation: 872 paths are identical, as expected +src/Irr.hs, WebAssembly translation: 6 paths are identical, as expected +src/Irr2.hs: 10 reducible +src/Irr2.hs, mutilation: all 6 paths are different, as expected +src/Irr2.hs, mutilation: all 6 paths are different, as expected +src/Irr2.hs, mutilation: all 6 paths are different, as expected +src/Irr2.hs, mutilation: all 13 paths are different, as expected +src/Irr2.hs, mutilation: all 6 paths are different, as expected +src/Irr2.hs, mutilation: all 6 paths are different, as expected +src/Irr2.hs, mutilation: all 6 paths are different, as expected +src/Irr2.hs, mutilation: all 13 paths are different, as expected +src/Irr2.hs, mutilation: all 6 paths are different, as expected +src/Irr2.hs, mutilation: all 11 paths are different, as expected +src/Irr2.hs, WebAssembly translation: 6 paths are identical, as expected +src/Irr2.hs, WebAssembly translation: 6 paths are identical, as expected +src/Irr2.hs, WebAssembly translation: 6 paths are identical, as expected +src/Irr2.hs, WebAssembly translation: 13 paths are identical, as expected +src/Irr2.hs, WebAssembly translation: 6 paths are identical, as expected +src/Irr2.hs, WebAssembly translation: 6 paths are identical, as expected +src/Irr2.hs, WebAssembly translation: 6 paths are identical, as expected +src/Irr2.hs, WebAssembly translation: 13 paths are identical, as expected +src/Irr2.hs, WebAssembly translation: 6 paths are identical, as expected +src/Irr2.hs, WebAssembly translation: 11 paths are identical, as expected +src/Irr3.hs: 1 reducible, 1 irreducible +src/Irr3.hs, node splitting: 24 paths are identical, as expected +src/Irr3.hs, mutilation: all 21 paths are different, as expected +src/Irr3.hs, mutilation: all 6 paths are different, as expected +src/Irr3.hs, WebAssembly translation: 24 paths are identical, as expected +src/Irr3.hs, WebAssembly translation: 6 paths are identical, as expected +src/Irr4.hs: 3 reducible, 1 irreducible +src/Irr4.hs, node splitting: 74 paths are identical, as expected +src/Irr4.hs, mutilation: all 3 paths are different, as expected +src/Irr4.hs, mutilation: all 3 paths are different, as expected +src/Irr4.hs, mutilation: all 61 paths are different, as expected +src/Irr4.hs, mutilation: all 6 paths are different, as expected +src/Irr4.hs, WebAssembly translation: 3 paths are identical, as expected +src/Irr4.hs, WebAssembly translation: 3 paths are identical, as expected +src/Irr4.hs, WebAssembly translation: 74 paths are identical, as expected +src/Irr4.hs, WebAssembly translation: 6 paths are identical, as expected +src/Length.hs: 5 reducible +src/Length.hs, mutilation: all 6 paths are different, as expected +src/Length.hs, mutilation: all 6 paths are different, as expected +src/Length.hs, mutilation: all 18 paths are different, as expected +src/Length.hs, mutilation: all 3 paths are different, as expected +src/Length.hs, mutilation: all 6 paths are different, as expected +src/Length.hs, WebAssembly translation: 6 paths are identical, as expected +src/Length.hs, WebAssembly translation: 6 paths are identical, as expected +src/Length.hs, WebAssembly translation: 18 paths are identical, as expected +src/Length.hs, WebAssembly translation: 3 paths are identical, as expected +src/Length.hs, WebAssembly translation: 6 paths are identical, as expected +src/Map.hs: 3 reducible +src/Map.hs, mutilation: all 3 paths are different, as expected +src/Map.hs, mutilation: all 3 paths are different, as expected +src/Map.hs, mutilation: all 18 paths are different, as expected +src/Map.hs, WebAssembly translation: 3 paths are identical, as expected +src/Map.hs, WebAssembly translation: 3 paths are identical, as expected +src/Map.hs, WebAssembly translation: 18 paths are identical, as expected +src/Max.hs: 2 reducible +src/Max.hs, mutilation: all 14 paths are different, as expected +src/Max.hs, mutilation: all 6 paths are different, as expected +src/Max.hs, WebAssembly translation: 14 paths are identical, as expected +src/Max.hs, WebAssembly translation: 6 paths are identical, as expected +src/PJIf.hs: reducible +src/PJIf.hs, mutilation: all 10 paths are different, as expected +src/PJIf.hs, WebAssembly translation: 10 paths are identical, as expected +src/dec.cmm: reducible +src/dec.cmm, mutilation: all 6 paths are different, as expected +src/dec.cmm, WebAssembly translation: 6 paths are identical, as expected +src/dloop.cmm: reducible +src/dloop.cmm, mutilation: all 10 paths are different, as expected +src/dloop.cmm, WebAssembly translation: 10 paths are identical, as expected +src/ex9.cmm: reducible +src/ex9.cmm, mutilation: all 9 paths are different, as expected +src/ex9.cmm, WebAssembly translation: 9 paths are identical, as expected +src/ex10.cmm: reducible +src/ex10.cmm, mutilation: all 10 paths are different, as expected +src/ex10.cmm, WebAssembly translation: 10 paths are identical, as expected +src/fig1b.cmm: reducible +src/fig1b.cmm, mutilation: all 5 paths are different, as expected +src/fig1b.cmm, WebAssembly translation: 5 paths are identical, as expected +src/hardswitch.cmm: reducible +src/hardswitch.cmm, mutilation: all 12 paths are different, as expected +src/hardswitch.cmm, WebAssembly translation: 13 paths are identical, as expected +src/idmerge.cmm: reducible +src/idmerge.cmm, mutilation: all 12 paths are different, as expected +src/idmerge.cmm, WebAssembly translation: 12 paths are identical, as expected +src/ifloop.cmm: reducible +src/ifloop.cmm, mutilation: all 12 paths are different, as expected +src/ifloop.cmm, WebAssembly translation: 12 paths are identical, as expected +src/irr.cmm: irreducible +src/irr.cmm, node splitting: 15 paths are identical, as expected +src/irr.cmm, mutilation: all 13 paths are different, as expected +src/irr.cmm, WebAssembly translation: 15 paths are identical, as expected +src/irrbad.cmm: irreducible +src/irrbad.cmm, node splitting: 30 paths are identical, as expected +src/irrbad.cmm, mutilation: all 25 paths are different, as expected +src/irrbad.cmm, WebAssembly translation: 30 paths are identical, as expected +src/loop.cmm: reducible +src/loop.cmm, mutilation: all 15 paths are different, as expected +src/loop.cmm, WebAssembly translation: 15 paths are identical, as expected +src/looptail.cmm: reducible +src/looptail.cmm, mutilation: all 15 paths are different, as expected +src/looptail.cmm, WebAssembly translation: 15 paths are identical, as expected +src/multiswitch.cmm: reducible +src/multiswitch.cmm, mutilation: all 97 paths are different, as expected +src/multiswitch.cmm, WebAssembly translation: 115 paths are identical, as expected +src/noloop.cmm: reducible +src/noloop.cmm, mutilation: all 13 paths are different, as expected +src/noloop.cmm, WebAssembly translation: 13 paths are identical, as expected +src/panic.cmm: reducible +src/panic.cmm, mutilation: all 6 paths are different, as expected +src/panic.cmm, WebAssembly translation: 9 paths are identical, as expected +src/panic2.cmm: reducible +src/panic2.cmm, mutilation: all 2 paths are different, as expected +src/panic2.cmm, WebAssembly translation: 2 paths are identical, as expected +src/self.cmm: reducible +src/self.cmm, mutilation: all 5 paths are different, as expected +src/self.cmm, WebAssembly translation: 5 paths are identical, as expected +src/selfloop.cmm: reducible +src/selfloop.cmm, mutilation: all 6 paths are different, as expected +src/selfloop.cmm, WebAssembly translation: 6 paths are identical, as expected +src/switch.cmm: reducible +src/switch.cmm, mutilation: all 12 paths are different, as expected +src/switch.cmm, WebAssembly translation: 15 paths are identical, as expected +src/webexample.cmm: reducible +src/webexample.cmm, mutilation: all 7 paths are different, as expected +src/webexample.cmm, WebAssembly translation: 7 paths are identical, as expected diff --git a/testsuite/tests/wasm/should_run/control-flow/all.T b/testsuite/tests/wasm/should_run/control-flow/all.T new file mode 100644 index 0000000000..f7db9be0be --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/all.T @@ -0,0 +1,47 @@ + + +ctlextra_files = extra_files(['src/', + 'ActionsAndObservations.hs', 'BitConsumer.hs', 'CmmPaths.hs', + 'ControlTestMonad.hs', 'EntropyTransducer.hs', 'LoadCmmGroup.hs', + 'RunCmm.hs', 'RunWasm.hs',]) + +basenames = ['Church.hs', + 'Closure.hs', + 'FailingLint.hs', + 'Irr.hs', + 'Irr2.hs', + 'Irr3.hs', + 'Irr4.hs', + 'Length.hs', + 'Map.hs', + 'Max.hs', + 'PJIf.hs', + 'dec.cmm', + 'dloop.cmm', + 'ex9.cmm', + 'ex10.cmm', + 'fig1b.cmm', + 'hardswitch.cmm', + 'idmerge.cmm', + 'ifloop.cmm', + 'irr.cmm', + 'irrbad.cmm', + 'loop.cmm', + 'looptail.cmm', + 'multiswitch.cmm', + 'noloop.cmm', + 'panic.cmm', + 'panic2.cmm', + 'self.cmm', + 'selfloop.cmm', + 'switch.cmm', + 'webexample.cmm' + ] + + +sources = ['src/' + basename for basename in basenames] + +test('WasmControlFlow', + [extra_run_opts(" ".join(['"' + config.libdir + '"', '-r'] + sources)), ctlextra_files], + multimod_compile_and_run, + ['WasmControlFlow', '-package ghc']) diff --git a/testsuite/tests/wasm/should_run/control-flow/src/Church.hs b/testsuite/tests/wasm/should_run/control-flow/src/Church.hs new file mode 100644 index 0000000000..ab5bcaefaf --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/Church.hs @@ -0,0 +1,10 @@ +module Church +where + + +type Churchlist t u = (t->u->u)->u->u + +nil :: Churchlist t u +nil = \c n -> n +cons :: t -> Churchlist t u -> Churchlist t u +cons x xs = \c n -> c x (xs c n) diff --git a/testsuite/tests/wasm/should_run/control-flow/src/Closure.hs b/testsuite/tests/wasm/should_run/control-flow/src/Closure.hs new file mode 100644 index 0000000000..f223086e8b --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/Closure.hs @@ -0,0 +1,4 @@ +module Closure where + +add :: Int -> [Int] -> [Int] +add x = map (\n -> n + x) diff --git a/testsuite/tests/wasm/should_run/control-flow/src/FailingLint.hs b/testsuite/tests/wasm/should_run/control-flow/src/FailingLint.hs new file mode 100644 index 0000000000..02502c087a --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/FailingLint.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Irr3 -- like Irr, but simplified +where + +import GHC.Exts hiding (List) + +data List = Nil | Cons !List + +length'' :: Int# -> List -> Int# +length'' !trigger !xs = + case trigger of 0# -> countA 0# xs + _ -> countB 0# xs + where countA !n Nil = n + countA !n (Cons as) = countB (n +# 1#) as + countB !n Nil = n + countB !n (Cons as) = countA (n +# 2#) as + {-# NOINLINE countA #-} + {-# NOINLINE countB #-} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/Irr.hs b/testsuite/tests/wasm/should_run/control-flow/src/Irr.hs new file mode 100644 index 0000000000..9604dc2404 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/Irr.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Irr +where + +import GHC.Exts hiding (List) + +data List a = Nil | Cons !a !(List a) + +length'' :: Bool -> List a -> Int# +length'' !trigger !xs = if trigger then countA 0# xs else countB 0# xs + where countA !n Nil = n + countA !n (Cons _ as) = countB (n +# 1#) as + countB !n Nil = n + countB !n (Cons _ as) = countA (n +# 2#) as + {-# NOINLINE countA #-} + {-# NOINLINE countB #-} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/Irr2.hs b/testsuite/tests/wasm/should_run/control-flow/src/Irr2.hs new file mode 100644 index 0000000000..43d73258c7 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/Irr2.hs @@ -0,0 +1,14 @@ +module Irr2 +where + +foo :: Bool -> Int -> Bool +foo b n + | n > 10 = even n + | otherwise = odd n + where + even 0 = b + even n = odd (n-1) + {-# NOINLINE even #-} + odd 0 = b + odd n = even (n-1) + {-# NOINLINE odd #-} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/Irr3.hs b/testsuite/tests/wasm/should_run/control-flow/src/Irr3.hs new file mode 100644 index 0000000000..f10a6ddb2b --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/Irr3.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Irr3 -- like Irr, but simplified +where + +import GHC.Exts hiding (List) + +type List :: TYPE UnliftedRep +data List = Nil | Cons !List + +length'' :: Int# -> List -> Int# +length'' trigger xs = + case trigger of 0# -> countA 0# xs + _ -> countB 0# xs + where countA n Nil = n + countA n (Cons as) = countB (n +# 1#) as + countB n Nil = n + countB n (Cons as) = countA (n +# 2#) as + {-# NOINLINE countA #-} + {-# NOINLINE countB #-} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/Irr4.hs b/testsuite/tests/wasm/should_run/control-flow/src/Irr4.hs new file mode 100644 index 0000000000..90a99ad2be --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/Irr4.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Irr4 -- like Irr3, but with lifted types +where + +import GHC.Exts hiding (List) + +type List :: TYPE UnliftedRep +data List = Nil | Cons !List + +length'' :: Int# -> List -> Int +length'' trigger xs = + case trigger of 0# -> countA 0 xs + _ -> countB 0 xs + where countA n Nil = n + I# trigger + countA n (Cons as) = countB (n + 1) as + countB n Nil = n + I# trigger + countB n (Cons as) = countA (n + 2) as + {-# NOINLINE countA #-} + {-# NOINLINE countB #-} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/Length.hs b/testsuite/tests/wasm/should_run/control-flow/src/Length.hs new file mode 100644 index 0000000000..01f022266b --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/Length.hs @@ -0,0 +1,9 @@ +module Length +where + +data List a = Nil | Cons a (List a) + +length' :: List a -> Int +length' = count 0 + where count n Nil = case n of m -> m + count n (Cons _ as) = case n + 1 of m -> case count m as of k -> k diff --git a/testsuite/tests/wasm/should_run/control-flow/src/Map.hs b/testsuite/tests/wasm/should_run/control-flow/src/Map.hs new file mode 100644 index 0000000000..07886c6a17 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/Map.hs @@ -0,0 +1,6 @@ +module Map +where + +myMap :: (a -> b) -> [a] -> [b] +myMap f [] = [] +myMap f (x:xs) = f x : myMap f xs diff --git a/testsuite/tests/wasm/should_run/control-flow/src/Max.hs b/testsuite/tests/wasm/should_run/control-flow/src/Max.hs new file mode 100644 index 0000000000..02e566337c --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/Max.hs @@ -0,0 +1,6 @@ +module Max where + +delta :: Int -> Int -> Int +delta m n = + let (large, small) = if m > n then (m, n) else (n, m) + in large - small diff --git a/testsuite/tests/wasm/should_run/control-flow/src/PJIf.hs b/testsuite/tests/wasm/should_run/control-flow/src/PJIf.hs new file mode 100644 index 0000000000..ec0b68d635 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/PJIf.hs @@ -0,0 +1,4 @@ +module PJIf where + +myIf True x y = x +myIf False x y = y diff --git a/testsuite/tests/wasm/should_run/control-flow/src/dec.cmm b/testsuite/tests/wasm/should_run/control-flow/src/dec.cmm new file mode 100644 index 0000000000..38f81f555b --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/dec.cmm @@ -0,0 +1,9 @@ +decrement(bits32 n) { + A: + if (n > 0) { + n = n - 1; + goto A; + } + return (n); +} + diff --git a/testsuite/tests/wasm/should_run/control-flow/src/dloop.cmm b/testsuite/tests/wasm/should_run/control-flow/src/dloop.cmm new file mode 100644 index 0000000000..4cc1f4f542 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/dloop.cmm @@ -0,0 +1,15 @@ +double_loop (bits32 n) { + A: + foreign "C" A(); + if (n > 1) goto B; + C: + foreign "C" C(); + if (n > 3) goto A; + goto D; + B: + foreign "C" B(); + if (n > 2) goto A; + D: + foreign "C" D(); + return (999); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/ex10.cmm b/testsuite/tests/wasm/should_run/control-flow/src/ex10.cmm new file mode 100644 index 0000000000..afaafd700f --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/ex10.cmm @@ -0,0 +1,19 @@ +ex10 (bits32 n) { + A: + foreign "C" A(); + if (n > 1) goto D; + B: + foreign "C" B(); + if (n > 2) goto E; + C: + foreign "C" C(); + goto F; + D: + foreign "C" D(); + if (n > 4) goto F; + E: + foreign "C" E(); + F: + foreign "C" F(); + return(1010); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/ex9.cmm b/testsuite/tests/wasm/should_run/control-flow/src/ex9.cmm new file mode 100644 index 0000000000..e0da722306 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/ex9.cmm @@ -0,0 +1,15 @@ +ex10 (bits32 n) { + A: + foreign "C" A(); + B: + foreign "C" B(); + if (n > 2) goto A; + C: + foreign "C" C(); + if (n > 3) goto E; + D: foreign "C" D(); + goto F; + E: foreign "C" E(); + F: foreign "C" F(); + return(333); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/fig1b.cmm b/testsuite/tests/wasm/should_run/control-flow/src/fig1b.cmm new file mode 100644 index 0000000000..14ee4e0f56 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/fig1b.cmm @@ -0,0 +1,14 @@ +fig1b (bits32 n) { + A: + foreign "C" A(); + if (n > 1) goto B; + goto C; + B: + foreign "C" B(); + goto D; + C: + foreign "C" C(); + D: + foreign "C" D(); + return(2020); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/hardswitch.cmm b/testsuite/tests/wasm/should_run/control-flow/src/hardswitch.cmm new file mode 100644 index 0000000000..f85bacf1d1 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/hardswitch.cmm @@ -0,0 +1,22 @@ +section "comment" { + mycomment: + bits8 [] "see https://medium.com/leaningtech/solving-the-structured-control-flow-problem-once-and-for-all-5123117b1ee2"; +} + +hardswitch(bits32 n) { + + bits32 m; + (m) = foreign "C" A(); + switch [0 .. 4] (m) { + case 0: + { foreign "C" B(); goto c1; } + case 1: + { c1: foreign "C" C(); goto c2; } + case 2: + { c2: foreign "C" D(); goto c3; } + default: + { c3: foreign "C" E(); goto finish; } + } + finish: + return(); +}
\ No newline at end of file diff --git a/testsuite/tests/wasm/should_run/control-flow/src/idmerge.cmm b/testsuite/tests/wasm/should_run/control-flow/src/idmerge.cmm new file mode 100644 index 0000000000..52f1ae5baa --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/idmerge.cmm @@ -0,0 +1,17 @@ +idmerge (bits32 n) { + A: + foreign "C" A(); + if (n > 1) goto C; + B: + foreign "C" B(); + goto D; + C: + foreign "C" C(); + D: + foreign "C" D(); + E: + foreign "C" E(); + if (n > 5) goto A; + return(888); + +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/ifloop.cmm b/testsuite/tests/wasm/should_run/control-flow/src/ifloop.cmm new file mode 100644 index 0000000000..76c61a12c3 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/ifloop.cmm @@ -0,0 +1,17 @@ +ifloop (bits32 n) { + A: + foreign "C" A(); + if (n > 0) goto C; + B: + foreign "C" B(); + goto D; + C: + foreign "C" C(); + D: + foreign "C" D(); + E: + foreign "C" E(); + if (n > 5) goto A; + foreign "C" F(); + return (999); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/irr.cmm b/testsuite/tests/wasm/should_run/control-flow/src/irr.cmm new file mode 100644 index 0000000000..2e5e3722d3 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/irr.cmm @@ -0,0 +1,19 @@ +section "comment" { + mycomment: + bits8 [] "The classic irreducible flow graph, modified so it doesn't loop forever (so we can test it"; +} + + +irr1 (bits32 n) { + A: + foreign "C" A(); + if (n > 1) goto B; + C: + foreign "C" C(); + if (n > 3) goto B; + return (888); + B: + foreign "C" B(); + if (n > 2) goto C; + return (999); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/irrbad.cmm b/testsuite/tests/wasm/should_run/control-flow/src/irrbad.cmm new file mode 100644 index 0000000000..a03d5dacc9 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/irrbad.cmm @@ -0,0 +1,26 @@ +section "comment" { + mycomment: + bits8 [] "An irreducible flow graph that can't be made reducible by node splitting alone (Hecht, page 117)"; +} + +double_loop (bits32 n) { + A: + foreign "C" A(); + if (n > 1) goto B; + C: + foreign "C" C(); + if (n > 3) goto B; + goto E; + B: + foreign "C" B(); + if (n > 2) goto C; + goto D; + D: + foreign "C" D(); + if (n > 4) goto B; + return (888); + E: + foreign "C" E(); + if (n > 5) goto C; + return (999); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/loop.cmm b/testsuite/tests/wasm/should_run/control-flow/src/loop.cmm new file mode 100644 index 0000000000..f6fab45b14 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/loop.cmm @@ -0,0 +1,23 @@ +loop (bits32 n) { + A: + foreign "C" A(); + B: + foreign "C" B(); + C: + foreign "C" C(); + if (n > 3) goto A; + D: + foreign "C" D(); + if (n > 4) goto H; + E: + foreign "C" E(); + if (n > 5) goto B; + F: + foreign "C" F(); + if (n > 6) goto A; + G: + foreign "C" G(); + H: + foreign "C" H(); + return(0); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/looptail.cmm b/testsuite/tests/wasm/should_run/control-flow/src/looptail.cmm new file mode 100644 index 0000000000..2ca3038130 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/looptail.cmm @@ -0,0 +1,21 @@ +ex10 (bits32 n) { + A: + foreign "C" A(); + if (n > 1) goto G; + B: + foreign "C" B(); + if (n > 2) goto D; + C: + foreign "C" C(); + goto E; + D: + foreign "C" D(); + E: + foreign "C" E(); + if (n > 5) goto B; + F: + foreign "C" F(); + G: + foreign "C" G(); + return(7331); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/multiswitch.cmm b/testsuite/tests/wasm/should_run/control-flow/src/multiswitch.cmm new file mode 100644 index 0000000000..8b3c76aa50 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/multiswitch.cmm @@ -0,0 +1,22 @@ +myswitch (bits32 n) { + switch [0 .. 4] n { + case 0, 1: { foreign "C" A(); goto next; } + case 2: { foreign "C" B(); goto inner; } + case 4: { inner: foreign "C" C(); goto next; } + default: { foreign "C" D(); goto next; } + } + next: + switch [0 .. 4] n { + case 0, 1: { foreign "C" G(); goto finish; } + case 2: { foreign "C" H(); goto inner2; } + case 4: { foreign "C" J(); goto finish; } + case 3: { inner2: foreign "C" I(); + switch [0 .. 1] n { + case 0: { foreign "C" I0(); goto finish; } + case 1: { foreign "C" I1(); goto finish; } + } + } + } + finish: + return(); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/noloop.cmm b/testsuite/tests/wasm/should_run/control-flow/src/noloop.cmm new file mode 100644 index 0000000000..1a8e791aa1 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/noloop.cmm @@ -0,0 +1,22 @@ +noloop (bits32 n) { + A: + foreign "C" A(); + if (n > 0) goto B; + G: + foreign "C" G(); + if (n > 7) goto F; + E: + foreign "C" E(); + return (999); + B: + foreign "C" B(); + if (n > 2) goto C; + F: + foreign "C" F(); + goto D; + C: + foreign "C" C(); + D: + foreign "C" D(); + goto E; +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/panic.cmm b/testsuite/tests/wasm/should_run/control-flow/src/panic.cmm new file mode 100644 index 0000000000..b07c5e7ce5 --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/panic.cmm @@ -0,0 +1,8 @@ +myswitch (bits32 n) { + switch [0 .. 4] n { + case 0, 1: { foreign "C" A(); return (666); } + case 2: { foreign "C" B(); return (555); } + case 4: { foreign "C" C(); return (444); } + default: { foreign "C" D(); return (333); } + } +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/panic2.cmm b/testsuite/tests/wasm/should_run/control-flow/src/panic2.cmm new file mode 100644 index 0000000000..79f8ebc32f --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/panic2.cmm @@ -0,0 +1,7 @@ +ex10 (bits32 n) { + C: + if (n > 3) { goto D; } else { goto E; } + D: + E: + return(333); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/self.cmm b/testsuite/tests/wasm/should_run/control-flow/src/self.cmm new file mode 100644 index 0000000000..e433cdc20a --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/self.cmm @@ -0,0 +1,6 @@ +self (bits32 n) { + A: + n = n - 1; + if (n > 0) goto A; + return (n); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/selfloop.cmm b/testsuite/tests/wasm/should_run/control-flow/src/selfloop.cmm new file mode 100644 index 0000000000..0b9a3c313a --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/selfloop.cmm @@ -0,0 +1,9 @@ +testLoop (bits32 counter) +{ +loop: + if (counter > 0) { + counter = counter - 1; + goto loop; + } + return (counter); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/switch.cmm b/testsuite/tests/wasm/should_run/control-flow/src/switch.cmm new file mode 100644 index 0000000000..53e968bf4f --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/switch.cmm @@ -0,0 +1,10 @@ +myswitch (bits32 n) { + switch [0 .. 4] n { + case 0, 1: { foreign "C" A(); goto finish; } + case 2: { foreign "C" B(); goto inner; } + case 4: { inner: foreign "C" C(); goto finish; } + default: { foreign "C" D(); goto finish; } + } + finish: + return(); +} diff --git a/testsuite/tests/wasm/should_run/control-flow/src/webexample.cmm b/testsuite/tests/wasm/should_run/control-flow/src/webexample.cmm new file mode 100644 index 0000000000..897b89be1b --- /dev/null +++ b/testsuite/tests/wasm/should_run/control-flow/src/webexample.cmm @@ -0,0 +1,19 @@ +section "comment" { + mycomment: + bits8 [] "see https://medium.com/leaningtech/solving-the-structured-control-flow-problem-once-and-for-all-5123117b1ee2"; +} + +hardswitch(bits32 n) { + + foreign "C" A(); + if (n > 1) { + header: + foreign "C" B(); + foreign "C" D(); + if (n > 4) goto header; + } else { + foreign "C" C(); + } + foreign "C" E(); + return(); +}
\ No newline at end of file |