From e17cf7ff32778f4e6b3622855f25426251e843d6 Mon Sep 17 00:00:00 2001 From: "Ben.Lippmeier@anu.edu.au" Date: Thu, 17 Sep 2009 09:07:30 +0000 Subject: [PATCH] NCG: Refactor representation of code with liveness info * I've pushed the SPILL and RELOAD instrs down into the LiveInstr type to make them easier to work with. * When the graph allocator does a spill cycle it now just re-annotates the LiveCmmTops instead of converting them to NatCmmTops and back. * This saves working out the SCCS again, and avoids rewriting the SPILL and RELOAD meta instructions into real machine instructions. --- compiler/nativeGen/AsmCodeGen.lhs | 4 +- compiler/nativeGen/RegAlloc/Graph/Coalesce.hs | 7 +- compiler/nativeGen/RegAlloc/Graph/Main.hs | 4 +- compiler/nativeGen/RegAlloc/Graph/Spill.hs | 22 +- compiler/nativeGen/RegAlloc/Graph/SpillClean.hs | 29 ++- compiler/nativeGen/RegAlloc/Graph/SpillCost.hs | 10 +- compiler/nativeGen/RegAlloc/Graph/Stats.hs | 12 +- compiler/nativeGen/RegAlloc/Linear/Main.hs | 12 +- compiler/nativeGen/RegAlloc/Liveness.hs | 245 ++++++++++++++--------- 9 files changed, 187 insertions(+), 158 deletions(-) diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index d73cb89..79d55f0 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -304,7 +304,9 @@ cmmNativeGen dflags us cmm count -- tag instructions with register liveness information let (withLiveness, usLive) = {-# SCC "regLiveness" #-} - initUs usGen $ mapUs regLiveness native + initUs usGen + $ mapUs regLiveness + $ map natCmmTopToLive native dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index a5d95a3..e0fad17 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -73,8 +73,8 @@ slurpJoinMovs live slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs - slurpLI rs (Instr _ Nothing) = rs - slurpLI rs (Instr instr (Just live)) + slurpLI rs (LiveInstr _ Nothing) = rs + slurpLI rs (LiveInstr instr (Just live)) | Just (r1, r2) <- takeRegRegMoveInstr instr , elementOfUniqSet r1 $ liveDieRead live , elementOfUniqSet r2 $ liveBorn live @@ -86,8 +86,5 @@ slurpJoinMovs live | otherwise = rs - - slurpLI rs SPILL{} = rs - slurpLI rs RELOAD{} = rs diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 40c3c00..093c211 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -211,8 +211,8 @@ regAlloc_spin <- regSpill code_coalesced slotsFree rsSpill -- recalculate liveness - let code_nat = map stripLive code_spilled - code_relive <- mapM regLiveness code_nat +-- let code_nat = map stripLive code_spilled + code_relive <- mapM regLiveness code_spilled -- record what happened in this stage for debugging let stat = diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index f9a2586..10bd669 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -80,19 +80,11 @@ regSpill_instr => UniqFM Int -> LiveInstr instr -> SpillM [LiveInstr instr] --- | The thing we're spilling shouldn't already have spill or reloads in it -regSpill_instr _ SPILL{} - = panic "regSpill_instr: unexpected SPILL" - -regSpill_instr _ RELOAD{} - = panic "regSpill_instr: unexpected RELOAD" - - -regSpill_instr _ li@(Instr _ Nothing) +regSpill_instr _ li@(LiveInstr _ Nothing) = do return [li] regSpill_instr regSlotMap - (Instr instr (Just _)) + (LiveInstr instr (Just _)) = do -- work out which regs are read and written in this instr let RU rlRead rlWritten = regUsageOfInstr instr @@ -123,7 +115,7 @@ regSpill_instr regSlotMap -- final code let instrs' = prefixes - ++ [Instr instr3 Nothing] + ++ [LiveInstr instr3 Nothing] ++ postfixes return @@ -147,7 +139,7 @@ spillRead regSlotMap instr reg { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) } return ( instr' - , ( [RELOAD slot nReg] + , ( [LiveInstr (RELOAD slot nReg) Nothing] , []) ) | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg" @@ -162,7 +154,7 @@ spillWrite regSlotMap instr reg return ( instr' , ( [] - , [SPILL nReg slot])) + , [LiveInstr (SPILL nReg slot) Nothing])) | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg" @@ -175,8 +167,8 @@ spillModify regSlotMap instr reg { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) } return ( instr' - , ( [RELOAD slot nReg] - , [SPILL nReg slot])) + , ( [LiveInstr (RELOAD slot nReg) Nothing] + , [LiveInstr (SPILL nReg slot) Nothing])) | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg" diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 15fbb59..11e3cef 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -158,16 +158,16 @@ cleanForward _ _ acc [] -- cleanForward blockId assoc acc (li1 : li2 : instrs) - | SPILL reg1 slot1 <- li1 - , RELOAD slot2 reg2 <- li2 + | LiveInstr (SPILL reg1 slot1) _ <- li1 + , LiveInstr (RELOAD slot2 reg2) _ <- li2 , slot1 == slot2 = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } cleanForward blockId assoc acc - (li1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs) + (li1 : LiveInstr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs) -cleanForward blockId assoc acc (li@(Instr i1 _) : instrs) +cleanForward blockId assoc acc (li@(LiveInstr i1 _) : instrs) | Just (r1, r2) <- takeRegRegMoveInstr i1 = if r1 == r2 -- erase any left over nop reg reg moves while we're here @@ -187,35 +187,32 @@ cleanForward blockId assoc acc (li@(Instr i1 _) : instrs) cleanForward blockId assoc acc (li : instrs) -- update association due to the spill - | SPILL reg slot <- li + | LiveInstr (SPILL reg slot) _ <- li = let assoc' = addAssoc (SReg reg) (SSlot slot) $ delAssoc (SSlot slot) $ assoc in cleanForward blockId assoc' (li : acc) instrs -- clean a reload instr - | RELOAD{} <- li + | LiveInstr (RELOAD{}) _ <- li = do (assoc', mli) <- cleanReload blockId assoc li case mli of Nothing -> cleanForward blockId assoc' acc instrs Just li' -> cleanForward blockId assoc' (li' : acc) instrs -- remember the association over a jump - | Instr instr _ <- li + | LiveInstr instr _ <- li , targets <- jumpDestsOfInstr instr , not $ null targets = do mapM_ (accJumpValid assoc) targets cleanForward blockId assoc (li : acc) instrs -- writing to a reg changes its value. - | Instr instr _ <- li + | LiveInstr instr _ <- li , RU _ written <- regUsageOfInstr instr = let assoc' = foldr delAssoc assoc (map SReg $ nub written) in cleanForward blockId assoc' (li : acc) instrs --- bogus, to stop pattern match warning -cleanForward _ _ _ _ - = panic "RegAlloc.Graph.SpillClean.cleanForward: no match" -- | Try and rewrite a reload instruction to something more pleasing @@ -227,7 +224,7 @@ cleanReload -> LiveInstr instr -> CleanM (Assoc Store, Maybe (LiveInstr instr)) -cleanReload blockId assoc li@(RELOAD slot reg) +cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) -- if the reg we're reloading already has the same value as the slot -- then we can erase the instruction outright @@ -244,7 +241,7 @@ cleanReload blockId assoc li@(RELOAD slot reg) $ delAssoc (SReg reg) $ assoc - return (assoc', Just $ Instr (mkRegRegMoveInstr reg2 reg) Nothing) + return (assoc', Just $ LiveInstr (mkRegRegMoveInstr reg2 reg) Nothing) -- gotta keep this instr | otherwise @@ -306,12 +303,12 @@ cleanBackward' _ _ acc [] cleanBackward' reloadedBy noReloads acc (li : instrs) -- if nothing ever reloads from this slot then we don't need the spill - | SPILL _ slot <- li + | LiveInstr (SPILL _ slot) _ <- li , Nothing <- lookupUFM reloadedBy (SSlot slot) = do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } cleanBackward noReloads acc instrs - | SPILL _ slot <- li + | LiveInstr (SPILL _ slot) _ <- li = if elementOfUniqSet slot noReloads -- we can erase this spill because the slot won't be read until after the next one @@ -325,7 +322,7 @@ cleanBackward' reloadedBy noReloads acc (li : instrs) cleanBackward noReloads' (li : acc) instrs -- if we reload from a slot then it's no longer unused - | RELOAD slot _ <- li + | LiveInstr (RELOAD slot _) _ <- li , noReloads' <- delOneFromUniqSet noReloads slot = cleanBackward noReloads' (li : acc) instrs diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 5932d31..9799587 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -93,13 +93,7 @@ slurpSpillCostInfo cmm = return () -- skip over comment and delta pseudo instrs - countLIs rsLive (SPILL{} : lis) - = countLIs rsLive lis - - countLIs rsLive (RELOAD{} : lis) - = countLIs rsLive lis - - countLIs rsLive (Instr instr Nothing : lis) + countLIs rsLive (LiveInstr instr Nothing : lis) | isMetaInstr instr = countLIs rsLive lis @@ -107,7 +101,7 @@ slurpSpillCostInfo cmm = pprPanic "RegSpillCost.slurpSpillCostInfo" (text "no liveness information on instruction " <> ppr instr) - countLIs rsLiveEntry (Instr instr (Just live) : lis) + countLIs rsLiveEntry (LiveInstr instr (Just live) : lis) = do -- increment the lifetime counts for regs live on entry to this instr mapM_ incLifetime $ uniqSetToList rsLiveEntry diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 339bd41..cdce1b6 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -258,15 +258,15 @@ countSRM_block (BasicBlock i instrs) return $ BasicBlock i instrs' countSRM_instr li - | SPILL _ _ <- li - = do modify $ \(s, r, m) -> (s + 1, r, m) + | LiveInstr SPILL{} _ <- li + = do modify $ \(s, r, m) -> (s + 1, r, m) return li - | RELOAD _ _ <- li - = do modify $ \(s, r, m) -> (s, r + 1, m) + | LiveInstr RELOAD{} _ <- li + = do modify $ \(s, r, m) -> (s, r + 1, m) return li - - | Instr instr _ <- li + + | LiveInstr instr _ <- li , Just _ <- takeRegRegMoveInstr instr = do modify $ \(s, r, m) -> (s, r, m + 1) return li diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 0014eec..29cc0e5 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -292,7 +292,7 @@ linearRA _ accInstr accFixup _ [] linearRA block_live accInstr accFixups id (instr:instrs) = do - (accInstr', new_fixups) + (accInstr', new_fixups) <- raInsn block_live accInstr id instr linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs @@ -309,17 +309,17 @@ raInsn ( [instr] -- new instructions , [NatBasicBlock instr]) -- extra fixup blocks -raInsn _ new_instrs _ (Instr ii Nothing) +raInsn _ new_instrs _ (LiveInstr ii Nothing) | Just n <- takeDeltaInstr ii = do setDeltaR n return (new_instrs, []) -raInsn _ new_instrs _ (Instr ii Nothing) +raInsn _ new_instrs _ (LiveInstr ii Nothing) | isMetaInstr ii = return (new_instrs, []) -raInsn block_live new_instrs id (Instr instr (Just live)) +raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do assig <- getAssigR @@ -380,9 +380,9 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = clobber_saves <- saveClobberedTemps real_written r_dying -- debugging -{- freeregs <- getFreeRegsR + freeregs <- getFreeRegsR assig <- getAssigR - pprTrace "genRaInsn" +{- pprTrace "genRaInsn" (ppr instr $$ text "r_dying = " <+> ppr r_dying $$ text "w_dying = " <+> ppr w_dying diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index e4481b5..69ec7ae 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -12,6 +12,7 @@ module RegAlloc.Liveness ( RegMap, emptyRegMap, BlockMap, emptyBlockMap, LiveCmmTop, + InstrSR (..), LiveInstr (..), Liveness (..), LiveInfo (..), @@ -26,8 +27,8 @@ module RegAlloc.Liveness ( eraseDeltasLive, patchEraseLive, patchRegsLiveInstr, - regLiveness - + regLiveness, + natCmmTopToLive ) where @@ -73,17 +74,76 @@ type LiveCmmTop instr [SCC (LiveBasicBlock instr)] --- | An instruction with liveness information. -data LiveInstr instr - = Instr instr (Maybe Liveness) +-- | 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 + | 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 + = LiveInstr (InstrSR instr) (Maybe Liveness) + -- | Liveness information. -- The regs which die are ones which are no longer live in the *next* instruction -- in this sequence. @@ -110,8 +170,12 @@ type LiveBasicBlock instr = GenBasicBlock (LiveInstr instr) -instance Outputable instr - => Outputable (LiveInstr instr) where +instance Outputable instr + => Outputable (InstrSR instr) where + + ppr (Instr realInstr) + = ppr realInstr + ppr (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), @@ -128,10 +192,13 @@ instance Outputable instr comma, ppr reg] - ppr (Instr instr Nothing) +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 @@ -186,12 +253,6 @@ mapSCCM f (CyclicSCC xs) = do xs' <- mapM f xs return $ CyclicSCC xs' -{- -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' --} -- map a function across all the basic blocks in this code mapGenBlockTop @@ -250,17 +311,10 @@ slurpConflicts live slurpLIs rsLive (conflicts, moves) [] = (consBag rsLive conflicts, moves) - slurpLIs rsLive rs (Instr _ Nothing : lis) + slurpLIs rsLive rs (LiveInstr _ Nothing : lis) = slurpLIs rsLive rs lis - - -- we're not expecting to be slurping conflicts from spilled code - slurpLIs _ _ (SPILL _ _ : _) - = panic "Liveness.slurpConflicts: unexpected SPILL" - - slurpLIs _ _ (RELOAD _ _ : _) - = panic "Liveness.slurpConflicts: unexpected RELOAD" - 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. @@ -349,12 +403,12 @@ slurpReloadCoalesce live slurpLI slotMap li -- remember what reg was stored into the slot - | SPILL reg slot <- li - , 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 <- li + | LiveInstr (RELOAD slot reg) _ <- li = case lookupUFM slotMap slot of Just reg2 | reg /= reg2 -> return (slotMap, Just (reg, reg2)) @@ -363,8 +417,8 @@ slurpReloadCoalesce live Nothing -> return (slotMap, Nothing) -- if we hit a jump, remember the current slotMap - | Instr instr _ <- li - , targets <- jumpDestsOfInstr instr + | LiveInstr (Instr instr) _ <- li + , targets <- jumpDestsOfInstr instr , not $ null targets = do mapM_ (accSlotMap slotMap) targets return (slotMap, Nothing) @@ -425,20 +479,20 @@ stripLiveBlock (BasicBlock i lis) spillNat acc [] = return (reverse acc) - 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 instr _ : instrs) + spillNat acc (LiveInstr (Instr instr) _ : instrs) | Just i <- takeDeltaInstr instr = do put i spillNat acc instrs - spillNat acc (Instr instr _ : instrs) + spillNat acc (LiveInstr (Instr instr) _ : instrs) = spillNat (instr : acc) instrs @@ -454,7 +508,7 @@ eraseDeltasLive cmm where eraseBlock (BasicBlock id lis) = BasicBlock id - $ filter (\(Instr i _) -> not $ isJust $ takeDeltaInstr i) + $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) $ lis @@ -493,7 +547,7 @@ patchEraseLive patchF cmm patchInstrs [] = [] patchInstrs (li : lis) - | Instr i (Just live) <- li' + | LiveInstr i (Just live) <- li' , Just (r1, r2) <- takeRegRegMoveInstr i , eatMe r1 r2 live = patchInstrs lis @@ -524,11 +578,11 @@ patchRegsLiveInstr patchRegsLiveInstr patchF li = case li of - Instr instr Nothing - -> Instr (patchRegsOfInstr instr patchF) Nothing + LiveInstr instr Nothing + -> LiveInstr (patchRegsOfInstr instr patchF) Nothing - Instr instr (Just live) - -> Instr + 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 @@ -536,87 +590,79 @@ patchRegsLiveInstr patchF li , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) - SPILL reg slot - -> SPILL (patchF reg) slot - - RELOAD slot reg - -> RELOAD slot (patchF reg) - -------------------------------------------------------------------------------- -- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information -{- + natCmmTopToLive - :: NatCmmTop instr + :: Instruction instr + => NatCmmTop instr -> LiveCmmTop instr -natCmmTopToLive cmm@(CmmData _ _) - = cmm +natCmmTopToLive (CmmData i d) + = CmmData i d natCmmTopToLive (CmmProc info lbl params (ListGraph [])) - = CmmProc (LiveInfo info Nothing emptyBlockEnv) - lbl params (ListGraph [])) + = CmmProc (LiveInfo info Nothing Nothing) + lbl params [] + +natCmmTopToLive (CmmProc info lbl params (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 + -natCmmTopToLive (CmmProc info lbl params (ListGraph blocks)) - = let first_id = blockId first - sccs = sccBlocks blocks +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC (NatBasicBlock instr)] + +sccBlocks blocks = stronglyConnCompFromEdgedVertices graph + where + getOutEdges :: Instruction instr => [instr] -> [BlockId] + getOutEdges instrs = concat $ map jumpDestsOfInstr instrs - liveBlocks - = map (\scc -> case scc of - AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [cmmBlockToLive b] - CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l (map cmmBlockToLive bs) - CyclicSCC [] - -> panic "RegLiveNess.natCmmTopToLive: no blocks in scc list") - sccs + graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) + | block@(BasicBlock id instrs) <- blocks ] - in CmmProc (LiveInfo info (Just first_id) ??? --} --------------------------------------------------------------------------------- -- Annotate code with register liveness information -- regLiveness :: Instruction instr - => NatCmmTop instr + => LiveCmmTop instr -> UniqSM (LiveCmmTop instr) regLiveness (CmmData i d) = returnUs $ CmmData i d -regLiveness (CmmProc info lbl params (ListGraph [])) +regLiveness (CmmProc info lbl params []) + | LiveInfo static mFirst _ <- info = returnUs $ CmmProc - (LiveInfo info Nothing (Just emptyBlockEnv)) + (LiveInfo static mFirst (Just emptyBlockEnv)) lbl params [] -regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _))) - = let first_id = blockId first - sccs = sccBlocks blocks - (ann_sccs, block_live) = computeLiveness sccs +regLiveness (CmmProc info lbl params sccs) + | LiveInfo static mFirst _ <- info + = let (ann_sccs, block_live) = computeLiveness sccs - in returnUs $ CmmProc (LiveInfo info (Just first_id) (Just block_live)) + in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live)) lbl params ann_sccs -sccBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [SCC (NatBasicBlock instr)] - -sccBlocks blocks = stronglyConnCompFromEdgedVertices graph - where - 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 computeLiveness :: Instruction instr - => [SCC (NatBasicBlock 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 @@ -634,11 +680,12 @@ livenessSCCs :: Instruction instr => BlockMap RegSet -> [SCC (LiveBasicBlock instr)] -- accum - -> [SCC (NatBasicBlock instr)] + -> [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 @@ -666,7 +713,7 @@ livenessSCCs blockmap done linearLiveness :: Instruction instr - => BlockMap RegSet -> [NatBasicBlock instr] + => BlockMap RegSet -> [LiveBasicBlock instr] -> (BlockMap RegSet, [LiveBasicBlock instr]) linearLiveness = mapAccumL livenessBlock @@ -686,7 +733,7 @@ livenessSCCs blockmap done livenessBlock :: Instruction instr => BlockMap RegSet - -> NatBasicBlock instr + -> LiveBasicBlock instr -> (BlockMap RegSet, LiveBasicBlock instr) livenessBlock blockmap (BasicBlock block_id instrs) @@ -710,7 +757,7 @@ livenessForward -> [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 @@ -726,7 +773,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" @@ -740,7 +787,7 @@ livenessBack => RegSet -- regs live on this instr -> BlockMap RegSet -- regs live on entry to other BBs -> [LiveInstr instr] -- instructions (accum) - -> [instr] -- instructions + -> [LiveInstr instr] -- instructions -> (RegSet, [LiveInstr instr]) livenessBack liveregs _ done [] = (liveregs, done) @@ -755,24 +802,24 @@ liveness1 :: Instruction instr => RegSet -> BlockMap RegSet - -> instr + -> LiveInstr instr -> (RegSet, LiveInstr instr) -liveness1 liveregs _ instr +liveness1 liveregs _ (LiveInstr instr _) | isMetaInstr instr - = (liveregs, Instr instr Nothing) + = (liveregs, LiveInstr instr Nothing) -liveness1 liveregs blockmap instr +liveness1 liveregs blockmap (LiveInstr instr _) | not_a_branch - = (liveregs1, Instr instr + = (liveregs1, LiveInstr instr (Just $ Liveness { liveBorn = emptyUniqSet , liveDieRead = mkUniqSet r_dying , liveDieWrite = mkUniqSet w_dying })) | otherwise - = (liveregs_br, Instr instr + = (liveregs_br, LiveInstr instr (Just $ Liveness { liveBorn = emptyUniqSet , liveDieRead = mkUniqSet r_dying_br -- 1.7.10.4