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