module CmmSpillReload
- ( ExtendWithSpills(..)
- , DualLive(..)
- , dualLiveLattice, dualLiveness
- , insertSpillsAndReloads --- XXX todo check live-in at entry against formals
+ ( DualLive(..)
+ , dualLiveLattice, dualLiveTransfers, dualLiveness
+ --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
, dualLivenessWithInsertion
- , spillAndReloadComments
, availRegsLattice
, cmmAvailableReloads
+ , insertLateReloads
+ , removeDeadAssignmentsAndReloads
)
where
+
+import BlockId
import CmmExpr
import CmmTx
import CmmLiveZ
import DFMonad
-import FastString
-import Maybe
import MkZipCfg
-import Outputable hiding (empty)
-import qualified Outputable as PP
-import Panic
import PprCmm()
-import UniqSet
import ZipCfg
import ZipCfgCmmRep
import ZipDataflow
+import Control.Monad
+import Outputable hiding (empty)
+import qualified Outputable as PP
+import UniqSet
+
+import Data.Maybe
+import Prelude hiding (zip)
+
-- The point of this module is to insert spills and reloads to
-- establish the invariant that at a call (or at any proc point with
-- an established protocol) all live variables not expected in
-- registers are sitting on the stack. We use a backward analysis to
--- insert spills and reloads. It should some day be followed by a
+-- insert spills and reloads. It should be followed by a
-- forward transformation to sink reloads as deeply as possible, so as
-- to reduce register pressure.
-data ExtendWithSpills m
- = NotSpillOrReload m
- | Spill RegSet
- | Reload RegSet
-
-type M = ExtendWithSpills Middle
-
-- A variable can be expected to be live in a register, live on the
-- stack, or both. This analysis ensures that spills and reloads are
-- inserted as needed to make sure that every live variable needed
where ss = unionManyUniqSets $ map on_stack ls
rs = unionManyUniqSets $ map in_regs ls
-_changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
-_changeStack f live = live { on_stack = f (on_stack live) }
-changeRegs f live = live { in_regs = f (in_regs live) }
+changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
+changeStack f live = live { on_stack = f (on_stack live) }
+changeRegs f live = live { in_regs = f (in_regs live) }
dualLiveLattice :: DataflowLattice DualLive
dualLiveLattice =
- DataflowLattice "variables live in registers and on stack" empty add False
+ DataflowLattice "variables live in registers and on stack" empty add True
where empty = DualLive emptyRegSet emptyRegSet
-- | compute in the Tx monad to track whether anything has changed
add new old = do stack <- add1 (on_stack new) (on_stack old)
return $ DualLive stack regs
add1 = fact_add_to liveLattice
-dualLivenessWithInsertion :: BPass M Last DualLive
-dualLivenessWithInsertion = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
+type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
+dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
+dualLivenessWithInsertion procPoints g@(LGraph entry _) =
+ liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
+ where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
+ dualLiveLattice (dualLiveTransfers entry procPoints)
+ (insertSpillAndReloadRewrites entry procPoints) empty g
+ empty = fact_bot dualLiveLattice
-dualLiveness :: BAnalysis M Last DualLive
-dualLiveness = BComp "dual liveness" exit last middle first
- where exit = empty
- last = lastDualLiveness
- middle = middleDualLiveness
- first live _id = live
+dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
+dualLiveness procPoints g@(LGraph entry _) =
+ liftM zdfFpFacts $ (res :: LiveReloadFix ())
+ where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
+ (dualLiveTransfers entry procPoints) empty g
empty = fact_bot dualLiveLattice
- -- ^ could take a proc-point set and choose to spill here,
- -- but it's probably better to run this pass, choose
- -- proc-point protocols, insert more CopyIn nodes, and run
- -- this pass again
-
-middleDualLiveness :: DualLive -> M -> DualLive
-middleDualLiveness live m@(Spill regs) =
- -- live-in on-stack requirements are satisfied;
- -- live-out in-regs obligations are created
- my_trace "before" (f4sep [ppr m, text "liveness is", ppr live']) $
- live'
- where live' = DualLive { on_stack = on_stack live `minusRegSet` regs
- , in_regs = in_regs live `plusRegSet` regs }
-
-middleDualLiveness live m@(Reload regs) =
- -- live-in in-regs requirements are satisfied;
- -- live-out on-stack obligations are created
- my_trace "before" (f4sep [ppr m, text "liveness is", ppr live']) $
- live'
- where live' = DualLive { on_stack = on_stack live `plusRegSet` regs
- , in_regs = in_regs live `minusRegSet` regs }
-
-middleDualLiveness live (NotSpillOrReload m) = changeRegs (middleLiveness m) live
-
-lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
-lastDualLiveness env l = last l
- where last (LastReturn ress) = changeRegs (gen ress) empty
- last (LastJump e args) = changeRegs (gen e . gen args) empty
- last (LastBranch id args) = changeRegs (gen args) $ env id
- last (LastCall tgt Nothing) = changeRegs (gen tgt) empty
- last (LastCall tgt (Just k)) =
- -- nothing can be live in registers at this point
- -- only 'formals' can be in regs at this point
- let live = env k in
- if isEmptyUniqSet (in_regs live) then
- DualLive (on_stack live) (gen tgt emptyRegSet)
- else
- panic "live values in registers at call continuation"
- last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f)
- last (LastSwitch e tbl) = changeRegs (gen e) $ dualUnionList $
+dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive
+dualLiveTransfers entry procPoints = BackwardTransfers first middle last
+ where last = lastDualLiveness
+ middle = middleDualLiveness
+ first id live = check live id $ -- live at procPoint => spill
+ if id /= entry && elemBlockSet id procPoints then
+ DualLive { on_stack = on_stack live `plusRegSet` in_regs live
+ , in_regs = emptyRegSet }
+ else live
+ check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
+
+middleDualLiveness :: Middle -> DualLive -> DualLive
+middleDualLiveness m live =
+ changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live)
+ where regs_in live = case m of MidForeignCall {} -> emptyRegSet
+ _ -> live
+ updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
+ spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
+ spill live _ = live
+ reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
+ reload live _ = live
+ check (RegSlot (LocalReg _ ty), o, w) x
+ | o == w && w == widthInBytes (typeWidth ty) = x
+ check _ _ = panic "middleDualLiveness unsupported: slices"
+
+lastDualLiveness :: Last -> (BlockId -> DualLive) -> DualLive
+lastDualLiveness l env = last l
+ where last (LastBranch id) = env id
+ last l@(LastCall _ Nothing _ _ _) = changeRegs (gen l . kill l) empty
+ last l@(LastCall _ (Just k) _ _ _) =
+ -- nothing can be live in registers at this point, unless safe foreign call
+ let live = env k
+ live_in = DualLive (on_stack live) (gen l emptyRegSet)
+ in if isEmptyUniqSet (in_regs live) then live_in
+ else pprTrace "Offending party:" (ppr k <+> ppr live) $
+ panic "live values in registers at call continuation"
+ last l@(LastCondBranch _ t f) =
+ changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
+ last l@(LastSwitch _ tbl) = changeRegs (gen l . kill l) $ dualUnionList $
map env (catMaybes tbl)
empty = fact_bot dualLiveLattice
-gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
-gen a live = foldRegsUsed extendRegSet live a
-kill a live = foldRegsUsed delOneFromUniqSet live a
-
-insertSpillsAndReloads :: BFunctionalTransformation M Last DualLive
-insertSpillsAndReloads = BComp "CPS spiller" exit last middle first
- where exit = Nothing
- last = \_ _ -> Nothing
- middle = middleInsertSpillsAndReloads
- first _ _ = Nothing
- -- ^ could take a proc-point set and choose to spill here,
- -- but it's probably better to run this pass, choose
- -- proc-point protocols, insert more CopyIn nodes, and run
- -- this pass again
-
-
-middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
-middleInsertSpillsAndReloads _ (Spill _) = Nothing
-middleInsertSpillsAndReloads _ (Reload _) = Nothing
-middleInsertSpillsAndReloads live (NotSpillOrReload m) = middle m
- where middle (MidAssign (CmmLocal reg') _) =
- if reg' `elemRegSet` on_stack live then -- must spill
- my_trace "Spilling" (f4sep [text "spill" <+> ppr reg',
- text "after", ppr m]) $
- Just $ graphOfMiddles [NotSpillOrReload m, Spill $ mkRegSet [reg']]
- else
- Nothing
- middle (CopyIn _ formals _) =
- -- only 'formals' can be in regs at this point
- let regs' = kill formals (in_regs live) -- live in regs; must reload
- is_stack_var r = elemRegSet r (on_stack live)
- needs_spilling = -- a formal that is expected on the stack; must spill
- foldRegsUsed (\rs r -> if is_stack_var r then extendRegSet rs r
- else rs) emptyRegSet formals
- in if isEmptyUniqSet regs' && isEmptyUniqSet needs_spilling then
- Nothing
- else
- let reload = if isEmptyUniqSet regs' then []
- else [Reload regs']
- spill_reload = if isEmptyUniqSet needs_spilling then reload
- else Spill needs_spilling : reload
- middles = NotSpillOrReload m : spill_reload
- in
- my_trace "At CopyIn" (f4sep [text "Triggered by ", ppr live,
- ppr (Reload regs' :: M),
- ppr (Spill needs_spilling :: M),
- text "after", ppr m]) $
- Just $ graphOfMiddles middles
+gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
+gen a live = foldRegsUsed extendRegSet live a
+kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
+kill a live = foldRegsDefd deleteFromRegSet live a
+
+insertSpillAndReloadRewrites ::
+ BlockId -> BlockSet -> BackwardRewrites Middle Last DualLive
+insertSpillAndReloadRewrites entry procPoints =
+ BackwardRewrites first middle last exit
+ where middle = middleInsertSpillsAndReloads
+ last _ _ = Nothing
+ exit = Nothing
+ first id live =
+ if id /= entry && elemBlockSet id procPoints then
+ case map reload (uniqSetToList (in_regs live)) of
+ [] -> Nothing
+ is -> Just (mkMiddles is)
+ else Nothing
+
+middleInsertSpillsAndReloads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
+middleInsertSpillsAndReloads m live = middle m
+ where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _))
+ | reg == reg' = Nothing
+ middle (MidAssign (CmmLocal reg) _) =
+ if reg `elemRegSet` on_stack live then -- must spill
+ my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
+ text "after", ppr m]) $
+ Just $ mkMiddles $ [m, spill reg]
+ else Nothing
+ middle (MidForeignCall _ _ fs _) =
+ case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
+ map reload (uniqSetToList (kill fs (in_regs live))) of
+ [] -> Nothing
+ reloads -> Just (mkMiddles (m : reloads))
middle _ = Nothing
--- | For conversion back to vanilla C--
-spillAndReloadComments :: M -> Middle
-spillAndReloadComments (NotSpillOrReload m) = m
-spillAndReloadComments (Spill regs) = show_regs "Spill" regs
-spillAndReloadComments (Reload regs) = show_regs "Reload" regs
-
-show_regs :: String -> RegSet -> Middle
-show_regs s regs = MidComment $ mkFastString $ showSDoc $ ppr_regs s regs
+-- Generating spill and reload code
+regSlot :: LocalReg -> CmmExpr
+regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
+spill, reload :: LocalReg -> Middle
+spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r)
+reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
----------------------------------------------------------------
--- sinking reloads
availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add True
+availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
where empty = UniverseMinus emptyRegSet
-- | compute in the Tx monad to track whether anything has changed
add new old =
extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
-deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
-deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
-deleteFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
-
-cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
-cmmAvailableReloads g = env
- where env = runDFA availRegsLattice $
- do run_f_anal transfer (fact_bot availRegsLattice) g
- allFacts
- transfer :: FAnalysis M Last AvailRegs
- transfer = FComp "available-reloads analysis" first middle last exit
- exit _ = LastOutFacts []
- first avail _ = avail
- middle = flip middleAvail
- last = lastAvail
-
-
--- | The transfer equations use the traditional 'gen' and 'kill'
--- notations, which should be familiar from the dragon book.
-agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
-agen a live = foldRegsUsed extendAvail live a
-akill a live = foldRegsUsed deleteFromAvail live a
-
-middleAvail :: M -> AvailRegs -> AvailRegs
-middleAvail (Spill _) = id
-middleAvail (Reload regs) = agen regs
-middleAvail (NotSpillOrReload m) = middle m
- where middle (MidNop) = id
- middle (MidComment {}) = id
- middle (MidAssign lhs _expr) = akill lhs
- middle (MidStore {}) = id
- middle (MidUnsafeCall _tgt ress _args) = akill ress
- middle (CopyIn _ formals _) = akill formals
- middle (CopyOut {}) = id
-
-lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
-lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
-lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
+delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
+delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
+delFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
+
+elemAvail :: AvailRegs -> LocalReg -> Bool
+elemAvail (UniverseMinus s) r = not $ elemRegSet r s
+elemAvail (AvailRegs s) r = elemRegSet r s
+
+type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
+
+cmmAvailableReloads :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs)
+cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
+ where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
+ avail_reloads_transfer empty g
+ empty = fact_bot availRegsLattice
+
+avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
+avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id
+
+middleAvail :: Middle -> AvailRegs -> AvailRegs
+middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail
+ | l `isStackSlotOf` r = extendAvail avail r
+middleAvail (MidAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
+middleAvail (MidStore l (CmmReg (CmmLocal r))) avail
+ | l `isStackSlotOf` r = avail
+middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
+middleAvail (MidStore {}) avail = avail
+middleAvail (MidForeignCall {}) _ = AvailRegs emptyRegSet
+middleAvail (MidComment {}) avail = avail
+
+lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs
+lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)]
+lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l
+
+type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
+
+availRewrites :: ForwardRewrites Middle Last AvailRegs
+availRewrites = ForwardRewrites first middle last exit
+ where first _ _ = Nothing
+ middle m avail = maybe_reload_before avail m (mkMiddle m)
+ last l avail = maybe_reload_before avail l (mkLast l)
+ exit _ = Nothing
+ maybe_reload_before avail node tail =
+ let used = filterRegsUsed (elemAvail avail) node
+ in if isEmptyUniqSet used then Nothing
+ else Just $ reloadTail used tail
+ reloadTail regset t = foldl rel t $ uniqSetToList regset
+ where rel t r = mkMiddle (reload r) <*> t
+
+
+insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
+insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix)
+ where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
+ availRegsLattice avail_reloads_transfer availRewrites bot g
+ bot = fact_bot availRegsLattice
+
+removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
+removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _) =
+ liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
+ where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
+ dualLiveLattice (dualLiveTransfers entry procPoints)
+ rewrites (fact_bot dualLiveLattice) g
+ rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing
+ nothing _ _ = Nothing
+
+middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
+middleRemoveDeads (MidAssign (CmmLocal reg') _) live
+ | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
+middleRemoveDeads _ _ = Nothing
+
---------------------
-- prettyprinting
-instance Outputable m => Outputable (ExtendWithSpills m) where
- ppr (Spill regs) = ppr_regs "Spill" regs
- ppr (Reload regs) = ppr_regs "Reload" regs
- ppr (NotSpillOrReload m) = ppr m
-
-instance Outputable (LGraph M Last) where
- ppr = pprLgraph
-
-instance DebugNodes M Last
-
ppr_regs :: String -> RegSet -> SDoc
ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
where commafy xs = hsep $ punctuate comma xs
else (ppr_regs "live on stack =" stack)]
instance Outputable AvailRegs where
- ppr (UniverseMinus s) = ppr_regs "available = all but" s
- ppr (AvailRegs s) = ppr_regs "available = " s
+ ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
+ else ppr_regs "available = all but" s
+ ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
+ else ppr_regs "available = " s
my_trace :: String -> SDoc -> a -> a
my_trace = if False then pprTrace else \_ _ a -> a
projects / ghc-hetmet.git / blobdiff