49ea6dd461c30bcff717bd99e0c20aef83337722
[ghc.git] / compiler / cmm / Cmm.hs
1 -- Cmm representations using Hoopl's Graph CmmNode e x.
2 {-# LANGUAGE GADTs #-}
3 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
4
5 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
6 #if __GLASGOW_HASKELL__ >= 703
7 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
8 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
9 #endif
10
11 module Cmm
12 ( CmmGraph, GenCmmGraph(..), CmmBlock
13 , CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop
14 , CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
15
16 , modifyGraph
17 , lastNode, replaceLastNode, insertBetween
18 , ofBlockMap, toBlockMap, insertBlock
19 , ofBlockList, toBlockList, bodyToBlockList
20 , foldGraphBlocks, mapGraphNodes, postorderDfs
21
22 , analFwd, analBwd, analRewFwd, analRewBwd
23 , dataflowPassFwd, dataflowPassBwd
24 , module CmmNode
25 )
26 where
27
28 import BlockId
29 import CmmDecl
30 import CmmNode
31 import OptimizationFuel as F
32 import SMRep
33 import UniqSupply
34
35 import Compiler.Hoopl
36 import Control.Monad
37 import Data.Maybe
38 import Panic
39
40 #include "HsVersions.h"
41
42 -------------------------------------------------
43 -- CmmBlock, CmmGraph and Cmm
44
45 type CmmGraph = GenCmmGraph CmmNode
46 data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
47 type CmmBlock = Block CmmNode C C
48
49 type CmmReplGraph e x = GenCmmReplGraph CmmNode e x
50 type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
51 type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
52 type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
53
54 data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff}
55 data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo}
56 type Cmm = GenCmm CmmStatics CmmTopInfo CmmGraph
57 type CmmTop = GenCmmTop CmmStatics CmmTopInfo CmmGraph
58
59 -------------------------------------------------
60 -- Manipulating CmmGraphs
61
62 modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
63 modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
64
65 toBlockMap :: CmmGraph -> LabelMap CmmBlock
66 toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
67
68 ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
69 ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
70
71 insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
72 insertBlock block map =
73 ASSERT (isNothing $ mapLookup id map)
74 mapInsert id block map
75 where id = entryLabel block
76
77 toBlockList :: CmmGraph -> [CmmBlock]
78 toBlockList g = mapElems $ toBlockMap g
79
80 ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
81 ofBlockList entry blocks = CmmGraph {g_entry=entry, g_graph=GMany NothingO body NothingO}
82 where body = foldr addBlock emptyBody blocks
83
84 bodyToBlockList :: Body CmmNode -> [CmmBlock]
85 bodyToBlockList body = mapElems body
86
87 mapGraphNodes :: ( CmmNode C O -> CmmNode C O
88 , CmmNode O O -> CmmNode O O
89 , CmmNode O C -> CmmNode O C)
90 -> CmmGraph -> CmmGraph
91 mapGraphNodes funs@(mf,_,_) g =
92 ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (blockMapNodes3 funs) $ toBlockMap g
93
94 foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
95 foldGraphBlocks k z g = mapFold k z $ toBlockMap g
96
97 postorderDfs :: CmmGraph -> [CmmBlock]
98 postorderDfs g = postorder_dfs_from (toBlockMap g) (g_entry g)
99
100 -------------------------------------------------
101 -- Manipulating CmmBlocks
102
103 lastNode :: CmmBlock -> CmmNode O C
104 lastNode block = foldBlockNodesF3 (nothing, nothing, const) block ()
105 where nothing :: a -> b -> ()
106 nothing _ _ = ()
107
108 replaceLastNode :: Block CmmNode e C -> CmmNode O C -> Block CmmNode e C
109 replaceLastNode block last = blockOfNodeList (first, middle, JustC last)
110 where (first, middle, _) = blockToNodeList block
111
112 ----------------------------------------------------------------------
113 ----- Splicing between blocks
114 -- Given a middle node, a block, and a successor BlockId,
115 -- we can insert the middle node between the block and the successor.
116 -- We return the updated block and a list of new blocks that must be added
117 -- to the graph.
118 -- The semantics is a bit tricky. We consider cases on the last node:
119 -- o For a branch, we can just insert before the branch,
120 -- but sometimes the optimizer does better if we actually insert
121 -- a fresh basic block, enabling some common blockification.
122 -- o For a conditional branch, switch statement, or call, we must insert
123 -- a new basic block.
124 -- o For a jump or return, this operation is impossible.
125
126 insertBetween :: MonadUnique m => CmmBlock -> [CmmNode O O] -> BlockId -> m (CmmBlock, [CmmBlock])
127 insertBetween b ms succId = insert $ lastNode b
128 where insert :: MonadUnique m => CmmNode O C -> m (CmmBlock, [CmmBlock])
129 insert (CmmBranch bid) =
130 if bid == succId then
131 do (bid', bs) <- newBlocks
132 return (replaceLastNode b (CmmBranch bid'), bs)
133 else panic "tried invalid block insertBetween"
134 insert (CmmCondBranch c t f) =
135 do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
136 (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
137 return (replaceLastNode b (CmmCondBranch c t' f'), tbs ++ fbs)
138 insert (CmmSwitch e ks) =
139 do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
140 return (replaceLastNode b (CmmSwitch e ids), join bs)
141 insert (CmmCall {}) =
142 panic "unimp: insertBetween after a call -- probably not a good idea"
143 insert (CmmForeignCall {}) =
144 panic "unimp: insertBetween after a foreign call -- probably not a good idea"
145
146 newBlocks :: MonadUnique m => m (BlockId, [CmmBlock])
147 newBlocks = do id <- liftM mkBlockId $ getUniqueM
148 return $ (id, [blockOfNodeList (JustC (CmmEntry id), ms, JustC (CmmBranch succId))])
149 mbNewBlocks :: MonadUnique m => Maybe BlockId -> m (Maybe BlockId, [CmmBlock])
150 mbNewBlocks (Just k) = if k == succId then liftM fstJust newBlocks
151 else return (Just k, [])
152 mbNewBlocks Nothing = return (Nothing, [])
153 fstJust (id, bs) = (Just id, bs)
154
155 -------------------------------------------------
156 -- Running dataflow analysis and/or rewrites
157
158 -- Constructing forward and backward analysis-only pass
159 analFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdPass m n f
160 analBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n f
161
162 analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
163 analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
164
165 -- Constructing forward and backward analysis + rewrite pass
166 analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdRewrite m n f -> FwdPass m n f
167 analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n f
168
169 analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
170 analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}
171
172 -- Running forward and backward dataflow analysis + optional rewrite
173 dataflowPassFwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
174 dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
175 (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
176 return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
177
178 dataflowPassBwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
179 dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
180 (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
181 return (CmmGraph {g_entry=entry, g_graph=graph}, facts)