1 {-# OPTIONS -fno-warn-missing-signatures #-}
2 -----------------------------------------------------------------------------
4 -- The register allocator
6 -- (c) The University of Glasgow 2004
8 -----------------------------------------------------------------------------
11 The algorithm is roughly:
13 1) Compute strongly connected components of the basic block list.
15 2) Compute liveness (mapping from pseudo register to
18 3) Walk instructions in each basic block. We keep track of
19 (a) Free real registers (a bitmap?)
20 (b) Current assignment of temporaries to machine registers and/or
21 spill slots (call this the "assignment").
22 (c) Partial mapping from basic block ids to a virt-to-loc mapping.
23 When we first encounter a branch to a basic block,
24 we fill in its entry in this table with the current mapping.
27 (a) For each real register clobbered by this instruction:
28 If a temporary resides in it,
29 If the temporary is live after this instruction,
30 Move the temporary to another (non-clobbered & free) reg,
31 or spill it to memory. Mark the temporary as residing
32 in both memory and a register if it was spilled (it might
33 need to be read by this instruction).
34 (ToDo: this is wrong for jump instructions?)
36 (b) For each temporary *read* by the instruction:
37 If the temporary does not have a real register allocation:
38 - Allocate a real register from the free list. If
40 - Find a temporary to spill. Pick one that is
41 not used in this instruction (ToDo: not
43 - generate a spill instruction
44 - If the temporary was previously spilled,
45 generate an instruction to read the temp from its spill loc.
46 (optimisation: if we can see that a real register is going to
47 be used soon, then don't use it for allocation).
49 (c) Update the current assignment
51 (d) If the intstruction is a branch:
52 if the destination block already has a register assignment,
53 Generate a new block with fixup code and redirect the
54 jump to the new block.
56 Update the block id->assignment mapping with the current
59 (e) Delete all register assignments for temps which are read
60 (only) and die here. Update the free register list.
62 (f) Mark all registers clobbered by this instruction as not free,
63 and mark temporaries which have been spilled due to clobbering
64 as in memory (step (a) marks then as in both mem & reg).
66 (g) For each temporary *written* by this instruction:
67 Allocate a real register as for (b), spilling something
69 - except when updating the assignment, drop any memory
70 locations that the temporary was previously in, since
71 they will be no longer valid after this instruction.
73 (h) Delete all register assignments for temps which are
74 written and die here (there should rarely be any). Update
75 the free register list.
77 (i) Rewrite the instruction with the new mapping.
79 (j) For each spilled reg known to be now dead, re-add its stack slot
84 module RegAlloc.Linear.Main (
86 module RegAlloc.Linear.Base,
87 module RegAlloc.Linear.Stats
90 #include "HsVersions.h"
93 import RegAlloc.Linear.State
94 import RegAlloc.Linear.Base
95 import RegAlloc.Linear.StackMap
96 import RegAlloc.Linear.FreeRegs
97 import RegAlloc.Linear.Stats
98 import RegAlloc.Linear.JoinToTargets
100 import RegAlloc.Liveness
105 import Cmm hiding (RegSet)
118 #include "../includes/stg/MachRegs.h"
121 -- -----------------------------------------------------------------------------
122 -- Top level of the register allocator
124 -- Allocate registers
126 :: (Outputable instr, Instruction instr)
128 -> UniqSM (NatCmmTop instr, Maybe RegAllocStats)
130 regAlloc (CmmData sec d)
135 regAlloc (CmmProc (LiveInfo info _ _) lbl params [])
136 = return ( CmmProc info lbl params (ListGraph [])
139 regAlloc (CmmProc static lbl params sccs)
140 | LiveInfo info (Just first_id) (Just block_live) <- static
142 -- do register allocation on each component.
143 (final_blocks, stats)
144 <- linearRegAlloc first_id block_live sccs
146 -- make sure the block that was first in the input list
147 -- stays at the front of the output
148 let ((first':_), rest')
149 = partition ((== first_id) . blockId) final_blocks
151 return ( CmmProc info lbl params (ListGraph (first' : rest'))
154 -- bogus. to make non-exhaustive match warning go away.
155 regAlloc (CmmProc _ _ _ _)
156 = panic "RegAllocLinear.regAlloc: no match"
159 -- -----------------------------------------------------------------------------
160 -- Linear sweep to allocate registers
163 -- | Do register allocation on some basic blocks.
164 -- But be careful to allocate a block in an SCC only if it has
165 -- an entry in the block map or it is the first block.
168 :: (Outputable instr, Instruction instr)
169 => BlockId -- ^ the first block
170 -> BlockMap RegSet -- ^ live regs on entry to each basic block
171 -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
172 -> UniqSM ([NatBasicBlock instr], RegAllocStats)
174 linearRegAlloc first_id block_live sccs
176 let (_, _, stats, blocks) =
177 runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
178 $ linearRA_SCCs first_id block_live [] sccs
180 return (blocks, stats)
182 linearRA_SCCs _ _ blocksAcc []
183 = return $ reverse blocksAcc
185 linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs)
186 = do blocks' <- processBlock block_live block
187 linearRA_SCCs first_id block_live
188 ((reverse blocks') ++ blocksAcc)
191 linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
193 blockss' <- process first_id block_live blocks [] (return []) False
194 linearRA_SCCs first_id block_live
195 (reverse (concat blockss') ++ blocksAcc)
198 {- from John Dias's patch 2008/10/16:
199 The linear-scan allocator sometimes allocates a block
200 before allocating one of its predecessors, which could lead to
201 inconsistent allocations. Make it so a block is only allocated
202 if a predecessor has set the "incoming" assignments for the block, or
203 if it's the procedure's entry block.
205 BL 2009/02: Careful. If the assignment for a block doesn't get set for
206 some reason then this function will loop. We should probably do some
207 more sanity checking to guard against this eventuality.
210 process _ _ [] [] accum _
211 = return $ reverse accum
213 process first_id block_live [] next_round accum madeProgress
215 = pprPanic "RegAlloc.Linear.Main.process: no progress made, bailing out"
216 ( text "stalled blocks:"
217 $$ vcat (map ppr next_round))
220 = process first_id block_live
221 next_round [] accum False
223 process first_id block_live (b@(BasicBlock id _) : blocks)
224 next_round accum madeProgress
226 block_assig <- getBlockAssigR
228 if isJust (lookupBlockEnv block_assig id)
231 b' <- processBlock block_live b
232 process first_id block_live blocks
233 next_round (b' : accum) True
235 else process first_id block_live blocks
236 (b : next_round) accum madeProgress
239 -- | Do register allocation on this basic block
242 :: (Outputable instr, Instruction instr)
243 => BlockMap RegSet -- ^ live regs on entry to each basic block
244 -> LiveBasicBlock instr -- ^ block to do register allocation on
245 -> RegM [NatBasicBlock instr] -- ^ block with registers allocated
247 processBlock block_live (BasicBlock id instrs)
250 <- linearRA block_live [] [] id instrs
251 return $ BasicBlock id instrs' : fixups
254 -- | Load the freeregs and current reg assignment into the RegM state
255 -- for the basic block with this BlockId.
256 initBlock :: BlockId -> RegM ()
258 = do block_assig <- getBlockAssigR
259 case lookupBlockEnv block_assig id of
260 -- no prior info about this block: assume everything is
261 -- free and the assignment is empty.
263 -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
265 setFreeRegsR initFreeRegs
266 setAssigR emptyRegMap
268 -- load info about register assignments leading into this block.
269 Just (freeregs, assig)
270 -> do setFreeRegsR freeregs
274 -- | Do allocation for a sequence of instructions.
276 :: (Outputable instr, Instruction instr)
277 => BlockMap RegSet -- ^ map of what vregs are live on entry to each block.
278 -> [instr] -- ^ accumulator for instructions already processed.
279 -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code.
280 -> BlockId -- ^ id of the current block, for debugging.
281 -> [LiveInstr instr] -- ^ liveness annotated instructions in this block.
283 -> RegM ( [instr] -- instructions after register allocation
284 , [NatBasicBlock instr]) -- fresh blocks of fixup code.
287 linearRA _ accInstr accFixup _ []
289 ( reverse accInstr -- instrs need to be returned in the correct order.
290 , accFixup) -- it doesn't matter what order the fixup blocks are returned in.
293 linearRA block_live accInstr accFixups id (instr:instrs)
295 (accInstr', new_fixups)
296 <- raInsn block_live accInstr id instr
298 linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
301 -- | Do allocation for a single instruction.
303 :: (Outputable instr, Instruction instr)
304 => BlockMap RegSet -- ^ map of what vregs are love on entry to each block.
305 -> [instr] -- ^ accumulator for instructions already processed.
306 -> BlockId -- ^ the id of the current block, for debugging
307 -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info.
309 ( [instr] -- new instructions
310 , [NatBasicBlock instr]) -- extra fixup blocks
312 raInsn _ new_instrs _ (LiveInstr ii Nothing)
313 | Just n <- takeDeltaInstr ii
315 return (new_instrs, [])
317 raInsn _ new_instrs _ (LiveInstr ii Nothing)
319 = return (new_instrs, [])
322 raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
326 -- If we have a reg->reg move between virtual registers, where the
327 -- src register is not live after this instruction, and the dst
328 -- register does not already have an assignment,
329 -- and the source register is assigned to a register, not to a spill slot,
330 -- then we can eliminate the instruction.
331 -- (we can't eliminitate it if the source register is on the stack, because
332 -- we do not want to use one spill slot for different virtual registers)
333 case takeRegRegMoveInstr instr of
334 Just (src,dst) | src `elementOfUniqSet` (liveDieRead live),
336 not (dst `elemUFM` assig),
337 Just (InReg _) <- (lookupUFM assig src) -> do
339 (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
340 -- if src is a fixed reg, then we just map dest to this
341 -- reg in the assignment. src must be an allocatable reg,
342 -- otherwise it wouldn't be in r_dying.
343 _virt -> case lookupUFM assig src of
344 Nothing -> panic "raInsn"
346 setAssigR (addToUFM (delFromUFM assig src) dst loc)
348 -- we have eliminated this instruction
350 freeregs <- getFreeRegsR
352 pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
353 $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
355 return (new_instrs, [])
357 _ -> genRaInsn block_live new_instrs id instr
358 (uniqSetToList $ liveDieRead live)
359 (uniqSetToList $ liveDieWrite live)
363 = pprPanic "raInsn" (text "no match for:" <> ppr instr)
368 genRaInsn block_live new_instrs block_id instr r_dying w_dying =
369 case regUsageOfInstr instr of { RU read written ->
371 let real_written = [ rr | (RegReal rr) <- written ]
372 let virt_written = [ vr | (RegVirtual vr) <- written ]
374 -- we don't need to do anything with real registers that are
375 -- only read by this instr. (the list is typically ~2 elements,
376 -- so using nub isn't a problem).
377 let virt_read = nub [ vr | (RegVirtual vr) <- read ]
379 -- (a) save any temporaries which will be clobbered by this instruction
380 clobber_saves <- saveClobberedTemps real_written r_dying
383 freeregs <- getFreeRegsR
385 {- pprTrace "genRaInsn"
387 $$ text "r_dying = " <+> ppr r_dying
388 $$ text "w_dying = " <+> ppr w_dying
389 $$ text "virt_read = " <+> ppr virt_read
390 $$ text "virt_written = " <+> ppr virt_written
391 $$ text "freeregs = " <+> text (show freeregs)
392 $$ text "assig = " <+> ppr assig)
396 -- (b), (c) allocate real regs for all regs read by this instruction.
397 (r_spills, r_allocd) <-
398 allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
400 -- (d) Update block map for new destinations
401 -- NB. do this before removing dead regs from the assignment, because
402 -- these dead regs might in fact be live in the jump targets (they're
403 -- only dead in the code that follows in the current basic block).
404 (fixup_blocks, adjusted_instr)
405 <- joinToTargets block_live block_id instr
407 -- (e) Delete all register assignments for temps which are read
408 -- (only) and die here. Update the free register list.
411 -- (f) Mark regs which are clobbered as unallocatable
412 clobberRegs real_written
414 -- (g) Allocate registers for temporaries *written* (only)
415 (w_spills, w_allocd) <-
416 allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
418 -- (h) Release registers for temps which are written here and not
423 -- (i) Patch the instruction
427 | (t, r) <- zip virt_read r_allocd
428 ++ zip virt_written w_allocd ]
431 = patchRegsOfInstr adjusted_instr patchLookup
434 = case lookupUFM patch_map x of
439 -- (j) free up stack slots for dead spilled regs
440 -- TODO (can't be bothered right now)
442 -- erase reg->reg moves where the source and destination are the same.
443 -- If the src temp didn't die in this instr but happened to be allocated
444 -- to the same real reg as the destination, then we can erase the move anyway.
445 let squashed_instr = case takeRegRegMoveInstr patched_instr of
450 let code = squashed_instr ++ w_spills ++ reverse r_spills
451 ++ clobber_saves ++ new_instrs
453 -- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
454 -- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
456 return (code, fixup_blocks)
460 -- -----------------------------------------------------------------------------
463 releaseRegs regs = do
468 loop _ free _ | free `seq` False = undefined
469 loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
470 loop assig free (RegReal rr : rs) = loop assig (releaseReg rr free) rs
471 loop assig free (r:rs) =
472 case lookupUFM assig r of
473 Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
474 Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
475 _other -> loop (delFromUFM assig r) free rs
478 -- -----------------------------------------------------------------------------
479 -- Clobber real registers
481 -- For each temp in a register that is going to be clobbered:
482 -- - if the temp dies after this instruction, do nothing
483 -- - otherwise, put it somewhere safe (another reg if possible,
484 -- otherwise spill and record InBoth in the assignment).
485 -- - for allocateRegs on the temps *read*,
486 -- - clobbered regs are allocatable.
488 -- for allocateRegs on the temps *written*,
489 -- - clobbered regs are not allocatable.
491 -- TODO: instead of spilling, try to copy clobbered
492 -- temps to another register if possible.
498 => [RealReg] -- real registers clobbered by this instruction
499 -> [Reg] -- registers which are no longer live after this insn
500 -> RegM [instr] -- return: instructions to spill any temps that will
503 saveClobberedTemps [] _
506 saveClobberedTemps clobbered dying
511 | (temp, InReg reg) <- ufmToList assig
512 , any (realRegsAlias reg) clobbered
513 , temp `notElem` map getUnique dying ]
515 (instrs,assig') <- clobber assig [] to_spill
520 clobber assig instrs []
521 = return (instrs, assig)
523 clobber assig instrs ((temp, reg) : rest)
525 (spill, slot) <- spillR (RegReal reg) temp
527 -- record why this reg was spilled for profiling
528 recordSpill (SpillClobber temp)
530 let new_assign = addToUFM assig temp (InBoth reg slot)
532 clobber new_assign (spill : instrs) rest
536 -- | Mark all these regal regs as allocated,
537 -- and kick out their vreg assignments.
539 clobberRegs :: [RealReg] -> RegM ()
543 clobberRegs clobbered
545 freeregs <- getFreeRegsR
546 setFreeRegsR $! foldr allocateReg freeregs clobbered
549 setAssigR $! clobber assig (ufmToList assig)
552 -- if the temp was InReg and clobbered, then we will have
553 -- saved it in saveClobberedTemps above. So the only case
554 -- we have to worry about here is InBoth. Note that this
555 -- also catches temps which were loaded up during allocation
556 -- of read registers, not just those saved in saveClobberedTemps.
561 clobber assig ((temp, InBoth reg slot) : rest)
562 | any (realRegsAlias reg) clobbered
563 = clobber (addToUFM assig temp (InMem slot)) rest
565 clobber assig (_:rest)
568 -- -----------------------------------------------------------------------------
569 -- allocateRegsAndSpill
571 -- This function does several things:
572 -- For each temporary referred to by this instruction,
573 -- we allocate a real register (spilling another temporary if necessary).
574 -- We load the temporary up from memory if necessary.
575 -- We also update the register assignment in the process, and
576 -- the list of free registers and free stack slots.
580 => Bool -- True <=> reading (load up spilled regs)
581 -> [VirtualReg] -- don't push these out
582 -> [instr] -- spill insns
583 -> [RealReg] -- real registers allocated (accum.)
584 -> [VirtualReg] -- temps to allocate
588 allocateRegsAndSpill _ _ spills alloc []
589 = return (spills, reverse alloc)
591 allocateRegsAndSpill reading keep spills alloc (r:rs)
592 = do assig <- getAssigR
593 case lookupUFM assig r of
594 -- case (1a): already in a register
595 Just (InReg my_reg) ->
596 allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
598 -- case (1b): already in a register (and memory)
599 -- NB1. if we're writing this register, update its assignemnt to be
600 -- InReg, because the memory value is no longer valid.
601 -- NB2. This is why we must process written registers here, even if they
602 -- are also read by the same instruction.
603 Just (InBoth my_reg _)
604 -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
605 allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
607 -- Not already in a register, so we need to find a free one...
608 loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig
611 allocRegsAndSpill_spill reading keep spills alloc r rs loc assig
613 freeRegs <- getFreeRegsR
614 let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs
616 case freeRegs_thisClass of
618 -- case (2): we have a free register
620 do spills' <- loadTemp reading r loc my_reg spills
623 -- if the tmp was in a slot, then now its in a reg as well
624 | Just (InMem slot) <- loc
628 -- tmp has been loaded into a reg
632 setAssigR (addToUFM assig r $! new_loc)
633 setFreeRegsR $ allocateReg my_reg freeRegs
635 allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
638 -- case (3): we need to push something out to free up a register
640 do let keep' = map getUnique keep
642 -- the vregs we could kick out that are already in a slot
643 let candidates_inBoth
645 | (temp, InBoth reg mem) <- ufmToList assig
646 , temp `notElem` keep'
647 , targetClassOfRealReg reg == classOfVirtualReg r ]
649 -- the vregs we could kick out that are only in a reg
650 -- this would require writing the reg to a new slot before using it.
653 | (temp, InReg reg) <- ufmToList assig
654 , temp `notElem` keep'
655 , targetClassOfRealReg reg == classOfVirtualReg r ]
659 -- we have a temporary that is in both register and mem,
660 -- just free up its register for use.
661 | (temp, my_reg, slot) : _ <- candidates_inBoth
662 = do spills' <- loadTemp reading r loc my_reg spills
663 let assig1 = addToUFM assig temp (InMem slot)
664 let assig2 = addToUFM assig1 r (InReg my_reg)
667 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
669 -- otherwise, we need to spill a temporary that currently
670 -- resides in a register.
671 | (temp_to_push_out, (my_reg :: RealReg)) : _
674 (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out
675 let spill_store = (if reading then id else reverse)
676 [ -- COMMENT (fsLit "spill alloc")
679 -- record that this temp was spilled
680 recordSpill (SpillAlloc temp_to_push_out)
682 -- update the register assignment
683 let assig1 = addToUFM assig temp_to_push_out (InMem slot)
684 let assig2 = addToUFM assig1 r (InReg my_reg)
687 -- if need be, load up a spilled temp into the reg we've just freed up.
688 spills' <- loadTemp reading r loc my_reg spills
690 allocateRegsAndSpill reading keep
691 (spill_store ++ spills')
695 -- there wasn't anything to spill, so we're screwed.
697 = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
699 [ text "allocating vreg: " <> text (show r)
700 , text "assignment: " <> text (show $ ufmToList assig)
701 , text "freeRegs: " <> text (show freeRegs)
702 , text "initFreeRegs: " <> text (show initFreeRegs) ]
707 -- | Load up a spilled temporary if we need to.
711 -> VirtualReg -- the temp being loaded
712 -> Maybe Loc -- the current location of this temp
713 -> RealReg -- the hreg to load the temp into
717 loadTemp True vreg (Just (InMem slot)) hreg spills
719 insn <- loadR (RegReal hreg) slot
720 recordSpill (SpillLoad $ getUnique vreg)
721 return $ {- COMMENT (fsLit "spill load") : -} insn : spills
723 loadTemp _ _ _ _ spills =