add new modules for reducibility and WebAssembly translationwip/nr/wasm-control-flow

also includes an emitter for GNU assembler code and some regression tests

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