X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLiveness.hs;h=a2030fafa99369e9112341d070cfd3f3530900aa;hp=a4eeafc00e0bca83851f1e67209ec36b93af29d3;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hpb=983b869a8333c66b4e1a07c9ba1fefc5bddbd173 diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index a4eeafc..a2030fa 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -18,7 +18,7 @@ module RegAlloc.Liveness ( LiveInfo (..), LiveBasicBlock, - mapBlockTop, mapBlockTopM, + mapBlockTop, mapBlockTopM, mapSCCM, mapGenBlockTop, mapGenBlockTopM, stripLive, stripLiveBlock, @@ -27,17 +27,16 @@ module RegAlloc.Liveness ( eraseDeltasLive, patchEraseLive, patchRegsLiveInstr, + reverseBlocksInTops, regLiveness, natCmmTopToLive ) where - - import Reg import Instruction import BlockId -import Cmm hiding (RegSet) -import PprCmm() +import OldCmm hiding (RegSet) +import OldPprCmm() import Digraph import Outputable @@ -51,6 +50,9 @@ import FastString import Data.List import Data.Maybe +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map ----------------------------------------------------------------------------- type RegSet = UniqSet Reg @@ -62,9 +64,6 @@ emptyRegMap = emptyUFM type BlockMap a = BlockEnv a -emptyBlockMap :: BlockEnv a -emptyBlockMap = emptyBlockEnv - -- | A top level thing which carries liveness information. type LiveCmmTop instr @@ -141,8 +140,6 @@ instance Instruction instr => Instruction (InstrSR instr) where -- | An instruction with liveness information. data LiveInstr instr = LiveInstr (InstrSR instr) (Maybe Liveness) - - -- | Liveness information. -- The regs which die are ones which are no longer live in the *next* instruction @@ -161,9 +158,11 @@ data Liveness -- | Stash regs live on entry to each basic block in the info part of the cmm code. data LiveInfo = LiveInfo - [CmmStatic] -- cmm static stuff - (Maybe BlockId) -- id of the first block - (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block + [CmmStatic] -- cmm static stuff + (Maybe BlockId) -- id of the first block + (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block + (Map BlockId (Set Int)) -- stack slots live on entry to this block + -- | A basic block with liveness information. type LiveBasicBlock instr @@ -213,10 +212,11 @@ instance Outputable instr | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) instance Outputable LiveInfo where - ppr (LiveInfo static firstId liveOnEntry) + ppr (LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry) = (vcat $ map ppr static) - $$ text "# firstId = " <> ppr firstId - $$ text "# liveOnEntry = " <> ppr liveOnEntry + $$ text "# firstId = " <> ppr firstId + $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry + $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) @@ -240,9 +240,9 @@ mapBlockTopM mapBlockTopM _ cmm@(CmmData{}) = return cmm -mapBlockTopM f (CmmProc header label params sccs) +mapBlockTopM f (CmmProc header label sccs) = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label params sccs' + return $ CmmProc header label sccs' mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) mapSCCM f (AcyclicSCC x) @@ -272,9 +272,9 @@ mapGenBlockTopM mapGenBlockTopM _ cmm@(CmmData{}) = return cmm -mapGenBlockTopM f (CmmProc header label params (ListGraph blocks)) +mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) = do blocks' <- mapM f blocks - return $ CmmProc header label params (ListGraph blocks') + return $ CmmProc header label (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. @@ -290,7 +290,7 @@ slurpConflicts live = slurpCmm (emptyBag, emptyBag) live where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ _ sccs) + slurpCmm rs (CmmProc info _ sccs) = foldl' (slurpSCC info) rs sccs slurpSCC info rs (AcyclicSCC b) @@ -300,9 +300,9 @@ slurpConflicts live = foldl' (slurpBlock info) rs bs slurpBlock info rs (BasicBlock blockId instrs) - | LiveInfo _ _ (Just blockLive) <- info - , Just rsLiveEntry <- lookupBlockEnv blockLive blockId - , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs + | LiveInfo _ _ (Just blockLive) _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs = (consBag rsLiveEntry conflicts, moves) | otherwise @@ -357,21 +357,30 @@ slurpConflicts live -- -- slurpReloadCoalesce - :: Instruction instr + :: forall instr. Instruction instr => LiveCmmTop instr -> Bag (Reg, Reg) slurpReloadCoalesce live = slurpCmm emptyBag live - where slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ _ sccs) + where + slurpCmm :: Bag (Reg, Reg) + -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)] + -> Bag (Reg, Reg) + slurpCmm cs CmmData{} = cs + slurpCmm cs (CmmProc _ _ sccs) = slurpComp cs (flattenSCCs sccs) + slurpComp :: Bag (Reg, Reg) + -> [LiveBasicBlock instr] + -> Bag (Reg, Reg) slurpComp cs blocks = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM in unionManyBags (cs : moveBags) + slurpCompM :: [LiveBasicBlock instr] + -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)] slurpCompM blocks = do -- run the analysis once to record the mapping across jumps. mapM_ (slurpBlock False) blocks @@ -382,6 +391,8 @@ slurpReloadCoalesce live -- not worth the trouble. mapM (slurpBlock True) blocks + slurpBlock :: Bool -> LiveBasicBlock instr + -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)) slurpBlock propagate (BasicBlock blockId instrs) = do -- grab the slot map for entry to this block slotMap <- if propagate @@ -391,8 +402,7 @@ slurpReloadCoalesce live (_, mMoves) <- mapAccumLM slurpLI slotMap instrs return $ listToBag $ catMaybes mMoves - slurpLI :: Instruction instr - => UniqFM Reg -- current slotMap + slurpLI :: UniqFM Reg -- current slotMap -> LiveInstr instr -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] -- for tracking slotMaps across jumps @@ -456,8 +466,7 @@ stripLive live = stripCmm live where stripCmm (CmmData sec ds) = CmmData sec ds - - stripCmm (CmmProc (LiveInfo info (Just first_id) _) label params sccs) + stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) = let final_blocks = flattenSCCs sccs -- make sure the block that was first in the input list @@ -466,17 +475,17 @@ stripLive live ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - in CmmProc info label params + in CmmProc info label (ListGraph $ map stripLiveBlock $ first' : rest') -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _) label params []) - = CmmProc info label params (ListGraph []) + stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) + = CmmProc info label (ListGraph []) -- If the proc has blocks but we don't know what the first one was, then we're dead. stripCmm proc = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) - + -- | Strip away liveness information from a basic block, -- and make real spill instructions out of SPILL, RELOAD pseudos along the way. @@ -531,7 +540,6 @@ eraseDeltasLive cmm -- | Patch the registers in this code according to this register mapping. -- also erase reg -> reg moves when the reg is the same. -- also erase reg -> reg moves when the destination dies in this instr. - patchEraseLive :: Instruction instr => (Reg -> Reg) @@ -542,14 +550,14 @@ patchEraseLive patchF cmm where patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label params sccs) - | LiveInfo static id (Just blockMap) <- info + patchCmm (CmmProc info label sccs) + | LiveInfo static id (Just blockMap) mLiveSlots <- info = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set - blockMap' = mapBlockEnv patchRegSet blockMap + blockMap' = mapMap patchRegSet blockMap - info' = LiveInfo static id (Just blockMap') - in CmmProc info' label params $ map patchSCC sccs + info' = LiveInfo static id (Just blockMap') mLiveSlots + in CmmProc info' label $ map patchSCC sccs | otherwise = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" @@ -618,19 +626,17 @@ natCmmTopToLive natCmmTopToLive (CmmData i d) = CmmData i d -natCmmTopToLive (CmmProc info lbl params (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing) - lbl params [] +natCmmTopToLive (CmmProc info lbl (ListGraph [])) + = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] -natCmmTopToLive (CmmProc info lbl params (ListGraph blocks@(first : _))) +natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _))) = let first_id = blockId first sccs = sccBlocks blocks sccsLive = map (fmap (\(BasicBlock l instrs) -> BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) $ sccs - in CmmProc (LiveInfo info (Just first_id) Nothing) - lbl params sccsLive + in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive sccBlocks @@ -651,46 +657,99 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph -- Annotate code with register liveness information -- regLiveness - :: Instruction instr + :: (Outputable instr, Instruction instr) => LiveCmmTop instr -> UniqSM (LiveCmmTop instr) regLiveness (CmmData i d) = returnUs $ CmmData i d -regLiveness (CmmProc info lbl params []) - | LiveInfo static mFirst _ <- info +regLiveness (CmmProc info lbl []) + | LiveInfo static mFirst _ _ <- info = returnUs $ CmmProc - (LiveInfo static mFirst (Just emptyBlockEnv)) - lbl params [] + (LiveInfo static mFirst (Just mapEmpty) Map.empty) + lbl [] -regLiveness (CmmProc info lbl params sccs) - | LiveInfo static mFirst _ <- info +regLiveness (CmmProc info lbl sccs) + | LiveInfo static mFirst _ liveSlotsOnEntry <- info = let (ann_sccs, block_live) = computeLiveness sccs - in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live)) - lbl params ann_sccs - + in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) + lbl ann_sccs -- ----------------------------------------------------------------------------- --- Computing liveness +-- | Check ordering of Blocks +-- The computeLiveness function requires SCCs to be in reverse dependent order. +-- If they're not the liveness information will be wrong, and we'll get a bad allocation. +-- Better to check for this precondition explicitly or some other poor sucker will +-- waste a day staring at bad assembly code.. +-- +checkIsReverseDependent + :: Instruction instr + => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. + -> Maybe BlockId -- ^ BlockIds that fail the test (if any) + +checkIsReverseDependent sccs' + = go emptyUniqSet sccs' + + where go _ [] + = Nothing + + go blocksSeen (AcyclicSCC block : sccs) + = let dests = slurpJumpDestsOfBlock block + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + go blocksSeen (CyclicSCC blocks : sccs) + = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + slurpJumpDestsOfBlock (BasicBlock _ instrs) + = unionManyUniqSets + $ map (mkUniqSet . jumpDestsOfInstr) + [ i | LiveInstr i _ <- instrs] + + +-- | If we've compute liveness info for this code already we have to reverse +-- the SCCs in each top to get them back to the right order so we can do it again. +reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr +reverseBlocksInTops top + = case top of + CmmData{} -> top + CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + +-- | Computing liveness +-- +-- On entry, the SCCs must be in "reverse" order: later blocks may transfer +-- control to earlier ones only, else `panic`. +-- +-- The SCCs returned are in the *opposite* order, which is exactly what we +-- want for the next pass. +-- computeLiveness - :: Instruction instr + :: (Outputable instr, Instruction instr) => [SCC (LiveBasicBlock instr)] -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers -- which are "dead after this instruction". BlockMap RegSet) -- blocks annontated with set of live registers -- on entry to the block. - - -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer - -- control to earlier ones only. The SCCs returned are in the *opposite* - -- order, which is exactly what we want for the next pass. computeLiveness sccs - = livenessSCCs emptyBlockMap [] sccs - + = case checkIsReverseDependent sccs of + Nothing -> livenessSCCs emptyBlockMap [] sccs + Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" + (vcat [ text "SCCs aren't in reverse dependent order" + , text "bad blockId" <+> ppr bad + , ppr sccs]) livenessSCCs :: Instruction instr @@ -738,8 +797,8 @@ livenessSCCs blockmap done -- BlockMaps for equality. equalBlockMaps a b = a' == b' - where a' = map f $ blockEnvToList a - b' = map f $ blockEnvToList b + where a' = map f $ mapToList a + b' = map f $ mapToList b f (key,elt) = (key, uniqSetToList elt) @@ -756,7 +815,7 @@ livenessBlock blockmap (BasicBlock block_id instrs) = let (regsLiveOnEntry, instrs1) = livenessBack emptyUniqSet blockmap [] (reverse instrs) - blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry + blockmap' = mapInsert block_id regsLiveOnEntry blockmap instrs2 = livenessForward regsLiveOnEntry instrs1 @@ -863,7 +922,7 @@ liveness1 liveregs blockmap (LiveInstr instr _) not_a_branch = null targets targetLiveRegs target - = case lookupBlockEnv blockmap target of + = case mapLookup target blockmap of Just ra -> ra Nothing -> emptyRegMap