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 )
102 import Maybe ( fromJust )
104 import List ( nub, partition )
105 import Monad ( when )
109 -- -----------------------------------------------------------------------------
112 type RegSet = UniqSet Reg
114 type RegMap a = UniqFM a
115 emptyRegMap = emptyUFM
117 type BlockMap a = UniqFM a
118 emptyBlockMap = emptyUFM
120 -- A basic block where the isntructions are annotated with the registers
121 -- which are no longer live in the *next* instruction in this sequence.
122 -- (NB. if the instruction is a jump, these registers might still be live
123 -- at the jump target(s) - you have to check the liveness at the destination
124 -- block to find out).
126 = GenBasicBlock (Instr,
127 [Reg], -- registers read (only) which die
128 [Reg]) -- registers written which die
130 -- -----------------------------------------------------------------------------
131 -- The free register set
133 -- This needs to be *efficient*
135 {- Here's an inefficient 'executable specification' of the FreeRegs data type:
136 type FreeRegs = [RegNo]
139 releaseReg n f = if n `elem` f then f else (n : f)
140 initFreeRegs = allocatableRegs
141 getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
142 allocateReg f r = filter (/= r) f
145 #if defined(powerpc_TARGET_ARCH)
147 -- The PowerPC has 32 integer and 32 floating point registers.
148 -- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
150 -- Note that when getFreeRegs scans for free registers, it starts at register
151 -- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
152 -- registers are callee-saves, while the lower regs are caller-saves, so it
153 -- makes sense to start at the high end.
154 -- Apart from that, the code does nothing PowerPC-specific, so feel free to
155 -- add your favourite platform to the #if (if you have 64 registers but only
158 data FreeRegs = FreeRegs !Word32 !Word32
159 deriving( Show ) -- The Show is used in an ASSERT
161 noFreeRegs :: FreeRegs
162 noFreeRegs = FreeRegs 0 0
164 releaseReg :: RegNo -> FreeRegs -> FreeRegs
165 releaseReg r (FreeRegs g f)
166 | r > 31 = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32)))
167 | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f
169 initFreeRegs :: FreeRegs
170 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
172 getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
173 getFreeRegs cls (FreeRegs g f)
174 | RcDouble <- cls = go f (0x80000000) 63
175 | RcInteger <- cls = go g (0x80000000) 31
178 go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
179 | otherwise = go x (m `shiftR` 1) $! i-1
181 allocateReg :: RegNo -> FreeRegs -> FreeRegs
182 allocateReg r (FreeRegs g f)
183 | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
184 | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f
188 -- If we have less than 32 registers, or if we have efficient 64-bit words,
189 -- we will just use a single bitfield.
191 #if defined(alpha_TARGET_ARCH)
192 type FreeRegs = Word64
194 type FreeRegs = Word32
197 noFreeRegs :: FreeRegs
200 releaseReg :: RegNo -> FreeRegs -> FreeRegs
201 releaseReg n f = f .|. (1 `shiftL` n)
203 initFreeRegs :: FreeRegs
204 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
206 getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
207 getFreeRegs cls f = go f 0
210 | n .&. 1 /= 0 && regClass (RealReg m) == cls
211 = m : (go (n `shiftR` 1) $! (m+1))
213 = go (n `shiftR` 1) $! (m+1)
214 -- ToDo: there's no point looking through all the integer registers
215 -- in order to find a floating-point one.
217 allocateReg :: RegNo -> FreeRegs -> FreeRegs
218 allocateReg r f = f .&. complement (1 `shiftL` fromIntegral r)
222 -- -----------------------------------------------------------------------------
223 -- The free list of stack slots
225 -- This doesn't need to be so efficient. It also doesn't really need to be
226 -- maintained as a set, so we just use an ordinary list (lazy, because it
227 -- contains all the possible stack slots and there are lots :-).
230 type FreeStack = [StackSlot]
232 completelyFreeStack :: FreeStack
233 completelyFreeStack = [0..maxSpillSlots]
235 getFreeStackSlot :: FreeStack -> (FreeStack,Int)
236 getFreeStackSlot (slot:stack) = (stack,slot)
238 freeStackSlot :: FreeStack -> Int -> FreeStack
239 freeStackSlot stack slot = slot:stack
242 -- -----------------------------------------------------------------------------
243 -- Top level of the register allocator
245 regAlloc :: NatCmmTop -> NatCmmTop
246 regAlloc (CmmData sec d) = CmmData sec d
247 regAlloc (CmmProc info lbl params [])
248 = CmmProc info lbl params [] -- no blocks to run the regalloc on
249 regAlloc (CmmProc info lbl params blocks@(first:rest))
250 = -- pprTrace "Liveness" (ppr block_live) $
251 CmmProc info lbl params (first':rest')
253 first_id = blockId first
254 sccs = sccBlocks blocks
255 (ann_sccs, block_live) = computeLiveness sccs
256 final_blocks = linearRegAlloc block_live ann_sccs
257 ((first':_),rest') = partition ((== first_id) . blockId) final_blocks
260 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
261 sccBlocks blocks = stronglyConnComp graph
263 getOutEdges :: [Instr] -> [BlockId]
264 getOutEdges instrs = foldr jumpDests [] instrs
266 graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
267 | block@(BasicBlock id instrs) <- blocks ]
270 -- -----------------------------------------------------------------------------
271 -- Computing liveness
274 :: [SCC NatBasicBlock]
275 -> ([SCC AnnBasicBlock], -- instructions annotated with list of registers
276 -- which are "dead after this instruction".
277 BlockMap RegSet) -- blocks annontated with set of live registers
278 -- on entry to the block.
280 -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
281 -- control to earlier ones only. The SCCs returned are in the *opposite*
282 -- order, which is exactly what we want for the next pass.
285 = livenessSCCs emptyBlockMap [] sccs
289 -> [SCC AnnBasicBlock] -- accum
290 -> [SCC NatBasicBlock]
291 -> ([SCC AnnBasicBlock], BlockMap RegSet)
293 livenessSCCs blockmap done [] = (done, blockmap)
294 livenessSCCs blockmap done
295 (AcyclicSCC (BasicBlock block_id instrs) : sccs) =
296 {- pprTrace "live instrs" (ppr (getUnique block_id) $$
297 vcat (map (\(instr,regs) -> docToSDoc (pprInstr instr) $$ ppr regs) instrs')) $
299 livenessSCCs blockmap'
300 (AcyclicSCC (BasicBlock block_id instrs'):done) sccs
301 where (live,instrs') = liveness emptyUniqSet blockmap []
303 blockmap' = addToUFM blockmap block_id live
304 -- TODO: cope with recursive blocks
306 liveness :: RegSet -- live regs
307 -> BlockMap RegSet -- live regs on entry to other BBs
308 -> [(Instr,[Reg],[Reg])] -- instructions (accum)
309 -> [Instr] -- instructions
310 -> (RegSet, [(Instr,[Reg],[Reg])])
312 liveness liveregs blockmap done [] = (liveregs, done)
313 liveness liveregs blockmap done (instr:instrs)
314 = liveness liveregs2 blockmap ((instr,r_dying,w_dying):done) instrs
316 RU read written = regUsage instr
318 -- registers that were written here are dead going backwards.
319 -- registers that were read here are live going backwards.
320 liveregs1 = (liveregs `delListFromUniqSet` written)
321 `addListToUniqSet` read
323 -- union in the live regs from all the jump destinations of this
325 targets = jumpDests instr [] -- where we go from here
326 liveregs2 = unionManyUniqSets
327 (liveregs1 : map (lookItUp "liveness" blockmap)
330 -- registers that are not live beyond this point, are recorded
332 r_dying = [ reg | reg <- read, reg `notElem` written,
333 not (elementOfUniqSet reg liveregs) ]
335 w_dying = [ reg | reg <- written,
336 not (elementOfUniqSet reg liveregs) ]
338 -- -----------------------------------------------------------------------------
339 -- Linear sweep to allocate registers
341 data Loc = InReg {-# UNPACK #-} !RegNo
342 | InMem {-# UNPACK #-} !Int -- stack slot
343 | InBoth {-# UNPACK #-} !RegNo
344 {-# UNPACK #-} !Int -- stack slot
348 A temporary can be marked as living in both a register and memory
349 (InBoth), for example if it was recently loaded from a spill location.
350 This makes it cheap to spill (no save instruction required), but we
351 have to be careful to turn this into InReg if the value in the
354 This is also useful when a temporary is about to be clobbered. We
355 save it in a spill location, but mark it as InBoth because the current
356 instruction might still want to read it.
360 instance Outputable Loc where
361 ppr l = text (show l)
365 :: BlockMap RegSet -- live regs on entry to each basic block
366 -> [SCC AnnBasicBlock] -- instructions annotated with "deaths"
368 linearRegAlloc block_live sccs = linearRA_SCCs emptyBlockMap sccs
372 -> [SCC AnnBasicBlock]
374 linearRA_SCCs block_assig [] = []
375 linearRA_SCCs block_assig
376 (AcyclicSCC (BasicBlock id instrs) : sccs)
377 = BasicBlock id instrs' : linearRA_SCCs block_assig' sccs
379 (block_assig',(instrs',fixups)) =
380 case lookupUFM block_assig id of
381 -- no prior info about this block: assume everything is
382 -- free and the assignment is empty.
384 runR block_assig initFreeRegs
385 emptyRegMap completelyFreeStack $
386 linearRA [] [] instrs
387 Just (freeregs,stack,assig) ->
388 runR block_assig freeregs assig stack $
389 linearRA [] [] instrs
391 linearRA :: [Instr] -> [NatBasicBlock] -> [(Instr,[Reg],[Reg])]
392 -> RegM ([Instr], [NatBasicBlock])
393 linearRA instr_acc fixups [] =
394 return (reverse instr_acc, fixups)
395 linearRA instr_acc fixups (instr:instrs) = do
396 (instr_acc', new_fixups) <- raInsn block_live instr_acc instr
397 linearRA instr_acc' (new_fixups++fixups) instrs
399 -- -----------------------------------------------------------------------------
400 -- Register allocation for a single instruction
402 type BlockAssignment = BlockMap (FreeRegs, FreeStack, RegMap Loc)
404 raInsn :: BlockMap RegSet -- Live temporaries at each basic block
405 -> [Instr] -- new instructions (accum.)
406 -> (Instr,[Reg],[Reg]) -- the instruction (with "deaths")
408 [Instr], -- new instructions
409 [NatBasicBlock] -- extra fixup blocks
412 raInsn block_live new_instrs (instr@(DELTA n), _, _) = do
414 return (new_instrs, [])
416 raInsn block_live new_instrs (instr, r_dying, w_dying) = do
419 -- If we have a reg->reg move between virtual registers, where the
420 -- src register is not live after this instruction, and the dst
421 -- register does not already have an assignment, then we can
422 -- eliminate the instruction.
423 case isRegRegMove instr of
425 | src `elem` r_dying,
427 Just loc <- lookupUFM assig src,
428 not (dst `elemUFM` assig) -> do
429 setAssigR (addToUFM (delFromUFM assig src) dst loc)
430 return (new_instrs, [])
432 other -> genRaInsn block_live new_instrs instr r_dying w_dying
435 genRaInsn block_live new_instrs instr r_dying w_dying =
436 case regUsage instr of { RU read written ->
437 case partition isRealReg written of { (real_written1,virt_written) ->
440 real_written = [ r | RealReg r <- real_written1 ]
442 -- we don't need to do anything with real registers that are
443 -- only read by this instr. (the list is typically ~2 elements,
444 -- so using nub isn't a problem).
445 virt_read = nub (filter isVirtualReg read)
448 -- (a) save any temporaries which will be clobbered by this instruction
449 clobber_saves <- saveClobberedTemps real_written r_dying
452 freeregs <- getFreeRegsR
454 pprTrace "raInsn" (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written $$ text (show freeregs) $$ ppr assig) $ do
457 -- (b), (c) allocate real regs for all regs read by this instruction.
458 (r_spills, r_allocd) <-
459 allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
461 -- (d) Update block map for new destinations
462 -- NB. do this before removing dead regs from the assignment, because
463 -- these dead regs might in fact be live in the jump targets (they're
464 -- only dead in the code that follows in the current basic block).
465 (fixup_blocks, adjusted_instr)
466 <- joinToTargets block_live [] instr (jumpDests instr [])
468 -- (e) Delete all register assignments for temps which are read
469 -- (only) and die here. Update the free register list.
472 -- (f) Mark regs which are clobbered as unallocatable
473 clobberRegs real_written
475 -- (g) Allocate registers for temporaries *written* (only)
476 (w_spills, w_allocd) <-
477 allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
479 -- (h) Release registers for temps which are written here and not
484 -- (i) Patch the instruction
485 patch_map = listToUFM [ (t,RealReg r) |
486 (t,r) <- zip virt_read r_allocd
487 ++ zip virt_written w_allocd ]
489 patched_instr = patchRegs adjusted_instr patchLookup
490 patchLookup x = case lookupUFM patch_map x of
495 -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do
497 -- (j) free up stack slots for dead spilled regs
498 -- TODO (can't be bothered right now)
500 return (patched_instr : w_spills ++ reverse r_spills
501 ++ clobber_saves ++ new_instrs,
505 -- -----------------------------------------------------------------------------
508 releaseRegs regs = do
513 loop assig free _ | free `seq` False = undefined
514 loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
515 loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
516 loop assig free (r:rs) =
517 case lookupUFM assig r of
518 Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
519 Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
520 _other -> loop (delFromUFM assig r) free rs
522 -- -----------------------------------------------------------------------------
523 -- Clobber real registers
526 For each temp in a register that is going to be clobbered:
527 - if the temp dies after this instruction, do nothing
528 - otherwise, put it somewhere safe (another reg if possible,
529 otherwise spill and record InBoth in the assignment).
531 for allocateRegs on the temps *read*,
532 - clobbered regs are allocatable.
534 for allocateRegs on the temps *written*,
535 - clobbered regs are not allocatable.
539 :: [RegNo] -- real registers clobbered by this instruction
540 -> [Reg] -- registers which are no longer live after this insn
541 -> RegM [Instr] -- return: instructions to spill any temps that will
544 saveClobberedTemps [] _ = return [] -- common case
545 saveClobberedTemps clobbered dying = do
548 to_spill = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig,
549 reg `elem` clobbered,
550 temp `notElem` map getUnique dying ]
552 (instrs,assig') <- clobber assig [] to_spill
556 clobber assig instrs [] = return (instrs,assig)
557 clobber assig instrs ((temp,reg):rest)
559 --ToDo: copy it to another register if possible
560 (spill,slot) <- spillR (RealReg reg)
561 clobber (addToUFM assig temp (InBoth reg slot)) (spill:instrs) rest
563 clobberRegs :: [RegNo] -> RegM ()
564 clobberRegs [] = return () -- common case
565 clobberRegs clobbered = do
566 freeregs <- getFreeRegsR
567 setFreeRegsR $! foldr allocateReg freeregs clobbered
569 setAssigR $! clobber assig (ufmToList assig)
571 -- if the temp was InReg and clobbered, then we will have
572 -- saved it in saveClobberedTemps above. So the only case
573 -- we have to worry about here is InBoth. Note that this
574 -- also catches temps which were loaded up during allocation
575 -- of read registers, not just those saved in saveClobberedTemps.
576 clobber assig [] = assig
577 clobber assig ((temp, InBoth reg slot) : rest)
578 | reg `elem` clobbered
579 = clobber (addToUFM assig temp (InMem slot)) rest
580 clobber assig (entry:rest)
583 -- -----------------------------------------------------------------------------
584 -- allocateRegsAndSpill
586 -- This function does several things:
587 -- For each temporary referred to by this instruction,
588 -- we allocate a real register (spilling another temporary if necessary).
589 -- We load the temporary up from memory if necessary.
590 -- We also update the register assignment in the process, and
591 -- the list of free registers and free stack slots.
594 :: Bool -- True <=> reading (load up spilled regs)
595 -> [Reg] -- don't push these out
596 -> [Instr] -- spill insns
597 -> [RegNo] -- real registers allocated (accum.)
598 -> [Reg] -- temps to allocate
599 -> RegM ([Instr], [RegNo])
601 allocateRegsAndSpill reading keep spills alloc []
602 = return (spills,reverse alloc)
604 allocateRegsAndSpill reading keep spills alloc (r:rs) = do
606 case lookupUFM assig r of
607 -- case (1a): already in a register
608 Just (InReg my_reg) ->
609 allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
611 -- case (1b): already in a register (and memory)
612 -- NB1. if we're writing this register, update its assignemnt to be
613 -- InReg, because the memory value is no longer valid.
614 -- NB2. This is why we must process written registers here, even if they
615 -- are also read by the same instruction.
616 Just (InBoth my_reg mem) -> do
617 when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
618 allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
620 -- Not already in a register, so we need to find a free one...
622 freeregs <- getFreeRegsR
624 case getFreeRegs (regClass r) freeregs of
626 -- case (2): we have a free register
628 spills' <- do_load reading loc my_reg spills
630 | Just (InMem slot) <- loc, reading = InBoth my_reg slot
631 | otherwise = InReg my_reg
632 setAssigR (addToUFM assig r $! new_loc)
633 setFreeRegsR (allocateReg my_reg freeregs)
634 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
636 -- case (3): we need to push something out to free up a register
639 keep' = map getUnique keep
640 candidates1 = [ (temp,reg,mem)
641 | (temp, InBoth reg mem) <- ufmToList assig,
642 temp `notElem` keep', regClass (RealReg reg) == regClass r ]
643 candidates2 = [ (temp,reg)
644 | (temp, InReg reg) <- ufmToList assig,
645 temp `notElem` keep', regClass (RealReg reg) == regClass r ]
647 ASSERT2(not (null candidates1 && null candidates2),
648 text (show freeregs) <+> ppr r <+> ppr assig) do
652 -- we have a temporary that is in both register and mem,
653 -- just free up its register for use.
655 (temp,my_reg,slot):_ -> do
656 spills' <- do_load reading loc my_reg spills
658 assig1 = addToUFM assig temp (InMem slot)
659 assig2 = addToUFM assig1 r (InReg my_reg)
662 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
664 -- otherwise, we need to spill a temporary that currently
665 -- resides in a register.
668 (temp_to_push_out, my_reg) = myHead "regalloc" candidates2
669 -- TODO: plenty of room for optimisation in choosing which temp
670 -- to spill. We just pick the first one that isn't used in
671 -- the current instruction for now.
673 (spill_insn,slot) <- spillR (RealReg my_reg)
675 assig1 = addToUFM assig temp_to_push_out (InMem slot)
676 assig2 = addToUFM assig1 r (InReg my_reg)
679 spills' <- do_load reading loc my_reg spills
680 allocateRegsAndSpill reading keep (spill_insn:spills')
683 -- load up a spilled temporary if we need to
684 do_load True (Just (InMem slot)) reg spills = do
685 insn <- loadR (RealReg reg) slot
686 return (insn : spills)
687 do_load _ _ _ spills =
690 myHead s [] = panic s
693 -- -----------------------------------------------------------------------------
694 -- Joining a jump instruction to its targets
696 -- The first time we encounter a jump to a particular basic block, we
697 -- record the assignment of temporaries. The next time we encounter a
698 -- jump to the same block, we compare our current assignment to the
699 -- stored one. They might be different if spilling has occrred in one
700 -- branch; so some fixup code will be required to match up the
708 -> RegM ([NatBasicBlock], Instr)
710 joinToTargets block_live new_blocks instr []
711 = return (new_blocks, instr)
712 joinToTargets block_live new_blocks instr (dest:dests) = do
713 block_assig <- getBlockAssigR
716 -- adjust the assignment to remove any registers which are not
717 -- live on entry to the destination block.
718 adjusted_assig = filterUFM_Directly still_live assig
719 still_live uniq _ = uniq `elemUniqSet_Directly` live_set
721 -- and free up those registers which are now free.
723 [ r | (reg, loc) <- ufmToList assig,
724 not (elemUniqSet_Directly reg live_set),
727 regsOfLoc (InReg r) = [r]
728 regsOfLoc (InBoth r _) = [r]
729 regsOfLoc (InMem _) = []
731 case lookupUFM block_assig dest of
732 -- Nothing <=> this is the first time we jumped to this
735 freeregs <- getFreeRegsR
736 let freeregs' = foldr releaseReg freeregs to_free
738 setBlockAssigR (addToUFM block_assig dest
739 (freeregs',stack,adjusted_assig))
740 joinToTargets block_live new_blocks instr dests
742 Just (freeregs,stack,dest_assig)
743 | ufmToList dest_assig == ufmToList adjusted_assig
744 -> -- ok, the assignments match
745 joinToTargets block_live new_blocks instr dests
747 -> -- need fixup code
748 panic "joinToTargets: ToDo: need fixup code"
750 live_set = lookItUp "joinToTargets" block_live dest
752 -- -----------------------------------------------------------------------------
753 -- The register allocator's monad.
755 -- Here we keep all the state that the register allocator keeps track
756 -- of as it walks the instructions in a basic block.
760 ra_blockassig :: BlockAssignment,
761 -- The current mapping from basic blocks to
762 -- the register assignments at the beginning of that block.
763 ra_freeregs :: {-#UNPACK#-}!FreeRegs, -- free machine registers
764 ra_assig :: RegMap Loc, -- assignment of temps to locations
765 ra_delta :: Int, -- current stack delta
766 ra_stack :: FreeStack -- free stack slots for spilling
769 newtype RegM a = RegM { unReg :: RA_State -> (# RA_State, a #) }
771 instance Monad RegM where
772 m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
773 return a = RegM $ \s -> (# s, a #)
775 runR :: BlockAssignment -> FreeRegs -> RegMap Loc -> FreeStack -> RegM a ->
777 runR block_assig freeregs assig stack thing =
778 case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs,
779 ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack }) of
780 (# RA_State{ ra_blockassig=block_assig }, returned_thing #)
781 -> (block_assig, returned_thing)
783 spillR :: Reg -> RegM (Instr, Int)
784 spillR reg = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
785 let (stack',slot) = getFreeStackSlot stack
786 instr = mkSpillInstr reg delta slot
788 (# s{ra_stack=stack'}, (instr,slot) #)
790 loadR :: Reg -> Int -> RegM Instr
791 loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
792 (# s, mkLoadInstr reg delta slot #)
794 freeSlotR :: Int -> RegM ()
795 freeSlotR slot = RegM $ \ s@RA_State{ra_stack=stack} ->
796 (# s{ra_stack=freeStackSlot stack slot}, () #)
798 getFreeRegsR :: RegM FreeRegs
799 getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
802 setFreeRegsR :: FreeRegs -> RegM ()
803 setFreeRegsR regs = RegM $ \ s ->
804 (# s{ra_freeregs = regs}, () #)
806 getAssigR :: RegM (RegMap Loc)
807 getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
810 setAssigR :: RegMap Loc -> RegM ()
811 setAssigR assig = RegM $ \ s ->
812 (# s{ra_assig=assig}, () #)
814 getStackR :: RegM FreeStack
815 getStackR = RegM $ \ s@RA_State{ra_stack = stack} ->
818 setStackR :: FreeStack -> RegM ()
819 setStackR stack = RegM $ \ s ->
820 (# s{ra_stack=stack}, () #)
822 getBlockAssigR :: RegM BlockAssignment
823 getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
826 setBlockAssigR :: BlockAssignment -> RegM ()
827 setBlockAssigR assig = RegM $ \ s ->
828 (# s{ra_blockassig = assig}, () #)
830 setDeltaR :: Int -> RegM ()
831 setDeltaR n = RegM $ \ s ->
832 (# s{ra_delta = n}, () #)
834 -- -----------------------------------------------------------------------------
838 my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
839 my_fromJust s p (Just x) = x
841 my_fromJust _ _ = fromJust
844 lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
845 lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)