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