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