2d6508096f3161958cbd25e224516baa22e79627
[ghc.git] / compiler / nativeGen / RegAlloc / Linear / Main.hs
1 -----------------------------------------------------------------------------
2 --
3 -- The register allocator
4 --
5 -- (c) The University of Glasgow 2004
6 --
7 -----------------------------------------------------------------------------
8
9 {-
10 The algorithm is roughly:
11
12 1) Compute strongly connected components of the basic block list.
13
14 2) Compute liveness (mapping from pseudo register to
15 point(s) of death?).
16
17 3) Walk instructions in each basic block. We keep track of
18 (a) Free real registers (a bitmap?)
19 (b) Current assignment of temporaries to machine registers and/or
20 spill slots (call this the "assignment").
21 (c) Partial mapping from basic block ids to a virt-to-loc mapping.
22 When we first encounter a branch to a basic block,
23 we fill in its entry in this table with the current mapping.
24
25 For each instruction:
26 (a) For each real register clobbered by this instruction:
27 If a temporary resides in it,
28 If the temporary is live after this instruction,
29 Move the temporary to another (non-clobbered & free) reg,
30 or spill it to memory. Mark the temporary as residing
31 in both memory and a register if it was spilled (it might
32 need to be read by this instruction).
33 (ToDo: this is wrong for jump instructions?)
34
35 (b) For each temporary *read* by the instruction:
36 If the temporary does not have a real register allocation:
37 - Allocate a real register from the free list. If
38 the list is empty:
39 - Find a temporary to spill. Pick one that is
40 not used in this instruction (ToDo: not
41 used for a while...)
42 - generate a spill instruction
43 - If the temporary was previously spilled,
44 generate an instruction to read the temp from its spill loc.
45 (optimisation: if we can see that a real register is going to
46 be used soon, then don't use it for allocation).
47
48 (c) Update the current assignment
49
50 (d) If the instruction is a branch:
51 if the destination block already has a register assignment,
52 Generate a new block with fixup code and redirect the
53 jump to the new block.
54 else,
55 Update the block id->assignment mapping with the current
56 assignment.
57
58 (e) Delete all register assignments for temps which are read
59 (only) and die here. Update the free register list.
60
61 (f) Mark all registers clobbered by this instruction as not free,
62 and mark temporaries which have been spilled due to clobbering
63 as in memory (step (a) marks then as in both mem & reg).
64
65 (g) For each temporary *written* by this instruction:
66 Allocate a real register as for (b), spilling something
67 else if necessary.
68 - except when updating the assignment, drop any memory
69 locations that the temporary was previously in, since
70 they will be no longer valid after this instruction.
71
72 (h) Delete all register assignments for temps which are
73 written and die here (there should rarely be any). Update
74 the free register list.
75
76 (i) Rewrite the instruction with the new mapping.
77
78 (j) For each spilled reg known to be now dead, re-add its stack slot
79 to the free list.
80
81 -}
82
83 module RegAlloc.Linear.Main (
84 regAlloc,
85 module RegAlloc.Linear.Base,
86 module RegAlloc.Linear.Stats
87 ) where
88
89 #include "HsVersions.h"
90
91
92 import RegAlloc.Linear.State
93 import RegAlloc.Linear.Base
94 import RegAlloc.Linear.StackMap
95 import RegAlloc.Linear.FreeRegs
96 import RegAlloc.Linear.Stats
97 import RegAlloc.Linear.JoinToTargets
98 import qualified RegAlloc.Linear.PPC.FreeRegs as PPC
99 import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
100 import qualified RegAlloc.Linear.X86.FreeRegs as X86
101 import TargetReg
102 import RegAlloc.Liveness
103 import Instruction
104 import Reg
105
106 import BlockId
107 import OldCmm hiding (RegSet)
108
109 import Digraph
110 import DynFlags
111 import Unique
112 import UniqSet
113 import UniqFM
114 import UniqSupply
115 import Outputable
116 import Platform
117
118 import Data.Maybe
119 import Data.List
120 import Control.Monad
121
122 #include "../includes/stg/MachRegs.h"
123
124
125 -- -----------------------------------------------------------------------------
126 -- Top level of the register allocator
127
128 -- Allocate registers
129 regAlloc
130 :: (PlatformOutputable instr, Instruction instr)
131 => DynFlags
132 -> LiveCmmDecl statics instr
133 -> UniqSM (NatCmmDecl statics instr, Maybe RegAllocStats)
134
135 regAlloc _ (CmmData sec d)
136 = return
137 ( CmmData sec d
138 , Nothing )
139
140 regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl [])
141 = return ( CmmProc info lbl (ListGraph [])
142 , Nothing )
143
144 regAlloc dflags (CmmProc static lbl sccs)
145 | LiveInfo info (Just first_id) (Just block_live) _ <- static
146 = do
147 -- do register allocation on each component.
148 (final_blocks, stats)
149 <- linearRegAlloc dflags first_id block_live sccs
150
151 -- make sure the block that was first in the input list
152 -- stays at the front of the output
153 let ((first':_), rest')
154 = partition ((== first_id) . blockId) final_blocks
155
156 return ( CmmProc info lbl (ListGraph (first' : rest'))
157 , Just stats)
158
159 -- bogus. to make non-exhaustive match warning go away.
160 regAlloc _ (CmmProc _ _ _)
161 = panic "RegAllocLinear.regAlloc: no match"
162
163
164 -- -----------------------------------------------------------------------------
165 -- Linear sweep to allocate registers
166
167
168 -- | Do register allocation on some basic blocks.
169 -- But be careful to allocate a block in an SCC only if it has
170 -- an entry in the block map or it is the first block.
171 --
172 linearRegAlloc
173 :: (PlatformOutputable instr, Instruction instr)
174 => DynFlags
175 -> BlockId -- ^ the first block
176 -> BlockMap RegSet -- ^ live regs on entry to each basic block
177 -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
178 -> UniqSM ([NatBasicBlock instr], RegAllocStats)
179
180 linearRegAlloc dflags first_id block_live sccs
181 = let platform = targetPlatform dflags
182 in case platformArch platform of
183 ArchX86 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs
184 ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs
185 ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs
186 ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs
187 ArchARM _ _ -> panic "linearRegAlloc ArchARM"
188 ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64"
189
190 linearRegAlloc'
191 :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
192 => Platform
193 -> freeRegs
194 -> BlockId -- ^ the first block
195 -> BlockMap RegSet -- ^ live regs on entry to each basic block
196 -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
197 -> UniqSM ([NatBasicBlock instr], RegAllocStats)
198
199 linearRegAlloc' platform initFreeRegs first_id block_live sccs
200 = do us <- getUs
201 let (_, _, stats, blocks) =
202 runR emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap platform) us
203 $ linearRA_SCCs platform first_id block_live [] sccs
204 return (blocks, stats)
205
206
207 linearRA_SCCs :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
208 => Platform
209 -> BlockId
210 -> BlockMap RegSet
211 -> [NatBasicBlock instr]
212 -> [SCC (LiveBasicBlock instr)]
213 -> RegM freeRegs [NatBasicBlock instr]
214
215 linearRA_SCCs _ _ _ blocksAcc []
216 = return $ reverse blocksAcc
217
218 linearRA_SCCs platform first_id block_live blocksAcc (AcyclicSCC block : sccs)
219 = do blocks' <- processBlock platform block_live block
220 linearRA_SCCs platform first_id block_live
221 ((reverse blocks') ++ blocksAcc)
222 sccs
223
224 linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs)
225 = do
226 blockss' <- process platform first_id block_live blocks [] (return []) False
227 linearRA_SCCs platform first_id block_live
228 (reverse (concat blockss') ++ blocksAcc)
229 sccs
230
231 {- from John Dias's patch 2008/10/16:
232 The linear-scan allocator sometimes allocates a block
233 before allocating one of its predecessors, which could lead to
234 inconsistent allocations. Make it so a block is only allocated
235 if a predecessor has set the "incoming" assignments for the block, or
236 if it's the procedure's entry block.
237
238 BL 2009/02: Careful. If the assignment for a block doesn't get set for
239 some reason then this function will loop. We should probably do some
240 more sanity checking to guard against this eventuality.
241 -}
242
243 process :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
244 => Platform
245 -> BlockId
246 -> BlockMap RegSet
247 -> [GenBasicBlock (LiveInstr instr)]
248 -> [GenBasicBlock (LiveInstr instr)]
249 -> [[NatBasicBlock instr]]
250 -> Bool
251 -> RegM freeRegs [[NatBasicBlock instr]]
252
253 process _ _ _ [] [] accum _
254 = return $ reverse accum
255
256 process platform first_id block_live [] next_round accum madeProgress
257 | not madeProgress
258
259 {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
260 pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
261 ( text "Unreachable blocks:"
262 $$ vcat (map ppr next_round)) -}
263 = return $ reverse accum
264
265 | otherwise
266 = process platform first_id block_live
267 next_round [] accum False
268
269 process platform first_id block_live (b@(BasicBlock id _) : blocks)
270 next_round accum madeProgress
271 = do
272 block_assig <- getBlockAssigR
273
274 if isJust (mapLookup id block_assig)
275 || id == first_id
276 then do
277 b' <- processBlock platform block_live b
278 process platform first_id block_live blocks
279 next_round (b' : accum) True
280
281 else process platform first_id block_live blocks
282 (b : next_round) accum madeProgress
283
284
285 -- | Do register allocation on this basic block
286 --
287 processBlock
288 :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
289 => Platform
290 -> BlockMap RegSet -- ^ live regs on entry to each basic block
291 -> LiveBasicBlock instr -- ^ block to do register allocation on
292 -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated
293
294 processBlock platform block_live (BasicBlock id instrs)
295 = do initBlock id
296 (instrs', fixups)
297 <- linearRA platform block_live [] [] id instrs
298 return $ BasicBlock id instrs' : fixups
299
300
301 -- | Load the freeregs and current reg assignment into the RegM state
302 -- for the basic block with this BlockId.
303 initBlock :: FR freeRegs => BlockId -> RegM freeRegs ()
304 initBlock id
305 = do block_assig <- getBlockAssigR
306 case mapLookup id block_assig of
307 -- no prior info about this block: assume everything is
308 -- free and the assignment is empty.
309 Nothing
310 -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
311
312 setFreeRegsR frInitFreeRegs
313 setAssigR emptyRegMap
314
315 -- load info about register assignments leading into this block.
316 Just (freeregs, assig)
317 -> do setFreeRegsR freeregs
318 setAssigR assig
319
320
321 -- | Do allocation for a sequence of instructions.
322 linearRA
323 :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
324 => Platform
325 -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block.
326 -> [instr] -- ^ accumulator for instructions already processed.
327 -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code.
328 -> BlockId -- ^ id of the current block, for debugging.
329 -> [LiveInstr instr] -- ^ liveness annotated instructions in this block.
330
331 -> RegM freeRegs
332 ( [instr] -- instructions after register allocation
333 , [NatBasicBlock instr]) -- fresh blocks of fixup code.
334
335
336 linearRA _ _ accInstr accFixup _ []
337 = return
338 ( reverse accInstr -- instrs need to be returned in the correct order.
339 , accFixup) -- it doesn't matter what order the fixup blocks are returned in.
340
341
342 linearRA platform block_live accInstr accFixups id (instr:instrs)
343 = do
344 (accInstr', new_fixups)
345 <- raInsn platform block_live accInstr id instr
346
347 linearRA platform block_live accInstr' (new_fixups ++ accFixups) id instrs
348
349
350 -- | Do allocation for a single instruction.
351 raInsn
352 :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
353 => Platform
354 -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block.
355 -> [instr] -- ^ accumulator for instructions already processed.
356 -> BlockId -- ^ the id of the current block, for debugging
357 -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info.
358 -> RegM freeRegs
359 ( [instr] -- new instructions
360 , [NatBasicBlock instr]) -- extra fixup blocks
361
362 raInsn _ _ new_instrs _ (LiveInstr ii Nothing)
363 | Just n <- takeDeltaInstr ii
364 = do setDeltaR n
365 return (new_instrs, [])
366
367 raInsn _ _ new_instrs _ (LiveInstr ii Nothing)
368 | isMetaInstr ii
369 = return (new_instrs, [])
370
371
372 raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live))
373 = do
374 assig <- getAssigR
375
376 -- If we have a reg->reg move between virtual registers, where the
377 -- src register is not live after this instruction, and the dst
378 -- register does not already have an assignment,
379 -- and the source register is assigned to a register, not to a spill slot,
380 -- then we can eliminate the instruction.
381 -- (we can't eliminate it if the source register is on the stack, because
382 -- we do not want to use one spill slot for different virtual registers)
383 case takeRegRegMoveInstr instr of
384 Just (src,dst) | src `elementOfUniqSet` (liveDieRead live),
385 isVirtualReg dst,
386 not (dst `elemUFM` assig),
387 Just (InReg _) <- (lookupUFM assig src) -> do
388 case src of
389 (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
390 -- if src is a fixed reg, then we just map dest to this
391 -- reg in the assignment. src must be an allocatable reg,
392 -- otherwise it wouldn't be in r_dying.
393 _virt -> case lookupUFM assig src of
394 Nothing -> panic "raInsn"
395 Just loc ->
396 setAssigR (addToUFM (delFromUFM assig src) dst loc)
397
398 -- we have eliminated this instruction
399 {-
400 freeregs <- getFreeRegsR
401 assig <- getAssigR
402 pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
403 $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
404 -}
405 return (new_instrs, [])
406
407 _ -> genRaInsn platform block_live new_instrs id instr
408 (uniqSetToList $ liveDieRead live)
409 (uniqSetToList $ liveDieWrite live)
410
411
412 raInsn platform _ _ _ instr
413 = pprPanic "raInsn" (text "no match for:" <> pprPlatform platform instr)
414
415
416 genRaInsn :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
417 => Platform
418 -> BlockMap RegSet
419 -> [instr]
420 -> BlockId
421 -> instr
422 -> [Reg]
423 -> [Reg]
424 -> RegM freeRegs ([instr], [NatBasicBlock instr])
425
426 genRaInsn platform block_live new_instrs block_id instr r_dying w_dying =
427 case regUsageOfInstr instr of { RU read written ->
428 do
429 let real_written = [ rr | (RegReal rr) <- written ]
430 let virt_written = [ vr | (RegVirtual vr) <- written ]
431
432 -- we don't need to do anything with real registers that are
433 -- only read by this instr. (the list is typically ~2 elements,
434 -- so using nub isn't a problem).
435 let virt_read = nub [ vr | (RegVirtual vr) <- read ]
436
437 -- (a) save any temporaries which will be clobbered by this instruction
438 clobber_saves <- saveClobberedTemps platform real_written r_dying
439
440 -- debugging
441 {- freeregs <- getFreeRegsR
442 assig <- getAssigR
443 pprTrace "genRaInsn"
444 (ppr instr
445 $$ text "r_dying = " <+> ppr r_dying
446 $$ text "w_dying = " <+> ppr w_dying
447 $$ text "virt_read = " <+> ppr virt_read
448 $$ text "virt_written = " <+> ppr virt_written
449 $$ text "freeregs = " <+> text (show freeregs)
450 $$ text "assig = " <+> ppr assig)
451 $ do
452 -}
453
454 -- (b), (c) allocate real regs for all regs read by this instruction.
455 (r_spills, r_allocd) <-
456 allocateRegsAndSpill platform True{-reading-} virt_read [] [] virt_read
457
458 -- (d) Update block map for new destinations
459 -- NB. do this before removing dead regs from the assignment, because
460 -- these dead regs might in fact be live in the jump targets (they're
461 -- only dead in the code that follows in the current basic block).
462 (fixup_blocks, adjusted_instr)
463 <- joinToTargets platform block_live block_id instr
464
465 -- (e) Delete all register assignments for temps which are read
466 -- (only) and die here. Update the free register list.
467 releaseRegs r_dying
468
469 -- (f) Mark regs which are clobbered as unallocatable
470 clobberRegs real_written
471
472 -- (g) Allocate registers for temporaries *written* (only)
473 (w_spills, w_allocd) <-
474 allocateRegsAndSpill platform False{-writing-} virt_written [] [] virt_written
475
476 -- (h) Release registers for temps which are written here and not
477 -- used again.
478 releaseRegs w_dying
479
480 let
481 -- (i) Patch the instruction
482 patch_map
483 = listToUFM
484 [ (t, RegReal r)
485 | (t, r) <- zip virt_read r_allocd
486 ++ zip virt_written w_allocd ]
487
488 patched_instr
489 = patchRegsOfInstr adjusted_instr patchLookup
490
491 patchLookup x
492 = case lookupUFM patch_map x of
493 Nothing -> x
494 Just y -> y
495
496
497 -- (j) free up stack slots for dead spilled regs
498 -- TODO (can't be bothered right now)
499
500 -- erase reg->reg moves where the source and destination are the same.
501 -- If the src temp didn't die in this instr but happened to be allocated
502 -- to the same real reg as the destination, then we can erase the move anyway.
503 let squashed_instr = case takeRegRegMoveInstr patched_instr of
504 Just (src, dst)
505 | src == dst -> []
506 _ -> [patched_instr]
507
508 let code = squashed_instr ++ w_spills ++ reverse r_spills
509 ++ clobber_saves ++ new_instrs
510
511 -- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
512 -- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
513
514 return (code, fixup_blocks)
515
516 }
517
518 -- -----------------------------------------------------------------------------
519 -- releaseRegs
520
521 releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
522 releaseRegs regs = do
523 assig <- getAssigR
524 free <- getFreeRegsR
525 loop assig free regs
526 where
527 loop _ free _ | free `seq` False = undefined
528 loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
529 loop assig free (RegReal rr : rs) = loop assig (frReleaseReg rr free) rs
530 loop assig free (r:rs) =
531 case lookupUFM assig r of
532 Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
533 Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
534 _other -> loop (delFromUFM assig r) free rs
535
536
537 -- -----------------------------------------------------------------------------
538 -- Clobber real registers
539
540 -- For each temp in a register that is going to be clobbered:
541 -- - if the temp dies after this instruction, do nothing
542 -- - otherwise, put it somewhere safe (another reg if possible,
543 -- otherwise spill and record InBoth in the assignment).
544 -- - for allocateRegs on the temps *read*,
545 -- - clobbered regs are allocatable.
546 --
547 -- for allocateRegs on the temps *written*,
548 -- - clobbered regs are not allocatable.
549 --
550 -- TODO: instead of spilling, try to copy clobbered
551 -- temps to another register if possible.
552 --
553
554
555 saveClobberedTemps
556 :: (PlatformOutputable instr, Instruction instr)
557 => Platform
558 -> [RealReg] -- real registers clobbered by this instruction
559 -> [Reg] -- registers which are no longer live after this insn
560 -> RegM freeRegs [instr] -- return: instructions to spill any temps that will
561 -- be clobbered.
562
563 saveClobberedTemps _ [] _
564 = return []
565
566 saveClobberedTemps platform clobbered dying
567 = do
568 assig <- getAssigR
569 let to_spill
570 = [ (temp,reg)
571 | (temp, InReg reg) <- ufmToList assig
572 , any (realRegsAlias reg) clobbered
573 , temp `notElem` map getUnique dying ]
574
575 (instrs,assig') <- clobber assig [] to_spill
576 setAssigR assig'
577 return instrs
578
579 where
580 clobber assig instrs []
581 = return (instrs, assig)
582
583 clobber assig instrs ((temp, reg) : rest)
584 = do
585 (spill, slot) <- spillR platform (RegReal reg) temp
586
587 -- record why this reg was spilled for profiling
588 recordSpill (SpillClobber temp)
589
590 let new_assign = addToUFM assig temp (InBoth reg slot)
591
592 clobber new_assign (spill : instrs) rest
593
594
595
596 -- | Mark all these real regs as allocated,
597 -- and kick out their vreg assignments.
598 --
599 clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
600 clobberRegs []
601 = return ()
602
603 clobberRegs clobbered
604 = do
605 freeregs <- getFreeRegsR
606 setFreeRegsR $! foldr frAllocateReg freeregs clobbered
607
608 assig <- getAssigR
609 setAssigR $! clobber assig (ufmToList assig)
610
611 where
612 -- if the temp was InReg and clobbered, then we will have
613 -- saved it in saveClobberedTemps above. So the only case
614 -- we have to worry about here is InBoth. Note that this
615 -- also catches temps which were loaded up during allocation
616 -- of read registers, not just those saved in saveClobberedTemps.
617
618 clobber assig []
619 = assig
620
621 clobber assig ((temp, InBoth reg slot) : rest)
622 | any (realRegsAlias reg) clobbered
623 = clobber (addToUFM assig temp (InMem slot)) rest
624
625 clobber assig (_:rest)
626 = clobber assig rest
627
628 -- -----------------------------------------------------------------------------
629 -- allocateRegsAndSpill
630
631 -- Why are we performing a spill?
632 data SpillLoc = ReadMem StackSlot -- reading from register only in memory
633 | WriteNew -- writing to a new variable
634 | WriteMem -- writing to register only in memory
635 -- Note that ReadNew is not valid, since you don't want to be reading
636 -- from an uninitialized register. We also don't need the location of
637 -- the register in memory, since that will be invalidated by the write.
638 -- Technically, we could coalesce WriteNew and WriteMem into a single
639 -- entry as well. -- EZY
640
641 -- This function does several things:
642 -- For each temporary referred to by this instruction,
643 -- we allocate a real register (spilling another temporary if necessary).
644 -- We load the temporary up from memory if necessary.
645 -- We also update the register assignment in the process, and
646 -- the list of free registers and free stack slots.
647
648 allocateRegsAndSpill
649 :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
650 => Platform
651 -> Bool -- True <=> reading (load up spilled regs)
652 -> [VirtualReg] -- don't push these out
653 -> [instr] -- spill insns
654 -> [RealReg] -- real registers allocated (accum.)
655 -> [VirtualReg] -- temps to allocate
656 -> RegM freeRegs ( [instr] , [RealReg])
657
658 allocateRegsAndSpill _ _ _ spills alloc []
659 = return (spills, reverse alloc)
660
661 allocateRegsAndSpill platform reading keep spills alloc (r:rs)
662 = do assig <- getAssigR
663 let doSpill = allocRegsAndSpill_spill platform reading keep spills alloc r rs assig
664 case lookupUFM assig r of
665 -- case (1a): already in a register
666 Just (InReg my_reg) ->
667 allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs
668
669 -- case (1b): already in a register (and memory)
670 -- NB1. if we're writing this register, update its assignment to be
671 -- InReg, because the memory value is no longer valid.
672 -- NB2. This is why we must process written registers here, even if they
673 -- are also read by the same instruction.
674 Just (InBoth my_reg _)
675 -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
676 allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs
677
678 -- Not already in a register, so we need to find a free one...
679 Just (InMem slot) | reading -> doSpill (ReadMem slot)
680 | otherwise -> doSpill WriteMem
681 Nothing | reading ->
682 -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
683 -- ToDo: This case should be a panic, but we
684 -- sometimes see an unreachable basic block which
685 -- triggers this because the register allocator
686 -- will start with an empty assignment.
687 doSpill WriteNew
688
689 | otherwise -> doSpill WriteNew
690
691
692 -- reading is redundant with reason, but we keep it around because it's
693 -- convenient and it maintains the recursive structure of the allocator. -- EZY
694 allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, PlatformOutputable instr)
695 => Platform
696 -> Bool
697 -> [VirtualReg]
698 -> [instr]
699 -> [RealReg]
700 -> VirtualReg
701 -> [VirtualReg]
702 -> UniqFM Loc
703 -> SpillLoc
704 -> RegM freeRegs ([instr], [RealReg])
705 allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc
706 = do
707 freeRegs <- getFreeRegsR
708 let freeRegs_thisClass = frGetFreeRegs (classOfVirtualReg r) freeRegs
709
710 case freeRegs_thisClass of
711
712 -- case (2): we have a free register
713 (my_reg : _) ->
714 do spills' <- loadTemp platform r spill_loc my_reg spills
715
716 setAssigR (addToUFM assig r $! newLocation spill_loc my_reg)
717 setFreeRegsR $ frAllocateReg my_reg freeRegs
718
719 allocateRegsAndSpill platform reading keep spills' (my_reg : alloc) rs
720
721
722 -- case (3): we need to push something out to free up a register
723 [] ->
724 do let keep' = map getUnique keep
725
726 -- the vregs we could kick out that are already in a slot
727 let candidates_inBoth
728 = [ (temp, reg, mem)
729 | (temp, InBoth reg mem) <- ufmToList assig
730 , temp `notElem` keep'
731 , targetClassOfRealReg platform reg == classOfVirtualReg r ]
732
733 -- the vregs we could kick out that are only in a reg
734 -- this would require writing the reg to a new slot before using it.
735 let candidates_inReg
736 = [ (temp, reg)
737 | (temp, InReg reg) <- ufmToList assig
738 , temp `notElem` keep'
739 , targetClassOfRealReg platform reg == classOfVirtualReg r ]
740
741 let result
742
743 -- we have a temporary that is in both register and mem,
744 -- just free up its register for use.
745 | (temp, my_reg, slot) : _ <- candidates_inBoth
746 = do spills' <- loadTemp platform r spill_loc my_reg spills
747 let assig1 = addToUFM assig temp (InMem slot)
748 let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
749
750 setAssigR assig2
751 allocateRegsAndSpill platform reading keep spills' (my_reg:alloc) rs
752
753 -- otherwise, we need to spill a temporary that currently
754 -- resides in a register.
755 | (temp_to_push_out, (my_reg :: RealReg)) : _
756 <- candidates_inReg
757 = do
758 (spill_insn, slot) <- spillR platform (RegReal my_reg) temp_to_push_out
759 let spill_store = (if reading then id else reverse)
760 [ -- COMMENT (fsLit "spill alloc")
761 spill_insn ]
762
763 -- record that this temp was spilled
764 recordSpill (SpillAlloc temp_to_push_out)
765
766 -- update the register assignment
767 let assig1 = addToUFM assig temp_to_push_out (InMem slot)
768 let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
769 setAssigR assig2
770
771 -- if need be, load up a spilled temp into the reg we've just freed up.
772 spills' <- loadTemp platform r spill_loc my_reg spills
773
774 allocateRegsAndSpill platform reading keep
775 (spill_store ++ spills')
776 (my_reg:alloc) rs
777
778
779 -- there wasn't anything to spill, so we're screwed.
780 | otherwise
781 = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
782 $ vcat
783 [ text "allocating vreg: " <> text (show r)
784 , text "assignment: " <> text (show $ ufmToList assig)
785 , text "freeRegs: " <> text (show freeRegs)
786 , text "initFreeRegs: " <> text (show (frInitFreeRegs `asTypeOf` freeRegs)) ]
787
788 result
789
790
791 -- | Calculate a new location after a register has been loaded.
792 newLocation :: SpillLoc -> RealReg -> Loc
793 -- if the tmp was read from a slot, then now its in a reg as well
794 newLocation (ReadMem slot) my_reg = InBoth my_reg slot
795 -- writes will always result in only the register being available
796 newLocation _ my_reg = InReg my_reg
797
798 -- | Load up a spilled temporary if we need to (read from memory).
799 loadTemp
800 :: (PlatformOutputable instr, Instruction instr)
801 => Platform
802 -> VirtualReg -- the temp being loaded
803 -> SpillLoc -- the current location of this temp
804 -> RealReg -- the hreg to load the temp into
805 -> [instr]
806 -> RegM freeRegs [instr]
807
808 loadTemp platform vreg (ReadMem slot) hreg spills
809 = do
810 insn <- loadR platform (RegReal hreg) slot
811 recordSpill (SpillLoad $ getUnique vreg)
812 return $ {- COMMENT (fsLit "spill load") : -} insn : spills
813
814 loadTemp _ _ _ _ spills =
815 return spills
816