-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module CmmSpillReload
( ExtendWithSpills(..)
, availRegsLattice
, cmmAvailableReloads
+ , insertLateReloads
+ , removeDeadAssignmentsAndReloads
)
where
+
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 FastString
+import Maybes
+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
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 }
+ 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)
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 $
middleAvail (Spill _) = id
middleAvail (Reload regs) = agen regs
middleAvail (NotSpillOrReload m) = middle m
- where middle (MidNop) = id
- middle (MidComment {}) = id
+ where middle (MidComment {}) = id
middle (MidAssign lhs _expr) = akill lhs
middle (MidStore {}) = id
middle (MidUnsafeCall _tgt ress _args) = akill ress
middle (CopyOut {}) = id
lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
-lastAvail _ (LastCall _ _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
+lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
+insertLateReloads :: LGraph M Last -> DFTx (LGraph M Last)
+insertLateReloads g = mapM_blocks insertM g
+ where env = cmmAvailableReloads g
+ avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
+ insertM b = functionalDFTx "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 = foldRegsUsed
+ (\u r -> if elemAvail avail r then extendRegSet u r else u)
+ emptyRegSet node
+ in if fuel == 0 || isEmptyUniqSet used then (h, fuel)
+ else (ZHead h (Reload used), fuel-1)
+
+
+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
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