Remove old, redundant note
[ghc-hetmet.git] / compiler / cmm / CmmLive.hs
1 module CmmLive (
2         CmmLive,
3         BlockEntryLiveness,
4         cmmLiveness,
5         cmmFormalsToLiveLocals,
6   ) where
7
8 #include "HsVersions.h"
9
10 import BlockId
11 import Cmm
12 import Dataflow
13
14 import Maybes
15 import Panic
16 import UniqSet
17
18 -----------------------------------------------------------------------------
19 -- Calculating what variables are live on entry to a basic block
20 -----------------------------------------------------------------------------
21
22 -- | The variables live on entry to a block
23 type CmmLive = UniqSet LocalReg
24
25 -- | A mapping from block labels to the variables live on entry
26 type BlockEntryLiveness = BlockEnv CmmLive
27
28 -- | A mapping from block labels to the blocks that target it
29 type BlockSources = BlockEnv (UniqSet BlockId)
30
31 -- | A mapping from block labels to the statements in the block
32 type BlockStmts = BlockEnv [CmmStmt]
33
34 -----------------------------------------------------------------------------
35 -- | Calculated liveness info for a list of 'CmmBasicBlock'
36 -----------------------------------------------------------------------------
37 cmmLiveness :: [CmmBasicBlock] -> BlockEntryLiveness
38 cmmLiveness blocks =
39     fixedpoint (cmmBlockDependants sources)
40                (cmmBlockUpdate blocks')
41                (map blockId blocks)
42                (mkBlockEnv [(blockId b, emptyUniqSet) | b <- blocks])
43     where
44       sources :: BlockSources
45       sources = cmmBlockSources blocks
46
47       blocks' :: BlockStmts
48       blocks' = mkBlockEnv $ map block_name blocks
49
50       block_name :: CmmBasicBlock -> (BlockId, [CmmStmt])
51       block_name b = (blockId b, blockStmts b)
52
53 {-
54 -- For debugging, annotate each block with a comment indicating
55 -- the calculated live variables
56 cmmLivenessComment ::
57     BlockEnv (UniqSet LocalReg) -> CmmBasicBlock -> CmmBasicBlock
58 cmmLivenessComment live (BasicBlock ident stmts) =
59     BasicBlock ident stmts' where
60         stmts' = (CmmComment $ mkFastString $ showSDoc $ ppr $ live'):stmts
61         live' = map CmmLocal $ uniqSetToList $ lookupWithDefaultUFM live emptyUniqSet ident
62 -}
63
64
65 -----------------------------------------------------------------------------
66 -- | Calculates a table of where one can lookup the blocks that might
67 -- need updating after a given block is updated in the liveness analysis
68 -----------------------------------------------------------------------------
69 cmmBlockSources :: [CmmBasicBlock] -> BlockSources
70 cmmBlockSources blocks = foldr aux emptyBlockEnv blocks
71     where
72       aux :: CmmBasicBlock
73           -> BlockSources
74           -> BlockSources
75       aux block sourcesUFM =
76           foldUniqSet (add_source_edges $ blockId block)
77                       sourcesUFM
78                       (branch_targets $ blockStmts block)
79
80       add_source_edges :: BlockId -> BlockId
81                        -> BlockSources
82                        -> BlockSources
83       add_source_edges source target ufm =
84           addToBEnv_Acc (flip addOneToUniqSet) unitUniqSet ufm target source
85
86       branch_targets :: [CmmStmt] -> UniqSet BlockId
87       branch_targets stmts =
88           mkUniqSet $ concatMap target stmts where
89               target (CmmBranch ident) = [ident]
90               target (CmmCondBranch _ ident) = [ident]
91               target (CmmSwitch _ blocks) = mapMaybe id blocks
92               target _ = []
93
94 -----------------------------------------------------------------------------
95 -- | Given the table calculated by 'cmmBlockSources', list all blocks
96 -- that depend on the result of a particular block.
97 --
98 -- Used by the call to 'fixedpoint'.
99 -----------------------------------------------------------------------------
100 cmmBlockDependants :: BlockSources -> BlockId -> [BlockId]
101 cmmBlockDependants sources ident =
102     uniqSetToList $ lookupWithDefaultBEnv sources emptyUniqSet ident
103
104 -----------------------------------------------------------------------------
105 -- | Given the table of type 'BlockStmts' and a block that was updated,
106 -- calculate an updated BlockEntryLiveness
107 -----------------------------------------------------------------------------
108 cmmBlockUpdate ::
109     BlockStmts
110     -> BlockId
111     -> Maybe BlockId
112     -> BlockEntryLiveness
113     -> Maybe BlockEntryLiveness
114 cmmBlockUpdate blocks node _ state =
115     if (sizeUniqSet old_live) == (sizeUniqSet new_live)
116       then Nothing
117       else Just $ extendBlockEnv state node new_live
118     where
119       new_live, old_live :: CmmLive
120       new_live = cmmStmtListLive state block_stmts
121       old_live = lookupWithDefaultBEnv state missing_live node
122
123       block_stmts :: [CmmStmt]
124       block_stmts = lookupWithDefaultBEnv blocks missing_block node
125
126       missing_live = panic "unknown block id during liveness analysis"
127       missing_block = panic "unknown block id during liveness analysis"
128
129 -----------------------------------------------------------------------------
130 -- Section: 
131 -----------------------------------------------------------------------------
132 -----------------------------------------------------------------------------
133 -- CmmBlockLive, cmmStmtListLive and helpers
134 -----------------------------------------------------------------------------
135
136 -- Calculate the live registers for a local block (list of statements)
137
138 cmmStmtListLive :: BlockEntryLiveness -> [CmmStmt] -> CmmLive
139 cmmStmtListLive other_live stmts =
140     foldr ((.) . (cmmStmtLive other_live)) id stmts emptyUniqSet
141
142 -----------------------------------------------------------------------------
143 -- This code is written in the style of a state monad,
144 -- but since Control.Monad.State is not in the core
145 -- we can't use it in GHC, so we'll fake one here.
146 -- We don't need a return value so well leave it out.
147 -- Thus 'bind' reduces to function composition.
148
149 type CmmLivenessTransformer = CmmLive -> CmmLive
150
151 -- Helpers for the "Monad"
152 addLive, addKilled :: CmmLive -> CmmLivenessTransformer
153 addLive new_live live = live `unionUniqSets` new_live
154 addKilled new_killed live = live `minusUniqSet` new_killed
155
156 --------------------------------
157 -- Liveness of a CmmStmt
158 --------------------------------
159 cmmFormalsToLiveLocals :: HintedCmmFormals -> [LocalReg]
160 cmmFormalsToLiveLocals formals = map hintlessCmm formals
161
162 cmmStmtLive :: BlockEntryLiveness -> CmmStmt -> CmmLivenessTransformer
163 cmmStmtLive _ (CmmNop) = id
164 cmmStmtLive _ (CmmComment _) = id
165 cmmStmtLive _ (CmmAssign reg expr) =
166     cmmExprLive expr . reg_liveness where
167         reg_liveness =
168             case reg of
169               (CmmLocal reg') -> addKilled $ unitUniqSet reg'
170               (CmmGlobal _) -> id
171 cmmStmtLive _ (CmmStore expr1 expr2) =
172     cmmExprLive expr2 . cmmExprLive expr1
173 cmmStmtLive _ (CmmCall target results arguments _ _) =
174     target_liveness .
175     foldr ((.) . cmmExprLive) id (map hintlessCmm arguments) .
176     addKilled (mkUniqSet $ cmmFormalsToLiveLocals results) where
177         target_liveness =
178             case target of
179               (CmmCallee target _) -> cmmExprLive target
180               (CmmPrim _) -> id
181 cmmStmtLive other_live (CmmBranch target) =
182     addLive (lookupWithDefaultBEnv other_live emptyUniqSet target)
183 cmmStmtLive other_live (CmmCondBranch expr target) =
184     cmmExprLive expr .
185     addLive (lookupWithDefaultBEnv other_live emptyUniqSet target)
186 cmmStmtLive other_live (CmmSwitch expr targets) =
187     cmmExprLive expr .
188     (foldr ((.) . (addLive .
189                    lookupWithDefaultBEnv other_live emptyUniqSet))
190            id
191            (mapCatMaybes id targets))
192 cmmStmtLive _ (CmmJump expr params) =
193     const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet)
194 cmmStmtLive _ (CmmReturn params) =
195     const (foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet)
196
197 --------------------------------
198 -- Liveness of a CmmExpr
199 --------------------------------
200 cmmExprLive :: CmmExpr -> CmmLivenessTransformer
201 cmmExprLive expr = addLive (mkUniqSet $ expr_liveness expr) where
202     expr_liveness :: CmmExpr -> [LocalReg]
203     expr_liveness (CmmLit _) = []
204     expr_liveness (CmmLoad expr _) = expr_liveness expr
205     expr_liveness (CmmReg reg) = reg_liveness reg
206     expr_liveness (CmmMachOp _ exprs) = concatMap expr_liveness exprs
207     expr_liveness (CmmRegOff reg _) = reg_liveness reg
208     expr_liveness (CmmStackSlot _ _) = panic "cmmExprLive CmmStackSlot"
209
210     reg_liveness :: CmmReg -> [LocalReg]
211     reg_liveness (CmmLocal reg) = [reg]
212     reg_liveness (CmmGlobal _) = []