Refactor the story around switches (#10137)
[ghc.git] / compiler / cmm / CmmImplementSwitchPlans.hs
1 {-# LANGUAGE GADTs #-}
2 module CmmImplementSwitchPlans
3 ( cmmImplementSwitchPlans
4 )
5 where
6
7 import Hoopl
8 import BlockId
9 import Cmm
10 import CmmUtils
11 import CmmSwitch
12 import UniqSupply
13 import DynFlags
14
15 --
16 -- This module replaces Switch statements as generated by the Stg -> Cmm
17 -- transformation, which might be huge and sparse and hence unsuitable for
18 -- assembly code, by proper constructs (if-then-else trees, dense jump tables).
19 --
20 -- The actual, abstract strategy is determined by createSwitchPlan in
21 -- CmmSwitch and returned as a SwitchPlan; here is just the implementation in
22 -- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch.
23 --
24 -- This division into different modules is both to clearly separte concerns,
25 -- but also because createSwitchPlan needs access to the constructors of
26 -- SwitchTargets, a data type exported abstractly by CmmSwitch.
27 --
28
29 -- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for
30 -- code generation.
31 cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph
32 cmmImplementSwitchPlans dflags g
33 | targetSupportsSwitch (hscTarget dflags) = return g
34 | otherwise = do
35 blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)
36 return $ ofBlockList (g_entry g) blocks'
37
38 visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]
39 visitSwitches dflags block
40 | (entry@(CmmEntry _ scope), middle, CmmSwitch expr ids) <- blockSplit block
41 = do
42 let plan = createSwitchPlan ids
43
44 (newTail, newBlocks) <- implementSwitchPlan dflags scope expr plan
45
46 let block' = entry `blockJoinHead` middle `blockAppend` newTail
47
48 return $ block' : newBlocks
49
50 | otherwise
51 = return [block]
52
53
54 -- Implementing a switch plan (returning a tail block)
55 implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
56 implementSwitchPlan dflags scope expr = go
57 where
58 go (Unconditionally l)
59 = return (emptyBlock `blockJoinTail` CmmBranch l, [])
60 go (JumpTable ids)
61 = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])
62 go (IfLT signed i ids1 ids2)
63 = do
64 (bid1, newBlocks1) <- go' ids1
65 (bid2, newBlocks2) <- go' ids2
66
67 let lt | signed = cmmSLtWord
68 | otherwise = cmmULtWord
69 scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i
70 lastNode = CmmCondBranch scrut bid1 bid2
71 lastBlock = emptyBlock `blockJoinTail` lastNode
72 return (lastBlock, newBlocks1++newBlocks2)
73 go (IfEqual i l ids2)
74 = do
75 (bid2, newBlocks2) <- go' ids2
76
77 let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i
78 lastNode = CmmCondBranch scrut bid2 l
79 lastBlock = emptyBlock `blockJoinTail` lastNode
80 return (lastBlock, newBlocks2)
81
82 -- Same but returning a label to branch to
83 go' (Unconditionally l)
84 = return (l, [])
85 go' p
86 = do
87 bid <- mkBlockId `fmap` getUniqueM
88 (last, newBlocks) <- go p
89 let block = CmmEntry bid scope `blockJoinHead` last
90 return (bid, block: newBlocks)