X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegisterAlloc.hs;fp=compiler%2FnativeGen%2FRegisterAlloc.hs;h=0000000000000000000000000000000000000000;hb=0f7d268d00795a58a06ae3c92ebbd14571295b84;hp=8f7a6564ba31405259dd80394c39c71a14ad26c4;hpb=27802c599d26c3358cb9870b6861cd32209bbe58;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegisterAlloc.hs b/compiler/nativeGen/RegisterAlloc.hs deleted file mode 100644 index 8f7a656..0000000 --- a/compiler/nativeGen/RegisterAlloc.hs +++ /dev/null @@ -1,1041 +0,0 @@ ------------------------------------------------------------------------------ --- --- The register allocator --- --- (c) The University of Glasgow 2004 --- ------------------------------------------------------------------------------ - -{- -The algorithm is roughly: - - 1) Compute strongly connected components of the basic block list. - - 2) Compute liveness (mapping from pseudo register to - point(s) of death?). - - 3) Walk instructions in each basic block. We keep track of - (a) Free real registers (a bitmap?) - (b) Current assignment of temporaries to machine registers and/or - spill slots (call this the "assignment"). - (c) Partial mapping from basic block ids to a virt-to-loc mapping. - When we first encounter a branch to a basic block, - we fill in its entry in this table with the current mapping. - - For each instruction: - (a) For each real register clobbered by this instruction: - If a temporary resides in it, - If the temporary is live after this instruction, - Move the temporary to another (non-clobbered & free) reg, - or spill it to memory. Mark the temporary as residing - in both memory and a register if it was spilled (it might - need to be read by this instruction). - (ToDo: this is wrong for jump instructions?) - - (b) For each temporary *read* by the instruction: - If the temporary does not have a real register allocation: - - Allocate a real register from the free list. If - the list is empty: - - Find a temporary to spill. Pick one that is - not used in this instruction (ToDo: not - used for a while...) - - generate a spill instruction - - If the temporary was previously spilled, - generate an instruction to read the temp from its spill loc. - (optimisation: if we can see that a real register is going to - be used soon, then don't use it for allocation). - - (c) Update the current assignment - - (d) If the intstruction is a branch: - if the destination block already has a register assignment, - Generate a new block with fixup code and redirect the - jump to the new block. - else, - Update the block id->assignment mapping with the current - assignment. - - (e) Delete all register assignments for temps which are read - (only) and die here. Update the free register list. - - (f) Mark all registers clobbered by this instruction as not free, - and mark temporaries which have been spilled due to clobbering - as in memory (step (a) marks then as in both mem & reg). - - (g) For each temporary *written* by this instruction: - Allocate a real register as for (b), spilling something - else if necessary. - - except when updating the assignment, drop any memory - locations that the temporary was previously in, since - they will be no longer valid after this instruction. - - (h) Delete all register assignments for temps which are - written and die here (there should rarely be any). Update - the free register list. - - (i) Rewrite the instruction with the new mapping. - - (j) For each spilled reg known to be now dead, re-add its stack slot - to the free list. - --} - -module RegisterAlloc ( - regAlloc - ) where - -#include "HsVersions.h" - -import PprMach -import MachRegs -import MachInstrs -import RegAllocInfo -import Cmm - -import Digraph -import Unique ( Uniquable(getUnique), Unique ) -import UniqSet -import UniqFM -import UniqSupply -import Outputable - -#ifndef DEBUG -import Data.Maybe ( fromJust ) -#endif -import Data.List ( nub, partition, mapAccumL, groupBy ) -import Control.Monad ( when ) -import Data.Word -import Data.Bits - --- ----------------------------------------------------------------------------- --- Some useful types - -type RegSet = UniqSet Reg - -type RegMap a = UniqFM a -emptyRegMap = emptyUFM - -type BlockMap a = UniqFM a -emptyBlockMap = emptyUFM - --- A basic block where the isntructions are annotated with the registers --- which are no longer live in the *next* instruction in this sequence. --- (NB. if the instruction is a jump, these registers might still be live --- at the jump target(s) - you have to check the liveness at the destination --- block to find out). -type AnnBasicBlock - = GenBasicBlock (Instr, - [Reg], -- registers read (only) which die - [Reg]) -- registers written which die - --- ----------------------------------------------------------------------------- --- The free register set - --- This needs to be *efficient* - -{- Here's an inefficient 'executable specification' of the FreeRegs data type: -type FreeRegs = [RegNo] - -noFreeRegs = 0 -releaseReg n f = if n `elem` f then f else (n : f) -initFreeRegs = allocatableRegs -getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f -allocateReg f r = filter (/= r) f --} - -#if defined(powerpc_TARGET_ARCH) - --- The PowerPC has 32 integer and 32 floating point registers. --- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much --- better. --- Note that when getFreeRegs scans for free registers, it starts at register --- 31 and counts down. This is a hack for the PowerPC - the higher-numbered --- registers are callee-saves, while the lower regs are caller-saves, so it --- makes sense to start at the high end. --- Apart from that, the code does nothing PowerPC-specific, so feel free to --- add your favourite platform to the #if (if you have 64 registers but only --- 32-bit words). - -data FreeRegs = FreeRegs !Word32 !Word32 - deriving( Show ) -- The Show is used in an ASSERT - -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 0 - -releaseReg :: RegNo -> FreeRegs -> FreeRegs -releaseReg r (FreeRegs g f) - | r > 31 = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32))) - | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f - -initFreeRegs :: FreeRegs -initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs - -getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly -getFreeRegs cls (FreeRegs g f) - | RcDouble <- cls = go f (0x80000000) 63 - | RcInteger <- cls = go g (0x80000000) 31 - where - go x 0 i = [] - go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1) - | otherwise = go x (m `shiftR` 1) $! i-1 - -allocateReg :: RegNo -> FreeRegs -> FreeRegs -allocateReg r (FreeRegs g f) - | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32))) - | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f - -#else - --- If we have less than 32 registers, or if we have efficient 64-bit words, --- we will just use a single bitfield. - -#if defined(alpha_TARGET_ARCH) -type FreeRegs = Word64 -#else -type FreeRegs = Word32 -#endif - -noFreeRegs :: FreeRegs -noFreeRegs = 0 - -releaseReg :: RegNo -> FreeRegs -> FreeRegs -releaseReg n f = f .|. (1 `shiftL` n) - -initFreeRegs :: FreeRegs -initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs - -getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly -getFreeRegs cls f = go f 0 - where go 0 m = [] - go n m - | n .&. 1 /= 0 && regClass (RealReg m) == cls - = m : (go (n `shiftR` 1) $! (m+1)) - | otherwise - = go (n `shiftR` 1) $! (m+1) - -- ToDo: there's no point looking through all the integer registers - -- in order to find a floating-point one. - -allocateReg :: RegNo -> FreeRegs -> FreeRegs -allocateReg r f = f .&. complement (1 `shiftL` fromIntegral r) - -#endif - --- ----------------------------------------------------------------------------- --- The assignment of virtual registers to stack slots - --- We have lots of stack slots. Memory-to-memory moves are a pain on most --- architectures. Therefore, we avoid having to generate memory-to-memory moves --- by simply giving every virtual register its own stack slot. - --- The StackMap stack map keeps track of virtual register - stack slot --- associations and of which stack slots are still free. Once it has been --- associated, a stack slot is never "freed" or removed from the StackMap again, --- it remains associated until we are done with the current CmmProc. - -type StackSlot = Int -data StackMap = StackMap [StackSlot] (UniqFM StackSlot) - -emptyStackMap :: StackMap -emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM - -getStackSlotFor :: StackMap -> Unique -> (StackMap,Int) -getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg = - case lookupUFM reserved reg of - Just slot -> (fs,slot) - Nothing -> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot) - --- ----------------------------------------------------------------------------- --- Top level of the register allocator - -regAlloc :: NatCmmTop -> UniqSM NatCmmTop -regAlloc (CmmData sec d) = returnUs $ CmmData sec d -regAlloc (CmmProc info lbl params []) - = returnUs $ CmmProc info lbl params [] -- no blocks to run the regalloc on -regAlloc (CmmProc info lbl params blocks@(first:rest)) - = let - first_id = blockId first - sccs = sccBlocks blocks - (ann_sccs, block_live) = computeLiveness sccs - in linearRegAlloc block_live ann_sccs `thenUs` \final_blocks -> - let ((first':_),rest') = partition ((== first_id) . blockId) final_blocks - in returnUs $ -- pprTrace "Liveness" (ppr block_live) $ - CmmProc info lbl params (first':rest') - -sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock] -sccBlocks blocks = stronglyConnComp graph - where - getOutEdges :: [Instr] -> [BlockId] - getOutEdges instrs = foldr jumpDests [] instrs - - graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) - | block@(BasicBlock id instrs) <- blocks ] - - --- ----------------------------------------------------------------------------- --- Computing liveness - -computeLiveness - :: [SCC NatBasicBlock] - -> ([SCC AnnBasicBlock], -- instructions annotated with list of registers - -- which are "dead after this instruction". - BlockMap RegSet) -- blocks annontated with set of live registers - -- on entry to the block. - - -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer - -- control to earlier ones only. The SCCs returned are in the *opposite* - -- order, which is exactly what we want for the next pass. - -computeLiveness sccs - = livenessSCCs emptyBlockMap [] sccs - where - livenessSCCs - :: BlockMap RegSet - -> [SCC AnnBasicBlock] -- accum - -> [SCC NatBasicBlock] - -> ([SCC AnnBasicBlock], BlockMap RegSet) - - livenessSCCs blockmap done [] = (done, blockmap) - livenessSCCs blockmap done - (AcyclicSCC (BasicBlock block_id instrs) : sccs) = - {- pprTrace "live instrs" (ppr (getUnique block_id) $$ - vcat (map (\(instr,regs) -> docToSDoc (pprInstr instr) $$ ppr regs) instrs')) $ - -} - livenessSCCs blockmap' - (AcyclicSCC (BasicBlock block_id instrs'):done) sccs - where (live,instrs') = liveness emptyUniqSet blockmap [] - (reverse instrs) - blockmap' = addToUFM blockmap block_id live - - livenessSCCs blockmap done - (CyclicSCC blocks : sccs) = - livenessSCCs blockmap' (CyclicSCC blocks':done) sccs - where (blockmap', blocks') - = iterateUntilUnchanged linearLiveness equalBlockMaps - blockmap blocks - - iterateUntilUnchanged - :: (a -> b -> (a,c)) -> (a -> a -> Bool) - -> a -> b - -> (a,c) - - iterateUntilUnchanged f eq a b - = head $ - concatMap tail $ - groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ - iterate (\(a, _) -> f a b) $ - (a, error "RegisterAlloc.livenessSCCs") - - - linearLiveness :: BlockMap RegSet -> [NatBasicBlock] - -> (BlockMap RegSet, [AnnBasicBlock]) - linearLiveness = mapAccumL processBlock - - processBlock blockmap input@(BasicBlock block_id instrs) - = (blockmap', BasicBlock block_id instrs') - where (live,instrs') = liveness emptyUniqSet blockmap [] - (reverse instrs) - blockmap' = addToUFM blockmap block_id live - - -- probably the least efficient way to compare two - -- BlockMaps for equality. - equalBlockMaps a b - = a' == b' - where a' = map f $ ufmToList a - b' = map f $ ufmToList b - f (key,elt) = (key, uniqSetToList elt) - - liveness :: RegSet -- live regs - -> BlockMap RegSet -- live regs on entry to other BBs - -> [(Instr,[Reg],[Reg])] -- instructions (accum) - -> [Instr] -- instructions - -> (RegSet, [(Instr,[Reg],[Reg])]) - - liveness liveregs blockmap done [] = (liveregs, done) - liveness liveregs blockmap done (instr:instrs) - | not_a_branch = liveness liveregs1 blockmap - ((instr,r_dying,w_dying):done) instrs - | otherwise = liveness liveregs_br blockmap - ((instr,r_dying_br,w_dying):done) instrs - where - RU read written = regUsage instr - - -- registers that were written here are dead going backwards. - -- registers that were read here are live going backwards. - liveregs1 = (liveregs `delListFromUniqSet` written) - `addListToUniqSet` read - - -- registers that are not live beyond this point, are recorded - -- as dying here. - r_dying = [ reg | reg <- read, reg `notElem` written, - not (elementOfUniqSet reg liveregs) ] - - w_dying = [ reg | reg <- written, - not (elementOfUniqSet reg liveregs) ] - - -- union in the live regs from all the jump destinations of this - -- instruction. - targets = jumpDests instr [] -- where we go from here - not_a_branch = null targets - - targetLiveRegs target = case lookupUFM blockmap target of - Just ra -> ra - Nothing -> emptyBlockMap - - live_from_branch = unionManyUniqSets (map targetLiveRegs targets) - - liveregs_br = liveregs1 `unionUniqSets` live_from_branch - - -- registers that are live only in the branch targets should - -- be listed as dying here. - live_branch_only = live_from_branch `minusUniqSet` liveregs - r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets` - live_branch_only) - --- ----------------------------------------------------------------------------- --- Linear sweep to allocate registers - -data Loc = InReg {-# UNPACK #-} !RegNo - | InMem {-# UNPACK #-} !Int -- stack slot - | InBoth {-# UNPACK #-} !RegNo - {-# UNPACK #-} !Int -- stack slot - deriving (Eq, Show, Ord) - -{- -A temporary can be marked as living in both a register and memory -(InBoth), for example if it was recently loaded from a spill location. -This makes it cheap to spill (no save instruction required), but we -have to be careful to turn this into InReg if the value in the -register is changed. - -This is also useful when a temporary is about to be clobbered. We -save it in a spill location, but mark it as InBoth because the current -instruction might still want to read it. --} - -#ifdef DEBUG -instance Outputable Loc where - ppr l = text (show l) -#endif - -linearRegAlloc - :: BlockMap RegSet -- live regs on entry to each basic block - -> [SCC AnnBasicBlock] -- instructions annotated with "deaths" - -> UniqSM [NatBasicBlock] -linearRegAlloc block_live sccs = linearRA_SCCs emptyBlockMap emptyStackMap sccs - where - linearRA_SCCs - :: BlockAssignment - -> StackMap - -> [SCC AnnBasicBlock] - -> UniqSM [NatBasicBlock] - linearRA_SCCs block_assig stack [] = returnUs [] - linearRA_SCCs block_assig stack - (AcyclicSCC (BasicBlock id instrs) : sccs) - = getUs `thenUs` \us -> - let - (block_assig',stack',(instrs',fixups)) = - case lookupUFM block_assig id of - -- no prior info about this block: assume everything is - -- free and the assignment is empty. - Nothing -> - runR block_assig initFreeRegs - emptyRegMap stack us $ - linearRA [] [] instrs - Just (freeregs,assig) -> - runR block_assig freeregs assig stack us $ - linearRA [] [] instrs - in - linearRA_SCCs block_assig' stack' sccs `thenUs` \moreBlocks -> - returnUs $ BasicBlock id instrs' : fixups ++ moreBlocks - - linearRA_SCCs block_assig stack - (CyclicSCC blocks : sccs) - = getUs `thenUs` \us -> - let - ((block_assig', stack', _), blocks') = mapAccumL processBlock - (block_assig, stack, us) - ({-reverse-} blocks) - in - linearRA_SCCs block_assig' stack' sccs `thenUs` \moreBlocks -> - returnUs $ concat blocks' ++ moreBlocks - where - processBlock (block_assig, stack, us0) (BasicBlock id instrs) - = ((block_assig', stack', us'), BasicBlock id instrs' : fixups) - where - (us, us') = splitUniqSupply us0 - (block_assig',stack',(instrs',fixups)) = - case lookupUFM block_assig id of - -- no prior info about this block: assume everything is - -- free and the assignment is empty. - Nothing -> - runR block_assig initFreeRegs - emptyRegMap stack us $ - linearRA [] [] instrs - Just (freeregs,assig) -> - runR block_assig freeregs assig stack us $ - linearRA [] [] instrs - - linearRA :: [Instr] -> [NatBasicBlock] -> [(Instr,[Reg],[Reg])] - -> RegM ([Instr], [NatBasicBlock]) - linearRA instr_acc fixups [] = - return (reverse instr_acc, fixups) - linearRA instr_acc fixups (instr:instrs) = do - (instr_acc', new_fixups) <- raInsn block_live instr_acc instr - linearRA instr_acc' (new_fixups++fixups) instrs - --- ----------------------------------------------------------------------------- --- Register allocation for a single instruction - -type BlockAssignment = BlockMap (FreeRegs, RegMap Loc) - -raInsn :: BlockMap RegSet -- Live temporaries at each basic block - -> [Instr] -- new instructions (accum.) - -> (Instr,[Reg],[Reg]) -- the instruction (with "deaths") - -> RegM ( - [Instr], -- new instructions - [NatBasicBlock] -- extra fixup blocks - ) - -raInsn block_live new_instrs (instr@(DELTA n), _, _) = do - setDeltaR n - return (new_instrs, []) - -raInsn block_live new_instrs (instr, r_dying, w_dying) = do - assig <- getAssigR - - -- If we have a reg->reg move between virtual registers, where the - -- src register is not live after this instruction, and the dst - -- register does not already have an assignment, - -- and the source register is assigned to a register, not to a spill slot, - -- then we can eliminate the instruction. - -- (we can't eliminitate it if the source register is on the stack, because - -- we do not want to use one spill slot for different virtual registers) - case isRegRegMove instr of - Just (src,dst) | src `elem` r_dying, - isVirtualReg dst, - not (dst `elemUFM` assig), - Just (InReg _) <- (lookupUFM assig src) -> do - case src of - RealReg i -> setAssigR (addToUFM assig dst (InReg i)) - -- if src is a fixed reg, then we just map dest to this - -- reg in the assignment. src must be an allocatable reg, - -- otherwise it wouldn't be in r_dying. - _virt -> case lookupUFM assig src of - Nothing -> panic "raInsn" - Just loc -> - setAssigR (addToUFM (delFromUFM assig src) dst loc) - - -- we have elimianted this instruction - {- - freeregs <- getFreeRegsR - assig <- getAssigR - pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do - -} - return (new_instrs, []) - - other -> genRaInsn block_live new_instrs instr r_dying w_dying - - -genRaInsn block_live new_instrs instr r_dying w_dying = - case regUsage instr of { RU read written -> - case partition isRealReg written of { (real_written1,virt_written) -> - do - let - real_written = [ r | RealReg r <- real_written1 ] - - -- we don't need to do anything with real registers that are - -- only read by this instr. (the list is typically ~2 elements, - -- so using nub isn't a problem). - virt_read = nub (filter isVirtualReg read) - -- in - - -- (a) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps real_written r_dying - - {- - freeregs <- getFreeRegsR - assig <- getAssigR - pprTrace "raInsn" (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written $$ text (show freeregs) $$ ppr assig) $ do - -} - - -- (b), (c) allocate real regs for all regs read by this instruction. - (r_spills, r_allocd) <- - allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read - - -- (d) Update block map for new destinations - -- NB. do this before removing dead regs from the assignment, because - -- these dead regs might in fact be live in the jump targets (they're - -- only dead in the code that follows in the current basic block). - (fixup_blocks, adjusted_instr) - <- joinToTargets block_live [] instr (jumpDests instr []) - - -- (e) Delete all register assignments for temps which are read - -- (only) and die here. Update the free register list. - releaseRegs r_dying - - -- (f) Mark regs which are clobbered as unallocatable - clobberRegs real_written - - -- (g) Allocate registers for temporaries *written* (only) - (w_spills, w_allocd) <- - allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written - - -- (h) Release registers for temps which are written here and not - -- used again. - releaseRegs w_dying - - let - -- (i) Patch the instruction - patch_map = listToUFM [ (t,RealReg r) | - (t,r) <- zip virt_read r_allocd - ++ zip virt_written w_allocd ] - - patched_instr = patchRegs adjusted_instr patchLookup - patchLookup x = case lookupUFM patch_map x of - Nothing -> x - Just y -> y - -- in - - -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do - - -- (j) free up stack slots for dead spilled regs - -- TODO (can't be bothered right now) - - return (patched_instr : w_spills ++ reverse r_spills - ++ clobber_saves ++ new_instrs, - fixup_blocks) - }} - --- ----------------------------------------------------------------------------- --- releaseRegs - -releaseRegs regs = do - assig <- getAssigR - free <- getFreeRegsR - loop assig free regs - where - loop assig free _ | free `seq` False = undefined - loop assig free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs - loop assig free (r:rs) = - case lookupUFM assig r of - Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs - Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs - _other -> loop (delFromUFM assig r) free rs - --- ----------------------------------------------------------------------------- --- Clobber real registers - -{- -For each temp in a register that is going to be clobbered: - - if the temp dies after this instruction, do nothing - - otherwise, put it somewhere safe (another reg if possible, - otherwise spill and record InBoth in the assignment). - -for allocateRegs on the temps *read*, - - clobbered regs are allocatable. - -for allocateRegs on the temps *written*, - - clobbered regs are not allocatable. --} - -saveClobberedTemps - :: [RegNo] -- real registers clobbered by this instruction - -> [Reg] -- registers which are no longer live after this insn - -> RegM [Instr] -- return: instructions to spill any temps that will - -- be clobbered. - -saveClobberedTemps [] _ = return [] -- common case -saveClobberedTemps clobbered dying = do - assig <- getAssigR - let - to_spill = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig, - reg `elem` clobbered, - temp `notElem` map getUnique dying ] - -- in - (instrs,assig') <- clobber assig [] to_spill - setAssigR assig' - return instrs - where - clobber assig instrs [] = return (instrs,assig) - clobber assig instrs ((temp,reg):rest) - = do - --ToDo: copy it to another register if possible - (spill,slot) <- spillR (RealReg reg) temp - clobber (addToUFM assig temp (InBoth reg slot)) (spill:instrs) rest - -clobberRegs :: [RegNo] -> RegM () -clobberRegs [] = return () -- common case -clobberRegs clobbered = do - freeregs <- getFreeRegsR - setFreeRegsR $! foldr allocateReg freeregs clobbered - assig <- getAssigR - setAssigR $! clobber assig (ufmToList assig) - where - -- if the temp was InReg and clobbered, then we will have - -- saved it in saveClobberedTemps above. So the only case - -- we have to worry about here is InBoth. Note that this - -- also catches temps which were loaded up during allocation - -- of read registers, not just those saved in saveClobberedTemps. - clobber assig [] = assig - clobber assig ((temp, InBoth reg slot) : rest) - | reg `elem` clobbered - = clobber (addToUFM assig temp (InMem slot)) rest - clobber assig (entry:rest) - = clobber assig rest - --- ----------------------------------------------------------------------------- --- allocateRegsAndSpill - --- This function does several things: --- For each temporary referred to by this instruction, --- we allocate a real register (spilling another temporary if necessary). --- We load the temporary up from memory if necessary. --- We also update the register assignment in the process, and --- the list of free registers and free stack slots. - -allocateRegsAndSpill - :: Bool -- True <=> reading (load up spilled regs) - -> [Reg] -- don't push these out - -> [Instr] -- spill insns - -> [RegNo] -- real registers allocated (accum.) - -> [Reg] -- temps to allocate - -> RegM ([Instr], [RegNo]) - -allocateRegsAndSpill reading keep spills alloc [] - = return (spills,reverse alloc) - -allocateRegsAndSpill reading keep spills alloc (r:rs) = do - assig <- getAssigR - case lookupUFM assig r of - -- case (1a): already in a register - Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignemnt to be - -- InReg, because the memory value is no longer valid. - -- NB2. This is why we must process written registers here, even if they - -- are also read by the same instruction. - Just (InBoth my_reg mem) -> do - when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- Not already in a register, so we need to find a free one... - loc -> do - freeregs <- getFreeRegsR - - case getFreeRegs (regClass r) freeregs of - - -- case (2): we have a free register - my_reg:_ -> do - spills' <- do_load reading loc my_reg spills - let new_loc - | Just (InMem slot) <- loc, reading = InBoth my_reg slot - | otherwise = InReg my_reg - setAssigR (addToUFM assig r $! new_loc) - setFreeRegsR (allocateReg my_reg freeregs) - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- case (3): we need to push something out to free up a register - [] -> do - let - keep' = map getUnique keep - candidates1 = [ (temp,reg,mem) - | (temp, InBoth reg mem) <- ufmToList assig, - temp `notElem` keep', regClass (RealReg reg) == regClass r ] - candidates2 = [ (temp,reg) - | (temp, InReg reg) <- ufmToList assig, - temp `notElem` keep', regClass (RealReg reg) == regClass r ] - -- in - ASSERT2(not (null candidates1 && null candidates2), - text (show freeregs) <+> ppr r <+> ppr assig) do - - case candidates1 of - - -- we have a temporary that is in both register and mem, - -- just free up its register for use. - -- - (temp,my_reg,slot):_ -> do - spills' <- do_load reading loc my_reg spills - let - assig1 = addToUFM assig temp (InMem slot) - assig2 = addToUFM assig1 r (InReg my_reg) - -- in - setAssigR assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- otherwise, we need to spill a temporary that currently - -- resides in a register. - [] -> do - let - (temp_to_push_out, my_reg) = myHead "regalloc" candidates2 - -- TODO: plenty of room for optimisation in choosing which temp - -- to spill. We just pick the first one that isn't used in - -- the current instruction for now. - -- in - (spill_insn,slot) <- spillR (RealReg my_reg) temp_to_push_out - let - assig1 = addToUFM assig temp_to_push_out (InMem slot) - assig2 = addToUFM assig1 r (InReg my_reg) - -- in - setAssigR assig2 - spills' <- do_load reading loc my_reg spills - allocateRegsAndSpill reading keep (spill_insn:spills') - (my_reg:alloc) rs - where - -- load up a spilled temporary if we need to - do_load True (Just (InMem slot)) reg spills = do - insn <- loadR (RealReg reg) slot - return (insn : spills) - do_load _ _ _ spills = - return spills - -myHead s [] = panic s -myHead s (x:xs) = x - --- ----------------------------------------------------------------------------- --- Joining a jump instruction to its targets - --- The first time we encounter a jump to a particular basic block, we --- record the assignment of temporaries. The next time we encounter a --- jump to the same block, we compare our current assignment to the --- stored one. They might be different if spilling has occrred in one --- branch; so some fixup code will be required to match up the --- assignments. - -joinToTargets - :: BlockMap RegSet - -> [NatBasicBlock] - -> Instr - -> [BlockId] - -> RegM ([NatBasicBlock], Instr) - -joinToTargets block_live new_blocks instr [] - = return (new_blocks, instr) -joinToTargets block_live new_blocks instr (dest:dests) = do - block_assig <- getBlockAssigR - assig <- getAssigR - let - -- adjust the assignment to remove any registers which are not - -- live on entry to the destination block. - adjusted_assig = filterUFM_Directly still_live assig - still_live uniq _ = uniq `elemUniqSet_Directly` live_set - - -- and free up those registers which are now free. - to_free = - [ r | (reg, loc) <- ufmToList assig, - not (elemUniqSet_Directly reg live_set), - r <- regsOfLoc loc ] - - regsOfLoc (InReg r) = [r] - regsOfLoc (InBoth r _) = [r] - regsOfLoc (InMem _) = [] - -- in - case lookupUFM block_assig dest of - -- Nothing <=> this is the first time we jumped to this - -- block. - Nothing -> do - freeregs <- getFreeRegsR - let freeregs' = foldr releaseReg freeregs to_free - setBlockAssigR (addToUFM block_assig dest - (freeregs',adjusted_assig)) - joinToTargets block_live new_blocks instr dests - - Just (freeregs,dest_assig) - | ufmToList dest_assig == ufmToList adjusted_assig - -> -- ok, the assignments match - joinToTargets block_live new_blocks instr dests - | otherwise - -> -- need fixup code - do - delta <- getDeltaR - -- Construct a graph of register/spill movements and - -- untangle it component by component. - -- - -- We cut some corners by - -- a) not handling cyclic components - -- b) not handling memory-to-memory moves. - -- - -- Cyclic components seem to occur only very rarely, - -- and we don't need memory-to-memory moves because we - -- make sure that every temporary always gets its own - -- stack slot. - - let graph = [ node | (vreg, src) <- ufmToList adjusted_assig, - node <- mkNodes src vreg ] - - sccs = stronglyConnCompR graph - - mkNodes src vreg = - expandNode vreg src (lookupWithDefaultUFM_Directly - dest_assig - (panic "RegisterAlloc.joinToTargets") - vreg) - - -- The InBoth handling is a little tricky here. If - -- the destination is InBoth, then we must ensure that - -- the value ends up in both locations. An InBoth - -- destination must conflict with an InReg or InMem - -- source, so we expand an InBoth destination as - -- necessary. An InBoth source is slightly different: - -- we only care about the register that the source value - -- is in, so that we can move it to the destinations. - - expandNode vreg loc@(InReg src) (InBoth dst mem) - | src == dst = [(vreg, loc, [InMem mem])] - | otherwise = [(vreg, loc, [InReg dst, InMem mem])] - expandNode vreg loc@(InMem src) (InBoth dst mem) - | src == mem = [(vreg, loc, [InReg dst])] - | otherwise = [(vreg, loc, [InReg dst, InMem mem])] - expandNode vreg loc@(InBoth _ src) (InMem dst) - | src == dst = [] -- guaranteed to be true - expandNode vreg loc@(InBoth src _) (InReg dst) - | src == dst = [] - expandNode vreg loc@(InBoth src _) dst - = expandNode vreg (InReg src) dst - expandNode vreg src dst - | src == dst = [] - | otherwise = [(vreg, src, [dst])] - - -- we have eliminated any possibility of single-node cylces - -- in expandNode above. - handleComponent (AcyclicSCC (vreg,src,dsts)) - = return $ map (makeMove vreg src) dsts - - -- we can not have cycles that involve memory - -- locations as source nor as single destination - -- because memory locations (stack slots) are - -- allocated exclusively for a virtual register and - -- therefore can not require a fixup - handleComponent (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest)) - = do - spill_id <- getUniqueR - (saveInstr,slot) <- spillR (RealReg sreg) spill_id - remainingFixUps <- mapM handleComponent (stronglyConnCompR rest) - restoreAndFixInstr <- getRestoreMoves dsts slot - return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr) - where - getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot - = do - restoreToReg <- loadR (RealReg reg) slot - return $ [restoreToReg, makeMove vreg r mem] - getRestoreMoves [InReg reg] slot - = loadR (RealReg reg) slot >>= return . (:[]) - getRestoreMoves [InMem _] _ = panic "getRestoreMoves can not handle memory only restores" - getRestoreMoves _ _ = panic "getRestoreMoves unknown case" - handleComponent (CyclicSCC _) - = panic "Register Allocator: handleComponent cyclic" - makeMove vreg (InReg src) (InReg dst) - = mkRegRegMoveInstr (RealReg src) (RealReg dst) - makeMove vreg (InMem src) (InReg dst) - = mkLoadInstr (RealReg dst) delta src - makeMove vreg (InReg src) (InMem dst) - = mkSpillInstr (RealReg src) delta dst - makeMove vreg src dst - = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" - ++ show dst ++ ")" - ++ " (workaround: use -fviaC)" - - block_id <- getUniqueR - fixUpInstrs <- mapM handleComponent sccs - let block = BasicBlock (BlockId block_id) $ - concat fixUpInstrs ++ mkBranchInstr dest - let instr' = patchJump instr dest (BlockId block_id) - joinToTargets block_live (block : new_blocks) instr' dests - where - live_set = lookItUp "joinToTargets" block_live dest - --- ----------------------------------------------------------------------------- --- The register allocator's monad. - --- Here we keep all the state that the register allocator keeps track --- of as it walks the instructions in a basic block. - -data RA_State - = RA_State { - ra_blockassig :: BlockAssignment, - -- The current mapping from basic blocks to - -- the register assignments at the beginning of that block. - ra_freeregs :: {-#UNPACK#-}!FreeRegs, -- free machine registers - ra_assig :: RegMap Loc, -- assignment of temps to locations - ra_delta :: Int, -- current stack delta - ra_stack :: StackMap, -- free stack slots for spilling - ra_us :: UniqSupply -- unique supply for generating names - -- for fixup blocks. - } - -newtype RegM a = RegM { unReg :: RA_State -> (# RA_State, a #) } - -instance Monad RegM where - m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s } - return a = RegM $ \s -> (# s, a #) - -runR :: BlockAssignment -> FreeRegs -> RegMap Loc -> StackMap -> UniqSupply - -> RegM a -> (BlockAssignment, StackMap, a) -runR block_assig freeregs assig stack us thing = - case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs, - ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack, - ra_us = us }) of - (# RA_State{ ra_blockassig=block_assig, ra_stack=stack' }, returned_thing #) - -> (block_assig, stack', returned_thing) - -spillR :: Reg -> Unique -> RegM (Instr, Int) -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> - let (stack',slot) = getStackSlotFor stack temp - instr = mkSpillInstr reg delta slot - in - (# s{ra_stack=stack'}, (instr,slot) #) - -loadR :: Reg -> Int -> RegM Instr -loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - (# s, mkLoadInstr reg delta slot #) - -getFreeRegsR :: RegM FreeRegs -getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> - (# s, freeregs #) - -setFreeRegsR :: FreeRegs -> RegM () -setFreeRegsR regs = RegM $ \ s -> - (# s{ra_freeregs = regs}, () #) - -getAssigR :: RegM (RegMap Loc) -getAssigR = RegM $ \ s@RA_State{ra_assig = assig} -> - (# s, assig #) - -setAssigR :: RegMap Loc -> RegM () -setAssigR assig = RegM $ \ s -> - (# s{ra_assig=assig}, () #) - -getBlockAssigR :: RegM BlockAssignment -getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} -> - (# s, assig #) - -setBlockAssigR :: BlockAssignment -> RegM () -setBlockAssigR assig = RegM $ \ s -> - (# s{ra_blockassig = assig}, () #) - -setDeltaR :: Int -> RegM () -setDeltaR n = RegM $ \ s -> - (# s{ra_delta = n}, () #) - -getDeltaR :: RegM Int -getDeltaR = RegM $ \s -> (# s, ra_delta s #) - -getUniqueR :: RegM Unique -getUniqueR = RegM $ \s -> - case splitUniqSupply (ra_us s) of - (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #) - --- ----------------------------------------------------------------------------- --- Utils - -#ifdef DEBUG -my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p -my_fromJust s p (Just x) = x -#else -my_fromJust _ _ = fromJust -#endif - -lookItUp :: Uniquable b => String -> UniqFM a -> b -> a -lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)