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
84 Possible plan for x86 floating pt register alloc:
86 - The standard reg alloc procedure allocates pretend floating point
87 registers to the GXXX instructions. We need to convert these GXXX
88 instructions to proper x86 FXXX instructions, using the FP stack for
91 We could do this in a separate pass, but it helps to have the
92 information about which real registers are live after the
93 instruction, so we do it at reg alloc time where that information
96 - keep a mapping from %fakeN to FP stack slot in the monad.
98 - after assigning registers to the GXXX instruction, convert the
99 instruction to an FXXX instruction. eg.
100 - for GMOV just update the mapping, and ffree any dead regs.
101 - GLD: just fld and update mapping
102 GLDZ: just fldz and update mapping
103 GLD1: just fld1 and update mapping
104 - GST: just fst and update mapping, ffree dead regs.
105 - special case for GST reg, where reg is st(0), we can fstp.
106 - for GADD fp1, fp2, fp3:
110 -- record that fp3 is now in %st(0), and all other
111 -- slots are pushed down one.
112 ffree fp1 -- if fp1 is dead now
113 ffree fp2 -- if fp2 is dead now
115 - if fp1 is in %st(0) and is dead afterward
117 -- record fp3 is in %st(0)
118 ffree fp2 -- if fp2 is dead now
119 - if fp2 is in %st(0) and is dead afterward
121 -- record fp3 is in %st(0)
122 - if fp1 is in %st(0), fp2 is dead afterward
124 -- record fp3 is in fp2's locn
125 - if fp2 is in %st(0), fp1 is dead afterward
127 -- record fp3 is in fp1's locn
129 - we should be able to avoid the nasty ffree problems of the current
130 scheme. The stack should be empty before doing a non-local
131 jump/call - we can assert that this is the case.
135 module RegisterAlloc (
139 #include "HsVersions.h"
148 import Unique ( Uniquable(..), Unique, getUnique )
154 import Maybe ( fromJust )
156 import List ( nub, partition )
157 import Monad ( when )
161 -- -----------------------------------------------------------------------------
164 type RegSet = UniqSet Reg
166 type RegMap a = UniqFM a
167 emptyRegMap = emptyUFM
169 type BlockMap a = UniqFM a
170 emptyBlockMap = emptyUFM
172 -- A basic block where the isntructions are annotated with the registers
173 -- which are no longer live in the *next* instruction in this sequence.
174 -- (NB. if the instruction is a jump, these registers might still be live
175 -- at the jump target(s) - you have to check the liveness at the destination
176 -- block to find out).
178 = GenBasicBlock (Instr,
179 [Reg], -- registers read (only) which die
180 [Reg]) -- registers written which die
182 -- -----------------------------------------------------------------------------
183 -- The free register set
185 -- This needs to be *efficient*
187 {- Here's an inefficient 'executable specification' of the FreeRegs data type:
188 type FreeRegs = [RegNo]
191 releaseReg n f = if n `elem` f then f else (n : f)
192 initFreeRegs = allocatableRegs
193 getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
194 allocateReg f r = filter (/= r) f
197 #if defined(powerpc_TARGET_ARCH)
199 -- The PowerPC has 32 integer and 32 floating point registers.
200 -- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
202 -- Note that when getFreeRegs scans for free registers, it starts at register
203 -- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
204 -- registers are callee-saves, while the lower regs are caller-saves, so it
205 -- makes sense to start at the high end.
206 -- Apart from that, the code does nothing PowerPC-specific, so feel free to
207 -- add your favourite platform to the #if (if you have 64 registers but only
210 data FreeRegs = FreeRegs !Word32 !Word32
212 noFreeRegs = FreeRegs 0 0
213 releaseReg r (FreeRegs g f)
214 | r > 31 = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32)))
215 | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f
217 initFreeRegs :: FreeRegs
218 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
220 getFreeRegs cls (FreeRegs g f)
221 | RcDouble <- cls = go f (0x80000000) 63
222 | RcInteger <- cls = go g (0x80000000) 31
225 go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
226 | otherwise = go x (m `shiftR` 1) $! i-1
228 allocateReg (FreeRegs g f) r
229 | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
230 | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f
234 -- If we have less than 32 registers, or if we have efficient 64-bit words,
235 -- we will just use a single bitfield.
237 #if defined(alpha_TARGET_ARCH)
238 type FreeRegs = Word64
240 type FreeRegs = Word32
243 noFreeRegs :: FreeRegs
246 releaseReg :: RegNo -> FreeRegs -> FreeRegs
247 releaseReg n f = f .|. (1 `shiftL` n)
249 initFreeRegs :: FreeRegs
250 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
252 getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
253 getFreeRegs cls f = go f 0
256 | n .&. 1 /= 0 && regClass (RealReg m) == cls
257 = m : (go (n `shiftR` 1) $! (m+1))
259 = go (n `shiftR` 1) $! (m+1)
260 -- ToDo: there's no point looking through all the integer registers
261 -- in order to find a floating-point one.
263 allocateReg :: FreeRegs -> RegNo -> FreeRegs
264 allocateReg f r = f .&. complement (1 `shiftL` fromIntegral r)
267 -- -----------------------------------------------------------------------------
268 -- The free list of stack slots
270 -- This doesn't need to be so efficient. It also doesn't really need to be
271 -- maintained as a set, so we just use an ordinary list (lazy, because it
272 -- contains all the possible stack slots and there are lots :-).
275 type FreeStack = [StackSlot]
277 completelyFreeStack :: FreeStack
278 completelyFreeStack = [0..maxSpillSlots]
280 getFreeStackSlot :: FreeStack -> (FreeStack,Int)
281 getFreeStackSlot (slot:stack) = (stack,slot)
283 freeStackSlot :: FreeStack -> Int -> FreeStack
284 freeStackSlot stack slot = slot:stack
287 -- -----------------------------------------------------------------------------
288 -- Top level of the register allocator
290 regAlloc :: NatCmmTop -> NatCmmTop
291 regAlloc (CmmData sec d) = CmmData sec d
292 regAlloc (CmmProc info lbl params [])
293 = CmmProc info lbl params [] -- no blocks to run the regalloc on
294 regAlloc (CmmProc info lbl params blocks@(first:rest))
295 = -- pprTrace "Liveness" (ppr block_live) $
296 CmmProc info lbl params (first':rest')
298 first_id = blockId first
299 sccs = sccBlocks blocks
300 (ann_sccs, block_live) = computeLiveness sccs
301 final_blocks = linearRegAlloc block_live ann_sccs
302 ((first':_),rest') = partition ((== first_id) . blockId) final_blocks
305 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
306 sccBlocks blocks = stronglyConnComp graph
308 getOutEdges :: [Instr] -> [BlockId]
309 getOutEdges instrs = foldr jumpDests [] instrs
311 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
312 | block@(BasicBlock id instrs) <- blocks ]
315 -- -----------------------------------------------------------------------------
316 -- Computing liveness
319 :: [SCC NatBasicBlock]
320 -> ([SCC AnnBasicBlock], -- instructions annotated with list of registers
321 -- which are "dead after this instruction".
322 BlockMap RegSet) -- blocks annontated with set of live registers
323 -- on entry to the block.
325 -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
326 -- control to earlier ones only. The SCCs returned are in the *opposite*
327 -- order, which is exactly what we want for the next pass.
330 = livenessSCCs emptyBlockMap [] sccs
334 -> [SCC AnnBasicBlock] -- accum
335 -> [SCC NatBasicBlock]
336 -> ([SCC AnnBasicBlock], BlockMap RegSet)
338 livenessSCCs blockmap done [] = (done, blockmap)
339 livenessSCCs blockmap done
340 (AcyclicSCC (BasicBlock block_id instrs) : sccs) =
341 {- pprTrace "live instrs" (ppr (getUnique block_id) $$
342 vcat (map (\(instr,regs) -> docToSDoc (pprInstr instr) $$ ppr regs) instrs')) $
344 livenessSCCs blockmap'
345 (AcyclicSCC (BasicBlock block_id instrs'):done) sccs
346 where (live,instrs') = liveness emptyUniqSet blockmap []
348 blockmap' = addToUFM blockmap block_id live
349 -- TODO: cope with recursive blocks
351 liveness :: RegSet -- live regs
352 -> BlockMap RegSet -- live regs on entry to other BBs
353 -> [(Instr,[Reg],[Reg])] -- instructions (accum)
354 -> [Instr] -- instructions
355 -> (RegSet, [(Instr,[Reg],[Reg])])
357 liveness liveregs blockmap done [] = (liveregs, done)
358 liveness liveregs blockmap done (instr:instrs)
359 = liveness liveregs2 blockmap ((instr,r_dying,w_dying):done) instrs
361 RU read written = regUsage instr
363 -- registers that were written here are dead going backwards.
364 -- registers that were read here are live going backwards.
365 liveregs1 = (liveregs `delListFromUniqSet` written)
366 `addListToUniqSet` read
368 -- union in the live regs from all the jump destinations of this
370 targets = jumpDests instr [] -- where we go from here
371 liveregs2 = unionManyUniqSets
372 (liveregs1 : map (lookItUp "liveness" blockmap)
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) ]
383 -- -----------------------------------------------------------------------------
384 -- Linear sweep to allocate registers
386 data Loc = InReg {-# UNPACK #-} !RegNo
387 | InMem {-# UNPACK #-} !Int -- stack slot
388 | InBoth {-# UNPACK #-} !RegNo
389 {-# UNPACK #-} !Int -- stack slot
393 A temporary can be marked as living in both a register and memory
394 (InBoth), for example if it was recently loaded from a spill location.
395 This makes it cheap to spill (no save instruction required), but we
396 have to be careful to turn this into InReg if the value in the
399 This is also useful when a temporary is about to be clobbered. We
400 save it in a spill location, but mark it as InBoth because the current
401 instruction might still want to read it.
405 instance Outputable Loc where
406 ppr l = text (show l)
410 :: BlockMap RegSet -- live regs on entry to each basic block
411 -> [SCC AnnBasicBlock] -- instructions annotated with "deaths"
413 linearRegAlloc block_live sccs = linearRA_SCCs emptyBlockMap sccs
417 -> [SCC AnnBasicBlock]
419 linearRA_SCCs block_assig [] = []
420 linearRA_SCCs block_assig
421 (AcyclicSCC (BasicBlock id instrs) : sccs)
422 = BasicBlock id instrs' : linearRA_SCCs block_assig' sccs
424 (block_assig',(instrs',fixups)) =
425 case lookupUFM block_assig id of
426 -- no prior info about this block: assume everything is
427 -- free and the assignment is empty.
429 runR block_assig initFreeRegs
430 emptyRegMap completelyFreeStack $
431 linearRA [] [] instrs
432 Just (freeregs,stack,assig) ->
433 runR block_assig freeregs assig stack $
434 linearRA [] [] instrs
436 linearRA :: [Instr] -> [NatBasicBlock] -> [(Instr,[Reg],[Reg])]
437 -> RegM ([Instr], [NatBasicBlock])
438 linearRA instr_acc fixups [] =
439 return (reverse instr_acc, fixups)
440 linearRA instr_acc fixups (instr:instrs) = do
441 (instr_acc', new_fixups) <- raInsn block_live instr_acc instr
442 linearRA instr_acc' (new_fixups++fixups) instrs
444 -- -----------------------------------------------------------------------------
445 -- Register allocation for a single instruction
447 type BlockAssignment = BlockMap (FreeRegs, FreeStack, RegMap Loc)
449 raInsn :: BlockMap RegSet -- Live temporaries at each basic block
450 -> [Instr] -- new instructions (accum.)
451 -> (Instr,[Reg],[Reg]) -- the instruction (with "deaths")
453 [Instr], -- new instructions
454 [NatBasicBlock] -- extra fixup blocks
457 raInsn block_live new_instrs (instr@(DELTA n), _, _) = do
459 return (new_instrs, [])
461 raInsn block_live new_instrs (instr, r_dying, w_dying) = do
464 -- If we have a reg->reg move between virtual registers, where the
465 -- src register is not live after this instruction, and the dst
466 -- register does not already have an assignment, then we can
467 -- eliminate the instruction.
468 case isRegRegMove instr of
470 | src `elem` r_dying,
472 Just loc <- lookupUFM assig src,
473 not (dst `elemUFM` assig) -> do
474 setAssigR (addToUFM (delFromUFM assig src) dst loc)
475 return (new_instrs, [])
477 other -> genRaInsn block_live new_instrs instr r_dying w_dying
480 genRaInsn block_live new_instrs instr r_dying w_dying = do
482 RU read written = regUsage instr
484 (real_written1,virt_written) = partition isRealReg written
486 real_written = [ r | RealReg r <- real_written1 ]
488 -- we don't need to do anything with real registers that are
489 -- only read by this instr. (the list is typically ~2 elements,
490 -- so using nub isn't a problem).
491 virt_read = nub (filter isVirtualReg read)
494 -- (a) save any temporaries which will be clobbered by this instruction
495 clobber_saves <- saveClobberedTemps real_written r_dying
498 freeregs <- getFreeRegsR
500 pprTrace "raInsn" (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written $$ text (show freeregs) $$ ppr assig) $ do
503 -- (b), (c) allocate real regs for all regs read by this instruction.
504 (r_spills, r_allocd) <-
505 allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
507 -- (d) Update block map for new destinations
508 -- NB. do this before removing dead regs from the assignment, because
509 -- these dead regs might in fact be live in the jump targets (they're
510 -- only dead in the code that follows in the current basic block).
511 (fixup_blocks, adjusted_instr)
512 <- joinToTargets block_live [] instr (jumpDests instr [])
514 -- (e) Delete all register assignments for temps which are read
515 -- (only) and die here. Update the free register list.
518 -- (f) Mark regs which are clobbered as unallocatable
519 clobberRegs real_written
521 -- (g) Allocate registers for temporaries *written* (only)
522 (w_spills, w_allocd) <-
523 allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
525 -- (h) Release registers for temps which are written here and not
530 -- (i) Patch the instruction
531 patch_map = listToUFM [ (t,RealReg r) |
532 (t,r) <- zip virt_read r_allocd
533 ++ zip virt_written w_allocd ]
535 patched_instr = patchRegs adjusted_instr patchLookup
536 patchLookup x = case lookupUFM patch_map x of
541 -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do
543 -- (j) free up stack slots for dead spilled regs
544 -- TODO (can't be bothered right now)
546 return (patched_instr : w_spills ++ reverse r_spills
547 ++ clobber_saves ++ new_instrs,
550 -- -----------------------------------------------------------------------------
553 releaseRegs regs = do
558 loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
559 loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
560 loop assig free (r:rs) =
561 case lookupUFM assig r of
562 Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
563 Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
564 _other -> loop (delFromUFM assig r) free rs
566 -- -----------------------------------------------------------------------------
567 -- Clobber real registers
570 For each temp in a register that is going to be clobbered:
571 - if the temp dies after this instruction, do nothing
572 - otherwise, put it somewhere safe (another reg if possible,
573 otherwise spill and record InBoth in the assignment).
575 for allocateRegs on the temps *read*,
576 - clobbered regs are allocatable.
578 for allocateRegs on the temps *written*,
579 - clobbered regs are not allocatable.
583 :: [RegNo] -- real registers clobbered by this instruction
584 -> [Reg] -- registers which are no longer live after this insn
585 -> RegM [Instr] -- return: instructions to spill any temps that will
588 saveClobberedTemps [] _ = return [] -- common case
589 saveClobberedTemps clobbered dying = do
592 to_spill = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig,
593 reg `elem` clobbered,
594 temp `notElem` map getUnique dying ]
596 (instrs,assig') <- clobber assig [] to_spill
600 clobber assig instrs [] = return (instrs,assig)
601 clobber assig instrs ((temp,reg):rest)
603 --ToDo: copy it to another register if possible
604 (spill,slot) <- spillR (RealReg reg)
605 clobber (addToUFM assig temp (InBoth reg slot)) (spill:instrs) rest
607 clobberRegs :: [RegNo] -> RegM ()
608 clobberRegs [] = return () -- common case
609 clobberRegs clobbered = do
610 freeregs <- getFreeRegsR
611 setFreeRegsR (foldl allocateReg freeregs clobbered)
613 setAssigR $! clobber assig (ufmToList assig)
615 -- if the temp was InReg and clobbered, then we will have
616 -- saved it in saveClobberedTemps above. So the only case
617 -- we have to worry about here is InBoth. Note that this
618 -- also catches temps which were loaded up during allocation
619 -- of read registers, not just those saved in saveClobberedTemps.
620 clobber assig [] = assig
621 clobber assig ((temp, InBoth reg slot) : rest)
622 | reg `elem` clobbered
623 = clobber (addToUFM assig temp (InMem slot)) rest
624 clobber assig (entry:rest)
627 -- -----------------------------------------------------------------------------
628 -- allocateRegsAndSpill
630 -- This function does several things:
631 -- For each temporary referred to by this instruction,
632 -- we allocate a real register (spilling another temporary if necessary).
633 -- We load the temporary up from memory if necessary.
634 -- We also update the register assignment in the process, and
635 -- the list of free registers and free stack slots.
638 :: Bool -- True <=> reading (load up spilled regs)
639 -> [Reg] -- don't push these out
640 -> [Instr] -- spill insns
641 -> [RegNo] -- real registers allocated (accum.)
642 -> [Reg] -- temps to allocate
643 -> RegM ([Instr], [RegNo])
645 allocateRegsAndSpill reading keep spills alloc []
646 = return (spills,reverse alloc)
648 allocateRegsAndSpill reading keep spills alloc (r:rs) = do
650 case lookupUFM assig r of
651 -- case (1a): already in a register
652 Just (InReg my_reg) ->
653 allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
655 -- case (1b): already in a register (and memory)
656 -- NB1. if we're writing this register, update its assignemnt to be
657 -- InReg, because the memory value is no longer valid.
658 -- NB2. This is why we must process written registers here, even if they
659 -- are also read by the same instruction.
660 Just (InBoth my_reg mem) -> do
661 when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
662 allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
664 -- Not already in a register, so we need to find a free one...
666 freeregs <- getFreeRegsR
668 case getFreeRegs (regClass r) freeregs of
670 -- case (2): we have a free register
672 spills' <- do_load reading loc my_reg spills
674 | Just (InMem slot) <- loc, reading = InBoth my_reg slot
675 | otherwise = InReg my_reg
676 setAssigR (addToUFM assig r $! new_loc)
677 setFreeRegsR (allocateReg freeregs my_reg)
678 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
680 -- case (3): we need to push something out to free up a register
683 keep' = map getUnique keep
684 candidates1 = [ (temp,reg,mem)
685 | (temp, InBoth reg mem) <- ufmToList assig,
686 temp `notElem` keep', regClass (RealReg reg) == regClass r ]
687 candidates2 = [ (temp,reg)
688 | (temp, InReg reg) <- ufmToList assig,
689 temp `notElem` keep', regClass (RealReg reg) == regClass r ]
691 ASSERT2(not (null candidates1 && null candidates2), ppr assig) do
695 -- we have a temporary that is in both register and mem,
696 -- just free up its register for use.
698 (temp,my_reg,slot):_ -> do
699 spills' <- do_load reading loc my_reg spills
701 assig1 = addToUFM assig temp (InMem slot)
702 assig2 = addToUFM assig1 r (InReg my_reg)
705 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
707 -- otherwise, we need to spill a temporary that currently
708 -- resides in a register.
711 (temp_to_push_out, my_reg) = head candidates2
712 -- TODO: plenty of room for optimisation in choosing which temp
713 -- to spill. We just pick the first one that isn't used in
714 -- the current instruction for now.
716 (spill_insn,slot) <- spillR (RealReg my_reg)
718 assig1 = addToUFM assig temp_to_push_out (InMem slot)
719 assig2 = addToUFM assig1 r (InReg my_reg)
722 spills' <- do_load reading loc my_reg spills
723 allocateRegsAndSpill reading keep (spill_insn:spills')
726 -- load up a spilled temporary if we need to
727 do_load True (Just (InMem slot)) reg spills = do
728 insn <- loadR (RealReg reg) slot
729 return (insn : spills)
730 do_load _ _ _ spills =
733 -- -----------------------------------------------------------------------------
734 -- Joining a jump instruction to its targets
736 -- The first time we encounter a jump to a particular basic block, we
737 -- record the assignment of temporaries. The next time we encounter a
738 -- jump to the same block, we compare our current assignment to the
739 -- stored one. They might be different if spilling has occrred in one
740 -- branch; so some fixup code will be required to match up the
748 -> RegM ([NatBasicBlock], Instr)
750 joinToTargets block_live new_blocks instr []
751 = return (new_blocks, instr)
752 joinToTargets block_live new_blocks instr (dest:dests) = do
753 block_assig <- getBlockAssigR
756 -- adjust the assignment to remove any registers which are not
757 -- live on entry to the destination block.
759 listToUFM [ (reg,loc) | reg <- live,
760 Just loc <- [lookupUFM assig reg] ]
762 case lookupUFM block_assig dest of
763 -- Nothing <=> this is the first time we jumped to this
766 freeregs <- getFreeRegsR
768 setBlockAssigR (addToUFM block_assig dest
769 (freeregs,stack,adjusted_assig))
770 joinToTargets block_live new_blocks instr dests
772 Just (freeregs,stack,dest_assig)
773 | ufmToList dest_assig == ufmToList adjusted_assig
774 -> -- ok, the assignments match
775 joinToTargets block_live new_blocks instr dests
777 -> -- need fixup code
778 panic "joinToTargets: ToDo: need fixup code"
780 live = uniqSetToList (lookItUp "joinToTargets" block_live dest)
782 -- -----------------------------------------------------------------------------
783 -- The register allocator's monad.
785 -- Here we keep all the state that the register allocator keeps track
786 -- of as it walks the instructions in a basic block.
790 ra_blockassig :: BlockAssignment,
791 -- The current mapping from basic blocks to
792 -- the register assignments at the beginning of that block.
793 ra_freeregs :: FreeRegs, -- free machine registers
794 ra_assig :: RegMap Loc, -- assignment of temps to locations
795 ra_delta :: Int, -- current stack delta
796 ra_stack :: FreeStack -- free stack slots for spilling
799 newtype RegM a = RegM { unReg :: RA_State -> (# RA_State, a #) }
801 instance Monad RegM where
802 m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
803 return a = RegM $ \s -> (# s, a #)
805 runR :: BlockAssignment -> FreeRegs -> RegMap Loc -> FreeStack -> RegM a ->
807 runR block_assig freeregs assig stack thing =
808 case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs,
809 ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack }) of
810 (# RA_State{ ra_blockassig=block_assig }, returned_thing #)
811 -> (block_assig, returned_thing)
813 spillR :: Reg -> RegM (Instr, Int)
814 spillR reg = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
815 let (stack',slot) = getFreeStackSlot stack
816 instr = mkSpillInstr reg delta slot
818 (# s{ra_stack=stack'}, (instr,slot) #)
820 loadR :: Reg -> Int -> RegM Instr
821 loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
822 (# s, mkLoadInstr reg delta slot #)
824 freeSlotR :: Int -> RegM ()
825 freeSlotR slot = RegM $ \ s@RA_State{ra_stack=stack} ->
826 (# s{ra_stack=freeStackSlot stack slot}, () #)
828 getFreeRegsR :: RegM FreeRegs
829 getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
832 setFreeRegsR :: FreeRegs -> RegM ()
833 setFreeRegsR regs = RegM $ \ s ->
834 (# s{ra_freeregs = regs}, () #)
836 getAssigR :: RegM (RegMap Loc)
837 getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
840 setAssigR :: RegMap Loc -> RegM ()
841 setAssigR assig = RegM $ \ s ->
842 (# s{ra_assig=assig}, () #)
844 getStackR :: RegM FreeStack
845 getStackR = RegM $ \ s@RA_State{ra_stack = stack} ->
848 setStackR :: FreeStack -> RegM ()
849 setStackR stack = RegM $ \ s ->
850 (# s{ra_stack=stack}, () #)
852 getBlockAssigR :: RegM BlockAssignment
853 getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
856 setBlockAssigR :: BlockAssignment -> RegM ()
857 setBlockAssigR assig = RegM $ \ s ->
858 (# s{ra_blockassig = assig}, () #)
860 setDeltaR :: Int -> RegM ()
861 setDeltaR n = RegM $ \ s ->
862 (# s{ra_delta = n}, () #)
864 -- -----------------------------------------------------------------------------
868 my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
869 my_fromJust s p (Just x) = x
871 my_fromJust _ _ = fromJust
874 lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
875 lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)