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