1 -----------------------------------------------------------------------------
3 -- The register allocator
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
10 The algorithm is roughly:
12 1) Compute strongly connected components of the basic block list.
14 2) Compute liveness (mapping from pseudo register to
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.
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?)
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
39 - Find a temporary to spill. Pick one that is
40 not used in this instruction (ToDo: not
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).
48 (c) Update the current assignment
50 (d) If the intstruction 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.
55 Update the block id->assignment mapping with the current
58 (e) Delete all register assignments for temps which are read
59 (only) and die here. Update the free register list.
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).
65 (g) For each temporary *written* by this instruction:
66 Allocate a real register as for (b), spilling something
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.
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.
76 (i) Rewrite the instruction with the new mapping.
78 (j) For each spilled reg known to be now dead, re-add its stack slot
83 module RegisterAlloc (
87 #include "HsVersions.h"
96 import Unique ( Uniquable(getUnique), Unique )
103 import Data.Maybe ( fromJust )
105 import Data.Maybe ( fromMaybe )
106 import Data.List ( nub, partition, mapAccumL, groupBy )
107 import Control.Monad ( when )
111 -- -----------------------------------------------------------------------------
114 type RegSet = UniqSet Reg
116 type RegMap a = UniqFM a
117 emptyRegMap = emptyUFM
119 type BlockMap a = UniqFM a
120 emptyBlockMap = emptyUFM
122 -- A basic block where the isntructions are annotated with the registers
123 -- which are no longer live in the *next* instruction in this sequence.
124 -- (NB. if the instruction is a jump, these registers might still be live
125 -- at the jump target(s) - you have to check the liveness at the destination
126 -- block to find out).
128 = GenBasicBlock (Instr,
129 [Reg], -- registers read (only) which die
130 [Reg]) -- registers written which die
132 -- -----------------------------------------------------------------------------
133 -- The free register set
135 -- This needs to be *efficient*
137 {- Here's an inefficient 'executable specification' of the FreeRegs data type:
138 type FreeRegs = [RegNo]
141 releaseReg n f = if n `elem` f then f else (n : f)
142 initFreeRegs = allocatableRegs
143 getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
144 allocateReg f r = filter (/= r) f
147 #if defined(powerpc_TARGET_ARCH)
149 -- The PowerPC has 32 integer and 32 floating point registers.
150 -- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
152 -- Note that when getFreeRegs scans for free registers, it starts at register
153 -- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
154 -- registers are callee-saves, while the lower regs are caller-saves, so it
155 -- makes sense to start at the high end.
156 -- Apart from that, the code does nothing PowerPC-specific, so feel free to
157 -- add your favourite platform to the #if (if you have 64 registers but only
160 data FreeRegs = FreeRegs !Word32 !Word32
161 deriving( Show ) -- The Show is used in an ASSERT
163 noFreeRegs :: FreeRegs
164 noFreeRegs = FreeRegs 0 0
166 releaseReg :: RegNo -> FreeRegs -> FreeRegs
167 releaseReg r (FreeRegs g f)
168 | r > 31 = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32)))
169 | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f
171 initFreeRegs :: FreeRegs
172 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
174 getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
175 getFreeRegs cls (FreeRegs g f)
176 | RcDouble <- cls = go f (0x80000000) 63
177 | RcInteger <- cls = go g (0x80000000) 31
180 go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
181 | otherwise = go x (m `shiftR` 1) $! i-1
183 allocateReg :: RegNo -> FreeRegs -> FreeRegs
184 allocateReg r (FreeRegs g f)
185 | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
186 | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f
190 -- If we have less than 32 registers, or if we have efficient 64-bit words,
191 -- we will just use a single bitfield.
193 #if defined(alpha_TARGET_ARCH)
194 type FreeRegs = Word64
196 type FreeRegs = Word32
199 noFreeRegs :: FreeRegs
202 releaseReg :: RegNo -> FreeRegs -> FreeRegs
203 releaseReg n f = f .|. (1 `shiftL` n)
205 initFreeRegs :: FreeRegs
206 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
208 getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
209 getFreeRegs cls f = go f 0
212 | n .&. 1 /= 0 && regClass (RealReg m) == cls
213 = m : (go (n `shiftR` 1) $! (m+1))
215 = go (n `shiftR` 1) $! (m+1)
216 -- ToDo: there's no point looking through all the integer registers
217 -- in order to find a floating-point one.
219 allocateReg :: RegNo -> FreeRegs -> FreeRegs
220 allocateReg r f = f .&. complement (1 `shiftL` fromIntegral r)
224 -- -----------------------------------------------------------------------------
225 -- The assignment of virtual registers to stack slots
227 -- We have lots of stack slots. Memory-to-memory moves are a pain on most
228 -- architectures. Therefore, we avoid having to generate memory-to-memory moves
229 -- by simply giving every virtual register its own stack slot.
231 -- The StackMap stack map keeps track of virtual register - stack slot
232 -- associations and of which stack slots are still free. Once it has been
233 -- associated, a stack slot is never "freed" or removed from the StackMap again,
234 -- it remains associated until we are done with the current CmmProc.
237 data StackMap = StackMap [StackSlot] (UniqFM StackSlot)
239 emptyStackMap :: StackMap
240 emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
242 getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
243 getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
244 case lookupUFM reserved reg of
245 Just slot -> (fs,slot)
246 Nothing -> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot)
248 -- -----------------------------------------------------------------------------
249 -- Top level of the register allocator
251 regAlloc :: NatCmmTop -> UniqSM NatCmmTop
252 regAlloc (CmmData sec d) = returnUs $ CmmData sec d
253 regAlloc (CmmProc info lbl params [])
254 = returnUs $ CmmProc info lbl params [] -- no blocks to run the regalloc on
255 regAlloc (CmmProc info lbl params blocks@(first:rest))
257 first_id = blockId first
258 sccs = sccBlocks blocks
259 (ann_sccs, block_live) = computeLiveness sccs
260 in linearRegAlloc block_live ann_sccs `thenUs` \final_blocks ->
261 let ((first':_),rest') = partition ((== first_id) . blockId) final_blocks
262 in returnUs $ -- pprTrace "Liveness" (ppr block_live) $
263 CmmProc info lbl params (first':rest')
265 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
266 sccBlocks blocks = stronglyConnComp graph
268 getOutEdges :: [Instr] -> [BlockId]
269 getOutEdges instrs = foldr jumpDests [] instrs
271 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
272 | block@(BasicBlock id instrs) <- blocks ]
275 -- -----------------------------------------------------------------------------
276 -- Computing liveness
279 :: [SCC NatBasicBlock]
280 -> ([SCC AnnBasicBlock], -- instructions annotated with list of registers
281 -- which are "dead after this instruction".
282 BlockMap RegSet) -- blocks annontated with set of live registers
283 -- on entry to the block.
285 -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
286 -- control to earlier ones only. The SCCs returned are in the *opposite*
287 -- order, which is exactly what we want for the next pass.
290 = livenessSCCs emptyBlockMap [] sccs
294 -> [SCC AnnBasicBlock] -- accum
295 -> [SCC NatBasicBlock]
296 -> ([SCC AnnBasicBlock], BlockMap RegSet)
298 livenessSCCs blockmap done [] = (done, blockmap)
299 livenessSCCs blockmap done
300 (AcyclicSCC (BasicBlock block_id instrs) : sccs) =
301 {- pprTrace "live instrs" (ppr (getUnique block_id) $$
302 vcat (map (\(instr,regs) -> docToSDoc (pprInstr instr) $$ ppr regs) instrs')) $
304 livenessSCCs blockmap'
305 (AcyclicSCC (BasicBlock block_id instrs'):done) sccs
306 where (live,instrs') = liveness emptyUniqSet blockmap []
308 blockmap' = addToUFM blockmap block_id live
310 livenessSCCs blockmap done
311 (CyclicSCC blocks : sccs) =
312 livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
313 where (blockmap', blocks')
314 = iterateUntilUnchanged linearLiveness equalBlockMaps
317 iterateUntilUnchanged
318 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
322 iterateUntilUnchanged f eq a b
325 groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
326 iterate (\(a, _) -> f a b) $
327 (a, error "RegisterAlloc.livenessSCCs")
330 linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
331 -> (BlockMap RegSet, [AnnBasicBlock])
332 linearLiveness = mapAccumL processBlock
334 processBlock blockmap input@(BasicBlock block_id instrs)
335 = (blockmap', BasicBlock block_id instrs')
336 where (live,instrs') = liveness emptyUniqSet blockmap []
338 blockmap' = addToUFM blockmap block_id live
340 -- probably the least efficient way to compare two
341 -- BlockMaps for equality.
344 where a' = map f $ ufmToList a
345 b' = map f $ ufmToList b
346 f (key,elt) = (key, uniqSetToList elt)
348 liveness :: RegSet -- live regs
349 -> BlockMap RegSet -- live regs on entry to other BBs
350 -> [(Instr,[Reg],[Reg])] -- instructions (accum)
351 -> [Instr] -- instructions
352 -> (RegSet, [(Instr,[Reg],[Reg])])
354 liveness liveregs blockmap done [] = (liveregs, done)
355 liveness liveregs blockmap done (instr:instrs)
356 = liveness liveregs2 blockmap ((instr,r_dying,w_dying):done) instrs
358 RU read written = regUsage instr
360 -- registers that were written here are dead going backwards.
361 -- registers that were read here are live going backwards.
362 liveregs1 = (liveregs `delListFromUniqSet` written)
363 `addListToUniqSet` read
365 -- union in the live regs from all the jump destinations of this
367 targets = jumpDests instr [] -- where we go from here
368 liveregs2 = unionManyUniqSets
369 (liveregs1 : map targetLiveRegs targets)
371 targetLiveRegs target = case lookupUFM blockmap target of
373 Nothing -> emptyBlockMap
375 -- registers that are not live beyond this point, are recorded
377 r_dying = [ reg | reg <- read, reg `notElem` written,
378 not (elementOfUniqSet reg liveregs) ]
380 w_dying = [ reg | reg <- written,
381 not (elementOfUniqSet reg liveregs) ]
384 -- -----------------------------------------------------------------------------
385 -- Linear sweep to allocate registers
387 data Loc = InReg {-# UNPACK #-} !RegNo
388 | InMem {-# UNPACK #-} !Int -- stack slot
389 | InBoth {-# UNPACK #-} !RegNo
390 {-# UNPACK #-} !Int -- stack slot
391 deriving (Eq, Show, Ord)
394 A temporary can be marked as living in both a register and memory
395 (InBoth), for example if it was recently loaded from a spill location.
396 This makes it cheap to spill (no save instruction required), but we
397 have to be careful to turn this into InReg if the value in the
400 This is also useful when a temporary is about to be clobbered. We
401 save it in a spill location, but mark it as InBoth because the current
402 instruction might still want to read it.
406 instance Outputable Loc where
407 ppr l = text (show l)
411 :: BlockMap RegSet -- live regs on entry to each basic block
412 -> [SCC AnnBasicBlock] -- instructions annotated with "deaths"
413 -> UniqSM [NatBasicBlock]
414 linearRegAlloc block_live sccs = linearRA_SCCs emptyBlockMap emptyStackMap sccs
419 -> [SCC AnnBasicBlock]
420 -> UniqSM [NatBasicBlock]
421 linearRA_SCCs block_assig stack [] = returnUs []
422 linearRA_SCCs block_assig stack
423 (AcyclicSCC (BasicBlock id instrs) : sccs)
424 = getUs `thenUs` \us ->
426 (block_assig',stack',(instrs',fixups)) =
427 case lookupUFM block_assig id of
428 -- no prior info about this block: assume everything is
429 -- free and the assignment is empty.
431 runR block_assig initFreeRegs
432 emptyRegMap stack us $
433 linearRA [] [] instrs
434 Just (freeregs,assig) ->
435 runR block_assig freeregs assig stack us $
436 linearRA [] [] instrs
438 linearRA_SCCs block_assig' stack' sccs `thenUs` \moreBlocks ->
439 returnUs $ BasicBlock id instrs' : fixups ++ moreBlocks
441 linearRA_SCCs block_assig stack
442 (CyclicSCC blocks : sccs)
443 = getUs `thenUs` \us ->
445 ((block_assig', stack', us'), blocks') = mapAccumL processBlock
446 (block_assig, stack, us)
449 linearRA_SCCs block_assig' stack' sccs `thenUs` \moreBlocks ->
450 returnUs $ concat blocks' ++ moreBlocks
452 processBlock (block_assig, stack, us0) (BasicBlock id instrs)
453 = ((block_assig', stack', us'), BasicBlock id instrs' : fixups)
455 (us, us') = splitUniqSupply us0
456 (block_assig',stack',(instrs',fixups)) =
457 case lookupUFM block_assig id of
458 -- no prior info about this block: assume everything is
459 -- free and the assignment is empty.
461 runR block_assig initFreeRegs
462 emptyRegMap stack us $
463 linearRA [] [] instrs
464 Just (freeregs,assig) ->
465 runR block_assig freeregs assig stack us $
466 linearRA [] [] instrs
468 linearRA :: [Instr] -> [NatBasicBlock] -> [(Instr,[Reg],[Reg])]
469 -> RegM ([Instr], [NatBasicBlock])
470 linearRA instr_acc fixups [] =
471 return (reverse instr_acc, fixups)
472 linearRA instr_acc fixups (instr:instrs) = do
473 (instr_acc', new_fixups) <- raInsn block_live instr_acc instr
474 linearRA instr_acc' (new_fixups++fixups) instrs
476 -- -----------------------------------------------------------------------------
477 -- Register allocation for a single instruction
479 type BlockAssignment = BlockMap (FreeRegs, RegMap Loc)
481 raInsn :: BlockMap RegSet -- Live temporaries at each basic block
482 -> [Instr] -- new instructions (accum.)
483 -> (Instr,[Reg],[Reg]) -- the instruction (with "deaths")
485 [Instr], -- new instructions
486 [NatBasicBlock] -- extra fixup blocks
489 raInsn block_live new_instrs (instr@(DELTA n), _, _) = do
491 return (new_instrs, [])
493 raInsn block_live new_instrs (instr, r_dying, w_dying) = do
496 -- If we have a reg->reg move between virtual registers, where the
497 -- src register is not live after this instruction, and the dst
498 -- register does not already have an assignment,
499 -- and the source register is assigned to a register, not to a spill slot,
500 -- then we can eliminate the instruction.
501 -- (we can't eliminitate it if the source register is on the stack, because
502 -- we do not want to use one spill slot for different virtual registers)
503 case isRegRegMove instr of
504 Just (src,dst) | src `elem` r_dying,
506 not (dst `elemUFM` assig),
507 Just (InReg _) <- (lookupUFM assig src) -> do
509 RealReg i -> setAssigR (addToUFM assig dst (InReg i))
510 -- if src is a fixed reg, then we just map dest to this
511 -- reg in the assignment. src must be an allocatable reg,
512 -- otherwise it wouldn't be in r_dying.
513 _virt -> case lookupUFM assig src of
514 Nothing -> panic "raInsn"
516 setAssigR (addToUFM (delFromUFM assig src) dst loc)
518 -- we have elimianted this instruction
520 freeregs <- getFreeRegsR
522 pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
524 return (new_instrs, [])
526 other -> genRaInsn block_live new_instrs instr r_dying w_dying
529 genRaInsn block_live new_instrs instr r_dying w_dying =
530 case regUsage instr of { RU read written ->
531 case partition isRealReg written of { (real_written1,virt_written) ->
534 real_written = [ r | RealReg r <- real_written1 ]
536 -- we don't need to do anything with real registers that are
537 -- only read by this instr. (the list is typically ~2 elements,
538 -- so using nub isn't a problem).
539 virt_read = nub (filter isVirtualReg read)
542 -- (a) save any temporaries which will be clobbered by this instruction
543 clobber_saves <- saveClobberedTemps real_written r_dying
546 freeregs <- getFreeRegsR
548 pprTrace "raInsn" (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written $$ text (show freeregs) $$ ppr assig) $ do
551 -- (b), (c) allocate real regs for all regs read by this instruction.
552 (r_spills, r_allocd) <-
553 allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
555 -- (d) Update block map for new destinations
556 -- NB. do this before removing dead regs from the assignment, because
557 -- these dead regs might in fact be live in the jump targets (they're
558 -- only dead in the code that follows in the current basic block).
559 (fixup_blocks, adjusted_instr)
560 <- joinToTargets block_live [] instr (jumpDests instr [])
562 -- (e) Delete all register assignments for temps which are read
563 -- (only) and die here. Update the free register list.
566 -- (f) Mark regs which are clobbered as unallocatable
567 clobberRegs real_written
569 -- (g) Allocate registers for temporaries *written* (only)
570 (w_spills, w_allocd) <-
571 allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
573 -- (h) Release registers for temps which are written here and not
578 -- (i) Patch the instruction
579 patch_map = listToUFM [ (t,RealReg r) |
580 (t,r) <- zip virt_read r_allocd
581 ++ zip virt_written w_allocd ]
583 patched_instr = patchRegs adjusted_instr patchLookup
584 patchLookup x = case lookupUFM patch_map x of
589 -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do
591 -- (j) free up stack slots for dead spilled regs
592 -- TODO (can't be bothered right now)
594 return (patched_instr : w_spills ++ reverse r_spills
595 ++ clobber_saves ++ new_instrs,
599 -- -----------------------------------------------------------------------------
602 releaseRegs regs = do
607 loop assig free _ | free `seq` False = undefined
608 loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
609 loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
610 loop assig free (r:rs) =
611 case lookupUFM assig r of
612 Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
613 Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
614 _other -> loop (delFromUFM assig r) free rs
616 -- -----------------------------------------------------------------------------
617 -- Clobber real registers
620 For each temp in a register that is going to be clobbered:
621 - if the temp dies after this instruction, do nothing
622 - otherwise, put it somewhere safe (another reg if possible,
623 otherwise spill and record InBoth in the assignment).
625 for allocateRegs on the temps *read*,
626 - clobbered regs are allocatable.
628 for allocateRegs on the temps *written*,
629 - clobbered regs are not allocatable.
633 :: [RegNo] -- real registers clobbered by this instruction
634 -> [Reg] -- registers which are no longer live after this insn
635 -> RegM [Instr] -- return: instructions to spill any temps that will
638 saveClobberedTemps [] _ = return [] -- common case
639 saveClobberedTemps clobbered dying = do
642 to_spill = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig,
643 reg `elem` clobbered,
644 temp `notElem` map getUnique dying ]
646 (instrs,assig') <- clobber assig [] to_spill
650 clobber assig instrs [] = return (instrs,assig)
651 clobber assig instrs ((temp,reg):rest)
653 --ToDo: copy it to another register if possible
654 (spill,slot) <- spillR (RealReg reg) temp
655 clobber (addToUFM assig temp (InBoth reg slot)) (spill:instrs) rest
657 clobberRegs :: [RegNo] -> RegM ()
658 clobberRegs [] = return () -- common case
659 clobberRegs clobbered = do
660 freeregs <- getFreeRegsR
661 setFreeRegsR $! foldr allocateReg freeregs clobbered
663 setAssigR $! clobber assig (ufmToList assig)
665 -- if the temp was InReg and clobbered, then we will have
666 -- saved it in saveClobberedTemps above. So the only case
667 -- we have to worry about here is InBoth. Note that this
668 -- also catches temps which were loaded up during allocation
669 -- of read registers, not just those saved in saveClobberedTemps.
670 clobber assig [] = assig
671 clobber assig ((temp, InBoth reg slot) : rest)
672 | reg `elem` clobbered
673 = clobber (addToUFM assig temp (InMem slot)) rest
674 clobber assig (entry:rest)
677 -- -----------------------------------------------------------------------------
678 -- allocateRegsAndSpill
680 -- This function does several things:
681 -- For each temporary referred to by this instruction,
682 -- we allocate a real register (spilling another temporary if necessary).
683 -- We load the temporary up from memory if necessary.
684 -- We also update the register assignment in the process, and
685 -- the list of free registers and free stack slots.
688 :: Bool -- True <=> reading (load up spilled regs)
689 -> [Reg] -- don't push these out
690 -> [Instr] -- spill insns
691 -> [RegNo] -- real registers allocated (accum.)
692 -> [Reg] -- temps to allocate
693 -> RegM ([Instr], [RegNo])
695 allocateRegsAndSpill reading keep spills alloc []
696 = return (spills,reverse alloc)
698 allocateRegsAndSpill reading keep spills alloc (r:rs) = do
700 case lookupUFM assig r of
701 -- case (1a): already in a register
702 Just (InReg my_reg) ->
703 allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
705 -- case (1b): already in a register (and memory)
706 -- NB1. if we're writing this register, update its assignemnt to be
707 -- InReg, because the memory value is no longer valid.
708 -- NB2. This is why we must process written registers here, even if they
709 -- are also read by the same instruction.
710 Just (InBoth my_reg mem) -> do
711 when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
712 allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
714 -- Not already in a register, so we need to find a free one...
716 freeregs <- getFreeRegsR
718 case getFreeRegs (regClass r) freeregs of
720 -- case (2): we have a free register
722 spills' <- do_load reading loc my_reg spills
724 | Just (InMem slot) <- loc, reading = InBoth my_reg slot
725 | otherwise = InReg my_reg
726 setAssigR (addToUFM assig r $! new_loc)
727 setFreeRegsR (allocateReg my_reg freeregs)
728 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
730 -- case (3): we need to push something out to free up a register
733 keep' = map getUnique keep
734 candidates1 = [ (temp,reg,mem)
735 | (temp, InBoth reg mem) <- ufmToList assig,
736 temp `notElem` keep', regClass (RealReg reg) == regClass r ]
737 candidates2 = [ (temp,reg)
738 | (temp, InReg reg) <- ufmToList assig,
739 temp `notElem` keep', regClass (RealReg reg) == regClass r ]
741 ASSERT2(not (null candidates1 && null candidates2),
742 text (show freeregs) <+> ppr r <+> ppr assig) do
746 -- we have a temporary that is in both register and mem,
747 -- just free up its register for use.
749 (temp,my_reg,slot):_ -> do
750 spills' <- do_load reading loc my_reg spills
752 assig1 = addToUFM assig temp (InMem slot)
753 assig2 = addToUFM assig1 r (InReg my_reg)
756 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
758 -- otherwise, we need to spill a temporary that currently
759 -- resides in a register.
762 (temp_to_push_out, my_reg) = myHead "regalloc" candidates2
763 -- TODO: plenty of room for optimisation in choosing which temp
764 -- to spill. We just pick the first one that isn't used in
765 -- the current instruction for now.
767 (spill_insn,slot) <- spillR (RealReg my_reg) temp_to_push_out
769 assig1 = addToUFM assig temp_to_push_out (InMem slot)
770 assig2 = addToUFM assig1 r (InReg my_reg)
773 spills' <- do_load reading loc my_reg spills
774 allocateRegsAndSpill reading keep (spill_insn:spills')
777 -- load up a spilled temporary if we need to
778 do_load True (Just (InMem slot)) reg spills = do
779 insn <- loadR (RealReg reg) slot
780 return (insn : spills)
781 do_load _ _ _ spills =
784 myHead s [] = panic s
787 -- -----------------------------------------------------------------------------
788 -- Joining a jump instruction to its targets
790 -- The first time we encounter a jump to a particular basic block, we
791 -- record the assignment of temporaries. The next time we encounter a
792 -- jump to the same block, we compare our current assignment to the
793 -- stored one. They might be different if spilling has occrred in one
794 -- branch; so some fixup code will be required to match up the
802 -> RegM ([NatBasicBlock], Instr)
804 joinToTargets block_live new_blocks instr []
805 = return (new_blocks, instr)
806 joinToTargets block_live new_blocks instr (dest:dests) = do
807 block_assig <- getBlockAssigR
810 -- adjust the assignment to remove any registers which are not
811 -- live on entry to the destination block.
812 adjusted_assig = filterUFM_Directly still_live assig
813 still_live uniq _ = uniq `elemUniqSet_Directly` live_set
815 -- and free up those registers which are now free.
817 [ r | (reg, loc) <- ufmToList assig,
818 not (elemUniqSet_Directly reg live_set),
821 regsOfLoc (InReg r) = [r]
822 regsOfLoc (InBoth r _) = [r]
823 regsOfLoc (InMem _) = []
825 case lookupUFM block_assig dest of
826 -- Nothing <=> this is the first time we jumped to this
829 freeregs <- getFreeRegsR
830 let freeregs' = foldr releaseReg freeregs to_free
831 setBlockAssigR (addToUFM block_assig dest
832 (freeregs',adjusted_assig))
833 joinToTargets block_live new_blocks instr dests
835 Just (freeregs,dest_assig)
836 | ufmToList dest_assig == ufmToList adjusted_assig
837 -> -- ok, the assignments match
838 joinToTargets block_live new_blocks instr dests
840 -> -- need fixup code
843 -- Construct a graph of register/spill movements and
844 -- untangle it component by component.
846 -- We cut some corners by
847 -- a) not handling cyclic components
848 -- b) not handling memory-to-memory moves.
850 -- Cyclic components seem to occur only very rarely,
851 -- and we don't need memory-to-memory moves because we
852 -- make sure that every temporary always gets its own
855 let graph = [ node | (vreg, src) <- ufmToList adjusted_assig,
856 node <- mkNodes src vreg ]
858 sccs = stronglyConnCompR graph
861 expandNode vreg src (lookupWithDefaultUFM_Directly
863 (panic "RegisterAlloc.joinToTargets")
866 -- The InBoth handling is a little tricky here. If
867 -- the destination is InBoth, then we must ensure that
868 -- the value ends up in both locations. An InBoth
869 -- destination must conflict with an InReg or InMem
870 -- source, so we expand an InBoth destination as
871 -- necessary. An InBoth source is slightly different:
872 -- we only care about the register that the source value
873 -- is in, so that we can move it to the destinations.
875 expandNode vreg loc@(InReg src) (InBoth dst mem)
876 | src == dst = [(vreg, loc, [InMem mem])]
877 | otherwise = [(vreg, loc, [InReg dst, InMem mem])]
878 expandNode vreg loc@(InMem src) (InBoth dst mem)
879 | src == mem = [(vreg, loc, [InReg dst])]
880 | otherwise = [(vreg, loc, [InReg dst, InMem mem])]
881 expandNode vreg loc@(InBoth _ src) (InMem dst)
882 | src == dst = [] -- guaranteed to be true
883 expandNode vreg loc@(InBoth src _) (InReg dst)
885 expandNode vreg loc@(InBoth src _) dst
886 = expandNode vreg (InReg src) dst
887 expandNode vreg src dst
889 | otherwise = [(vreg, src, [dst])]
891 -- we have eliminated any possibility of single-node cylces
892 -- in expandNode above.
893 handleComponent (AcyclicSCC (vreg,src,dsts))
894 = map (makeMove vreg src) dsts
895 handleComponent (CyclicSCC things)
896 = panic $ "Register Allocator: handleComponent: cyclic"
897 ++ " (workaround: use -fviaC)"
899 makeMove vreg (InReg src) (InReg dst)
900 = mkRegRegMoveInstr (RealReg src) (RealReg dst)
901 makeMove vreg (InMem src) (InReg dst)
902 = mkLoadInstr (RealReg dst) delta src
903 makeMove vreg (InReg src) (InMem dst)
904 = mkSpillInstr (RealReg src) delta dst
905 makeMove vreg src dst
906 = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
908 ++ " (workaround: use -fviaC)"
910 block_id <- getUniqueR
911 let block = BasicBlock (BlockId block_id) $
912 concatMap handleComponent sccs ++ mkBranchInstr dest
913 let instr' = patchJump instr dest (BlockId block_id)
914 joinToTargets block_live (block : new_blocks) instr' dests
916 live_set = lookItUp "joinToTargets" block_live dest
918 -- -----------------------------------------------------------------------------
919 -- The register allocator's monad.
921 -- Here we keep all the state that the register allocator keeps track
922 -- of as it walks the instructions in a basic block.
926 ra_blockassig :: BlockAssignment,
927 -- The current mapping from basic blocks to
928 -- the register assignments at the beginning of that block.
929 ra_freeregs :: {-#UNPACK#-}!FreeRegs, -- free machine registers
930 ra_assig :: RegMap Loc, -- assignment of temps to locations
931 ra_delta :: Int, -- current stack delta
932 ra_stack :: StackMap, -- free stack slots for spilling
933 ra_us :: UniqSupply -- unique supply for generating names
937 newtype RegM a = RegM { unReg :: RA_State -> (# RA_State, a #) }
939 instance Monad RegM where
940 m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
941 return a = RegM $ \s -> (# s, a #)
943 runR :: BlockAssignment -> FreeRegs -> RegMap Loc -> StackMap -> UniqSupply
944 -> RegM a -> (BlockAssignment, StackMap, a)
945 runR block_assig freeregs assig stack us thing =
946 case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs,
947 ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack,
949 (# RA_State{ ra_blockassig=block_assig, ra_stack=stack' }, returned_thing #)
950 -> (block_assig, stack', returned_thing)
952 spillR :: Reg -> Unique -> RegM (Instr, Int)
953 spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
954 let (stack',slot) = getStackSlotFor stack temp
955 instr = mkSpillInstr reg delta slot
957 (# s{ra_stack=stack'}, (instr,slot) #)
959 loadR :: Reg -> Int -> RegM Instr
960 loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
961 (# s, mkLoadInstr reg delta slot #)
963 getFreeRegsR :: RegM FreeRegs
964 getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
967 setFreeRegsR :: FreeRegs -> RegM ()
968 setFreeRegsR regs = RegM $ \ s ->
969 (# s{ra_freeregs = regs}, () #)
971 getAssigR :: RegM (RegMap Loc)
972 getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
975 setAssigR :: RegMap Loc -> RegM ()
976 setAssigR assig = RegM $ \ s ->
977 (# s{ra_assig=assig}, () #)
979 getStackR :: RegM StackMap
980 getStackR = RegM $ \ s@RA_State{ra_stack = stack} ->
983 setStackR :: StackMap -> RegM ()
984 setStackR stack = RegM $ \ s ->
985 (# s{ra_stack=stack}, () #)
987 getBlockAssigR :: RegM BlockAssignment
988 getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
991 setBlockAssigR :: BlockAssignment -> RegM ()
992 setBlockAssigR assig = RegM $ \ s ->
993 (# s{ra_blockassig = assig}, () #)
995 setDeltaR :: Int -> RegM ()
996 setDeltaR n = RegM $ \ s ->
997 (# s{ra_delta = n}, () #)
999 getDeltaR :: RegM Int
1000 getDeltaR = RegM $ \s -> (# s, ra_delta s #)
1002 getUniqueR :: RegM Unique
1003 getUniqueR = RegM $ \s ->
1004 case splitUniqSupply (ra_us s) of
1005 (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #)
1007 -- -----------------------------------------------------------------------------
1011 my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
1012 my_fromJust s p (Just x) = x
1014 my_fromJust _ _ = fromJust
1017 lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
1018 lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)