Refactor the story around switches (#10137)

This re-implements the code generation for case expressions at the Stg →
Cmm level, both for data type cases as well as for integral literal
cases. (Cases on float are still treated as before).

The goal is to allow for fancier strategies in implementing them, for a
cleaner separation of the strategy from the gritty details of Cmm, and
to run this later than the Common Block Optimization, allowing for one
way to attack #10124. The new module CmmSwitch contains a number of
notes explaining this changes. For example, it creates larger
consecutive jump tables than the previous code, if possible.

nofib shows little significant overall improvement of runtime. The
rather large wobbling comes from changes in the code block order
(see #8082, not much we can do about it). But the decrease in code size
alone makes this worthwhile.

```
        Program           Size    Allocs   Runtime   Elapsed  TotalMem
            Min          -1.8%      0.0%     -6.1%     -6.1%     -2.9%
            Max          -0.7%     +0.0%     +5.6%     +5.7%     +7.8%
 Geometric Mean          -1.4%     -0.0%     -0.3%     -0.3%     +0.0%
```

Compilation time increases slightly:
```
        -1 s.d.                -----            -2.0%
        +1 s.d.                -----            +2.5%
        Average                -----            +0.3%
```

The test case T783 regresses a lot, but it is the only one exhibiting
any regression. The cause is the changed order of branches in an
if-then-else tree, which makes the hoople data flow analysis traverse
the blocks in a suboptimal order. Reverting that gets rid of this
regression, but has a consistent, if only very small (+0.2%), negative
effect on runtime. So I conclude that this test is an extreme outlier
and no reason to change the code.

Differential Revision: https://phabricator.haskell.org/D720

1 files changed, 90 insertions, 0 deletions

diff --git a/compiler/cmm/CmmImplementSwitchPlans.hs b/compiler/cmm/CmmImplementSwitchPlans.hs
new file mode 100644
index 0000000000..9fb68d8131
--- /dev/null
+++ b/compiler/cmm/CmmImplementSwitchPlans.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE GADTs #-}
+module CmmImplementSwitchPlans
+  ( cmmImplementSwitchPlans
+  )
+where
+
+import Hoopl
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch
+import UniqSupply
+import DynFlags
+
+--
+-- This module replaces Switch statements as generated by the Stg -> Cmm
+-- transformation, which might be huge and sparse and hence unsuitable for
+-- assembly code, by proper constructs (if-then-else trees, dense jump tables).
+--
+-- The actual, abstract strategy is determined by createSwitchPlan in
+-- CmmSwitch and returned as a SwitchPlan; here is just the implementation in
+-- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch.
+--
+-- This division into different modules is both to clearly separte concerns,
+-- but also because createSwitchPlan needs access to the constructors of
+-- SwitchTargets, a data type exported abstractly by CmmSwitch.
+--
+
+-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for
+-- code generation.
+cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph
+cmmImplementSwitchPlans dflags g
+    | targetSupportsSwitch (hscTarget dflags) = return g
+    | otherwise = do
+    blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)
+    return $ ofBlockList (g_entry g) blocks'
+
+visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]
+visitSwitches dflags block
+  | (entry@(CmmEntry _ scope), middle, CmmSwitch expr ids) <- blockSplit block
+  = do
+    let plan = createSwitchPlan ids
+
+    (newTail, newBlocks) <- implementSwitchPlan dflags scope expr plan
+
+    let block' = entry `blockJoinHead` middle `blockAppend` newTail
+
+    return $ block' : newBlocks
+
+  | otherwise
+  = return [block]
+
+
+-- Implementing a switch plan (returning a tail block)
+implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
+implementSwitchPlan dflags scope expr = go
+  where
+    go (Unconditionally l)
+      = return (emptyBlock `blockJoinTail` CmmBranch l, [])
+    go (JumpTable ids)
+      = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])
+    go (IfLT signed i ids1 ids2)
+      = do
+        (bid1, newBlocks1) <- go' ids1
+        (bid2, newBlocks2) <- go' ids2
+
+        let lt | signed    = cmmSLtWord
+               | otherwise = cmmULtWord
+            scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i
+            lastNode = CmmCondBranch scrut bid1 bid2
+            lastBlock = emptyBlock `blockJoinTail` lastNode
+        return (lastBlock, newBlocks1++newBlocks2)
+    go (IfEqual i l ids2)
+      = do
+        (bid2, newBlocks2) <- go' ids2
+
+        let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i
+            lastNode = CmmCondBranch scrut bid2 l
+            lastBlock = emptyBlock `blockJoinTail` lastNode
+        return (lastBlock, newBlocks2)
+
+    -- Same but returning a label to branch to
+    go' (Unconditionally l)
+      = return (l, [])
+    go' p
+      = do
+        bid <- mkBlockId `fmap` getUniqueM
+        (last, newBlocks) <- go p
+        let block = CmmEntry bid scope `blockJoinHead` last
+        return (bid, block: newBlocks)