summaryrefslogtreecommitdiff
path: root/compiler/cmm/CmmImplementSwitchPlans.hs
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-01-07 02:44:39 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-01-25 05:22:20 -0500
commit6e2d9ee25bce06ae51d2f1cf8df4f7422106a383 (patch)
tree4bb0aa9527bc0bed4fb2e991eb02d0f031d514bf /compiler/cmm/CmmImplementSwitchPlans.hs
parentc3fde723633d1788e4ded8c6f59eb7cef1ae95fd (diff)
downloadhaskell-6e2d9ee25bce06ae51d2f1cf8df4f7422106a383.tar.gz
Module hierarchy: Cmm (cf #13009)
Diffstat (limited to 'compiler/cmm/CmmImplementSwitchPlans.hs')
-rw-r--r--compiler/cmm/CmmImplementSwitchPlans.hs116
1 files changed, 0 insertions, 116 deletions
diff --git a/compiler/cmm/CmmImplementSwitchPlans.hs b/compiler/cmm/CmmImplementSwitchPlans.hs
deleted file mode 100644
index 83c29cf6b5..0000000000
--- a/compiler/cmm/CmmImplementSwitchPlans.hs
+++ /dev/null
@@ -1,116 +0,0 @@
-{-# LANGUAGE GADTs #-}
-module CmmImplementSwitchPlans
- ( cmmImplementSwitchPlans
- )
-where
-
-import GhcPrelude
-
-import Hoopl.Block
-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 separate 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
- -- Switch generation done by backend (LLVM/C)
- | 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 vanillaExpr ids) <- blockSplit block
- = do
- let plan = createSwitchPlan ids
- -- See Note [Floating switch expressions]
- (assignSimple, simpleExpr) <- floatSwitchExpr dflags vanillaExpr
-
- (newTail, newBlocks) <- implementSwitchPlan dflags scope simpleExpr plan
-
- let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail
-
- return $ block' : newBlocks
-
- | otherwise
- = return [block]
-
--- Note [Floating switch expressions]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
--- When we translate a sparse switch into a search tree we would like
--- to compute the value we compare against only once.
-
--- For this purpose we assign the switch expression to a local register
--- and then use this register when constructing the actual binary tree.
-
--- This is important as the expression could contain expensive code like
--- memory loads or divisions which we REALLY don't want to duplicate.
-
--- This happened in parts of the handwritten RTS Cmm code. See also #16933
-
--- See Note [Floating switch expressions]
-floatSwitchExpr :: DynFlags -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)
-floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg)
-floatSwitchExpr dflags expr = do
- (assign, expr') <- cmmMkAssign dflags expr <$> getUniqueM
- return (BMiddle assign, expr')
-
-
--- 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 Nothing
- 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 Nothing
- 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)