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

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

44 files changed, 1534 insertions, 1 deletions

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