802046c51933907cf8effc0b3f1bb95b4e70a9db
[ghc.git] / compiler / nativeGen / RegAlloc / Graph / Spill.hs
1
2 -- | When there aren't enough registers to hold all the vregs we have to spill
3 -- some of those vregs to slots on the stack. This module is used modify the
4 -- code to use those slots.
5 module RegAlloc.Graph.Spill (
6 regSpill,
7 SpillStats(..),
8 accSpillSL
9 ) where
10 import RegAlloc.Liveness
11 import Instruction
12 import Reg
13 import Cmm hiding (RegSet)
14 import BlockId
15
16 import MonadUtils
17 import State
18 import Unique
19 import UniqFM
20 import UniqSet
21 import UniqSupply
22 import Outputable
23 import Platform
24
25 import Data.List
26 import Data.Maybe
27 import Data.Map (Map)
28 import Data.Set (Set)
29 import qualified Data.Map as Map
30 import qualified Data.Set as Set
31
32
33 -- | Spill all these virtual regs to stack slots.
34 --
35 -- TODO: See if we can split some of the live ranges instead of just globally
36 -- spilling the virtual reg. This might make the spill cleaner's job easier.
37 --
38 -- TODO: On CISCy x86 and x86_64 we don't nessesarally have to add a mov instruction
39 -- when making spills. If an instr is using a spilled virtual we may be able to
40 -- address the spill slot directly.
41 --
42 regSpill
43 :: Instruction instr
44 => Platform
45 -> [LiveCmmDecl statics instr] -- ^ the code
46 -> UniqSet Int -- ^ available stack slots
47 -> UniqSet VirtualReg -- ^ the regs to spill
48 -> UniqSM
49 ([LiveCmmDecl statics instr]
50 -- code with SPILL and RELOAD meta instructions added.
51 , UniqSet Int -- left over slots
52 , SpillStats ) -- stats about what happened during spilling
53
54 regSpill platform code slotsFree regs
55
56 -- Not enough slots to spill these regs.
57 | sizeUniqSet slotsFree < sizeUniqSet regs
58 = pprPanic "regSpill: out of spill slots!"
59 ( text " regs to spill = " <> ppr (sizeUniqSet regs)
60 $$ text " slots left = " <> ppr (sizeUniqSet slotsFree))
61
62 | otherwise
63 = do
64 -- Allocate a slot for each of the spilled regs.
65 let slots = take (sizeUniqSet regs) $ uniqSetToList slotsFree
66 let regSlotMap = listToUFM
67 $ zip (uniqSetToList regs) slots
68
69 -- Grab the unique supply from the monad.
70 us <- getUs
71
72 -- Run the spiller on all the blocks.
73 let (code', state') =
74 runState (mapM (regSpill_top platform regSlotMap) code)
75 (initSpillS us)
76
77 return ( code'
78 , minusUniqSet slotsFree (mkUniqSet slots)
79 , makeSpillStats state')
80
81
82 -- | Spill some registers to stack slots in a top-level thing.
83 regSpill_top
84 :: Instruction instr
85 => Platform
86 -> RegMap Int
87 -- ^ map of vregs to slots they're being spilled to.
88 -> LiveCmmDecl statics instr
89 -- ^ the top level thing.
90 -> SpillM (LiveCmmDecl statics instr)
91
92 regSpill_top platform regSlotMap cmm
93 = case cmm of
94 CmmData{}
95 -> return cmm
96
97 CmmProc info label live sccs
98 | LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info
99 -> do
100 -- We should only passed Cmms with the liveness maps filled in,
101 -- but we'll create empty ones if they're not there just in case.
102 let liveVRegsOnEntry = fromMaybe mapEmpty mLiveVRegsOnEntry
103
104 -- The liveVRegsOnEntry contains the set of vregs that are live
105 -- on entry to each basic block. If we spill one of those vregs
106 -- we remove it from that set and add the corresponding slot
107 -- number to the liveSlotsOnEntry set. The spill cleaner needs
108 -- this information to erase unneeded spill and reload instructions
109 -- after we've done a successful allocation.
110 let liveSlotsOnEntry' :: Map BlockId (Set Int)
111 liveSlotsOnEntry'
112 = mapFoldWithKey patchLiveSlot
113 liveSlotsOnEntry liveVRegsOnEntry
114
115 let info'
116 = LiveInfo static firstId
117 (Just liveVRegsOnEntry)
118 liveSlotsOnEntry'
119
120 -- Apply the spiller to all the basic blocks in the CmmProc.
121 sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs
122
123 return $ CmmProc info' label live sccs'
124
125 where -- Given a BlockId and the set of registers live in it,
126 -- if registers in this block are being spilled to stack slots,
127 -- then record the fact that these slots are now live in those blocks
128 -- in the given slotmap.
129 patchLiveSlot
130 :: BlockId -> RegSet
131 -> Map BlockId (Set Int) -> Map BlockId (Set Int)
132
133 patchLiveSlot blockId regsLive slotMap
134 = let
135 -- Slots that are already recorded as being live.
136 curSlotsLive = fromMaybe Set.empty
137 $ Map.lookup blockId slotMap
138
139 moreSlotsLive = Set.fromList
140 $ catMaybes
141 $ map (lookupUFM regSlotMap)
142 $ uniqSetToList regsLive
143
144 slotMap'
145 = Map.insert blockId (Set.union curSlotsLive moreSlotsLive)
146 slotMap
147
148 in slotMap'
149
150
151 -- | Spill some registers to stack slots in a basic block.
152 regSpill_block
153 :: Instruction instr
154 => Platform
155 -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.
156 -> LiveBasicBlock instr
157 -> SpillM (LiveBasicBlock instr)
158
159 regSpill_block platform regSlotMap (BasicBlock i instrs)
160 = do instrss' <- mapM (regSpill_instr platform regSlotMap) instrs
161 return $ BasicBlock i (concat instrss')
162
163
164 -- | Spill some registers to stack slots in a single instruction.
165 -- If the instruction uses registers that need to be spilled, then it is
166 -- prefixed (or postfixed) with the appropriate RELOAD or SPILL meta
167 -- instructions.
168 regSpill_instr
169 :: Instruction instr
170 => Platform
171 -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.
172 -> LiveInstr instr
173 -> SpillM [LiveInstr instr]
174
175 regSpill_instr _ _ li@(LiveInstr _ Nothing)
176 = do return [li]
177
178 regSpill_instr platform regSlotMap
179 (LiveInstr instr (Just _))
180 = do
181 -- work out which regs are read and written in this instr
182 let RU rlRead rlWritten = regUsageOfInstr platform instr
183
184 -- sometimes a register is listed as being read more than once,
185 -- nub this so we don't end up inserting two lots of spill code.
186 let rsRead_ = nub rlRead
187 let rsWritten_ = nub rlWritten
188
189 -- if a reg is modified, it appears in both lists, want to undo this..
190 let rsRead = rsRead_ \\ rsWritten_
191 let rsWritten = rsWritten_ \\ rsRead_
192 let rsModify = intersect rsRead_ rsWritten_
193
194 -- work out if any of the regs being used are currently being spilled.
195 let rsSpillRead = filter (\r -> elemUFM r regSlotMap) rsRead
196 let rsSpillWritten = filter (\r -> elemUFM r regSlotMap) rsWritten
197 let rsSpillModify = filter (\r -> elemUFM r regSlotMap) rsModify
198
199 -- rewrite the instr and work out spill code.
200 (instr1, prepost1) <- mapAccumLM (spillRead regSlotMap) instr rsSpillRead
201 (instr2, prepost2) <- mapAccumLM (spillWrite regSlotMap) instr1 rsSpillWritten
202 (instr3, prepost3) <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
203
204 let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)
205 let prefixes = concat mPrefixes
206 let postfixes = concat mPostfixes
207
208 -- final code
209 let instrs' = prefixes
210 ++ [LiveInstr instr3 Nothing]
211 ++ postfixes
212
213 return $ instrs'
214
215
216 -- | Add a RELOAD met a instruction to load a value for an instruction that
217 -- writes to a vreg that is being spilled.
218 spillRead
219 :: Instruction instr
220 => UniqFM Int
221 -> instr
222 -> Reg
223 -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
224
225 spillRead regSlotMap instr reg
226 | Just slot <- lookupUFM regSlotMap reg
227 = do (instr', nReg) <- patchInstr reg instr
228
229 modify $ \s -> s
230 { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
231
232 return ( instr'
233 , ( [LiveInstr (RELOAD slot nReg) Nothing]
234 , []) )
235
236 | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg"
237
238
239 -- | Add a SPILL meta instruction to store a value for an instruction that
240 -- writes to a vreg that is being spilled.
241 spillWrite
242 :: Instruction instr
243 => UniqFM Int
244 -> instr
245 -> Reg
246 -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
247
248 spillWrite regSlotMap instr reg
249 | Just slot <- lookupUFM regSlotMap reg
250 = do (instr', nReg) <- patchInstr reg instr
251
252 modify $ \s -> s
253 { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
254
255 return ( instr'
256 , ( []
257 , [LiveInstr (SPILL nReg slot) Nothing]))
258
259 | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg"
260
261
262 -- | Add both RELOAD and SPILL meta instructions for an instruction that
263 -- both reads and writes to a vreg that is being spilled.
264 spillModify
265 :: Instruction instr
266 => UniqFM Int
267 -> instr
268 -> Reg
269 -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
270
271 spillModify regSlotMap instr reg
272 | Just slot <- lookupUFM regSlotMap reg
273 = do (instr', nReg) <- patchInstr reg instr
274
275 modify $ \s -> s
276 { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
277
278 return ( instr'
279 , ( [LiveInstr (RELOAD slot nReg) Nothing]
280 , [LiveInstr (SPILL nReg slot) Nothing]))
281
282 | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg"
283
284
285 -- | Rewrite uses of this virtual reg in an instr to use a different
286 -- virtual reg.
287 patchInstr
288 :: Instruction instr
289 => Reg -> instr -> SpillM (instr, Reg)
290
291 patchInstr reg instr
292 = do nUnique <- newUnique
293
294 -- The register we're rewriting is suppoed to be virtual.
295 -- If it's not then something has gone horribly wrong.
296 let nReg
297 = case reg of
298 RegVirtual vr
299 -> RegVirtual (renameVirtualReg nUnique vr)
300
301 RegReal{}
302 -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"
303
304 let instr' = patchReg1 reg nReg instr
305 return (instr', nReg)
306
307
308 patchReg1
309 :: Instruction instr
310 => Reg -> Reg -> instr -> instr
311
312 patchReg1 old new instr
313 = let patchF r
314 | r == old = new
315 | otherwise = r
316 in patchRegsOfInstr instr patchF
317
318
319 -- Spiller monad --------------------------------------------------------------
320 -- | State monad for the spill code generator.
321 type SpillM a
322 = State SpillS a
323
324 -- | Spill code generator state.
325 data SpillS
326 = SpillS
327 { -- | Unique supply for generating fresh vregs.
328 stateUS :: UniqSupply
329
330 -- | Spilled vreg vs the number of times it was loaded, stored.
331 , stateSpillSL :: UniqFM (Reg, Int, Int) }
332
333
334 -- | Create a new spiller state.
335 initSpillS :: UniqSupply -> SpillS
336 initSpillS uniqueSupply
337 = SpillS
338 { stateUS = uniqueSupply
339 , stateSpillSL = emptyUFM }
340
341
342 -- | Allocate a new unique in the spiller monad.
343 newUnique :: SpillM Unique
344 newUnique
345 = do us <- gets stateUS
346 case takeUniqFromSupply us of
347 (uniq, us')
348 -> do modify $ \s -> s { stateUS = us' }
349 return uniq
350
351
352 -- | Add a spill/reload count to a stats record for a register.
353 accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
354 accSpillSL (r1, s1, l1) (_, s2, l2)
355 = (r1, s1 + s2, l1 + l2)
356
357
358 -- Spiller stats --------------------------------------------------------------
359 -- | Spiller statistics.
360 -- Tells us what registers were spilled.
361 data SpillStats
362 = SpillStats
363 { spillStoreLoad :: UniqFM (Reg, Int, Int) }
364
365
366 -- | Extract spiller statistics from the spiller state.
367 makeSpillStats :: SpillS -> SpillStats
368 makeSpillStats s
369 = SpillStats
370 { spillStoreLoad = stateSpillSL s }
371
372
373 instance Outputable SpillStats where
374 ppr stats
375 = (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
376 $ eltsUFM (spillStoreLoad stats))
377