+{-# OPTIONS -fno-warn-missing-signatures #-}
-----------------------------------------------------------------------------
--
-- The register allocator
-}
module RegAllocLinear (
- regAlloc,
+ regAlloc,
+ RegAllocStats, pprStats
) where
#include "HsVersions.h"
import MachInstrs
import RegAllocInfo
import RegLiveness
-import Cmm
+import Cmm hiding (RegSet)
import Digraph
import Unique ( Uniquable(getUnique), Unique )
import UniqFM
import UniqSupply
import Outputable
+import State
-#ifndef DEBUG
-import Data.Maybe ( fromJust )
-#endif
-import Data.List ( nub, partition, mapAccumL)
-import Control.Monad ( when )
+import Data.Maybe
+import Data.List
+import Control.Monad
import Data.Word
import Data.Bits
getFreeRegs cls (FreeRegs g f)
| RcDouble <- cls = go f (0x80000000) 63
| RcInteger <- cls = go g (0x80000000) 31
+ | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad cls" (ppr cls)
where
- go x 0 i = []
+ go _ 0 _ = []
go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
| otherwise = go x (m `shiftR` 1) $! i-1
getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
getFreeRegs cls f = go f 0
- where go 0 m = []
+ where go 0 _ = []
go n m
| n .&. 1 /= 0 && regClass (RealReg m) == cls
= m : (go (n `shiftR` 1) $! (m+1))
emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
-getStackSlotFor fs@(StackMap [] reserved) reg
- = panic "RegAllocLinear.getStackSlotFor: out of stack slots"
+getStackSlotFor (StackMap [] _) _
+ = panic "RegAllocLinear.getStackSlotFor: out of stack slots, try -fregs-graph"
+ -- This happens with darcs' SHA1.hs, see #1993
+
getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
case lookupUFM reserved reg of
Just slot -> (fs,slot)
-- Allocate registers
regAlloc
:: LiveCmmTop
- -> UniqSM NatCmmTop
+ -> UniqSM (NatCmmTop, Maybe RegAllocStats)
-regAlloc cmm@(CmmData sec d)
- = returnUs $ CmmData sec d
+regAlloc (CmmData sec d)
+ = return
+ ( CmmData sec d
+ , Nothing )
-regAlloc cmm@(CmmProc (LiveInfo info _ _) lbl params [])
- = returnUs $ CmmProc info lbl params []
+regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
+ = return
+ ( CmmProc info lbl params (ListGraph [])
+ , Nothing )
-regAlloc cmm@(CmmProc (LiveInfo info (Just first_id) block_live) lbl params comps)
- = let ann_sccs = map (\b -> case b of
- BasicBlock i [b] -> AcyclicSCC b
- BasicBlock i bs -> CyclicSCC bs)
- $ comps
-
- in linearRegAlloc block_live ann_sccs `thenUs` \final_blocks ->
-
- let ((first':_), rest') = partition ((== first_id) . blockId) final_blocks
- in returnUs $ CmmProc info lbl params (first' : rest')
+regAlloc (CmmProc static lbl params (ListGraph comps))
+ | LiveInfo info (Just first_id) block_live <- static
+ = do
+ -- do register allocation on each component.
+ (final_blocks, stats)
+ <- linearRegAlloc block_live
+ $ map (\b -> case b of
+ BasicBlock _ [b] -> AcyclicSCC b
+ BasicBlock _ bs -> CyclicSCC bs)
+ $ comps
+
+ -- make sure the block that was first in the input list
+ -- stays at the front of the output
+ let ((first':_), rest')
+ = partition ((== first_id) . blockId) final_blocks
+
+ return ( CmmProc info lbl params (ListGraph (first' : rest'))
+ , Just stats)
+-- bogus. to make non-exhaustive match warning go away.
+regAlloc (CmmProc _ _ _ _)
+ = panic "RegAllocLinear.regAlloc: no match"
-- -----------------------------------------------------------------------------
instruction might still want to read it.
-}
-#ifdef DEBUG
instance Outputable Loc where
ppr l = text (show l)
-#endif
+
+-- | Do register allocation on some basic blocks.
+--
linearRegAlloc
- :: BlockMap RegSet -- live regs on entry to each basic block
- -> [SCC LiveBasicBlock] -- instructions annotated with "deaths"
- -> UniqSM [NatBasicBlock]
-linearRegAlloc block_live sccs = linearRA_SCCs emptyBlockMap emptyStackMap sccs
- where
- linearRA_SCCs
- :: BlockAssignment
- -> StackMap
- -> [SCC LiveBasicBlock]
- -> 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] -> [LiveInstr]
+ :: BlockMap RegSet -- ^ live regs on entry to each basic block
+ -> [SCC LiveBasicBlock] -- ^ instructions annotated with "deaths"
+ -> UniqSM ([NatBasicBlock], RegAllocStats)
+
+linearRegAlloc block_live sccs
+ = do us <- getUs
+ let (_, _, stats, blocks) =
+ runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
+ $ linearRA_SCCs block_live [] sccs
+
+ return (blocks, stats)
+
+linearRA_SCCs _ blocksAcc []
+ = return $ reverse blocksAcc
+
+linearRA_SCCs block_live blocksAcc (AcyclicSCC block : sccs)
+ = do blocks' <- processBlock block_live block
+ linearRA_SCCs block_live
+ ((reverse blocks') ++ blocksAcc)
+ sccs
+
+linearRA_SCCs block_live blocksAcc (CyclicSCC blocks : sccs)
+ = do blockss' <- mapM (processBlock block_live) blocks
+ linearRA_SCCs block_live
+ (reverse (concat blockss') ++ blocksAcc)
+ sccs
+
+
+-- | 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
+
+processBlock block_live (BasicBlock id instrs)
+ = do initBlock id
+ (instrs', fixups)
+ <- linearRA block_live [] [] instrs
+
+ return $ BasicBlock id instrs' : fixups
+
+
+-- | Load the freeregs and current reg assignment into the RegM state
+-- for the basic block with this BlockId.
+initBlock :: BlockId -> RegM ()
+initBlock id
+ = do block_assig <- getBlockAssigR
+ case lookupUFM block_assig id of
+ -- no prior info about this block: assume everything is
+ -- free and the assignment is empty.
+ Nothing
+ -> do setFreeRegsR initFreeRegs
+ setAssigR emptyRegMap
+
+ -- load info about register assignments leading into this block.
+ Just (freeregs, assig)
+ -> do setFreeRegsR freeregs
+ setAssigR assig
+
+
+linearRA
+ :: BlockMap RegSet
+ -> [Instr] -> [NatBasicBlock] -> [LiveInstr]
-> 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
+
+linearRA _ instr_acc fixups []
+ = return (reverse instr_acc, fixups)
+
+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
[NatBasicBlock] -- extra fixup blocks
)
-raInsn block_live new_instrs (Instr instr@(COMMENT _) Nothing)
+raInsn _ new_instrs (Instr (COMMENT _) Nothing)
= return (new_instrs, [])
-raInsn block_live new_instrs (Instr instr@(DELTA n) Nothing)
+raInsn _ new_instrs (Instr (DELTA n) Nothing)
= do
setDeltaR n
return (new_instrs, [])
-}
return (new_instrs, [])
- other -> genRaInsn block_live new_instrs instr
+ _ -> genRaInsn block_live new_instrs instr
(uniqSetToList $ liveDieRead live)
(uniqSetToList $ liveDieWrite live)
-raInsn block_live new_instrs li
+raInsn _ _ li
= pprPanic "raInsn" (text "no match for:" <> ppr li)
-- (j) free up stack slots for dead spilled regs
-- TODO (can't be bothered right now)
- return (patched_instr : w_spills ++ reverse r_spills
+ -- 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
+ Just (src, dst)
+ | src == dst -> []
+ _ -> [patched_instr]
+
+ return (squashed_instr ++ w_spills ++ reverse r_spills
++ clobber_saves ++ new_instrs,
fixup_blocks)
}}
free <- getFreeRegsR
loop assig free regs
where
- loop assig free _ | free `seq` False = undefined
+ loop _ 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) =
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: COMMENT FSLIT("spill clobber") : instrs) rest
+ (spill,slot) <- spillR (RealReg reg) temp
+ recordSpill (SpillClobber temp)
+
+ let new_assign = addToUFM assig temp (InBoth reg slot)
+ clobber new_assign (spill : COMMENT FSLIT("spill clobber") : instrs) rest
clobberRegs :: [RegNo] -> RegM ()
clobberRegs [] = return () -- common case
clobber assig ((temp, InBoth reg slot) : rest)
| reg `elem` clobbered
= clobber (addToUFM assig temp (InMem slot)) rest
- clobber assig (entry:rest)
+ clobber assig (_:rest)
= clobber assig rest
-- -----------------------------------------------------------------------------
-> [Reg] -- temps to allocate
-> RegM ([Instr], [RegNo])
-allocateRegsAndSpill reading keep spills alloc []
+allocateRegsAndSpill _ _ spills alloc []
= return (spills,reverse alloc)
allocateRegsAndSpill reading keep spills alloc (r:rs) = do
-- 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
+ Just (InBoth my_reg _) -> do
when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
-- case (2): we have a free register
my_reg:_ -> do
- spills' <- do_load reading loc my_reg spills
+ spills' <- loadTemp reading r loc my_reg spills
let new_loc
| Just (InMem slot) <- loc, reading = InBoth my_reg slot
| otherwise = InReg my_reg
-- just free up its register for use.
--
(temp,my_reg,slot):_ -> do
- spills' <- do_load reading loc my_reg spills
+ spills' <- loadTemp reading r loc my_reg spills
let
assig1 = addToUFM assig temp (InMem slot)
assig2 = addToUFM assig1 r (InReg my_reg)
-- 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
+
+ -- 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.
+
+ let (temp_to_push_out, my_reg) = myHead "regalloc" candidates2
+
+ (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 ]
+
+ -- record that this temp was spilled
+ recordSpill (SpillAlloc temp_to_push_out)
+
+ -- update the register assignment
+ let assig1 = addToUFM assig temp_to_push_out (InMem slot)
+ let assig2 = addToUFM assig1 r (InReg my_reg)
setAssigR assig2
- spills' <- do_load reading loc my_reg spills
- allocateRegsAndSpill reading keep
- (spill_insn : COMMENT FSLIT("spill alloc") : spills')
+
+ -- if need be, load up a spilled temp into the reg we've just freed up.
+ spills' <- loadTemp reading r loc my_reg spills
+
+ allocateRegsAndSpill reading keep
+ (spill_store ++ 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 : COMMENT FSLIT("spill load") : spills)
- do_load _ _ _ spills =
- return spills
+
+
+-- | Load up a spilled temporary if we need to.
+loadTemp
+ :: 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]
+
+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
+
+loadTemp _ _ _ _ spills =
+ return spills
+
myHead s [] = panic s
-myHead s (x:xs) = x
+myHead _ (x:_) = x
-- -----------------------------------------------------------------------------
-- Joining a jump instruction to its targets
-> [BlockId]
-> RegM ([NatBasicBlock], Instr)
-joinToTargets block_live new_blocks instr []
+joinToTargets _ new_blocks instr []
= return (new_blocks, instr)
+
joinToTargets block_live new_blocks instr (dest:dests) = do
block_assig <- getBlockAssigR
assig <- getAssigR
-- 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.
(freeregs',adjusted_assig))
joinToTargets block_live new_blocks instr dests
- Just (freeregs,dest_assig)
+ Just (_, dest_assig)
+
+ -- the assignments match
| ufmToList dest_assig == ufmToList adjusted_assig
- -> -- ok, the assignments match
- joinToTargets block_live new_blocks instr dests
+ -> joinToTargets block_live new_blocks instr dests
+
+ -- need fixup code
| otherwise
- -> -- need fixup code
- do
+ -> 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)"
-
+ let graph = makeRegMovementGraph adjusted_assig dest_assig
+ let sccs = stronglyConnCompR graph
+ fixUpInstrs <- mapM (handleComponent delta instr) sccs
+
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
+
+
+-- | 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 "RegisterAlloc.joinToTargets")
+ 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) (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
+ 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"
+
+
-- -----------------------------------------------------------------------------
-- The register allocator's monad.
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
+ ra_us :: UniqSupply, -- unique supply for generating names
-- for fixup blocks.
+
+ -- Record why things were spilled, for -ddrop-asm-stats.
+ -- Just keep a list here instead of a map of regs -> reasons.
+ -- We don't want to slow down the allocator if we're not going to emit the stats.
+ ra_spills :: [SpillReason]
}
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)
+ -> RegM a -> (BlockAssignment, StackMap, RegAllocStats, 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)
+ ra_us = us, ra_spills = [] }) of
+ (# state'@RA_State{ ra_blockassig=block_assig, ra_stack=stack' }, returned_thing #)
+ -> (block_assig, stack', makeRAStats state', returned_thing)
spillR :: Reg -> Unique -> RegM (Instr, Int)
spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
case splitUniqSupply (ra_us s) of
(us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #)
+-- | Record that a spill instruction was inserted, for profiling.
+recordSpill :: SpillReason -> RegM ()
+recordSpill spill
+ = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
+
+-- -----------------------------------------------------------------------------
+
+-- | Reasons why instructions might be inserted by the spiller.
+-- Used when generating stats for -ddrop-asm-stats.
+--
+data SpillReason
+ = SpillAlloc !Unique -- ^ vreg was spilled to a slot so we could use its
+ -- current hreg for another vreg
+ | SpillClobber !Unique -- ^ vreg was moved because its hreg was clobbered
+ | SpillLoad !Unique -- ^ vreg was loaded from a spill slot
+
+ | SpillJoinRR !Unique -- ^ reg-reg move inserted during join to targets
+ | SpillJoinRM !Unique -- ^ reg-mem move inserted during join to targets
+
+
+-- | Used to carry interesting stats out of the register allocator.
+data RegAllocStats
+ = RegAllocStats
+ { ra_spillInstrs :: UniqFM [Int] }
+
+
+-- | Make register allocator stats from its final state.
+makeRAStats :: RA_State -> RegAllocStats
+makeRAStats state
+ = RegAllocStats
+ { ra_spillInstrs = binSpillReasons (ra_spills state) }
+
+
+-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
+binSpillReasons
+ :: [SpillReason] -> UniqFM [Int]
+
+binSpillReasons reasons
+ = addListToUFM_C
+ (zipWith (+))
+ emptyUFM
+ (map (\reason -> case reason of
+ SpillAlloc r -> (r, [1, 0, 0, 0, 0])
+ SpillClobber r -> (r, [0, 1, 0, 0, 0])
+ SpillLoad r -> (r, [0, 0, 1, 0, 0])
+ SpillJoinRR r -> (r, [0, 0, 0, 1, 0])
+ SpillJoinRM r -> (r, [0, 0, 0, 0, 1])) reasons)
+
+
+-- | Count reg-reg moves remaining in this code.
+countRegRegMovesNat :: NatCmmTop -> Int
+countRegRegMovesNat cmm
+ = execState (mapGenBlockTopM countBlock cmm) 0
+ where
+ countBlock b@(BasicBlock _ instrs)
+ = do mapM_ countInstr instrs
+ return b
+
+ countInstr instr
+ | Just _ <- isRegRegMove instr
+ = do modify (+ 1)
+ return instr
+
+ | otherwise
+ = return instr
+
+
+-- | Pretty print some RegAllocStats
+pprStats :: [NatCmmTop] -> [RegAllocStats] -> SDoc
+pprStats code statss
+ = let -- sum up all the instrs inserted by the spiller
+ spills = foldl' (plusUFM_C (zipWith (+)))
+ emptyUFM
+ $ map ra_spillInstrs statss
+
+ spillTotals = foldl' (zipWith (+))
+ [0, 0, 0, 0, 0]
+ $ eltsUFM spills
+
+ -- count how many reg-reg-moves remain in the code
+ moves = sum $ map countRegRegMovesNat code
+
+ pprSpill (reg, spills)
+ = parens $ (hcat $ punctuate (text ", ") (doubleQuotes (ppr reg) : map ppr spills))
+
+ in ( text "-- spills-added-total"
+ $$ text "-- (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
+ $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))
+ $$ text ""
+ $$ text "-- spills-added"
+ $$ text "-- (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
+ $$ (vcat $ map pprSpill
+ $ ufmToList spills)
+ $$ text "")
+
+
-- -----------------------------------------------------------------------------
-- Utils
#ifdef DEBUG
my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
-my_fromJust s p (Just x) = x
+my_fromJust _ _ (Just x) = x
#else
my_fromJust _ _ = fromJust
#endif
projects / ghc-hetmet.git / blobdiff