X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fcmm%2FCmmSpillReload.hs;h=2b54b9ac36d78ee7cfbc3abb24158386c4293c41;hb=25628e2771424cae1b3366322e8ce6f8a85440f9;hp=bef608036b2128e835c74c488dd08e405681fab1;hpb=8b7eaa404043294bd4cb4a0322ac1f7115bad6a0;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index bef6080..2b54b9a 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -1,29 +1,41 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} 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 + , insertLateReloads + , insertLateReloads' + , removeDeadAssignmentsAndReloads ) where + import CmmExpr -import CmmTx() +import CmmTx import CmmLiveZ import DFMonad -import FastString -import Maybe import MkZipCfg +import OptimizationFuel +import PprCmm() +import StackSlot +import ZipCfg +import ZipCfgCmmRep +import ZipDataflow + +import Maybes +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 @@ -65,7 +77,7 @@ 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) @@ -73,63 +85,62 @@ 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 M Last DualLive a) +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 :: 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 -> 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 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 + 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 $ @@ -140,62 +151,235 @@ 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 +insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive Graph +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 $ graphOfMiddles $ [Reload reloads] + else Nothing + where reloads = in_regs live 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-- -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 -> FuelMonad (StackSlotMap, LGraph Middle l) +elimSpillAndReload slots g = fold_blocks block (return (slots, [])) g >>= toGraph + where toGraph (slots, l) = return (slots, of_block_list (lg_entry g) l) + block (Block id t) z = + do (slots, blocks) <- z + (slots, t) <- tail t slots + return (slots, Block id t : blocks) + tail (ZLast l) slots = return (slots, ZLast l) + tail (ZTail m t) slots = + do (slots, t) <- tail t slots + middle m t slots + middle (Spill regs) t slots = foldUniqSet spill (return (slots, t)) regs + middle (Reload regs) t slots = foldUniqSet reload (return (slots, t)) regs + middle (NotSpillOrReload m) t slots = return (slots, ZTail m t) + move f r z = do let reg = CmmLocal r + (slots, t) <- z + (slots, slot) <- getSlot slots reg + return (slots, ZTail (f (CmmStack slot) reg) t) + spill = move (\ slot reg -> MidAssign slot (CmmReg reg)) + reload = move (\ slot reg -> MidAssign reg (CmmReg slot)) + + +---------------------------------------------------------------- +--- 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 False + -- last True <==> debugging on + 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 + +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 :: 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 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 :: 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 + 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)) + exit _ = Nothing + 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 + +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 (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 @@ -204,10 +388,7 @@ instance Outputable m => Outputable (ExtendWithSpills m) where 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) @@ -223,6 +404,12 @@ instance Outputable DualLive where 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 "" + 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