1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
module Dataflow {-(fixedpoint, cmmLivenessComment, cmmLiveness, CmmLive)-} where
import Cmm
import PprCmm ()
import UniqSet
import UniqFM
import FastString
import Outputable
import Maybes
import Data.List
import Data.Maybe
cmmBranchSources :: [(BlockId, [BlockId])] -> [(BlockId, [BlockId])]
cmmBranchSources input =
[(target, [s | (s, ts) <- input, target `elem` ts])
| target <- targets] where
targets = nub [t | (s, ts) <- input, t <- ts]
cmmBranchTargets :: CmmBasicBlock -> UniqSet BlockId
cmmBranchTargets (BasicBlock _ stmts) =
mkUniqSet $ concatMap target stmts where
target (CmmBranch ident) = [ident]
target (CmmCondBranch _ ident) = [ident]
target (CmmSwitch _ blocks) = mapMaybe id blocks
target _ = []
--------------------------------------------------------------------------------
-- This should really be a state monad, but that is not in the core libraries
-- so we'll hack around it here.
-- The monad we're using is: type State a = s -> s
-- The variables that were made live and killed respectively
type CmmLive = UniqSet LocalReg
type BlockEntryLiveness = BlockEnv CmmLive -- The variables live on entry to each block
addLive new_live live = live `unionUniqSets` new_live
addKilled new_killed live = live `minusUniqSet` new_killed
-- Calculate the live and killed registers for a local block
cmmBlockLive :: UniqFM {-BlockId-} CmmLive -> CmmBasicBlock -> CmmLive
cmmBlockLive other_live (BasicBlock _ stmts) =
foldr ((.) . (cmmStmtLive other_live)) id stmts emptyUniqSet
-- Helper for cmmLocalLiveness
cmmStmtLive :: UniqFM {-BlockId-} CmmLive -> CmmStmt -> (CmmLive -> CmmLive)
cmmStmtLive _ (CmmNop) = id
cmmStmtLive _ (CmmComment _) = id
cmmStmtLive _ (CmmAssign reg expr) =
cmmExprLive expr . reg_liveness where
reg_liveness =
case reg of
(CmmLocal reg') -> addKilled $ unitUniqSet reg'
(CmmGlobal _) -> id
cmmStmtLive _ (CmmStore expr1 expr2) =
cmmExprLive expr2 . cmmExprLive expr1
cmmStmtLive _ (CmmCall target results arguments _) =
target_liveness .
foldr ((.) . cmmExprLive) id (map fst arguments) .
addKilled (mkUniqSet $ only_local_regs results) where
only_local_regs [] = []
only_local_regs ((CmmGlobal _,_):args) = only_local_regs args
only_local_regs ((CmmLocal r,_):args) = r:only_local_regs args
target_liveness =
case target of
(CmmForeignCall target _) -> cmmExprLive target
(CmmPrim _) -> id
cmmStmtLive other_live (CmmBranch target) = addLive (lookupWithDefaultUFM other_live emptyUniqSet target)
cmmStmtLive other_live (CmmCondBranch expr target) = cmmExprLive expr . addLive (lookupWithDefaultUFM other_live emptyUniqSet target)
cmmStmtLive other_live (CmmSwitch expr targets) =
cmmExprLive expr .
(foldr ((.) . (addLive . lookupWithDefaultUFM other_live emptyUniqSet)) id (mapCatMaybes id targets))
cmmStmtLive _ (CmmJump expr params) =
const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet)
cmmStmtLive _ (CmmReturn params) =
const (foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet)
--------
-- Helper for cmmLocalLiveness
cmmExprLive :: CmmExpr -> (CmmLive -> CmmLive)
cmmExprLive expr = addLive (mkUniqSet $ expr_liveness expr) where
expr_liveness (CmmLit _) = []
expr_liveness (CmmLoad expr _) = expr_liveness expr
expr_liveness (CmmReg reg) = reg_liveness reg
expr_liveness (CmmMachOp _ exprs) = concatMap expr_liveness exprs
expr_liveness (CmmRegOff reg _) = reg_liveness reg
reg_liveness (CmmLocal reg) = [reg]
reg_liveness (CmmGlobal _) = []
cmmBlockUpdate ::
UniqFM {-BlockId-} CmmBasicBlock
-> BlockId
-> Maybe BlockId
-> UniqFM {-BlockId-} CmmLive
-> Maybe (UniqFM {-BlockId-} CmmLive)
cmmBlockUpdate blocks node _ state =
let old_live = lookupWithDefaultUFM state (panic "unknown block id during liveness analysis") node
block = lookupWithDefaultUFM blocks (panic "unknown block id during liveness analysis") node
new_live = cmmBlockLive state block
in if (sizeUniqSet old_live) == (sizeUniqSet new_live)
then Nothing
else Just $ addToUFM state node new_live
cmmBlockDependants :: UniqFM {-BlockId-} (UniqSet BlockId) -> BlockId -> [BlockId]
cmmBlockDependants sources ident =
uniqSetToList $ lookupWithDefaultUFM sources emptyUniqSet ident
cmmBlockSourcesAndTargets ::
[CmmBasicBlock]
-> (UniqFM {-BlockId-} (UniqSet BlockId), UniqFM (UniqSet BlockId))
cmmBlockSourcesAndTargets blocks = foldr aux (emptyUFM, emptyUFM) blocks where
aux block (sourcesUFM, targetsUFM) =
(foldUniqSet add_source_edges sourcesUFM targets,
addToUFM_Acc unionUniqSets id targetsUFM ident targets) where
add_source_edges t ufm =
addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm t ident
targets = cmmBranchTargets block
ident = blockId block
cmmBlockNames :: [CmmBasicBlock] -> UniqFM {-BlockId-} CmmBasicBlock
cmmBlockNames blocks = listToUFM $ map block_name blocks where
block_name b = (blockId b, b)
cmmLiveness :: [CmmBasicBlock] -> BlockEnv CmmLive
cmmLiveness blocks =
fixedpoint (cmmBlockDependants sources) (cmmBlockUpdate blocks')
(map blockId blocks) (listToUFM [(blockId b, emptyUniqSet) | b <- blocks]) where
(sources, targets) = cmmBlockSourcesAndTargets blocks
blocks' = cmmBlockNames blocks
cmmLivenessComment ::
UniqFM {-BlockId-} (UniqSet LocalReg)
-> CmmBasicBlock -> CmmBasicBlock
cmmLivenessComment live (BasicBlock ident stmts) =
BasicBlock ident stmts' where
stmts' = (CmmComment $ mkFastString $ showSDoc $ ppr $ live'):stmts
live' = map CmmLocal $ uniqSetToList $ lookupWithDefaultUFM live emptyUniqSet ident
--------------------------------------------------------------------------------
-- Solve a fixed-point of a dataflow problem.
-- O(N+H*E) calls to update where
-- N = number of nodes,
-- E = number of edges,
-- H = maximum height of the lattice for any particular node.
-- dependants: map from nodes to those who's value depend on the argument node
-- update:
-- Given the node which needs to be updated, and
-- which node caused that node to need to be updated,
-- update the state.
-- (The causing node will be 'Nothing' if this is the initial update.)
-- Must return 'Nothing' if no change,
-- otherwise returrn 'Just' of the new state
-- nodes: a set of nodes that initially need updating
-- state: some sort of state (usually a map)
-- containing the initial value for each node
--
-- Sketch for proof of complexity:
-- Note that the state is threaded through the entire execution.
-- Also note that the height of the latice at any particular node
-- is the number of times 'update' can return non-Nothing for a particular node.
-- Every call (except for the top level one) must be caused by a non-Nothing
-- result and each non-Nothing result causes as many calls as it has
-- out-going edges. Thus any particular node, n, may cause in total
-- at most H*out(n) further calls. When summed over all nodes,
-- that is H*E. The N term of the complexity is from the initial call
-- when 'update' will be passed 'Nothing'.
fixedpoint ::
(node -> [node])
-> (node -> Maybe node -> s -> Maybe s)
-> [node] -> s -> s
fixedpoint dependants update nodes state =
foldr (fixedpoint' Nothing) state nodes where
fixedpoint' cause node state =
case update node cause state of
Nothing -> state
Just state' ->
foldr (fixedpoint' (Just node)) state' (dependants node)
|
