5 , dualLiveLattice, dualLiveness
6 , insertSpillsAndReloads --- XXX todo check live-in at entry against formals
7 , dualLivenessWithInsertion
8 , spillAndReloadComments
21 import Outputable hiding (empty)
22 import qualified Outputable as PP
30 -- The point of this module is to insert spills and reloads to
31 -- establish the invariant that at a call (or at any proc point with
32 -- an established protocol) all live variables not expected in
33 -- registers are sitting on the stack. We use a backward analysis to
34 -- insert spills and reloads. It should some day be followed by a
35 -- forward transformation to sink reloads as deeply as possible, so as
36 -- to reduce register pressure.
38 data ExtendWithSpills m
43 type M = ExtendWithSpills Middle
45 -- A variable can be expected to be live in a register, live on the
46 -- stack, or both. This analysis ensures that spills and reloads are
47 -- inserted as needed to make sure that every live variable needed
48 -- after a call is available on the stack. Spills are pushed back to
49 -- their reaching definitions, but reloads are dropped wherever needed
50 -- and will have to be sunk by a later forward transformation.
52 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
54 dualUnion :: DualLive -> DualLive -> DualLive
55 dualUnion (DualLive s r) (DualLive s' r') =
56 DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
58 dualUnionList :: [DualLive] -> DualLive
59 dualUnionList ls = DualLive ss rs
60 where ss = unionManyUniqSets $ map on_stack ls
61 rs = unionManyUniqSets $ map in_regs ls
63 _changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
64 _changeStack f live = live { on_stack = f (on_stack live) }
65 changeRegs f live = live { in_regs = f (in_regs live) }
68 dualLiveLattice :: DataflowLattice DualLive
70 DataflowLattice "variables live in registers and on stack" empty add False
71 where empty = DualLive emptyRegSet emptyRegSet
72 -- | compute in the Tx monad to track whether anything has changed
73 add new old = do stack <- add1 (on_stack new) (on_stack old)
74 regs <- add1 (in_regs new) (in_regs old)
75 return $ DualLive stack regs
76 add1 = fact_add_to liveLattice
78 dualLivenessWithInsertion :: BPass M Last DualLive
79 dualLivenessWithInsertion = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
82 dualLiveness :: BAnalysis M Last DualLive
83 dualLiveness = BComp "dual liveness" exit last middle first
85 last = lastDualLiveness
86 middle = middleDualLiveness
88 empty = fact_bot dualLiveLattice
90 -- ^ could take a proc-point set and choose to spill here,
91 -- but it's probably better to run this pass, choose
92 -- proc-point protocols, insert more CopyIn nodes, and run
95 middleDualLiveness :: DualLive -> M -> DualLive
96 middleDualLiveness live m@(Spill regs) =
97 -- live-in on-stack requirements are satisfied;
98 -- live-out in-regs obligations are created
99 my_trace "before" (f4sep [ppr m, text "liveness is", ppr live']) $
101 where live' = DualLive { on_stack = on_stack live `minusRegSet` regs
102 , in_regs = in_regs live `plusRegSet` regs }
104 middleDualLiveness live m@(Reload regs) =
105 -- live-in in-regs requirements are satisfied;
106 -- live-out on-stack obligations are created
107 my_trace "before" (f4sep [ppr m, text "liveness is", ppr live']) $
109 where live' = DualLive { on_stack = on_stack live `plusRegSet` regs
110 , in_regs = in_regs live `minusRegSet` regs }
112 middleDualLiveness live (NotSpillOrReload m) = changeRegs (middleLiveness m) live
114 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
115 lastDualLiveness env l = last l
116 where last (LastReturn) = empty
117 last (LastJump e) = changeRegs (gen e) empty
118 last (LastBranch id) = env id
119 last (LastCall tgt Nothing) = changeRegs (gen tgt) empty
120 last (LastCall tgt (Just k)) =
121 -- nothing can be live in registers at this point
122 -- only 'formals' can be in regs at this point
124 if isEmptyUniqSet (in_regs live) then
125 DualLive (on_stack live) (gen tgt emptyRegSet)
127 panic "live values in registers at call continuation"
128 last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f)
129 last (LastSwitch e tbl) = changeRegs (gen e) $ dualUnionList $
130 map env (catMaybes tbl)
131 empty = fact_bot dualLiveLattice
133 gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
134 gen a live = foldRegsUsed extendRegSet live a
135 kill a live = foldRegsUsed delOneFromUniqSet live a
137 insertSpillsAndReloads :: BFunctionalTransformation M Last DualLive
138 insertSpillsAndReloads = BComp "CPS spiller" exit last middle first
140 last = \_ _ -> Nothing
141 middle = middleInsertSpillsAndReloads
143 -- ^ could take a proc-point set and choose to spill here,
144 -- but it's probably better to run this pass, choose
145 -- proc-point protocols, insert more CopyIn nodes, and run
149 middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
150 middleInsertSpillsAndReloads _ (Spill _) = Nothing
151 middleInsertSpillsAndReloads _ (Reload _) = Nothing
152 middleInsertSpillsAndReloads live (NotSpillOrReload m) = middle m
153 where middle (MidAssign (CmmLocal reg') _) =
154 if reg' `elemRegSet` on_stack live then -- must spill
155 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg',
156 text "after", ppr m]) $
157 Just $ graphOfMiddles [NotSpillOrReload m, Spill $ mkRegSet [reg']]
160 middle (CopyIn _ formals _) =
161 -- only 'formals' can be in regs at this point
162 let regs' = kill formals (in_regs live) -- live in regs; must reload
163 is_stack_var r = elemRegSet r (on_stack live)
164 needs_spilling = -- a formal that is expected on the stack; must spill
165 foldRegsUsed (\rs r -> if is_stack_var r then extendRegSet rs r
166 else rs) emptyRegSet formals
167 in if isEmptyUniqSet regs' && isEmptyUniqSet needs_spilling then
170 let reload = if isEmptyUniqSet regs' then []
172 spill_reload = if isEmptyUniqSet needs_spilling then reload
173 else Spill needs_spilling : reload
174 middles = NotSpillOrReload m : spill_reload
176 my_trace "At CopyIn" (f4sep [text "Triggered by ", ppr live,
177 ppr (Reload regs' :: M),
178 ppr (Spill needs_spilling :: M),
179 text "after", ppr m]) $
180 Just $ graphOfMiddles middles
183 -- | For conversion back to vanilla C--
184 spillAndReloadComments :: M -> Middle
185 spillAndReloadComments (NotSpillOrReload m) = m
186 spillAndReloadComments (Spill regs) = show_regs "Spill" regs
187 spillAndReloadComments (Reload regs) = show_regs "Reload" regs
189 show_regs :: String -> RegSet -> Middle
190 show_regs s regs = MidComment $ mkFastString $ showSDoc $ ppr_regs s regs
193 ----------------------------------------------------------------
196 -- The idea is to compute at each point the set of registers such that
197 -- on every path to the point, the register is defined by a Reload
198 -- instruction. Then, if a use appears at such a point, we can safely
199 -- insert a Reload right before the use. Finally, we can eliminate
200 -- the early reloads along with other dead assignments.
202 data AvailRegs = UniverseMinus RegSet
206 availRegsLattice :: DataflowLattice AvailRegs
207 availRegsLattice = DataflowLattice "register gotten from reloads" empty add True
208 where empty = UniverseMinus emptyRegSet
209 -- | compute in the Tx monad to track whether anything has changed
211 let join = interAvail new old in
212 if join `smallerAvail` old then aTx join else noTx join
215 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
216 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
217 interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
218 interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
219 interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
221 smallerAvail :: AvailRegs -> AvailRegs -> Bool
222 smallerAvail (AvailRegs _) (UniverseMinus _) = True
223 smallerAvail (UniverseMinus _) (AvailRegs _) = False
224 smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
225 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
227 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
228 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
229 extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
231 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
232 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
233 deleteFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
235 cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
236 cmmAvailableReloads g = env
237 where env = runDFA availRegsLattice $
238 do run_f_anal transfer (fact_bot availRegsLattice) g
240 transfer :: FAnalysis M Last AvailRegs
241 transfer = FComp "available-reloads analysis" first middle last exit
242 exit _ = LastOutFacts []
243 first avail _ = avail
244 middle = flip middleAvail
248 -- | The transfer equations use the traditional 'gen' and 'kill'
249 -- notations, which should be familiar from the dragon book.
250 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
251 agen a live = foldRegsUsed extendAvail live a
252 akill a live = foldRegsUsed deleteFromAvail live a
254 middleAvail :: M -> AvailRegs -> AvailRegs
255 middleAvail (Spill _) = id
256 middleAvail (Reload regs) = agen regs
257 middleAvail (NotSpillOrReload m) = middle m
258 where middle (MidNop) = id
259 middle (MidComment {}) = id
260 middle (MidAssign lhs _expr) = akill lhs
261 middle (MidStore {}) = id
262 middle (MidUnsafeCall _tgt ress _args) = akill ress
263 middle (CopyIn _ formals _) = akill formals
264 middle (CopyOut {}) = id
266 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
267 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
268 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
271 ---------------------
274 instance Outputable m => Outputable (ExtendWithSpills m) where
275 ppr (Spill regs) = ppr_regs "Spill" regs
276 ppr (Reload regs) = ppr_regs "Reload" regs
277 ppr (NotSpillOrReload m) = ppr m
279 instance Outputable (LGraph M Last) where
282 instance DebugNodes M Last
284 ppr_regs :: String -> RegSet -> SDoc
285 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
286 where commafy xs = hsep $ punctuate comma xs
288 instance Outputable DualLive where
289 ppr (DualLive {in_regs = regs, on_stack = stack}) =
290 if isEmptyUniqSet regs && isEmptyUniqSet stack then
291 text "<nothing-live>"
293 nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
294 else (ppr_regs "live in regs =" regs),
295 if isEmptyUniqSet stack then PP.empty
296 else (ppr_regs "live on stack =" stack)]
298 instance Outputable AvailRegs where
299 ppr (UniverseMinus s) = ppr_regs "available = all but" s
300 ppr (AvailRegs s) = ppr_regs "available = " s
302 my_trace :: String -> SDoc -> a -> a
303 my_trace = if False then pprTrace else \_ _ a -> a
305 f4sep :: [SDoc] -> SDoc
307 f4sep (d:ds) = fsep (d : map (nest 4) ds)