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