1 {-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
2 -- Norman likes local bindings
3 -- If this module lives on I'd like to get rid of this flag in due course
7 , dualLiveLattice, dualLiveTransfers, dualLiveness
8 --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
9 , dualLivenessWithInsertion
14 , removeDeadAssignmentsAndReloads
22 import OptimizationFuel
25 import Outputable hiding (empty)
26 import qualified Outputable as PP
31 import Prelude hiding (succ, zip)
33 {- Note [Overview of spill/reload]
34 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
35 The point of this module is to insert spills and reloads to
36 establish the invariant that at a call (or at any proc point with
37 an established protocol) all live variables not expected in
38 registers are sitting on the stack. We use a backward analysis to
39 insert spills and reloads. It should be followed by a
40 forward transformation to sink reloads as deeply as possible, so as
41 to reduce register pressure.
43 A variable can be expected to be live in a register, live on the
44 stack, or both. This analysis ensures that spills and reloads are
45 inserted as needed to make sure that every live variable needed
46 after a call is available on the stack. Spills are pushed back to
47 their reaching definitions, but reloads are dropped wherever needed
48 and will have to be sunk by a later forward transformation.
51 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
53 dualUnion :: DualLive -> DualLive -> DualLive
54 dualUnion (DualLive s r) (DualLive s' r') =
55 DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
57 dualUnionList :: [DualLive] -> DualLive
58 dualUnionList ls = DualLive ss rs
59 where ss = unionManyUniqSets $ map on_stack ls
60 rs = unionManyUniqSets $ map in_regs ls
62 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
63 changeStack f live = live { on_stack = f (on_stack live) }
64 changeRegs f live = live { in_regs = f (in_regs live) }
67 dualLiveLattice :: DataflowLattice DualLive
68 dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
69 where empty = DualLive emptyRegSet emptyRegSet
70 add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
71 where (change1, stack) = add1 (on_stack old) (on_stack new)
72 (change2, regs) = add1 (in_regs old) (in_regs new)
73 add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
74 where join = unionUniqSets old new
76 dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
77 dualLivenessWithInsertion procPoints g =
78 liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
79 (dualLiveTransfers (g_entry g) procPoints)
80 (insertSpillAndReloadRewrites g procPoints)
82 dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
83 dualLiveness procPoints g =
84 liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
86 dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
87 dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
88 where first :: CmmNode C O -> DualLive -> DualLive
89 first (CmmEntry id) live = check live id $ -- live at procPoint => spill
90 if id /= entry && setMember id procPoints
91 then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
92 , in_regs = emptyRegSet }
94 where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
96 middle :: CmmNode O O -> DualLive -> DualLive
97 middle m live = changeStack updSlots $ changeRegs (xferLiveMiddle m) (changeRegs regs_in live)
98 where xferLiveMiddle = case getBTransfer3 xferLive of (_, middle, _) -> middle
99 regs_in :: RegSet -> RegSet
100 regs_in live = case m of CmmUnsafeForeignCall {} -> emptyRegSet
102 updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
103 spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
105 reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
107 check (RegSlot (LocalReg _ ty), o, w) x
108 | o == w && w == widthInBytes (typeWidth ty) = x
109 check _ _ = panic "middleDualLiveness unsupported: slices"
110 last :: CmmNode O C -> FactBase DualLive -> DualLive
111 last l fb = case l of
112 CmmBranch id -> lkp id
113 l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
114 l@(CmmCall {cml_cont=Just k}) -> call l k
115 l@(CmmForeignCall {succ=k}) -> call l k
116 l@(CmmCondBranch _ t f) -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
117 l@(CmmSwitch _ tbl) -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
118 where empty = fact_bot dualLiveLattice
119 lkp id = empty `fromMaybe` lookupFact id fb
120 call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
122 gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
123 gen a live = foldRegsUsed extendRegSet live a
124 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
125 kill a live = foldRegsDefd deleteFromRegSet live a
127 insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
128 insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
129 -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
130 -- but GHC miscompiles it, see bug #4044.
131 where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
132 first e@(CmmEntry id) live = return $
133 if id /= (g_entry graph) && setMember id procPoints then
134 case map reload (uniqSetToList spill_regs) of
136 is -> Just $ mkFirst e <*> mkMiddles is
139 -- If we are splitting procedures, we need the LastForeignCall
140 -- to spill its results to the stack because they will only
141 -- be used by a separate procedure (so they can't stay in LocalRegs).
143 spill_regs = if splitting then in_regs live
144 else in_regs live `minusRegSet` defs
145 defs = case mapLookup id firstDefs of
147 Nothing -> emptyRegSet
148 -- A LastForeignCall may contain some definitions, which take place
149 -- on return from the function call. Therefore, we build a map (firstDefs)
150 -- from BlockId to the set of variables defined on return to the BlockId.
151 firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
152 addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
153 addLive b env = case lastNode b of
154 CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
156 add bid defs env = mapInsert bid defs'' env
157 where defs'' = case mapLookup bid env of
158 Just defs' -> timesRegSet defs defs'
161 middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
162 middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
163 middle m@(CmmAssign (CmmLocal reg) _) live = return $
164 if reg `elemRegSet` on_stack live then -- must spill
165 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
166 text "after"{-, ppr m-}]) $
167 Just $ mkMiddles $ [m, spill reg]
169 middle m@(CmmUnsafeForeignCall _ fs _) live = return $
170 case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
171 map reload (uniqSetToList (kill fs (in_regs live))) of
173 reloads -> Just $ mkMiddles (m : reloads)
174 middle _ _ = return Nothing
176 nothing _ _ = return Nothing
178 regSlot :: LocalReg -> CmmExpr
179 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
181 spill, reload :: LocalReg -> CmmNode O O
182 spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
183 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
185 ----------------------------------------------------------------
188 -- The idea is to compute at each point the set of registers such that
189 -- on every path to the point, the register is defined by a Reload
190 -- instruction. Then, if a use appears at such a point, we can safely
191 -- insert a Reload right before the use. Finally, we can eliminate
192 -- the early reloads along with other dead assignments.
194 data AvailRegs = UniverseMinus RegSet
198 availRegsLattice :: DataflowLattice AvailRegs
199 availRegsLattice = DataflowLattice "register gotten from reloads" empty add
200 where empty = UniverseMinus emptyRegSet
201 -- | compute in the Tx monad to track whether anything has changed
202 add _ (OldFact old) (NewFact new) =
203 if join `smallerAvail` old then (SomeChange, join) else (NoChange, old)
204 where join = interAvail new old
207 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
208 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
209 interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
210 interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
211 interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
213 smallerAvail :: AvailRegs -> AvailRegs -> Bool
214 smallerAvail (AvailRegs _) (UniverseMinus _) = True
215 smallerAvail (UniverseMinus _) (AvailRegs _) = False
216 smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
217 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
219 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
220 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
221 extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
223 delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
224 delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
225 delFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
227 elemAvail :: AvailRegs -> LocalReg -> Bool
228 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
229 elemAvail (AvailRegs s) r = elemRegSet r s
231 cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs)
232 cmmAvailableReloads g =
233 liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
234 analFwd availRegsLattice availReloadsTransfer
236 availReloadsTransfer :: FwdTransfer CmmNode AvailRegs
237 availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail)
239 middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs
240 middleAvail (CmmAssign (CmmLocal r) (CmmLoad l _)) avail
241 | l `isStackSlotOf` r = extendAvail avail r
242 middleAvail (CmmAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
243 middleAvail (CmmStore l (CmmReg (CmmLocal r))) avail
244 | l `isStackSlotOf` r = avail
245 middleAvail (CmmStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
246 middleAvail (CmmStore {}) avail = avail
247 middleAvail (CmmUnsafeForeignCall {}) _ = AvailRegs emptyRegSet
248 middleAvail (CmmComment {}) avail = avail
250 lastAvail :: CmmNode O C -> AvailRegs -> [(Label, AvailRegs)]
251 lastAvail (CmmCall _ (Just k) _ _ _) _ = [(k, AvailRegs emptyRegSet)]
252 lastAvail (CmmForeignCall {succ=k}) _ = [(k, AvailRegs emptyRegSet)]
253 lastAvail l avail = map (\id -> (id, avail)) $ successors l
255 insertLateReloads :: CmmGraph -> FuelUniqSM CmmGraph
256 insertLateReloads g =
257 liftM fst $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
258 analRewFwd availRegsLattice availReloadsTransfer rewrites
259 where rewrites = mkFRewrite3 first middle last
260 first _ _ = return Nothing
261 middle m avail = return $ maybe_reload_before avail m (mkMiddle m)
262 last l avail = return $ maybe_reload_before avail l (mkLast l)
263 maybe_reload_before avail node tail =
264 let used = filterRegsUsed (elemAvail avail) node
265 in if isEmptyUniqSet used then Nothing
266 else Just $ reloadTail used tail
267 reloadTail regset t = foldl rel t $ uniqSetToList regset
268 where rel t r = mkMiddle (reload r) <*> t
270 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
271 removeDeadAssignmentsAndReloads procPoints g =
272 liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
273 (dualLiveTransfers (g_entry g) procPoints)
275 where rewrites = deepBwdRw3 nothing middle nothing
276 -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
277 -- but GHC panics while compiling, see bug #4045.
278 middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
279 middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
280 middle _ _ = return Nothing
282 nothing _ _ = return Nothing
285 ---------------------
288 ppr_regs :: String -> RegSet -> SDoc
289 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
290 where commafy xs = hsep $ punctuate comma xs
292 instance Outputable DualLive where
293 ppr (DualLive {in_regs = regs, on_stack = stack}) =
294 if isEmptyUniqSet regs && isEmptyUniqSet stack then
295 text "<nothing-live>"
297 nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
298 else (ppr_regs "live in regs =" regs),
299 if isEmptyUniqSet stack then PP.empty
300 else (ppr_regs "live on stack =" stack)]
302 instance Outputable AvailRegs where
303 ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
304 else ppr_regs "available = all but" s
305 ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
306 else ppr_regs "available = " s
308 my_trace :: String -> SDoc -> a -> a
309 my_trace = if False then pprTrace else \_ _ a -> a
311 f4sep :: [SDoc] -> SDoc
313 f4sep (d:ds) = fsep (d : map (nest 4) ds)