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