+{-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+#if __GLASGOW_HASKELL__ >= 701
+-- GHC 7.0.1 improved incomplete pattern warnings with GADTs
+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
+#endif
module CmmSpillReload
( DualLive(..)
--, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
, dualLivenessWithInsertion
- , availRegsLattice
- , cmmAvailableReloads
- , insertLateReloads
- , insertLateReloads'
, removeDeadAssignmentsAndReloads
)
where
import BlockId
+import Cmm
import CmmExpr
-import CmmTx
-import CmmLiveZ
-import DFMonad
-import MkZipCfg
+import CmmLive
import OptimizationFuel
-import PprCmm()
-import ZipCfg
-import ZipCfgCmmRep
-import ZipDataflow
-import Maybes
-import Monad
+import Control.Monad
import Outputable hiding (empty)
import qualified Outputable as PP
-import Panic
import UniqSet
-import 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 be followed by a
--- forward transformation to sink reloads as deeply as possible, so as
--- to reduce register pressure.
-
--- 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
--- after a call is available on the stack. Spills are pushed back to
--- their reaching definitions, but reloads are dropped wherever needed
--- and will have to be sunk by a later forward transformation.
+import Compiler.Hoopl hiding (Unique)
+import Data.Maybe
+import Prelude hiding (succ, zip)
+
+{- Note [Overview of spill/reload]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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 be followed by a
+forward transformation to sink reloads as deeply as possible, so as
+to reduce register pressure.
+
+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
+after a call is available on the stack. Spills are pushed back to
+their reaching definitions, but reloads are dropped immediately after
+we return from a call and will have to be sunk by a later forward
+transformation.
+
+Note that we offer no guarantees about the consistency of the value
+in memory and the value in the register, except that they are
+equal across calls/procpoints. If the variable is changed, this
+mapping breaks: but as the original value of the register may still
+be useful in a different context, the memory location is not updated.
+-}
data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
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) }
+changeRegs f live = live { in_regs = f (in_regs live) }
dualLiveLattice :: DataflowLattice DualLive
-dualLiveLattice =
- DataflowLattice "variables live in registers and on stack" empty add True
+dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
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)
- regs <- add1 (in_regs new) (in_regs old)
- return $ DualLive stack regs
- add1 = fact_add_to liveLattice
-
-type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
+ add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
+ where (change1, stack) = add1 (on_stack old) (on_stack new)
+ (change2, regs) = add1 (in_regs old) (in_regs new)
+ add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
+ where join = unionUniqSets old new
-dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
+dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
dualLivenessWithInsertion procPoints g =
- liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
- where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
- dualLiveLattice (dualLiveTransfers procPoints)
- (insertSpillAndReloadRewrites procPoints) empty g
- empty = fact_bot dualLiveLattice
-
-dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
-dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ())
- where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
- (dualLiveTransfers procPoints) empty g
- empty = fact_bot dualLiveLattice
-
-dualLiveTransfers :: BlockSet -> BackwardTransfers Middle Last DualLive
-dualLiveTransfers procPoints = BackwardTransfers first middle last
- where last = lastDualLiveness
- middle = middleDualLiveness
- first live _id =
- if elemBlockSet _id procPoints then -- live at procPoint => spill
- DualLive { on_stack = on_stack live `plusRegSet` in_regs live
- , in_regs = emptyRegSet }
- else live
-
-middleDualLiveness :: DualLive -> Middle -> DualLive
-middleDualLiveness live m =
- changeStack updSlots $ changeRegs (middleLiveness m) live
- where 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 :: (BlockId -> DualLive) -> Last -> DualLive
-lastDualLiveness env l = last l
- where last (LastReturn _) = empty
- last (LastJump e _) = changeRegs (gen e) empty
- last (LastBranch id) = env id
- last (LastCall tgt Nothing _) = changeRegs (gen tgt) empty
- last (LastCall tgt (Just k) _) =
- -- nothing can be live in registers at this point
- let live = env k in
- if isEmptyUniqSet (in_regs live) then
- DualLive (on_stack live) (gen tgt emptyRegSet)
- else
- pprTrace "Offending party:" (ppr k <+> ppr live) $
- 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 $
- map env (catMaybes tbl)
- empty = fact_bot dualLiveLattice
-
-gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
-gen a live = foldRegsUsed extendRegSet live a
-
-insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites Middle Last DualLive
-insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
- where middle = middleInsertSpillsAndReloads
- last = \_ _ -> Nothing
- exit = Nothing
- first live id =
- if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
- Just $ mkMiddles $ map reload $ uniqSetToList reloads
+ liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
+ (dualLiveTransfers (g_entry g) procPoints)
+ (insertSpillAndReloadRewrites g procPoints)
+
+dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
+dualLiveness procPoints g =
+ liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
+
+dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
+dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
+ where first :: CmmNode C O -> DualLive -> DualLive
+ first (CmmEntry id) live = check live id $ -- live at procPoint => spill
+ if id /= entry && setMember id procPoints
+ then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
+ , in_regs = emptyRegSet }
+ else live
+ where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
+
+ middle :: CmmNode O O -> DualLive -> DualLive
+ middle m = changeStack updSlots
+ . changeRegs updRegs
+ where -- Reuse middle of liveness analysis from CmmLive
+ updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m
+
+ 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"
+ last :: CmmNode O C -> FactBase DualLive -> DualLive
+ last l fb = case l of
+ CmmBranch id -> lkp id
+ l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
+ l@(CmmCall {cml_cont=Just k}) -> call l k
+ l@(CmmForeignCall {succ=k}) -> call l k
+ l@(CmmCondBranch _ t f) -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
+ l@(CmmSwitch _ tbl) -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
+ where empty = fact_bot dualLiveLattice
+ lkp id = empty `fromMaybe` lookupFact id fb
+ call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
+
+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 :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
+insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
+ -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
+ -- but GHC miscompiles it, see bug #4044.
+ where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
+ first e@(CmmEntry id) live = return $
+ if id /= (g_entry graph) && setMember id procPoints then
+ case map reload (uniqSetToList spill_regs) of
+ [] -> Nothing
+ is -> Just $ mkFirst e <*> mkMiddles is
else Nothing
- where reloads = in_regs live
-
-
-middleInsertSpillsAndReloads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
-middleInsertSpillsAndReloads live m = 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 _ = Nothing
-
--- 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)
-
-spillHead :: ZHead Middle -> RegSet -> ZHead Middle
-reloadTail :: RegSet -> ZTail Middle Last -> ZTail Middle Last
-spillHead h regset = foldl spl h $ uniqSetToList regset
- where spl h r = ZHead h $ spill r
-reloadTail regset t = foldl rel t $ uniqSetToList regset
- where rel t r = ZTail (reload r) t
-
-----------------------------------------------------------------
---- sinking reloads
-
--- The idea is to compute at each point the set of registers such that
--- on every path to the point, the register is defined by a Reload
--- instruction. Then, if a use appears at such a point, we can safely
--- insert a Reload right before the use. Finally, we can eliminate
--- the early reloads along with other dead assignments.
-
-data AvailRegs = UniverseMinus RegSet
- | AvailRegs RegSet
-
-
-availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
- -- last True <==> debugging on
- where empty = UniverseMinus emptyRegSet
- -- | compute in the Tx monad to track whether anything has changed
- add new old =
- let join = interAvail new old in
- if join `smallerAvail` old then aTx join else noTx join
-
-
-interAvail :: AvailRegs -> AvailRegs -> AvailRegs
-interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
-interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
-interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
-interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
-
-smallerAvail :: AvailRegs -> AvailRegs -> Bool
-smallerAvail (AvailRegs _) (UniverseMinus _) = True
-smallerAvail (UniverseMinus _) (AvailRegs _) = False
-smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
-smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
-
---extendAvail :: AvailRegs -> LocalReg -> AvailRegs
---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)
-
-elemAvail :: AvailRegs -> LocalReg -> Bool
-elemAvail (UniverseMinus s) r = not $ elemRegSet r s
-elemAvail (AvailRegs s) r = elemRegSet r s
-
-type CmmAvail = BlockEnv AvailRegs
-type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
-
-cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail
-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 first middle last id
- where 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
-
--- Note: you can't sink the reload past a use.
-middleAvail :: Middle -> AvailRegs -> AvailRegs
-middleAvail m = middle m
- where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
- middle' (MidComment {}) = id
- middle' (MidAssign lhs _expr) = akill lhs
- middle' (MidStore {}) = id
- middle' (MidUnsafeCall _tgt ress _args) = akill ress
- middle' (MidAddToContext {}) = id
-
-lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
-lastAvail _ (LastCall _ (Just k) _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
-lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
-
-insertLateReloads :: LGraph Middle Last -> FuelMonad (LGraph Middle Last)
-insertLateReloads g =
- do env <- cmmAvailableReloads g
- mapM_blocks (insertM env) g
- where insertM env b = fuelConsumingPass "late reloads" (insert b)
- where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
- insert (Block id off tail) fuel =
- propagate (ZFirst id off) (avail id) tail fuel
- propagate h avail (ZTail m t) fuel =
- let (h', fuel') = maybe_add_reload h avail m fuel in
- propagate (ZHead h' m) (middleAvail m avail) t fuel'
- propagate h avail (ZLast l) fuel =
- let (h', fuel') = maybe_add_reload h avail l fuel in
- (zipht h' (ZLast l), fuel')
- maybe_add_reload h avail node fuel =
- let used = filterRegsUsed (elemAvail avail) node
- in if not (canRewriteWithFuel fuel) || isEmptyUniqSet used
- then (h,fuel)
- else (spillHead h used, oneLessFuel fuel)
-
-type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs (LGraph Middle Last))
-
-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 rewrites bot g
- bot = fact_bot availRegsLattice
- rewrites = ForwardRewrites first middle last exit
- first _ _ = Nothing
- middle :: AvailRegs -> Middle -> Maybe (AGraph Middle Last)
- last :: AvailRegs -> Last -> Maybe (AGraph Middle Last)
- middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
- last avail l = maybe_reload_before avail l (ZLast (LastOther l))
- exit _ = Nothing
- maybe_reload_before avail node tail =
- let used = filterRegsUsed (elemAvail avail) node
- in if isEmptyUniqSet used then Nothing
- else Just $ mkZTail $ reloadTail used tail
-
-removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
+ where
+ -- If we are splitting procedures, we need the LastForeignCall
+ -- to spill its results to the stack because they will only
+ -- be used by a separate procedure (so they can't stay in LocalRegs).
+ splitting = True
+ spill_regs = if splitting then in_regs live
+ else in_regs live `minusRegSet` defs
+ defs = case mapLookup id firstDefs of
+ Just defs -> defs
+ Nothing -> emptyRegSet
+ -- A LastForeignCall may contain some definitions, which take place
+ -- on return from the function call. Therefore, we build a map (firstDefs)
+ -- from BlockId to the set of variables defined on return to the BlockId.
+ firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
+ addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
+ addLive b env = case lastNode b of
+ CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
+ _ -> env
+ add bid defs env = mapInsert bid defs'' env
+ where defs'' = case mapLookup bid env of
+ Just defs' -> timesRegSet defs defs'
+ Nothing -> defs
+
+ middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
+ middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
+ middle m@(CmmAssign (CmmLocal reg) _) live = return $
+ 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 _ _ = return Nothing
+
+ nothing _ _ = return Nothing
+
+spill, reload :: LocalReg -> CmmNode O O
+spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
+reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
+
+removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
removeDeadAssignmentsAndReloads procPoints g =
- liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
- where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
- dualLiveLattice (dualLiveTransfers procPoints)
- rewrites (fact_bot dualLiveLattice) g
- rewrites = BackwardRewrites first middle last exit
- exit = Nothing
- last = \_ _ -> Nothing
- middle = middleRemoveDeads
- first _ _ = Nothing
-
-middleRemoveDeads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
-middleRemoveDeads live m = middle m
- where middle (MidAssign (CmmLocal reg') _)
- | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
- middle _ = Nothing
-
-
+ liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
+ (dualLiveTransfers (g_entry g) procPoints)
+ rewrites
+ where rewrites = deepBwdRw3 nothing middle nothing
+ -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
+ -- but GHC panics while compiling, see bug #4045.
+ middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
+ middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
+ -- XXX maybe this should be somewhere else...
+ middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph
+ middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
+ middle _ _ = return Nothing
+
+ nothing _ _ = return Nothing
---------------------
-- prettyprinting
if isEmptyUniqSet stack then PP.empty
else (ppr_regs "live on stack =" stack)]
-instance Outputable AvailRegs where
- 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