Remove warning flags from individual compiler modules
[ghc.git] / compiler / cmm / CmmContFlowOpt.hs
1
2 module CmmContFlowOpt
3 ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
4 , branchChainElimZ, removeUnreachableBlocksZ
5 )
6 where
7
8 import Cmm
9 import CmmTx
10 import qualified ZipCfg as G
11 import ZipCfgCmmRep
12 import Maybes
13 import Util
14 import UniqFM
15
16 ------------------------------------
17 mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s)
18 mapProcs f (Cmm tops) = fmap Cmm (mapTx f tops)
19
20
21 ------------------------------------
22 cmmCfgOpts :: Tx (ListGraph CmmStmt)
23 cmmCfgOptsZ :: Tx CmmGraph
24
25 cmmCfgOpts = branchChainElim -- boring, but will get more exciting later
26 cmmCfgOptsZ = branchChainElimZ `seqTx` removeUnreachableBlocksZ
27 -- Here branchChainElim can ultimately be replaced
28 -- with a more exciting combination of optimisations
29
30 runCmmOpts :: Tx g -> Tx (GenCmm d h g)
31 runCmmOpts opt = mapProcs (optGraph opt)
32
33 optGraph :: Tx g -> Tx (GenCmmTop d h g)
34 optGraph _ top@(CmmData {}) = noTx top
35 optGraph opt (CmmProc info lbl formals g) = fmap (CmmProc info lbl formals) (opt g)
36
37 ----------------------------------------------------------------
38 branchChainElim :: Tx (ListGraph CmmStmt)
39 -- Remove any basic block of the form L: goto L',
40 -- and replace L with L' everywhere else
41 branchChainElim (ListGraph blocks)
42 | null lone_branch_blocks -- No blocks to remove
43 = noTx (ListGraph blocks)
44 | otherwise
45 = aTx (ListGraph new_blocks)
46 where
47 (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
48 new_blocks = map (replaceLabels env) others
49 env = mkClosureBlockEnv lone_branch_blocks
50
51 isLoneBranch :: CmmBasicBlock -> Either (BlockId, BlockId) CmmBasicBlock
52 isLoneBranch (BasicBlock id [CmmBranch target]) | id /= target = Left (id, target)
53 isLoneBranch other_block = Right other_block
54 -- ^ An infinite loop is not a link in a branch chain!
55
56 replaceLabels :: BlockEnv BlockId -> CmmBasicBlock -> CmmBasicBlock
57 replaceLabels env (BasicBlock id stmts)
58 = BasicBlock id (map replace stmts)
59 where
60 replace (CmmBranch id) = CmmBranch (lookup id)
61 replace (CmmCondBranch e id) = CmmCondBranch e (lookup id)
62 replace (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
63 replace other_stmt = other_stmt
64
65 lookup id = lookupBlockEnv env id `orElse` id
66 ----------------------------------------------------------------
67 branchChainElimZ :: Tx CmmGraph
68 -- Remove any basic block of the form L: goto L',
69 -- and replace L with L' everywhere else
70 branchChainElimZ g@(G.LGraph eid _)
71 | null lone_branch_blocks -- No blocks to remove
72 = noTx g
73 | otherwise
74 = aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others)
75 where
76 (lone_branch_blocks, others) = partitionWith isLoneBranchZ (G.to_block_list g)
77 env = mkClosureBlockEnv lone_branch_blocks
78 self_branches =
79 let loop_to (id, _) =
80 if lookup id == id then
81 Just (G.Block id (G.ZLast (G.mkBranchNode id)))
82 else
83 Nothing
84 in mapMaybe loop_to lone_branch_blocks
85 lookup id = G.lookupBlockEnv env id `orElse` id
86
87 isLoneBranchZ :: CmmBlock -> Either (G.BlockId, G.BlockId) CmmBlock
88 isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target []))))
89 | id /= target = Left (id,target)
90 isLoneBranchZ other = Right other
91 -- ^ An infinite loop is not a link in a branch chain!
92
93 replaceLabelsZ :: BlockEnv G.BlockId -> CmmGraph -> CmmGraph
94 replaceLabelsZ env = replace_eid . G.map_nodes id id last
95 where
96 replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
97 last (LastBranch id args) = LastBranch (lookup id) args
98 last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi)
99 last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl)
100 last (LastCall tgt (Just id)) = LastCall tgt (Just $ lookup id)
101 last exit_jump_return = exit_jump_return
102 lookup id = G.lookupBlockEnv env id `orElse` id
103 ----------------------------------------------------------------
104 mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
105 mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks
106 where singleEnv = mkBlockEnv blocks
107 follow (id, next) = (id, endChain id next)
108 endChain orig id = case lookupBlockEnv singleEnv id of
109 Just id' | id /= orig -> endChain orig id'
110 _ -> id
111 ----------------------------------------------------------------
112 removeUnreachableBlocksZ :: Tx CmmGraph
113 removeUnreachableBlocksZ g@(G.LGraph id blocks) =
114 if length blocks' < sizeUFM blocks then aTx $ G.of_block_list id blocks'
115 else noTx g
116 where blocks' = G.postorder_dfs g