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.
parent 028c032b
...@@ -304,7 +304,9 @@ cmmNativeGen dflags us cmm count ...@@ -304,7 +304,9 @@ cmmNativeGen dflags us cmm count
-- tag instructions with register liveness information -- tag instructions with register liveness information
let (withLiveness, usLive) = let (withLiveness, usLive) =
{-# SCC "regLiveness" #-} {-# SCC "regLiveness" #-}
initUs usGen $ mapUs regLiveness native initUs usGen
$ mapUs regLiveness
$ map natCmmTopToLive native
dumpIfSet_dyn dflags dumpIfSet_dyn dflags
Opt_D_dump_asm_liveness "Liveness annotations added" Opt_D_dump_asm_liveness "Liveness annotations added"
......
...@@ -73,8 +73,8 @@ slurpJoinMovs live ...@@ -73,8 +73,8 @@ slurpJoinMovs live
slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs)
slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs
slurpLI rs (Instr _ Nothing) = rs slurpLI rs (LiveInstr _ Nothing) = rs
slurpLI rs (Instr instr (Just live)) slurpLI rs (LiveInstr instr (Just live))
| Just (r1, r2) <- takeRegRegMoveInstr instr | Just (r1, r2) <- takeRegRegMoveInstr instr
, elementOfUniqSet r1 $ liveDieRead live , elementOfUniqSet r1 $ liveDieRead live
, elementOfUniqSet r2 $ liveBorn live , elementOfUniqSet r2 $ liveBorn live
...@@ -86,8 +86,5 @@ slurpJoinMovs live ...@@ -86,8 +86,5 @@ slurpJoinMovs live
| otherwise | otherwise
= rs = rs
slurpLI rs SPILL{} = rs
slurpLI rs RELOAD{} = rs
...@@ -211,8 +211,8 @@ regAlloc_spin ...@@ -211,8 +211,8 @@ regAlloc_spin
<- regSpill code_coalesced slotsFree rsSpill <- regSpill code_coalesced slotsFree rsSpill
-- recalculate liveness -- recalculate liveness
let code_nat = map stripLive code_spilled -- let code_nat = map stripLive code_spilled
code_relive <- mapM regLiveness code_nat code_relive <- mapM regLiveness code_spilled
-- record what happened in this stage for debugging -- record what happened in this stage for debugging
let stat = let stat =
......
...@@ -80,19 +80,11 @@ regSpill_instr ...@@ -80,19 +80,11 @@ regSpill_instr
=> UniqFM Int => UniqFM Int
-> LiveInstr instr -> SpillM [LiveInstr instr] -> LiveInstr instr -> SpillM [LiveInstr instr]
-- | The thing we're spilling shouldn't already have spill or reloads in it regSpill_instr _ li@(LiveInstr _ Nothing)
regSpill_instr _ SPILL{}
= panic "regSpill_instr: unexpected SPILL"
regSpill_instr _ RELOAD{}
= panic "regSpill_instr: unexpected RELOAD"
regSpill_instr _ li@(Instr _ Nothing)
= do return [li] = do return [li]
regSpill_instr regSlotMap regSpill_instr regSlotMap
(Instr instr (Just _)) (LiveInstr instr (Just _))
= do = do
-- work out which regs are read and written in this instr -- work out which regs are read and written in this instr
let RU rlRead rlWritten = regUsageOfInstr instr let RU rlRead rlWritten = regUsageOfInstr instr
...@@ -123,7 +115,7 @@ regSpill_instr regSlotMap ...@@ -123,7 +115,7 @@ regSpill_instr regSlotMap
-- final code -- final code
let instrs' = prefixes let instrs' = prefixes
++ [Instr instr3 Nothing] ++ [LiveInstr instr3 Nothing]
++ postfixes ++ postfixes
return return
...@@ -147,7 +139,7 @@ spillRead regSlotMap instr reg ...@@ -147,7 +139,7 @@ spillRead regSlotMap instr reg
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) } { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
return ( instr' return ( instr'
, ( [RELOAD slot nReg] , ( [LiveInstr (RELOAD slot nReg) Nothing]
, []) ) , []) )
| otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg" | otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg"
...@@ -162,7 +154,7 @@ spillWrite regSlotMap instr reg ...@@ -162,7 +154,7 @@ spillWrite regSlotMap instr reg
return ( instr' return ( instr'
, ( [] , ( []
, [SPILL nReg slot])) , [LiveInstr (SPILL nReg slot) Nothing]))
| otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg" | otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg"
...@@ -175,8 +167,8 @@ spillModify regSlotMap instr reg ...@@ -175,8 +167,8 @@ spillModify regSlotMap instr reg
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) } { stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
return ( instr' return ( instr'
, ( [RELOAD slot nReg] , ( [LiveInstr (RELOAD slot nReg) Nothing]
, [SPILL nReg slot])) , [LiveInstr (SPILL nReg slot) Nothing]))
| otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg" | otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg"
......
...@@ -158,16 +158,16 @@ cleanForward _ _ acc [] ...@@ -158,16 +158,16 @@ cleanForward _ _ acc []
-- --
cleanForward blockId assoc acc (li1 : li2 : instrs) cleanForward blockId assoc acc (li1 : li2 : instrs)
| SPILL reg1 slot1 <- li1 | LiveInstr (SPILL reg1 slot1) _ <- li1
, RELOAD slot2 reg2 <- li2 , LiveInstr (RELOAD slot2 reg2) _ <- li2
, slot1 == slot2 , slot1 == slot2
= do = do
modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
cleanForward blockId assoc acc 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 | Just (r1, r2) <- takeRegRegMoveInstr i1
= if r1 == r2 = if r1 == r2
-- erase any left over nop reg reg moves while we're here -- erase any left over nop reg reg moves while we're here
...@@ -187,35 +187,32 @@ cleanForward blockId assoc acc (li@(Instr i1 _) : instrs) ...@@ -187,35 +187,32 @@ cleanForward blockId assoc acc (li@(Instr i1 _) : instrs)
cleanForward blockId assoc acc (li : instrs) cleanForward blockId assoc acc (li : instrs)
-- update association due to the spill -- update association due to the spill
| SPILL reg slot <- li | LiveInstr (SPILL reg slot) _ <- li
= let assoc' = addAssoc (SReg reg) (SSlot slot) = let assoc' = addAssoc (SReg reg) (SSlot slot)
$ delAssoc (SSlot slot) $ delAssoc (SSlot slot)
$ assoc $ assoc
in cleanForward blockId assoc' (li : acc) instrs in cleanForward blockId assoc' (li : acc) instrs
-- clean a reload instr -- clean a reload instr
| RELOAD{} <- li | LiveInstr (RELOAD{}) _ <- li
= do (assoc', mli) <- cleanReload blockId assoc li = do (assoc', mli) <- cleanReload blockId assoc li
case mli of case mli of
Nothing -> cleanForward blockId assoc' acc instrs Nothing -> cleanForward blockId assoc' acc instrs
Just li' -> cleanForward blockId assoc' (li' : acc) instrs Just li' -> cleanForward blockId assoc' (li' : acc) instrs
-- remember the association over a jump -- remember the association over a jump
| Instr instr _ <- li | LiveInstr instr _ <- li
, targets <- jumpDestsOfInstr instr , targets <- jumpDestsOfInstr instr
, not $ null targets , not $ null targets
= do mapM_ (accJumpValid assoc) targets = do mapM_ (accJumpValid assoc) targets
cleanForward blockId assoc (li : acc) instrs cleanForward blockId assoc (li : acc) instrs
-- writing to a reg changes its value. -- writing to a reg changes its value.
| Instr instr _ <- li | LiveInstr instr _ <- li
, RU _ written <- regUsageOfInstr instr , RU _ written <- regUsageOfInstr instr
= let assoc' = foldr delAssoc assoc (map SReg $ nub written) = let assoc' = foldr delAssoc assoc (map SReg $ nub written)
in cleanForward blockId assoc' (li : acc) instrs 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 -- | Try and rewrite a reload instruction to something more pleasing
...@@ -227,7 +224,7 @@ cleanReload ...@@ -227,7 +224,7 @@ cleanReload
-> LiveInstr instr -> LiveInstr instr
-> CleanM (Assoc Store, Maybe (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 -- if the reg we're reloading already has the same value as the slot
-- then we can erase the instruction outright -- then we can erase the instruction outright
...@@ -244,7 +241,7 @@ cleanReload blockId assoc li@(RELOAD slot reg) ...@@ -244,7 +241,7 @@ cleanReload blockId assoc li@(RELOAD slot reg)
$ delAssoc (SReg reg) $ delAssoc (SReg reg)
$ assoc $ assoc
return (assoc', Just $ Instr (mkRegRegMoveInstr reg2 reg) Nothing) return (assoc', Just $ LiveInstr (mkRegRegMoveInstr reg2 reg) Nothing)
-- gotta keep this instr -- gotta keep this instr
| otherwise | otherwise
...@@ -306,12 +303,12 @@ cleanBackward' _ _ acc [] ...@@ -306,12 +303,12 @@ cleanBackward' _ _ acc []
cleanBackward' reloadedBy noReloads acc (li : instrs) cleanBackward' reloadedBy noReloads acc (li : instrs)
-- if nothing ever reloads from this slot then we don't need the spill -- 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) , Nothing <- lookupUFM reloadedBy (SSlot slot)
= do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 } = do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
cleanBackward noReloads acc instrs cleanBackward noReloads acc instrs
| SPILL _ slot <- li | LiveInstr (SPILL _ slot) _ <- li
= if elementOfUniqSet slot noReloads = if elementOfUniqSet slot noReloads
-- we can erase this spill because the slot won't be read until after the next one -- 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) ...@@ -325,7 +322,7 @@ cleanBackward' reloadedBy noReloads acc (li : instrs)
cleanBackward noReloads' (li : acc) instrs cleanBackward noReloads' (li : acc) instrs
-- if we reload from a slot then it's no longer unused -- if we reload from a slot then it's no longer unused
| RELOAD slot _ <- li | LiveInstr (RELOAD slot _) _ <- li
, noReloads' <- delOneFromUniqSet noReloads slot , noReloads' <- delOneFromUniqSet noReloads slot
= cleanBackward noReloads' (li : acc) instrs = cleanBackward noReloads' (li : acc) instrs
......
...@@ -93,13 +93,7 @@ slurpSpillCostInfo cmm ...@@ -93,13 +93,7 @@ slurpSpillCostInfo cmm
= return () = return ()
-- skip over comment and delta pseudo instrs -- skip over comment and delta pseudo instrs
countLIs rsLive (SPILL{} : lis) countLIs rsLive (LiveInstr instr Nothing : lis)
= countLIs rsLive lis
countLIs rsLive (RELOAD{} : lis)
= countLIs rsLive lis
countLIs rsLive (Instr instr Nothing : lis)
| isMetaInstr instr | isMetaInstr instr
= countLIs rsLive lis = countLIs rsLive lis
...@@ -107,7 +101,7 @@ slurpSpillCostInfo cmm ...@@ -107,7 +101,7 @@ slurpSpillCostInfo cmm
= pprPanic "RegSpillCost.slurpSpillCostInfo" = pprPanic "RegSpillCost.slurpSpillCostInfo"
(text "no liveness information on instruction " <> ppr instr) (text "no liveness information on instruction " <> ppr instr)
countLIs rsLiveEntry (Instr instr (Just live) : lis) countLIs rsLiveEntry (LiveInstr instr (Just live) : lis)
= do = do
-- increment the lifetime counts for regs live on entry to this instr -- increment the lifetime counts for regs live on entry to this instr
mapM_ incLifetime $ uniqSetToList rsLiveEntry mapM_ incLifetime $ uniqSetToList rsLiveEntry
......
...@@ -258,15 +258,15 @@ countSRM_block (BasicBlock i instrs) ...@@ -258,15 +258,15 @@ countSRM_block (BasicBlock i instrs)
return $ BasicBlock i instrs' return $ BasicBlock i instrs'
countSRM_instr li countSRM_instr li
| SPILL _ _ <- li | LiveInstr SPILL{} _ <- li
= do modify $ \(s, r, m) -> (s + 1, r, m) = do modify $ \(s, r, m) -> (s + 1, r, m)
return li return li
| RELOAD _ _ <- li | LiveInstr RELOAD{} _ <- li
= do modify $ \(s, r, m) -> (s, r + 1, m) = do modify $ \(s, r, m) -> (s, r + 1, m)
return li return li
| Instr instr _ <- li | LiveInstr instr _ <- li
, Just _ <- takeRegRegMoveInstr instr , Just _ <- takeRegRegMoveInstr instr
= do modify $ \(s, r, m) -> (s, r, m + 1) = do modify $ \(s, r, m) -> (s, r, m + 1)
return li return li
......
...@@ -292,7 +292,7 @@ linearRA _ accInstr accFixup _ [] ...@@ -292,7 +292,7 @@ linearRA _ accInstr accFixup _ []
linearRA block_live accInstr accFixups id (instr:instrs) linearRA block_live accInstr accFixups id (instr:instrs)
= do = do
(accInstr', new_fixups) (accInstr', new_fixups)
<- raInsn block_live accInstr id instr <- raInsn block_live accInstr id instr
linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
...@@ -309,17 +309,17 @@ raInsn ...@@ -309,17 +309,17 @@ raInsn
( [instr] -- new instructions ( [instr] -- new instructions
, [NatBasicBlock instr]) -- extra fixup blocks , [NatBasicBlock instr]) -- extra fixup blocks
raInsn _ new_instrs _ (Instr ii Nothing) raInsn _ new_instrs _ (LiveInstr ii Nothing)
| Just n <- takeDeltaInstr ii | Just n <- takeDeltaInstr ii
= do setDeltaR n = do setDeltaR n
return (new_instrs, []) return (new_instrs, [])
raInsn _ new_instrs _ (Instr ii Nothing) raInsn _ new_instrs _ (LiveInstr ii Nothing)
| isMetaInstr ii | isMetaInstr ii
= return (new_instrs, []) = 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 = do
assig <- getAssigR assig <- getAssigR
...@@ -380,9 +380,9 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = ...@@ -380,9 +380,9 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying =
clobber_saves <- saveClobberedTemps real_written r_dying clobber_saves <- saveClobberedTemps real_written r_dying
-- debugging -- debugging
{- freeregs <- getFreeRegsR freeregs <- getFreeRegsR
assig <- getAssigR assig <- getAssigR
pprTrace "genRaInsn" {- pprTrace "genRaInsn"
(ppr instr (ppr instr
$$ text "r_dying = " <+> ppr r_dying $$ text "r_dying = " <+> ppr r_dying
$$ text "w_dying = " <+> ppr w_dying $$ text "w_dying = " <+> ppr w_dying
......
...@@ -12,6 +12,7 @@ module RegAlloc.Liveness ( ...@@ -12,6 +12,7 @@ module RegAlloc.Liveness (
RegMap, emptyRegMap, RegMap, emptyRegMap,
BlockMap, emptyBlockMap, BlockMap, emptyBlockMap,
LiveCmmTop, LiveCmmTop,
InstrSR (..),
LiveInstr (..), LiveInstr (..),
Liveness (..), Liveness (..),
LiveInfo (..), LiveInfo (..),
...@@ -26,8 +27,8 @@ module RegAlloc.Liveness ( ...@@ -26,8 +27,8 @@ module RegAlloc.Liveness (
eraseDeltasLive, eraseDeltasLive,
patchEraseLive, patchEraseLive,
patchRegsLiveInstr, patchRegsLiveInstr,
regLiveness regLiveness,
natCmmTopToLive
) where ) where
...@@ -73,17 +74,76 @@ type LiveCmmTop instr ...@@ -73,17 +74,76 @@ type LiveCmmTop instr
[SCC (LiveBasicBlock instr)] [SCC (LiveBasicBlock instr)]
-- | An instruction with liveness information. -- | The register allocator also wants to use SPILL/RELOAD meta instructions,
data LiveInstr instr -- so we'll keep those here.
= Instr instr (Maybe Liveness) data InstrSR instr
-- | A real machine instruction
= Instr instr
-- | spill this reg to a stack slot -- | spill this reg to a stack slot
| SPILL Reg Int | SPILL Reg Int
-- | reload this reg from a stack slot -- | reload this reg from a stack slot
| RELOAD Int Reg | 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. -- | Liveness information.
-- The regs which die are ones which are no longer live in the *next* instruction -- The regs which die are ones which are no longer live in the *next* instruction
-- in this sequence. -- in this sequence.
...@@ -110,8 +170,12 @@ type LiveBasicBlock instr ...@@ -110,8 +170,12 @@ type LiveBasicBlock instr
= GenBasicBlock (LiveInstr instr) = GenBasicBlock (LiveInstr instr)
instance Outputable instr instance Outputable instr
=> Outputable (LiveInstr instr) where => Outputable (InstrSR instr) where
ppr (Instr realInstr)
= ppr realInstr
ppr (SPILL reg slot) ppr (SPILL reg slot)
= hcat [ = hcat [
ptext (sLit "\tSPILL"), ptext (sLit "\tSPILL"),
...@@ -128,10 +192,13 @@ instance Outputable instr ...@@ -128,10 +192,13 @@ instance Outputable instr
comma, comma,
ppr reg] ppr reg]
ppr (Instr instr Nothing) instance Outputable instr
=> Outputable (LiveInstr instr) where
ppr (LiveInstr instr Nothing)
= ppr instr = ppr instr
ppr (Instr instr (Just live)) ppr (LiveInstr instr (Just live))
= ppr instr = ppr instr
$$ (nest 8 $$ (nest 8
$ vcat $ vcat
...@@ -186,12 +253,6 @@ mapSCCM f (CyclicSCC xs) ...@@ -186,12 +253,6 @@ mapSCCM f (CyclicSCC xs)
= do xs' <- mapM f xs = do xs' <- mapM f xs
return $ CyclicSCC 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 -- map a function across all the basic blocks in this code
mapGenBlockTop mapGenBlockTop
...@@ -250,17 +311,10 @@ slurpConflicts live ...@@ -250,17 +311,10 @@ slurpConflicts live
slurpLIs rsLive (conflicts, moves) [] slurpLIs rsLive (conflicts, moves) []
= (consBag rsLive conflicts, moves) = (consBag rsLive conflicts, moves)
slurpLIs rsLive rs (Instr _ Nothing : lis) slurpLIs rsLive rs (LiveInstr _ Nothing : lis)
= slurpLIs rsLive rs 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 = let
-- regs that die because they are read for the last time at the start of an instruction -- regs that die because they are read for the last time at the start of an instruction