X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmSpillReload.hs;h=a8839a87985de736923e2c0f4c679faea9e08d17;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hp=be570f2bcc4a21bc5f8ab979b859bc58e7fa711e;hpb=6bc92166180824bf046d31e378359e3c386150f9;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index be570f2..a8839a8 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -1,3 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 611 +{-# OPTIONS_GHC -XNoMonoLocalBinds #-} +#endif +-- Norman likes local bindings +-- If this module lives on I'd like to get rid of this flag in due course module CmmSpillReload ( DualLive(..) @@ -18,35 +23,36 @@ import CmmTx import CmmLiveZ import DFMonad import MkZipCfg -import OptimizationFuel import PprCmm() import ZipCfg import ZipCfgCmmRep import ZipDataflow -import Monad +import Control.Monad import Outputable hiding (empty) import qualified Outputable as PP -import Panic import UniqSet -import Maybe +import Data.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. +{- 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 wherever needed +and will have to be sunk by a later forward transformation. +-} data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet } @@ -77,7 +83,7 @@ dualLiveLattice = type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a) dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) -dualLivenessWithInsertion procPoints g@(LGraph entry _ _) = +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) @@ -85,7 +91,7 @@ dualLivenessWithInsertion procPoints g@(LGraph entry _ _) = empty = fact_bot dualLiveLattice dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive) -dualLiveness procPoints g@(LGraph entry _ _) = +dualLiveness procPoints g@(LGraph entry _) = liftM zdfFpFacts $ (res :: LiveReloadFix ()) where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice (dualLiveTransfers entry procPoints) empty g @@ -95,15 +101,15 @@ dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLi dualLiveTransfers entry procPoints = BackwardTransfers first middle last where last = lastDualLiveness middle = middleDualLiveness - first live id = check live id $ -- live at procPoint => spill + first id live = 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 = +middleDualLiveness :: Middle -> DualLive -> DualLive +middleDualLiveness m live = changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live) where regs_in live = case m of MidForeignCall {} -> emptyRegSet _ -> live @@ -116,11 +122,11 @@ middleDualLiveness live m = | o == w && w == widthInBytes (typeWidth ty) = x check _ _ = panic "middleDualLiveness unsupported: slices" -lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive -lastDualLiveness env l = last l +lastDualLiveness :: Last -> (BlockId -> DualLive) -> DualLive +lastDualLiveness l env = last l where last (LastBranch id) = env id - last l@(LastCall _ Nothing _ _) = changeRegs (gen l . kill l) empty - last l@(LastCall _ (Just k) _ _) = + last l@(LastCall _ Nothing _ _ _) = changeRegs (gen l . kill l) empty + last l@(LastCall _ (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) @@ -145,15 +151,15 @@ insertSpillAndReloadRewrites entry procPoints = where middle = middleInsertSpillsAndReloads last _ _ = Nothing exit = Nothing - first live id = + first id live = 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 +middleInsertSpillsAndReloads :: Middle -> DualLive -> Maybe (AGraph Middle Last) +middleInsertSpillsAndReloads m live = middle m where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) | reg == reg' = Nothing middle (MidAssign (CmmLocal reg) _) = @@ -177,10 +183,6 @@ 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 @@ -196,7 +198,6 @@ data AvailRegs = UniverseMinus 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 = @@ -216,89 +217,79 @@ 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) +delFromAvail :: AvailRegs -> LocalReg -> AvailRegs +delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r) +delFromAvail (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 :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs) 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 {}) live = live - middle' (MidAssign lhs _expr) live = akill lhs live - middle' (MidStore {}) live = live - middle' (MidForeignCall {}) _ = AvailRegs emptyRegSet +avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id -lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs -lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)] -lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l +middleAvail :: Middle -> AvailRegs -> AvailRegs +middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail + | l `isStackSlotOf` r = extendAvail avail r +middleAvail (MidAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs +middleAvail (MidStore l (CmmReg (CmmLocal r))) avail + | l `isStackSlotOf` r = avail +middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r +middleAvail (MidStore {}) avail = avail +middleAvail (MidForeignCall {}) _ = AvailRegs emptyRegSet +middleAvail (MidComment {}) avail = avail + +lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs +lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)] +lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph) +availRewrites :: ForwardRewrites Middle Last AvailRegs +availRewrites = ForwardRewrites first middle last exit + where first _ _ = Nothing + middle m avail = maybe_reload_before avail m (mkMiddle m) + last l avail = maybe_reload_before avail l (mkLast l) + exit _ = Nothing + maybe_reload_before avail node tail = + let used = filterRegsUsed (elemAvail avail) node + in if isEmptyUniqSet used then Nothing + else Just $ reloadTail used tail + reloadTail regset t = foldl rel t $ uniqSetToList regset + where rel t r = mkMiddle (reload r) <*> t + + 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 + availRegsLattice avail_reloads_transfer availRewrites 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 _ _) = +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 + rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing + nothing _ _ = Nothing + +middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last) +middleRemoveDeads (MidAssign (CmmLocal reg') _) live + | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph +middleRemoveDeads _ _ = Nothing