module CmmSpillReload
( ExtendWithSpills(..)
, DualLive(..)
- , dualLiveLattice, dualLiveness
- , insertSpillsAndReloads --- XXX todo check live-in at entry against formals
+ , dualLiveLattice, dualLiveTransfers, dualLiveness
+ --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
, dualLivenessWithInsertion
- , spillAndReloadComments
+ , elimSpillAndReload
, availRegsLattice
, cmmAvailableReloads
)
where
+import BlockId
import CmmExpr
import CmmTx
import CmmLiveZ
import DFMonad
import MkZipCfg
+import OptimizationFuel
import PprCmm()
import ZipCfg
import ZipCfgCmmRep
-import ZipDataflow0
+import ZipDataflow
-import FastString
import Maybes
+import Monad
import Outputable hiding (empty)
import qualified Outputable as PP
import Panic
import UniqSet
-import UniqSupply
import Maybe
import Prelude hiding (zip)
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 M Last DualLive a)
-dualLiveness :: BAnalysis M Last DualLive
-dualLiveness = BComp "dual liveness" exit last middle first
- where exit = empty
- last = lastDualLiveness
- middle = middleDualLiveness
- first live _id = live
+dualLivenessWithInsertion :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
+dualLivenessWithInsertion procPoints g =
+ liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
+ where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dual liveness with insertion"
+ dualLiveLattice (dualLiveTransfers procPoints)
+ (insertSpillAndReloadRewrites procPoints) empty g
+ empty = fact_bot dualLiveLattice
+-- = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
+
+dualLiveness :: BlockSet -> Graph M Last -> FuelMonad (BlockEnv DualLive)
+dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ())
+ where res = zdfSolveFrom emptyBlockEnv "dual liveness" dualLiveLattice
+ (dualLiveTransfers 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
+dualLiveTransfers :: BlockSet -> BackwardTransfers M 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 -> M -> DualLive
middleDualLiveness live (Spill regs) = live'
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 $
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
+insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive
+insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
+ where middle = middleInsertSpillsAndReloads
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
+ exit = Nothing
+ first live id =
+ if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
+ Just $ mkMiddles $ [Reload reloads]
+ else Nothing
+ where reloads = in_regs live
-middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
+middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (AGraph M Last)
middleInsertSpillsAndReloads _ (Spill _) = Nothing
middleInsertSpillsAndReloads _ (Reload _) = Nothing
middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
if reg `elemRegSet` on_stack live then -- must spill
my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
text "after", ppr m]) $
- Just $ graphOfMiddles [m, Spill $ mkRegSet [reg]]
+ Just $ mkMiddles [m, Spill $ mkRegSet [reg]]
else
Nothing
middle (CopyIn _ formals _) =
ppr (Reload regs' :: M),
ppr (Spill needs_spilling :: M),
text "after", ppr m]) $
- Just $ graphOfMiddles (m : code')
+ Just $ mkMiddles (m : code')
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
+elimSpillAndReload :: StackSlotMap -> LGraph M l -> (StackSlotMap, LGraph Middle l)
+elimSpillAndReload slots g = toGraph $ fold_blocks block ((slots, [])) g
+ where toGraph (slots, l) = (slots, of_block_list (lg_entry g) l)
+ block (Block id t) (slots, blocks) =
+ lift (\ t' -> Block id t' : blocks) $ tail t slots
+ tail (ZLast l) slots = (slots, ZLast l)
+ tail (ZTail m t) slots = middle m $ tail t slots
+ middle (NotSpillOrReload m) (slots, t) = (slots, ZTail m t)
+ middle (Spill regs) z = foldUniqSet spill z regs
+ middle (Reload regs) z = foldUniqSet reload z regs
+ move f r (slots, t) =
+ lift (\ slot -> ZTail (f slot (CmmLocal r)) t) $ getSlot slots r
+ spill = move (\ slot reg -> MidStore slot (CmmReg reg))
+ reload = move (\ slot reg -> MidAssign reg slot)
+ lift f (slots, x) = (slots, f x)
----------------------------------------------------------------
availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add True
+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 =
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
+type CmmAvail = BlockEnv AvailRegs
+type AvailFix = FuelMonad (ForwardFixedPoint M Last AvailRegs ())
+
+cmmAvailableReloads :: Graph M Last -> FuelMonad CmmAvail
+cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
+ where res = zdfSolveFrom emptyBlockEnv "available reloads" availRegsLattice
+ avail_reloads_transfer empty g
+ empty = (fact_bot availRegsLattice)
-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
+avail_reloads_transfer :: ForwardTransfers M 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 :: 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
+ 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
+ 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
+insertLateReloads :: Graph M Last -> FuelMonad (Graph M Last)
+insertLateReloads g =
+ do env <- cmmAvailableReloads g
+ g <- lGraphOfGraph g
+ liftM graphOfLGraph $ 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 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)
+
+type LateReloadFix = FuelMonad (ForwardFixedPoint M Last AvailRegs (Graph M Last))
+
+insertLateReloads' :: (Graph M Last) -> FuelMonad (Graph M Last)
+insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
+ where res = zdfRewriteFrom RewriteShallow emptyBlockEnv "insert late reloads"
+ availRegsLattice avail_reloads_transfer rewrites bot g
+ bot = fact_bot availRegsLattice
+ rewrites = ForwardRewrites first middle last exit
first _ _ = Nothing
-
-middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
+ middle :: AvailRegs -> M -> Maybe (AGraph M Last)
+ last :: AvailRegs -> Last -> Maybe (AGraph 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))
+ exit _ = Nothing
+ maybe_reload_before avail node tail =
+ let used = filterRegsUsed (elemAvail avail) node
+ in if isEmptyUniqSet used then Nothing
+ else Just $ mkZTail $ ZTail (Reload used) tail
+
+removeDeadAssignmentsAndReloads :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
+removeDeadAssignmentsAndReloads procPoints g =
+ liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
+ where res = zdfRewriteFrom 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 -> M -> Maybe (AGraph 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]
+ Just $ if isEmptyUniqSet worth_reloading then emptyAGraph
+ else mkMiddles [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
+ | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
middle _ = Nothing
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)
projects / ghc-hetmet.git / blobdiff