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