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
-- 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"
......
......@@ -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
......@@ -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 =
......
......@@ -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"
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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