X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocLinear.hs;h=5e2529979dd2d66c5f4540270ffb7bb4e2956a68;hb=240a8f698e7aa7be84fb68e8aa63ed68389e74de;hp=4a706b070acb017ec7d918c0cd974b9daeb37111;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs index 4a706b0..5e25299 100644 --- a/compiler/nativeGen/RegAllocLinear.hs +++ b/compiler/nativeGen/RegAllocLinear.hs @@ -1,10 +1,4 @@ -{-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings --- for details - +{-# OPTIONS -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- -- The register allocator @@ -94,11 +88,13 @@ module RegAllocLinear ( #include "HsVersions.h" +import BlockId import MachRegs import MachInstrs import RegAllocInfo import RegLiveness -import Cmm +import Cmm hiding (RegSet) +import PprMach import Digraph import Unique ( Uniquable(getUnique), Unique ) @@ -107,15 +103,18 @@ import UniqFM import UniqSupply import Outputable import State +import FastString +import MonadUtils -#ifndef DEBUG -import Data.Maybe ( fromJust ) -#endif -import Data.List ( nub, partition, mapAccumL, foldl') -import Control.Monad ( when ) +import Data.Maybe +import Data.List +import Control.Monad import Data.Word import Data.Bits +import Debug.Trace + +#include "../includes/MachRegs.h" -- ----------------------------------------------------------------------------- -- The free register set @@ -132,7 +131,7 @@ getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f allocateReg f r = filter (/= r) f -} -#if defined(powerpc_TARGET_ARCH) +#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 @@ -163,8 +162,9 @@ getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly getFreeRegs cls (FreeRegs g f) | RcDouble <- cls = go f (0x80000000) 63 | RcInteger <- cls = go g (0x80000000) 31 + | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (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 @@ -173,16 +173,174 @@ 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 + +#elif defined(sparc_TARGET_ARCH) +-------------------------------------------------------------------------------- +-- SPARC is like PPC, except for twinning of floating point regs. +-- When we allocate a double reg we must take an even numbered +-- float reg, as well as the one after it. + + +-- Holds bitmaps showing what registers are currently allocated. +-- The float and double reg bitmaps overlap, but we only alloc +-- float regs into the float map, and double regs into the double map. +-- +-- Free regs have a bit set in the corresponding bitmap. +-- +data FreeRegs + = FreeRegs + !Word32 -- int reg bitmap regs 0..31 + !Word32 -- float reg bitmap regs 32..63 + !Word32 -- double reg bitmap regs 32..63 + deriving( Show ) + + +-- | A reg map where no regs are free to be allocated. +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 0 + + +-- | The initial set of free regs. +-- Don't treat the top half of reg pairs we're using as doubles as being free. +initFreeRegs :: FreeRegs +initFreeRegs + = regs + where + freeDouble = getFreeRegs RcDouble regs + regs = foldr releaseReg noFreeRegs allocable + allocable = allocatableRegs \\ doublePairs + doublePairs = [43, 45, 47, 49, 51, 53] + + +-- | Get all the free registers of this class. +getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly +getFreeRegs cls (FreeRegs g f d) + | RcInteger <- cls = go g 1 0 + | RcFloat <- cls = go f 1 32 + | RcDouble <- cls = go d 1 32 + | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls) + where + go _ 0 _ = [] + go x m i | x .&. m /= 0 = i : (go x (m `shiftL` 1) $! i+1) + | otherwise = go x (m `shiftL` 1) $! i+1 + +showFreeRegs :: FreeRegs -> String +showFreeRegs regs + = "FreeRegs\n" + ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" + ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" + ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" + + +-- | Check whether a reg is free +regIsFree :: RegNo -> FreeRegs -> Bool +regIsFree r (FreeRegs g f d) + + -- a general purpose reg + | r <= 31 + , mask <- 1 `shiftL` fromIntegral r + = g .&. mask /= 0 + + -- use the first 22 float regs as double precision + | r >= 32 + , r <= 53 + , mask <- 1 `shiftL` (fromIntegral r - 32) + = d .&. mask /= 0 + + -- use the last 10 float regs as single precision + | otherwise + , mask <- 1 `shiftL` (fromIntegral r - 32) + = f .&. mask /= 0 + + +-- | Grab a register. +grabReg :: RegNo -> FreeRegs -> FreeRegs +grabReg r (FreeRegs g f d) + + -- a general purpose reg + | r <= 31 + , mask <- complement (1 `shiftL` fromIntegral r) + = FreeRegs (g .&. mask) f d + + -- use the first 22 float regs as double precision + | r >= 32 + , r <= 53 + , mask <- complement (1 `shiftL` (fromIntegral r - 32)) + = FreeRegs g f (d .&. mask) + + -- use the last 10 float regs as single precision + | otherwise + , mask <- complement (1 `shiftL` (fromIntegral r - 32)) + = FreeRegs g (f .&. mask) d + + + +-- | Release a register from allocation. +-- The register liveness information says that most regs die after a C call, +-- but we still don't want to allocate to some of them. +-- +releaseReg :: RegNo -> FreeRegs -> FreeRegs +releaseReg r regs@(FreeRegs g f d) + + -- used by STG machine, or otherwise unavailable + | r >= 0 && r <= 15 = regs + | r >= 17 && r <= 21 = regs + | r >= 24 && r <= 31 = regs + | r >= 32 && r <= 41 = regs + | r >= 54 && r <= 59 = regs + + -- never release the high part of double regs. + | r == 43 = regs + | r == 45 = regs + | r == 47 = regs + | r == 49 = regs + | r == 51 = regs + | r == 53 = regs + + -- a general purpose reg + | r <= 31 + , mask <- 1 `shiftL` fromIntegral r + = FreeRegs (g .|. mask) f d + + -- use the first 22 float regs as double precision + | r >= 32 + , r <= 53 + , mask <- 1 `shiftL` (fromIntegral r - 32) + = FreeRegs g f (d .|. mask) + + -- use the last 10 float regs as single precision + | otherwise + , mask <- 1 `shiftL` (fromIntegral r - 32) + = FreeRegs g (f .|. mask) d + + +-- | Allocate a register in the map. +allocateReg :: RegNo -> FreeRegs -> FreeRegs +allocateReg r regs@(FreeRegs g f d) + + -- if the reg isn't actually free then we're in trouble +{- | not $ regIsFree r regs + = pprPanic + "RegAllocLinear.allocateReg" + (text "reg " <> ppr r <> text " is not free") +-} + | otherwise + = grabReg r regs + + + +-------------------------------------------------------------------------------- -- 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 + +# if defined(alpha_TARGET_ARCH) +type FreeRegs = Word64 +# else type FreeRegs = Word32 -#endif +# endif noFreeRegs :: FreeRegs noFreeRegs = 0 @@ -195,7 +353,7 @@ initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs 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)) @@ -228,8 +386,10 @@ emptyStackMap :: StackMap 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) @@ -243,25 +403,24 @@ regAlloc :: LiveCmmTop -> UniqSM (NatCmmTop, Maybe RegAllocStats) -regAlloc cmm@(CmmData sec d) +regAlloc (CmmData sec d) = return ( CmmData sec d , Nothing ) -regAlloc cmm@(CmmProc (LiveInfo info _ _) lbl params []) - = return - ( CmmProc info lbl params [] - , Nothing ) +regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph [])) + = return ( CmmProc info lbl params (ListGraph []) + , Nothing ) -regAlloc cmm@(CmmProc static lbl params comps) +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 + <- linearRegAlloc first_id block_live $ map (\b -> case b of - BasicBlock i [b] -> AcyclicSCC b - BasicBlock i bs -> CyclicSCC bs) + BasicBlock _ [b] -> AcyclicSCC b + BasicBlock _ bs -> CyclicSCC bs) $ comps -- make sure the block that was first in the input list @@ -269,9 +428,12 @@ regAlloc cmm@(CmmProc static lbl params comps) let ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - return ( CmmProc info lbl params (first' : rest') + 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" -- ----------------------------------------------------------------------------- @@ -295,39 +457,48 @@ 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 -- | Do register allocation on some basic blocks. +-- But be careful to allocate a block in an SCC only if it has +-- an entry in the block map or it is the first block. -- linearRegAlloc - :: BlockMap RegSet -- ^ live regs on entry to each basic block + :: BlockId -- ^ the first block + -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC LiveBasicBlock] -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock], RegAllocStats) -linearRegAlloc block_live sccs +linearRegAlloc first_id block_live sccs = do us <- getUs - let (block_assig', stackMap', stats, blocks) = + let (_, _, stats, blocks) = runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us - $ linearRA_SCCs block_live [] sccs + $ linearRA_SCCs first_id block_live [] sccs return (blocks, stats) -linearRA_SCCs block_live blocksAcc [] +linearRA_SCCs _ _ blocksAcc [] = return $ reverse blocksAcc -linearRA_SCCs block_live blocksAcc (AcyclicSCC block : sccs) +linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) = do blocks' <- processBlock block_live block - linearRA_SCCs block_live + linearRA_SCCs first_id 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 +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 []) + linearRA_SCCs first_id block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -352,7 +523,7 @@ processBlock block_live (BasicBlock id instrs) initBlock :: BlockId -> RegM () initBlock id = do block_assig <- getBlockAssigR - case lookupUFM block_assig id of + case lookupBlockEnv block_assig id of -- no prior info about this block: assume everything is -- free and the assignment is empty. Nothing @@ -370,7 +541,7 @@ linearRA -> [Instr] -> [NatBasicBlock] -> [LiveInstr] -> RegM ([Instr], [NatBasicBlock]) -linearRA block_live instr_acc fixups [] +linearRA _ instr_acc fixups [] = return (reverse instr_acc, fixups) linearRA block_live instr_acc fixups (instr:instrs) @@ -390,10 +561,10 @@ raInsn :: BlockMap RegSet -- Live temporaries at each basic block [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, []) @@ -424,20 +595,20 @@ raInsn block_live new_instrs (Instr instr (Just live)) 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 - -} + -- we have eliminated 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 + _ -> 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) @@ -457,11 +628,14 @@ genRaInsn block_live new_instrs instr r_dying w_dying = -- (a) save any temporaries which will be clobbered by this instruction clobber_saves <- saveClobberedTemps real_written r_dying - {- - freeregs <- getFreeRegsR + +{- 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 - -} + 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) <- @@ -527,7 +701,7 @@ releaseRegs regs = do 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) = @@ -578,13 +752,15 @@ 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 clobberRegs clobbered = do freeregs <- getFreeRegsR +-- setFreeRegsR $! foldr grabReg freeregs clobbered setFreeRegsR $! foldr allocateReg freeregs clobbered + assig <- getAssigR setAssigR $! clobber assig (ufmToList assig) where @@ -597,7 +773,7 @@ clobberRegs clobbered = do 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 -- ----------------------------------------------------------------------------- @@ -618,7 +794,7 @@ allocateRegsAndSpill -> [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 @@ -633,7 +809,7 @@ 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 @@ -644,13 +820,14 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do case getFreeRegs (regClass r) freeregs of -- case (2): we have a free register - my_reg:_ -> do + freeClass@(my_reg:_) -> {- pprTrace "alloc" (ppr r <+> ppr my_reg <+> ppr freeClass) $ -} + do spills' <- loadTemp reading r 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) + 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 @@ -691,11 +868,15 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do -- 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 - + let (temp_to_push_out, my_reg) + = case candidates2 of + [] -> panic $ "RegAllocLinear.allocRegsAndSpill: no spill candidates" + ++ "assignment: " ++ show (ufmToList assig) ++ "\n" + (x:_) -> x + (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out let spill_store = (if reading then id else reverse) - [ COMMENT FSLIT("spill alloc") + [ COMMENT (fsLit "spill alloc") , spill_insn ] -- record that this temp was spilled @@ -727,15 +908,12 @@ 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 -myHead s [] = panic s -myHead s (x:xs) = x - -- ----------------------------------------------------------------------------- -- Joining a jump instruction to its targets @@ -753,7 +931,7 @@ joinToTargets -> [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 @@ -777,17 +955,17 @@ joinToTargets block_live new_blocks instr (dest:dests) = do regsOfLoc (InBoth r _) = [r] regsOfLoc (InMem _) = [] -- in - case lookupUFM block_assig dest of + 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 (addToUFM block_assig dest + setBlockAssigR (extendBlockEnv block_assig dest (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 @@ -799,7 +977,7 @@ joinToTargets block_live new_blocks instr (dest:dests) = do delta <- getDeltaR let graph = makeRegMovementGraph adjusted_assig dest_assig - let sccs = stronglyConnCompR graph + let sccs = stronglyConnCompFromEdgedVerticesR graph fixUpInstrs <- mapM (handleComponent delta instr) sccs block_id <- getUniqueR @@ -811,7 +989,7 @@ joinToTargets block_live new_blocks instr (dest:dests) = do joinToTargets block_live (block : new_blocks) instr' dests --- | Construct a graph of register/spill movements. +-- | Construct a graph of register\/spill movements. -- -- We cut some corners by -- a) not handling cyclic components @@ -829,7 +1007,7 @@ makeRegMovementGraph adjusted_assig dest_assig = expandNode vreg src $ lookupWithDefaultUFM_Directly dest_assig - (panic "RegisterAlloc.joinToTargets") + (panic "RegAllocLinear.makeRegMovementGraph") vreg in [ node | (vreg, src) <- ufmToList adjusted_assig @@ -852,13 +1030,13 @@ 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) +expandNode _ (InBoth _ src) (InMem dst) | src == dst = [] -- guaranteed to be true -expandNode vreg loc@(InBoth src _) (InReg dst) +expandNode _ (InBoth src _) (InReg dst) | src == dst = [] -expandNode vreg loc@(InBoth src _) dst +expandNode vreg (InBoth src _) dst = expandNode vreg (InReg src) dst expandNode vreg src dst @@ -870,7 +1048,7 @@ expandNode vreg src dst -- can join together allocations for different basic blocks. -- makeMove :: Int -> Unique -> Loc -> Loc -> RegM Instr -makeMove delta vreg (InReg src) (InReg dst) +makeMove _ vreg (InReg src) (InReg dst) = do recordSpill (SpillJoinRR vreg) return $ mkRegRegMoveInstr (RealReg src) (RealReg dst) @@ -882,7 +1060,7 @@ makeMove delta vreg (InReg src) (InMem dst) = do recordSpill (SpillJoinRM vreg) return $ mkSpillInstr (RealReg src) delta dst -makeMove delta vreg src dst +makeMove _ vreg src dst = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" ++ show dst ++ ")" ++ " (workaround: use -fviaC)" @@ -891,7 +1069,7 @@ makeMove delta vreg src dst -- we have eliminated any possibility of single-node cylces -- in expandNode above. handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr] -handleComponent delta instr (AcyclicSCC (vreg,src,dsts)) +handleComponent delta _ (AcyclicSCC (vreg,src,dsts)) = mapM (makeMove delta vreg src) dsts -- we can not have cycles that involve memory @@ -899,11 +1077,11 @@ handleComponent delta instr (AcyclicSCC (vreg,src,dsts)) -- because memory locations (stack slots) are -- allocated exclusively for a virtual register and -- therefore can not require a fixup -handleComponent delta instr (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest)) +handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest)) = do spill_id <- getUniqueR - (saveInstr,slot) <- spillR (RealReg sreg) spill_id - remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompR rest) + (_, slot) <- spillR (RealReg sreg) spill_id + remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest) restoreAndFixInstr <- getRestoreMoves dsts slot return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr) @@ -912,7 +1090,7 @@ handleComponent delta instr (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest)) = do restoreToReg <- loadR (RealReg reg) slot moveInstr <- makeMove delta vreg r mem - return $ [COMMENT FSLIT("spill join move"), restoreToReg, moveInstr] + return $ [COMMENT (fsLit "spill join move"), restoreToReg, moveInstr] getRestoreMoves [InReg reg] slot = loadR (RealReg reg) slot >>= return . (:[]) @@ -921,7 +1099,7 @@ handleComponent delta instr (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest)) getRestoreMoves _ _ = panic "getRestoreMoves unknown case" -handleComponent delta instr (CyclicSCC _) +handleComponent _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" @@ -963,7 +1141,7 @@ 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, ra_spills = [] }) of - (# state'@RA_State{ ra_blockassig=block_assig, ra_stack=stack', ra_spills=spills' }, returned_thing #) + (# 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) @@ -1067,8 +1245,8 @@ countRegRegMovesNat :: NatCmmTop -> Int countRegRegMovesNat cmm = execState (mapGenBlockTopM countBlock cmm) 0 where - countBlock b@(BasicBlock i instrs) - = do instrs' <- mapM countInstr instrs + countBlock b@(BasicBlock _ instrs) + = do mapM_ countInstr instrs return b countInstr instr @@ -1112,12 +1290,9 @@ pprStats code statss -- ----------------------------------------------------------------------------- -- Utils -#ifdef DEBUG -my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p -my_fromJust s p (Just x) = x -#else -my_fromJust _ _ = fromJust -#endif +my_fromJust :: String -> SDoc -> Maybe a -> a +my_fromJust _ _ (Just x) = x +my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p -lookItUp :: Uniquable b => String -> UniqFM a -> b -> a -lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x) +lookItUp :: String -> BlockMap a -> BlockId -> a +lookItUp str fm x = my_fromJust str (ppr x) (lookupBlockEnv fm x)