-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module CmmSpillReload
( ExtendWithSpills(..)
, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
, dualLivenessWithInsertion
, spillAndReloadComments
+
+ , availRegsLattice
+ , cmmAvailableReloads
+ , insertLateReloads
+ , insertLateReloads'
+ , removeDeadAssignmentsAndReloads
)
where
+
import CmmExpr
-import CmmTx()
+import CmmTx
import CmmLiveZ
import DFMonad
-import FastString
-import Maybe
import MkZipCfg
+import PprCmm()
+import ZipCfg
+import ZipCfgCmmRep
+import ZipDataflow0
+
+import FastString
+import Maybes
import Outputable hiding (empty)
import qualified Outputable as PP
import Panic
-import PprCmm()
import UniqSet
-import ZipCfg
-import ZipCfgCmm
-import ZipDataflow
+import UniqSupply
+
+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
dualLivenessWithInsertion :: BPass M Last DualLive
dualLivenessWithInsertion = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
-
dualLiveness :: BAnalysis M Last DualLive
dualLiveness = BComp "dual liveness" exit last middle first
where exit = empty
-- this pass again
middleDualLiveness :: DualLive -> M -> DualLive
-middleDualLiveness live m@(Spill regs) =
+middleDualLiveness live (Spill regs) = live'
-- 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 }
+ , in_regs = in_regs live `plusRegSet` regs }
-middleDualLiveness live m@(Reload regs) =
+middleDualLiveness live (Reload regs) = live'
-- 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) = middle m live
- where middle (MidNop) = id
- middle (MidComment {}) = id
- middle (MidAssign (CmmLocal reg') expr) = changeRegs (gen expr . kill reg')
- middle (MidAssign (CmmGlobal _) expr) = changeRegs (gen expr)
- middle (MidStore addr rval) = changeRegs (gen addr . gen rval)
- middle (MidUnsafeCall _ ress args) = changeRegs (gen args . kill ress)
- middle (CopyIn _ formals _) = changeRegs (kill formals)
- middle (CopyOut _ formals) = changeRegs (gen formals)
+ 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 args Nothing) = changeRegs (gen tgt. gen args) empty
- last (LastCall tgt args (Just k)) =
+ 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
- -- 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 $ gen args emptyRegSet)
+ 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)
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',
+middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
+ 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']]
+ Just $ graphOfMiddles [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
+ needs_spilling = filterRegsUsed is_stack_var formals
+ -- a formal that is expected on the stack; must spill
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
+ let code = if isEmptyUniqSet regs' then []
+ else Reload regs' : []
+ code' = if isEmptyUniqSet needs_spilling then code
+ else Spill needs_spilling : code
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
+ Just $ graphOfMiddles (m : code')
middle _ = Nothing
-- | For conversion back to vanilla C--
show_regs s regs = MidComment $ mkFastString $ showSDoc $ ppr_regs s regs
+----------------------------------------------------------------
+--- 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 True
+ 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
+
+cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
+cmmAvailableReloads g = env
+ where env = runDFA availRegsLattice $
+ do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g
+ allFacts
+
+avail_reloads_transfer :: FAnalysis M Last AvailRegs
+avail_reloads_transfer = FComp "available-reloads analysis" first middle last exit
+ where exit avail = avail
+ 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 (MidComment {}) = id
+ middle (MidAssign lhs _expr) = akill lhs
+ middle (MidStore {}) = id
+ middle (MidUnsafeCall _tgt ress _args) = akill ress
+ middle (MidAddToContext {}) = id
+ 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
+
+insertLateReloads :: LGraph M Last -> FuelMonad (LGraph M Last)
+insertLateReloads g = mapM_blocks insertM g
+ where env = cmmAvailableReloads g
+ avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
+ insertM b = fuelConsumingPass "late reloads" (insert b)
+ insert (Block id tail) fuel = propagate (ZFirst id) (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 (ZHead h (Reload used), oneLessFuel fuel)
+
+insertLateReloads' :: UniqSupply -> (Graph M Last) -> FuelMonad (Graph M Last)
+insertLateReloads' us g =
+ runDFM us availRegsLattice $
+ f_shallow_rewrite avail_reloads_transfer insert bot g
+ where bot = fact_bot availRegsLattice
+ insert = null_f_ft { fc_middle_out = middle, fc_last_outs = last }
+ middle :: AvailRegs -> M -> Maybe (Graph M Last)
+ last :: AvailRegs -> Last -> Maybe (Graph M Last)
+ middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
+ last avail l = maybe_reload_before avail l (ZLast (LastOther l))
+ maybe_reload_before avail node tail =
+ let used = filterRegsUsed (elemAvail avail) node
+ in if isEmptyUniqSet used then Nothing
+ else Just $ graphOfZTail $ ZTail (Reload used) tail
+
+_lateReloadsWithoutFuel :: LGraph M Last -> LGraph M Last
+_lateReloadsWithoutFuel g = map_blocks insert g
+ where env = cmmAvailableReloads g
+ avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
+ insert (Block id tail) = propagate (ZFirst id) (avail id) tail
+ propagate h avail (ZTail m t) =
+ propagate (ZHead (maybe_add_reload h avail m) m) (middleAvail m avail) t
+ propagate h avail (ZLast l) =
+ zipht (maybe_add_reload h avail l) (ZLast l)
+ maybe_add_reload h avail node =
+ let used = filterRegsUsed (elemAvail avail) node
+ in if isEmptyUniqSet used then h
+ else ZHead h (Reload used)
+
+
+removeDeadAssignmentsAndReloads :: BPass M Last DualLive
+removeDeadAssignmentsAndReloads = a_ft_b dualLiveness remove_deads
+ where remove_deads = BComp "dead-assignment & -reload elim" exit last middle first
+ exit = Nothing
+ last = \_ _ -> Nothing
+ middle = middleRemoveDeads
+ first _ _ = Nothing
+
+middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
+middleRemoveDeads _ (Spill _) = Nothing
+middleRemoveDeads live (Reload s) =
+ if sizeUniqSet worth_reloading < sizeUniqSet s then
+ Just $ if isEmptyUniqSet worth_reloading then emptyGraph
+ else graphOfMiddles [Reload worth_reloading]
+ else
+ Nothing
+ where worth_reloading = intersectUniqSets s (in_regs live)
+middleRemoveDeads live (NotSpillOrReload m) = middle m
+ where middle (MidAssign (CmmLocal reg') _)
+ | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
+ middle _ = Nothing
+
+
+
+---------------------
+-- register usage
+
+instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
+ foldRegsUsed f z (Spill regs) = foldRegsUsed f z regs
+ foldRegsUsed _f z (Reload _) = z
+ foldRegsUsed f z (NotSpillOrReload m) = foldRegsUsed f z m
+
---------------------
-- prettyprinting
ppr (Reload regs) = ppr_regs "Reload" regs
ppr (NotSpillOrReload m) = ppr m
-instance Outputable (LGraph M Last) where
- ppr = pprLgraph
-
-instance DebugNodes M Last
+instance Outputable m => DebugNodes (ExtendWithSpills m) Last
ppr_regs :: String -> RegSet -> SDoc
ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
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