X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocLinear.hs;h=5e2529979dd2d66c5f4540270ffb7bb4e2956a68;hb=240a8f698e7aa7be84fb68e8aa63ed68389e74de;hp=94789794fe2f139d7d1b2aa30a9fdbb27fad505b;hpb=7dd753a02c3bdce61287b9ad2064daecf31e8258;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs index 9478979..5e25299 100644 --- a/compiler/nativeGen/RegAllocLinear.hs +++ b/compiler/nativeGen/RegAllocLinear.hs @@ -88,11 +88,13 @@ module RegAllocLinear ( #include "HsVersions.h" +import BlockId import MachRegs import MachInstrs import RegAllocInfo import RegLiveness import Cmm hiding (RegSet) +import PprMach import Digraph import Unique ( Uniquable(getUnique), Unique ) @@ -102,6 +104,7 @@ import UniqSupply import Outputable import State import FastString +import MonadUtils import Data.Maybe import Data.List @@ -109,6 +112,9 @@ import Control.Monad import Data.Word import Data.Bits +import Debug.Trace + +#include "../includes/MachRegs.h" -- ----------------------------------------------------------------------------- -- The free register set @@ -125,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 @@ -156,7 +162,7 @@ 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 cls" (ppr cls) + | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls) where go _ 0 _ = [] go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1) @@ -167,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 @@ -245,16 +409,15 @@ regAlloc (CmmData sec d) , Nothing ) regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph [])) - = return - ( CmmProc info lbl params (ListGraph []) - , Nothing ) + = return ( CmmProc info lbl params (ListGraph []) + , Nothing ) 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 _ [b] -> AcyclicSCC b BasicBlock _ bs -> CyclicSCC bs) @@ -299,32 +462,43 @@ instance Outputable Loc where -- | 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 (_, _, 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 _ 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 @@ -349,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 @@ -421,12 +595,12 @@ 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, []) _ -> genRaInsn block_live new_instrs instr @@ -454,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) <- @@ -581,7 +758,9 @@ 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 @@ -641,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 @@ -688,8 +868,12 @@ 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") @@ -730,9 +914,6 @@ loadTemp _ _ _ _ spills = return spills -myHead s [] = panic s -myHead _ (x:_) = x - -- ----------------------------------------------------------------------------- -- Joining a jump instruction to its targets @@ -774,13 +955,13 @@ 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 @@ -796,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 @@ -808,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 @@ -900,7 +1081,7 @@ 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) + remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest) restoreAndFixInstr <- getRestoreMoves dsts slot return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr) @@ -1113,5 +1294,5 @@ 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)