import RegAlloc.Linear.StackMap
import RegAlloc.Linear.FreeRegs
import RegAlloc.Linear.Stats
+import RegAlloc.Linear.JoinToTargets
+import TargetReg
+import RegAlloc.Liveness
+import Instruction
+import Reg
+
+-- import PprMach
import BlockId
-import MachRegs
-import MachInstrs
-import RegAllocInfo
-import RegLiveness
import Cmm hiding (RegSet)
import Digraph
-import Unique ( Uniquable(getUnique), Unique )
+import Unique
import UniqSet
import UniqFM
import UniqSupply
import Outputable
-import FastString
import Data.Maybe
import Data.List
-- Allocate registers
regAlloc
- :: LiveCmmTop
- -> UniqSM (NatCmmTop, Maybe RegAllocStats)
+ :: (Outputable instr, Instruction instr)
+ => LiveCmmTop instr
+ -> UniqSM (NatCmmTop instr, Maybe RegAllocStats)
regAlloc (CmmData sec d)
= return
-- an entry in the block map or it is the first block.
--
linearRegAlloc
- :: BlockId -- ^ the first block
+ :: (Outputable instr, Instruction instr)
+ => BlockId -- ^ the first block
-> BlockMap RegSet -- ^ live regs on entry to each basic block
- -> [SCC LiveBasicBlock] -- ^ instructions annotated with "deaths"
- -> UniqSM ([NatBasicBlock], RegAllocStats)
+ -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
+ -> UniqSM ([NatBasicBlock instr], RegAllocStats)
linearRegAlloc first_id block_live sccs
= do us <- getUs
sccs
linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
- = do let process [] [] accum = return $ reverse accum
- process [] next_round accum = process next_round [] accum
- process (b@(BasicBlock id _) : blocks) next_round accum =
- do block_assig <- getBlockAssigR
- if isJust (lookupBlockEnv block_assig id) || id == first_id
- then do b' <- processBlock block_live b
- process blocks next_round (b' : accum)
- else process blocks (b : next_round) accum
- blockss' <- process blocks [] (return [])
+ = do
+ blockss' <- process first_id block_live blocks [] (return [])
linearRA_SCCs first_id block_live
(reverse (concat blockss') ++ blocksAcc)
sccs
+
+{- from John Dias's patch 2008/10/16:
+ The linear-scan allocator sometimes allocates a block
+ before allocating one of its predecessors, which could lead to
+ inconsistent allocations. Make it so a block is only allocated
+ if a predecessor has set the "incoming" assignments for the block, or
+ if it's the procedure's entry block.
+
+ BL 2009/02: Careful. If the assignment for a block doesn't get set for
+ some reason then this function will loop. We should probably do some
+ more sanity checking to guard against this eventuality.
+-}
+process _ _ [] [] accum
+ = return $ reverse accum
+
+process first_id block_live [] next_round accum
+ = process first_id block_live next_round [] accum
+
+process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum
+ = do
+ block_assig <- getBlockAssigR
+
+ if isJust (lookupBlockEnv block_assig id)
+ || id == first_id
+ then do
+ b' <- processBlock block_live b
+ process first_id block_live blocks next_round (b' : accum)
+
+ else process first_id block_live blocks (b : next_round) accum
+
-- | Do register allocation on this basic block
--
processBlock
- :: BlockMap RegSet -- ^ live regs on entry to each basic block
- -> LiveBasicBlock -- ^ block to do register allocation on
- -> RegM [NatBasicBlock] -- ^ block with registers allocated
+ :: (Outputable instr, Instruction instr)
+ => BlockMap RegSet -- ^ live regs on entry to each basic block
+ -> LiveBasicBlock instr -- ^ block to do register allocation on
+ -> RegM [NatBasicBlock instr] -- ^ block with registers allocated
processBlock block_live (BasicBlock id instrs)
= do initBlock id
(instrs', fixups)
- <- linearRA block_live [] [] instrs
-
+ <- linearRA block_live [] [] id instrs
return $ BasicBlock id instrs' : fixups
setAssigR assig
+-- | Do allocation for a sequence of instructions.
linearRA
- :: BlockMap RegSet
- -> [Instr] -> [NatBasicBlock] -> [LiveInstr]
- -> RegM ([Instr], [NatBasicBlock])
+ :: (Outputable instr, Instruction instr)
+ => BlockMap RegSet -- ^ map of what vregs are live on entry to each block.
+ -> [instr] -- ^ accumulator for instructions already processed.
+ -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code.
+ -> BlockId -- ^ id of the current block, for debugging.
+ -> [LiveInstr instr] -- ^ liveness annotated instructions in this block.
-linearRA _ instr_acc fixups []
- = return (reverse instr_acc, fixups)
+ -> RegM ( [instr] -- instructions after register allocation
+ , [NatBasicBlock instr]) -- fresh blocks of fixup code.
-linearRA block_live instr_acc fixups (instr:instrs)
- = do (instr_acc', new_fixups) <- raInsn block_live instr_acc instr
- linearRA block_live instr_acc' (new_fixups++fixups) instrs
--- -----------------------------------------------------------------------------
--- Register allocation for a single instruction
-
-raInsn :: BlockMap RegSet -- Live temporaries at each basic block
- -> [Instr] -- new instructions (accum.)
- -> LiveInstr -- the instruction (with "deaths")
- -> RegM (
- [Instr], -- new instructions
- [NatBasicBlock] -- extra fixup blocks
- )
+linearRA _ accInstr accFixup _ []
+ = return
+ ( reverse accInstr -- instrs need to be returned in the correct order.
+ , accFixup) -- it doesn't matter what order the fixup blocks are returned in.
-raInsn _ new_instrs (Instr (COMMENT _) Nothing)
- = return (new_instrs, [])
-raInsn _ new_instrs (Instr (DELTA n) Nothing)
+linearRA block_live accInstr accFixups id (instr:instrs)
= do
- setDeltaR n
- return (new_instrs, [])
+ (accInstr', new_fixups)
+ <- raInsn block_live accInstr id instr
+
+ linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
-raInsn block_live new_instrs (Instr instr (Just live))
+
+-- | Do allocation for a single instruction.
+raInsn
+ :: (Outputable instr, Instruction instr)
+ => BlockMap RegSet -- ^ map of what vregs are love on entry to each block.
+ -> [instr] -- ^ accumulator for instructions already processed.
+ -> BlockId -- ^ the id of the current block, for debugging
+ -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info.
+ -> RegM
+ ( [instr] -- new instructions
+ , [NatBasicBlock instr]) -- extra fixup blocks
+
+raInsn _ new_instrs _ (Instr ii Nothing)
+ | Just n <- takeDeltaInstr ii
+ = do setDeltaR n
+ return (new_instrs, [])
+
+raInsn _ new_instrs _ (Instr ii Nothing)
+ | isMetaInstr ii
+ = return (new_instrs, [])
+
+
+raInsn block_live new_instrs id (Instr instr (Just live))
= do
assig <- getAssigR
-- 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
+ case takeRegRegMoveInstr instr of
Just (src,dst) | src `elementOfUniqSet` (liveDieRead live),
isVirtualReg dst,
not (dst `elemUFM` assig),
{-
freeregs <- getFreeRegsR
assig <- getAssigR
- pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
+ pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
+ $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
-}
return (new_instrs, [])
- _ -> genRaInsn block_live new_instrs instr
+ _ -> genRaInsn block_live new_instrs id instr
(uniqSetToList $ liveDieRead live)
(uniqSetToList $ liveDieWrite live)
-raInsn _ _ li
- = pprPanic "raInsn" (text "no match for:" <> ppr li)
+raInsn _ _ _ instr
+ = pprPanic "raInsn" (text "no match for:" <> ppr instr)
+
+
-genRaInsn block_live new_instrs instr r_dying w_dying =
- case regUsage instr of { RU read written ->
+genRaInsn block_live new_instrs block_id instr r_dying w_dying =
+ case regUsageOfInstr instr of { RU read written ->
case partition isRealReg written of { (real_written1,virt_written) ->
do
let
clobber_saves <- saveClobberedTemps real_written r_dying
-{- freeregs <- getFreeRegsR
- assig <- getAssigR
- pprTrace "raInsn"
+{- freeregs <- getFreeRegsR
+ assig <- getAssigR
+ pprTrace "genRaInsn"
(docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written
$$ text (show freeregs) $$ ppr assig)
$ do
-- 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 [])
+ <- joinToTargets block_live block_id instr
-- (e) Delete all register assignments for temps which are read
-- (only) and die here. Update the free register list.
(t,r) <- zip virt_read r_allocd
++ zip virt_written w_allocd ]
- patched_instr = patchRegs adjusted_instr patchLookup
+ patched_instr = patchRegsOfInstr adjusted_instr patchLookup
patchLookup x = case lookupUFM patch_map x of
Nothing -> x
Just y -> y
-- in
- -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do
+-- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do
-- (j) free up stack slots for dead spilled regs
-- TODO (can't be bothered right now)
-- erase reg->reg moves where the source and destination are the same.
-- If the src temp didn't die in this instr but happened to be allocated
-- to the same real reg as the destination, then we can erase the move anyway.
- squashed_instr = case isRegRegMove patched_instr of
+ let squashed_instr = case takeRegRegMoveInstr patched_instr of
Just (src, dst)
| src == dst -> []
_ -> [patched_instr]
- return (squashed_instr ++ w_spills ++ reverse r_spills
- ++ clobber_saves ++ new_instrs,
- fixup_blocks)
+ let code = squashed_instr ++ w_spills ++ reverse r_spills
+ ++ clobber_saves ++ new_instrs
+
+-- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
+-- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
+
+ return (code, fixup_blocks)
+
}}
-- -----------------------------------------------------------------------------
-}
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.
+ :: Instruction instr
+ => [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
recordSpill (SpillClobber temp)
let new_assign = addToUFM assig temp (InBoth reg slot)
- clobber new_assign (spill : COMMENT (fsLit "spill clobber") : instrs) rest
+ clobber new_assign (spill : {- COMMENT (fsLit "spill clobber") : -} instrs) rest
clobberRegs :: [RegNo] -> RegM ()
clobberRegs [] = return () -- common case
-- the list of free registers and free stack slots.
allocateRegsAndSpill
- :: Bool -- True <=> reading (load up spilled regs)
+ :: Instruction instr
+ => Bool -- True <=> reading (load up spilled regs)
-> [Reg] -- don't push these out
- -> [Instr] -- spill insns
+ -> [instr] -- spill insns
-> [RegNo] -- real registers allocated (accum.)
-> [Reg] -- temps to allocate
- -> RegM ([Instr], [RegNo])
+ -> RegM ([instr], [RegNo])
allocateRegsAndSpill _ _ spills alloc []
= return (spills,reverse alloc)
loc -> do
freeregs <- getFreeRegsR
- case getFreeRegs (regClass r) freeregs of
+ case getFreeRegs (targetRegClass r) freeregs of
-- case (2): we have a free register
my_reg:_ -> {- pprTrace "alloc" (ppr r <+> ppr my_reg <+> ppr freeClass) $ -}
keep' = map getUnique keep
candidates1 = [ (temp,reg,mem)
| (temp, InBoth reg mem) <- ufmToList assig,
- temp `notElem` keep', regClass (RealReg reg) == regClass r ]
+ temp `notElem` keep', targetRegClass (RealReg reg) == targetRegClass r ]
candidates2 = [ (temp,reg)
| (temp, InReg reg) <- ufmToList assig,
- temp `notElem` keep', regClass (RealReg reg) == regClass r ]
+ temp `notElem` keep', targetRegClass (RealReg reg) == targetRegClass r ]
-- in
ASSERT2(not (null candidates1 && null candidates2),
text (show freeregs) <+> ppr r <+> ppr assig) do
(spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out
let spill_store = (if reading then id else reverse)
- [ COMMENT (fsLit "spill alloc")
- , spill_insn ]
+ [ -- COMMENT (fsLit "spill alloc")
+ spill_insn ]
-- record that this temp was spilled
recordSpill (SpillAlloc temp_to_push_out)
-- | Load up a spilled temporary if we need to.
loadTemp
- :: Bool
+ :: Instruction instr
+ => Bool
-> Reg -- the temp being loaded
-> Maybe Loc -- the current location of this temp
-> RegNo -- the hreg to load the temp into
- -> [Instr]
- -> RegM [Instr]
+ -> [instr]
+ -> RegM [instr]
loadTemp True vreg (Just (InMem slot)) hreg spills
= do
insn <- loadR (RealReg hreg) slot
recordSpill (SpillLoad $ getUnique vreg)
- return $ COMMENT (fsLit "spill load") : insn : spills
+ return $ {- COMMENT (fsLit "spill load") : -} insn : spills
loadTemp _ _ _ _ spills =
return spills
-
--- -----------------------------------------------------------------------------
--- 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 _ 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
-
- live_set = lookItUp "joinToTargets" block_live dest
- 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 lookupBlockEnv 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 (extendBlockEnv block_assig dest
- (freeregs',adjusted_assig))
- joinToTargets block_live new_blocks instr dests
-
- Just (_, dest_assig)
-
- -- the assignments match
- | ufmToList dest_assig == ufmToList adjusted_assig
- -> joinToTargets block_live new_blocks instr dests
-
- -- need fixup code
- | otherwise
- -> do
- delta <- getDeltaR
-
- let graph = makeRegMovementGraph adjusted_assig dest_assig
- let sccs = stronglyConnCompFromEdgedVerticesR graph
- fixUpInstrs <- mapM (handleComponent delta instr) sccs
-
- block_id <- getUniqueR
- 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
-
-
--- | Construct a graph of register\/spill movements.
---
--- 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.
-
-makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])]
-makeRegMovementGraph adjusted_assig dest_assig
- = let
- mkNodes src vreg
- = expandNode vreg src
- $ lookupWithDefaultUFM_Directly
- dest_assig
- (panic "RegAllocLinear.makeRegMovementGraph")
- vreg
-
- in [ node | (vreg, src) <- ufmToList adjusted_assig
- , node <- mkNodes src 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 _ (InBoth _ src) (InMem dst)
- | src == dst = [] -- guaranteed to be true
-
-expandNode _ (InBoth src _) (InReg dst)
- | src == dst = []
-
-expandNode vreg (InBoth src _) dst
- = expandNode vreg (InReg src) dst
-
-expandNode vreg src dst
- | src == dst = []
- | otherwise = [(vreg, src, [dst])]
-
-
--- | Make a move instruction between these two locations so we
--- can join together allocations for different basic blocks.
---
-makeMove :: Int -> Unique -> Loc -> Loc -> RegM Instr
-makeMove _ vreg (InReg src) (InReg dst)
- = do recordSpill (SpillJoinRR vreg)
- return $ mkRegRegMoveInstr (RealReg src) (RealReg dst)
-
-makeMove delta vreg (InMem src) (InReg dst)
- = do recordSpill (SpillJoinRM vreg)
- return $ mkLoadInstr (RealReg dst) delta src
-
-makeMove delta vreg (InReg src) (InMem dst)
- = do recordSpill (SpillJoinRM vreg)
- return $ mkSpillInstr (RealReg src) delta dst
-
-makeMove _ vreg src dst
- = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
- ++ show dst ++ ")"
- ++ " (workaround: use -fviaC)"
-
-
--- we have eliminated any possibility of single-node cylces
--- in expandNode above.
-handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr]
-handleComponent delta _ (AcyclicSCC (vreg,src,dsts))
- = mapM (makeMove delta 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 delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
- = do
- spill_id <- getUniqueR
- (_, slot) <- spillR (RealReg sreg) spill_id
- remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest)
- restoreAndFixInstr <- getRestoreMoves dsts slot
- return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
-
- where
- getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot
- = do
- restoreToReg <- loadR (RealReg reg) slot
- moveInstr <- makeMove delta vreg r mem
- return $ [COMMENT (fsLit "spill join move"), restoreToReg, moveInstr]
-
- 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"
-
-
-
--- -----------------------------------------------------------------------------
--- Utils
-
-my_fromJust :: String -> SDoc -> Maybe a -> a
-my_fromJust _ _ (Just x) = x
-my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
-
-lookItUp :: String -> BlockMap a -> BlockId -> a
-lookItUp str fm x = my_fromJust str (ppr x) (lookupBlockEnv fm x)
projects / ghc-hetmet.git / blobdiff