X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocLinear.hs;h=e6491b77ee9a15cdbc437d30e2067c47a5695530;hp=d9ff1214bc508a85980b7dba737844c293ff475d;hb=e3971de1fe67e414060047c09c4d5c64c7083981;hpb=f2cd56cf9fc310c9b587ecb5dfaee4ad6b580355 diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs index d9ff121..e6491b7 100644 --- a/compiler/nativeGen/RegAllocLinear.hs +++ b/compiler/nativeGen/RegAllocLinear.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- -- The register allocator @@ -91,7 +92,7 @@ import MachRegs import MachInstrs import RegAllocInfo import RegLiveness -import Cmm +import Cmm hiding (RegSet) import Digraph import Unique ( Uniquable(getUnique), Unique ) @@ -99,12 +100,11 @@ import UniqSet import UniqFM import UniqSupply import Outputable +import State -#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 @@ -155,8 +155,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 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 @@ -187,7 +188,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)) @@ -220,8 +221,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) @@ -235,25 +238,25 @@ 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 []) +regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph [])) = return - ( CmmProc info lbl params [] + ( 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 $ 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 @@ -261,9 +264,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" -- ----------------------------------------------------------------------------- @@ -287,10 +293,8 @@ 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. @@ -302,13 +306,13 @@ linearRegAlloc linearRegAlloc 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 return (blocks, stats) -linearRA_SCCs block_live blocksAcc [] +linearRA_SCCs _ blocksAcc [] = return $ reverse blocksAcc linearRA_SCCs block_live blocksAcc (AcyclicSCC block : sccs) @@ -362,7 +366,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) @@ -382,10 +386,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,12 +428,12 @@ raInsn block_live new_instrs (Instr instr (Just live)) -} 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) @@ -498,7 +502,15 @@ genRaInsn block_live new_instrs instr r_dying w_dying = -- (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) }} @@ -511,7 +523,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) = @@ -581,7 +593,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 -- ----------------------------------------------------------------------------- @@ -602,7 +614,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 @@ -617,7 +629,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 @@ -718,7 +730,7 @@ loadTemp _ _ _ _ spills = myHead s [] = panic s -myHead s (x:xs) = x +myHead _ (x:_) = x -- ----------------------------------------------------------------------------- -- Joining a jump instruction to its targets @@ -737,7 +749,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 @@ -771,7 +783,7 @@ joinToTargets block_live new_blocks instr (dest:dests) = do (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 @@ -836,13 +848,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 @@ -854,7 +866,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) @@ -866,7 +878,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)" @@ -875,7 +887,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 @@ -883,10 +895,10 @@ 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 + (_, slot) <- spillR (RealReg sreg) spill_id remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompR rest) restoreAndFixInstr <- getRestoreMoves dsts slot return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr) @@ -905,7 +917,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" @@ -947,7 +959,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) @@ -1046,10 +1058,29 @@ binSpillReasons reasons 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 :: [RegAllocStats] -> SDoc -pprStats statss - = let spills = foldl' (plusUFM_C (zipWith (+))) +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 @@ -1057,12 +1088,15 @@ pprStats statss [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)" - $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals))) + $$ 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)" @@ -1076,7 +1110,7 @@ pprStats statss #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