X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmSpillReload.hs;h=be043fe26c25ed0d558db728d1e778b9f25be14c;hp=5601350f74058778c960668fa5f100b9730eb15f;hb=e6243a818496aad82b6f47511d3bd9bc800f747d;hpb=7ed4f0716220b03fe5e04100ddbbc9e37d5323fe diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index 5601350..be043fe 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -1,48 +1,46 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} 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 OptimizationFuel +import PprCmm() +import ZipCfg +import ZipCfgCmmRep +import ZipDataflow + +import Monad import Outputable hiding (empty) import qualified Outputable as PP import Panic -import PprCmm() import UniqSet -import ZipCfg -import ZipCfgCmm -import ZipDataflow + +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 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 @@ -61,14 +59,14 @@ dualUnionList ls = DualLive ss rs 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) @@ -76,120 +74,112 @@ dualLiveLattice = 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 +dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive +dualLiveTransfers entry procPoints = BackwardTransfers first middle last + where last = lastDualLiveness + middle = middleDualLiveness + first live id = 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 :: DualLive -> Middle -> DualLive +middleDualLiveness live m = + 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 :: (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)) = - -- 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) - 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 $ + where last (LastBranch id) = env id + last l@(LastCall tgt Nothing _ _) = changeRegs (gen l . kill l) empty + last l@(LastCall tgt (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 e t f) = + changeRegs (gen l . kill l) $ dualUnion (env t) (env f) + last l@(LastSwitch e 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 live id = + if id /= entry && elemBlockSet id procPoints then + case map reload (uniqSetToList (in_regs live)) of + [] -> Nothing + is -> Just (mkMiddles is) + else Nothing + +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 (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 +-- Generating spill and reload code +regSlot :: LocalReg -> CmmExpr +regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r) -show_regs :: String -> RegSet -> Middle -show_regs s regs = MidComment $ mkFastString $ showSDoc $ ppr_regs s regs +spill, reload :: LocalReg -> Middle +spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r) +reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r) +reloadTail :: RegSet -> ZTail Middle Last -> ZTail Middle Last +reloadTail regset t = foldl rel t $ uniqSetToList regset + where rel t r = ZTail (reload r) t ---------------------------------------------------------------- --- sinking reloads @@ -206,6 +196,7 @@ data AvailRegs = UniverseMinus RegSet availRegsLattice :: DataflowLattice AvailRegs availRegsLattice = DataflowLattice "register gotten from reloads" empty add True + -- last True <==> debugging on where empty = UniverseMinus emptyRegSet -- | compute in the Tx monad to track whether anything has changed add new old = @@ -225,62 +216,95 @@ 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) +--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) -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 +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 +--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 +-- 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 {}) live = live + middle' (MidAssign lhs _expr) live = akill lhs live + middle' (MidStore {}) live = live + middle' (MidForeignCall _ _tgt ress _args) _ = AvailRegs emptyRegSet lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs +lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)] lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l +type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph) ---------------------- --- prettyprinting +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) +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 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 + -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 +--------------------- +-- prettyprinting -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 @@ -296,8 +320,10 @@ instance Outputable DualLive where 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 "" + else ppr_regs "available = all but" s + ppr (AvailRegs s) = if isEmptyUniqSet s then text "" + else ppr_regs "available = " s my_trace :: String -> SDoc -> a -> a my_trace = if False then pprTrace else \_ _ a -> a