X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLiveness.hs;h=a2030fafa99369e9112341d070cfd3f3530900aa;hb=8133a9f47b99f4e65ed30551de32ad72c6b61b27;hp=8445034ab91faea2084a08361d402094c7fcac3a;hpb=ee6bba6f3d80c56b47bc623bc6e4f076be1f046f;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 8445034..a2030fa 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -12,30 +12,31 @@ module RegAlloc.Liveness ( RegMap, emptyRegMap, BlockMap, emptyBlockMap, LiveCmmTop, + InstrSR (..), LiveInstr (..), Liveness (..), LiveInfo (..), LiveBasicBlock, - mapBlockTop, mapBlockTopM, + mapBlockTop, mapBlockTopM, mapSCCM, mapGenBlockTop, mapGenBlockTopM, stripLive, - spillNatBlock, + stripLiveBlock, slurpConflicts, slurpReloadCoalesce, eraseDeltasLive, patchEraseLive, patchRegsLiveInstr, - regLiveness - + reverseBlocksInTops, + regLiveness, + natCmmTopToLive ) where +import Reg +import Instruction import BlockId -import Regs -import Instrs -import PprMach -import RegAllocInfo -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) +import OldPprCmm() import Digraph import Outputable @@ -49,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 @@ -60,23 +64,82 @@ emptyRegMap = emptyUFM type BlockMap a = BlockEnv a -emptyBlockMap :: BlockEnv a -emptyBlockMap = emptyBlockEnv - -- | A top level thing which carries liveness information. -type LiveCmmTop +type LiveCmmTop instr = GenCmmTop CmmStatic LiveInfo - (ListGraph (GenBasicBlock LiveInstr)) - -- the "instructions" here are actually more blocks, - -- single blocks are acyclic - -- multiple blocks are taken to be cyclic. + [SCC (LiveBasicBlock instr)] + + +-- | The register allocator also wants to use SPILL/RELOAD meta instructions, +-- so we'll keep those here. +data InstrSR instr + -- | A real machine instruction + = Instr instr + + -- | spill this reg to a stack slot + | SPILL Reg Int + + -- | reload this reg from a stack slot + | RELOAD Int Reg + +instance Instruction instr => Instruction (InstrSR instr) where + regUsageOfInstr i + = case i of + Instr instr -> regUsageOfInstr instr + SPILL reg _ -> RU [reg] [] + RELOAD _ reg -> RU [] [reg] + + patchRegsOfInstr i f + = case i of + Instr instr -> Instr (patchRegsOfInstr instr f) + SPILL reg slot -> SPILL (f reg) slot + RELOAD slot reg -> RELOAD slot (f reg) + + isJumpishInstr i + = case i of + Instr instr -> isJumpishInstr instr + _ -> False + + jumpDestsOfInstr i + = case i of + Instr instr -> jumpDestsOfInstr instr + _ -> [] + + patchJumpInstr i f + = case i of + Instr instr -> Instr (patchJumpInstr instr f) + _ -> i + + mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" + mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" + + takeDeltaInstr i + = case i of + Instr instr -> takeDeltaInstr instr + _ -> Nothing + + isMetaInstr i + = case i of + Instr instr -> isMetaInstr instr + _ -> False + + mkRegRegMoveInstr r1 r2 = Instr (mkRegRegMoveInstr r1 r2) + + takeRegRegMoveInstr i + = case i of + Instr instr -> takeRegRegMoveInstr instr + _ -> Nothing + + mkJumpInstr target = map Instr (mkJumpInstr target) + + -- | An instruction with liveness information. -data LiveInstr - = Instr Instr (Maybe Liveness) +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 @@ -95,20 +158,46 @@ 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 - (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 - = GenBasicBlock LiveInstr +type LiveBasicBlock instr + = GenBasicBlock (LiveInstr instr) + + +instance Outputable instr + => Outputable (InstrSR instr) where + + ppr (Instr realInstr) + = ppr realInstr + ppr (SPILL reg slot) + = hcat [ + ptext (sLit "\tSPILL"), + char ' ', + ppr reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] -instance Outputable LiveInstr where - ppr (Instr instr Nothing) + ppr (RELOAD slot reg) + = hcat [ + ptext (sLit "\tRELOAD"), + char ' ', + ptext (sLit "SLOT") <> parens (int slot), + comma, + ppr reg] + +instance Outputable instr + => Outputable (LiveInstr instr) where + + ppr (LiveInstr instr Nothing) = ppr instr - ppr (Instr instr (Just live)) + ppr (LiveInstr instr (Just live)) = ppr instr $$ (nest 8 $ vcat @@ -120,21 +209,22 @@ instance Outputable LiveInstr where where pprRegs :: SDoc -> RegSet -> SDoc pprRegs name regs | isEmptyUniqSet regs = empty - | otherwise = name <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) $ uniqSetToList regs) - + | 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) + -- | map a function across all the basic blocks in this code -- mapBlockTop - :: (LiveBasicBlock -> LiveBasicBlock) - -> LiveCmmTop -> LiveCmmTop + :: (LiveBasicBlock instr -> LiveBasicBlock instr) + -> LiveCmmTop instr -> LiveCmmTop instr mapBlockTop f cmm = evalState (mapBlockTopM (\x -> return $ f x) cmm) () @@ -144,20 +234,24 @@ mapBlockTop f cmm -- mapBlockTopM :: Monad m - => (LiveBasicBlock -> m LiveBasicBlock) - -> LiveCmmTop -> m LiveCmmTop + => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) + -> LiveCmmTop instr -> m (LiveCmmTop instr) mapBlockTopM _ cmm@(CmmData{}) = return cmm -mapBlockTopM f (CmmProc header label params (ListGraph comps)) - = do comps' <- mapM (mapBlockCompM f) comps - return $ CmmProc header label params (ListGraph comps') +mapBlockTopM f (CmmProc header label sccs) + = do sccs' <- mapM (mapSCCM f) sccs + return $ CmmProc header label sccs' -mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a') -mapBlockCompM f (BasicBlock i blocks) - = do blocks' <- mapM f blocks - return $ BasicBlock i blocks' +mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) +mapSCCM f (AcyclicSCC x) + = do x' <- f x + return $ AcyclicSCC x' + +mapSCCM f (CyclicSCC xs) + = do xs' <- mapM f xs + return $ CyclicSCC xs' -- map a function across all the basic blocks in this code @@ -178,41 +272,49 @@ 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. -- Slurping of conflicts and moves is wrapped up together so we don't have -- to make two passes over the same code when we want to build the graph. -- -slurpConflicts :: LiveCmmTop -> (Bag (UniqSet Reg), Bag (Reg, Reg)) +slurpConflicts + :: Instruction instr + => LiveCmmTop instr + -> (Bag (UniqSet Reg), Bag (Reg, Reg)) + slurpConflicts live = slurpCmm (emptyBag, emptyBag) live where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ _ (ListGraph blocks)) - = foldl' (slurpComp info) rs blocks + slurpCmm rs (CmmProc info _ sccs) + = foldl' (slurpSCC info) rs sccs + + slurpSCC info rs (AcyclicSCC b) + = slurpBlock info rs b - slurpComp info rs (BasicBlock _ blocks) - = foldl' (slurpBlock info) rs blocks + slurpSCC info rs (CyclicSCC bs) + = foldl' (slurpBlock info) rs bs slurpBlock info rs (BasicBlock blockId instrs) - | LiveInfo _ _ 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 - = panic "RegLiveness.slurpBlock: bad block" + = panic "Liveness.slurpConflicts: bad block" slurpLIs rsLive (conflicts, moves) [] = (consBag rsLive conflicts, moves) - slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis + slurpLIs rsLive rs (LiveInstr _ Nothing : lis) + = slurpLIs rsLive rs lis - slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis) + slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) = let -- regs that die because they are read for the last time at the start of an instruction -- are not live across it. @@ -234,7 +336,7 @@ slurpConflicts live -- rsConflicts = unionUniqSets rsLiveNext rsOrphans - in case isRegRegMove instr of + in case takeRegRegMoveInstr instr of Just rr -> slurpLIs rsLiveNext ( consBag rsConflicts conflicts , consBag rr moves) lis @@ -254,19 +356,32 @@ slurpConflicts live -- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. -- -- -slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg) +slurpReloadCoalesce + :: forall instr. Instruction instr + => LiveCmmTop instr + -> Bag (Reg, Reg) + slurpReloadCoalesce live = slurpCmm emptyBag live - where slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ _ (ListGraph blocks)) - = foldl' slurpComp cs blocks - - slurpComp cs comp - = let (moveBags, _) = runState (slurpCompM comp) emptyUFM + 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 (BasicBlock _ blocks) + 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 @@ -276,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 @@ -286,22 +403,22 @@ slurpReloadCoalesce live return $ listToBag $ catMaybes mMoves slurpLI :: UniqFM Reg -- current slotMap - -> LiveInstr + -> LiveInstr instr -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] -- for tracking slotMaps across jumps ( UniqFM Reg -- new slotMap , Maybe (Reg, Reg)) -- maybe a new coalesce edge - slurpLI slotMap (Instr instr _) + slurpLI slotMap li -- remember what reg was stored into the slot - | SPILL reg slot <- instr - , slotMap' <- addToUFM slotMap slot reg + | LiveInstr (SPILL reg slot) _ <- li + , slotMap' <- addToUFM slotMap slot reg = return (slotMap', Nothing) -- add an edge betwen the this reg and the last one stored into the slot - | RELOAD slot reg <- instr + | LiveInstr (RELOAD slot reg) _ <- li = case lookupUFM slotMap slot of Just reg2 | reg /= reg2 -> return (slotMap, Just (reg, reg2)) @@ -310,7 +427,8 @@ slurpReloadCoalesce live Nothing -> return (slotMap, Nothing) -- if we hit a jump, remember the current slotMap - | targets <- jumpDests instr [] + | LiveInstr (Instr instr) _ <- li + , targets <- jumpDestsOfInstr instr , not $ null targets = do mapM_ (accSlotMap slotMap) targets return (slotMap, Nothing) @@ -339,86 +457,113 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmTop +stripLive + :: (Outputable instr, Instruction instr) + => LiveCmmTop instr + -> NatCmmTop instr -stripLive :: LiveCmmTop -> NatCmmTop stripLive live = stripCmm live where stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps)) - = CmmProc info label params - (ListGraph $ concatMap stripComp comps) + 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 + -- stays at the front of the output. This is the entry point + -- of the proc, and it needs to come first. + ((first':_), rest') + = partition ((== first_id) . blockId) final_blocks + + in CmmProc info label + (ListGraph $ map stripLiveBlock $ first' : rest') - stripComp (BasicBlock _ blocks) = map stripBlock blocks - stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs) - stripLI (Instr instr _) = instr + -- procs used for stg_split_markers don't contain any blocks, and have no first_id. + 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) --- | Make real spill instructions out of SPILL, RELOAD pseudos -spillNatBlock :: NatBasicBlock -> NatBasicBlock -spillNatBlock (BasicBlock i is) +-- | Strip away liveness information from a basic block, +-- and make real spill instructions out of SPILL, RELOAD pseudos along the way. + +stripLiveBlock + :: Instruction instr + => LiveBasicBlock instr + -> NatBasicBlock instr + +stripLiveBlock (BasicBlock i lis) = BasicBlock i instrs' + where (instrs', _) - = runState (spillNat [] is) 0 + = runState (spillNat [] lis) 0 spillNat acc [] = return (reverse acc) - spillNat acc (DELTA i : instrs) - = do put i - spillNat acc instrs - - spillNat acc (SPILL reg slot : instrs) + spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) = do delta <- get spillNat (mkSpillInstr reg delta slot : acc) instrs - spillNat acc (RELOAD slot reg : instrs) + spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) = do delta <- get spillNat (mkLoadInstr reg delta slot : acc) instrs - spillNat acc (instr : instrs) + spillNat acc (LiveInstr (Instr instr) _ : instrs) + | Just i <- takeDeltaInstr instr + = do put i + spillNat acc instrs + + spillNat acc (LiveInstr (Instr instr) _ : instrs) = spillNat (instr : acc) instrs -- | Erase Delta instructions. -eraseDeltasLive :: LiveCmmTop -> LiveCmmTop +eraseDeltasLive + :: Instruction instr + => LiveCmmTop instr + -> LiveCmmTop instr + eraseDeltasLive cmm = mapBlockTop eraseBlock cmm where - isDelta (DELTA _) = True - isDelta _ = False - eraseBlock (BasicBlock id lis) = BasicBlock id - $ filter (\(Instr i _) -> not $ isDelta i) + $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) $ lis -- | 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 - :: (Reg -> Reg) - -> LiveCmmTop -> LiveCmmTop + :: Instruction instr + => (Reg -> Reg) + -> LiveCmmTop instr -> LiveCmmTop instr patchEraseLive patchF cmm = patchCmm cmm where patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label params (ListGraph comps)) - | LiveInfo static id blockMap <- info - = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set - blockMap' = mapBlockEnv patchRegSet blockMap + patchCmm (CmmProc info label sccs) + | LiveInfo static id (Just blockMap) mLiveSlots <- info + = let + patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set + blockMap' = mapMap patchRegSet blockMap - info' = LiveInfo static id blockMap' - in CmmProc info' label params $ ListGraph $ map patchComp comps + info' = LiveInfo static id (Just blockMap') mLiveSlots + in CmmProc info' label $ map patchSCC sccs - patchComp (BasicBlock id blocks) - = BasicBlock id $ map patchBlock blocks + | otherwise + = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" + + patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) + patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) patchBlock (BasicBlock id lis) = BasicBlock id $ patchInstrs lis @@ -426,8 +571,8 @@ patchEraseLive patchF cmm patchInstrs [] = [] patchInstrs (li : lis) - | Instr i (Just live) <- li' - , Just (r1, r2) <- isRegRegMove i + | LiveInstr i (Just live) <- li' + , Just (r1, r2) <- takeRegRegMoveInstr i , eatMe r1 r2 live = patchInstrs lis @@ -451,17 +596,18 @@ patchEraseLive patchF cmm -- | Patch registers in this LiveInstr, including the liveness information. -- patchRegsLiveInstr - :: (Reg -> Reg) - -> LiveInstr -> LiveInstr + :: Instruction instr + => (Reg -> Reg) + -> LiveInstr instr -> LiveInstr instr patchRegsLiveInstr patchF li = case li of - Instr instr Nothing - -> Instr (patchRegs instr patchF) Nothing + LiveInstr instr Nothing + -> LiveInstr (patchRegsOfInstr instr patchF) Nothing - Instr instr (Just live) - -> Instr - (patchRegs instr patchF) + LiveInstr instr (Just live) + -> LiveInstr + (patchRegsOfInstr instr patchF) (Just live { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live @@ -469,73 +615,152 @@ patchRegsLiveInstr patchF li , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) ---------------------------------------------------------------------------------- --- Annotate code with register liveness information --- -regLiveness - :: NatCmmTop - -> UniqSM LiveCmmTop +-------------------------------------------------------------------------------- +-- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information -regLiveness (CmmData i d) - = returnUs $ CmmData i d +natCmmTopToLive + :: Instruction instr + => NatCmmTop instr + -> LiveCmmTop instr -regLiveness (CmmProc info lbl params (ListGraph [])) - = returnUs $ CmmProc - (LiveInfo info Nothing emptyBlockEnv) - lbl params (ListGraph []) +natCmmTopToLive (CmmData i d) + = CmmData i d -regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _))) - = let first_id = blockId first - sccs = sccBlocks blocks - (ann_sccs, block_live) = computeLiveness sccs +natCmmTopToLive (CmmProc info lbl (ListGraph [])) + = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] - liveBlocks - = map (\scc -> case scc of - AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [b] - CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l bs - CyclicSCC [] - -> panic "RegLiveness.regLiveness: no blocks in scc list") - $ ann_sccs +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 Map.empty) lbl sccsLive - in returnUs $ CmmProc (LiveInfo info (Just first_id) block_live) - lbl params (ListGraph liveBlocks) +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC (NatBasicBlock instr)] -sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock] sccBlocks blocks = stronglyConnCompFromEdgedVertices graph where - getOutEdges :: [Instr] -> [BlockId] - getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs + getOutEdges :: Instruction instr => [instr] -> [BlockId] + getOutEdges instrs = concat $ map jumpDestsOfInstr instrs graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) | block@(BasicBlock id instrs) <- blocks ] --- ----------------------------------------------------------------------------- --- Computing liveness +--------------------------------------------------------------------------------- +-- Annotate code with register liveness information +-- +regLiveness + :: (Outputable instr, Instruction instr) + => LiveCmmTop instr + -> UniqSM (LiveCmmTop instr) -computeLiveness - :: [SCC NatBasicBlock] - -> ([SCC LiveBasicBlock], -- 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. +regLiveness (CmmData i d) + = returnUs $ CmmData i d - -- 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. +regLiveness (CmmProc info lbl []) + | LiveInfo static mFirst _ _ <- info + = returnUs $ CmmProc + (LiveInfo static mFirst (Just mapEmpty) Map.empty) + lbl [] -computeLiveness sccs - = livenessSCCs emptyBlockMap [] sccs +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) liveSlotsOnEntry) + lbl ann_sccs + + +-- ----------------------------------------------------------------------------- +-- | 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 + :: (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. + +computeLiveness 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 - :: BlockMap RegSet - -> [SCC LiveBasicBlock] -- accum - -> [SCC NatBasicBlock] - -> ([SCC LiveBasicBlock], BlockMap RegSet) + :: Instruction instr + => BlockMap RegSet + -> [SCC (LiveBasicBlock instr)] -- accum + -> [SCC (LiveBasicBlock instr)] + -> ( [SCC (LiveBasicBlock instr)] + , BlockMap RegSet) -livenessSCCs blockmap done [] = (done, blockmap) +livenessSCCs blockmap done [] + = (done, blockmap) livenessSCCs blockmap done (AcyclicSCC block : sccs) = let (blockmap', block') = livenessBlock blockmap block @@ -561,16 +786,19 @@ livenessSCCs blockmap done (a, panic "RegLiveness.livenessSCCs") - linearLiveness :: BlockMap RegSet -> [NatBasicBlock] - -> (BlockMap RegSet, [LiveBasicBlock]) + linearLiveness + :: Instruction instr + => BlockMap RegSet -> [LiveBasicBlock instr] + -> (BlockMap RegSet, [LiveBasicBlock instr]) + linearLiveness = mapAccumL livenessBlock -- probably the least efficient way to compare two -- 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) @@ -578,15 +806,16 @@ livenessSCCs blockmap done -- | Annotate a basic block with register liveness information. -- livenessBlock - :: BlockMap RegSet - -> NatBasicBlock - -> (BlockMap RegSet, LiveBasicBlock) + :: Instruction instr + => BlockMap RegSet + -> LiveBasicBlock instr + -> (BlockMap RegSet, LiveBasicBlock instr) 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 @@ -598,16 +827,17 @@ livenessBlock blockmap (BasicBlock block_id instrs) -- filling in when regs are born livenessForward - :: RegSet -- regs live on this instr - -> [LiveInstr] -> [LiveInstr] + :: Instruction instr + => RegSet -- regs live on this instr + -> [LiveInstr instr] -> [LiveInstr instr] livenessForward _ [] = [] -livenessForward rsLiveEntry (li@(Instr instr mLive) : lis) +livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis) | Nothing <- mLive = li : livenessForward rsLiveEntry lis | Just live <- mLive - , RU _ written <- regUsage instr + , RU _ written <- regUsageOfInstr instr = let -- Regs that are written to but weren't live on entry to this instruction -- are recorded as being born here. @@ -618,7 +848,7 @@ livenessForward rsLiveEntry (li@(Instr instr mLive) : lis) `minusUniqSet` (liveDieRead live) `minusUniqSet` (liveDieWrite live) - in Instr instr (Just live { liveBorn = rsBorn }) + in LiveInstr instr (Just live { liveBorn = rsBorn }) : livenessForward rsLiveNext lis livenessForward _ _ = panic "RegLiveness.livenessForward: no match" @@ -628,11 +858,12 @@ livenessForward _ _ = panic "RegLiveness.livenessForward: no match" -- filling in when regs die, and what regs are live across each instruction livenessBack - :: RegSet -- regs live on this instr + :: Instruction instr + => RegSet -- regs live on this instr -> BlockMap RegSet -- regs live on entry to other BBs - -> [LiveInstr] -- instructions (accum) - -> [Instr] -- instructions - -> (RegSet, [LiveInstr]) + -> [LiveInstr instr] -- instructions (accum) + -> [LiveInstr instr] -- instructions + -> (RegSet, [LiveInstr instr]) livenessBack liveregs _ done [] = (liveregs, done) @@ -640,32 +871,37 @@ livenessBack liveregs blockmap acc (instr : instrs) = let (liveregs', instr') = liveness1 liveregs blockmap instr in livenessBack liveregs' blockmap (instr' : acc) instrs + -- don't bother tagging comments or deltas with liveness -liveness1 :: RegSet -> BlockMap RegSet -> Instr -> (RegSet, LiveInstr) -liveness1 liveregs _ (instr@COMMENT{}) - = (liveregs, Instr instr Nothing) +liveness1 + :: Instruction instr + => RegSet + -> BlockMap RegSet + -> LiveInstr instr + -> (RegSet, LiveInstr instr) -liveness1 liveregs _ (instr@DELTA{}) - = (liveregs, Instr instr Nothing) +liveness1 liveregs _ (LiveInstr instr _) + | isMetaInstr instr + = (liveregs, LiveInstr instr Nothing) -liveness1 liveregs blockmap instr +liveness1 liveregs blockmap (LiveInstr instr _) - | not_a_branch - = (liveregs1, Instr instr + | not_a_branch + = (liveregs1, LiveInstr instr (Just $ Liveness { liveBorn = emptyUniqSet , liveDieRead = mkUniqSet r_dying , liveDieWrite = mkUniqSet w_dying })) - | otherwise - = (liveregs_br, Instr instr + | otherwise + = (liveregs_br, LiveInstr instr (Just $ Liveness { liveBorn = emptyUniqSet , liveDieRead = mkUniqSet r_dying_br , liveDieWrite = mkUniqSet w_dying })) - where - RU read written = regUsage instr + where + RU read written = regUsageOfInstr instr -- registers that were written here are dead going backwards. -- registers that were read here are live going backwards. @@ -682,11 +918,11 @@ liveness1 liveregs blockmap instr -- union in the live regs from all the jump destinations of this -- instruction. - targets = jumpDests instr [] -- where we go from here + targets = jumpDestsOfInstr instr -- where we go from here not_a_branch = null targets targetLiveRegs target - = case lookupBlockEnv blockmap target of + = case mapLookup target blockmap of Just ra -> ra Nothing -> emptyRegMap @@ -701,5 +937,3 @@ liveness1 liveregs blockmap instr live_branch_only) - -