X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmSpillReload.hs;h=0c0099434dba311787e45b029c7a34dbfa559e3b;hp=c457383e6b6448eb32a520b0bdde8bfffa6399c5;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hpb=f1a90f54590e5a7a32a9c3ef2950740922b1f425 diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index c457383..0c00994 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XNoMonoLocalBinds #-} +{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-} -- Norman likes local bindings -- If this module lives on I'd like to get rid of this flag in due course @@ -16,23 +16,19 @@ module CmmSpillReload where import BlockId +import Cmm import CmmExpr -import CmmTx -import CmmLiveZ -import DFMonad -import MkZipCfg -import PprCmm() -import ZipCfg -import ZipCfgCmmRep -import ZipDataflow +import CmmLive +import OptimizationFuel import Control.Monad import Outputable hiding (empty) import qualified Outputable as PP import UniqSet +import Compiler.Hoopl import Data.Maybe -import Prelude hiding (zip) +import Prelude hiding (succ, zip) {- Note [Overview of spill/reload] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -69,117 +65,122 @@ 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 +dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add 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) - regs <- add1 (in_regs new) (in_regs old) - return $ DualLive stack regs - add1 = fact_add_to liveLattice - -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 :: 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 - -dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive -dualLiveTransfers entry procPoints = BackwardTransfers first middle last - where last = lastDualLiveness - middle = middleDualLiveness - 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 :: 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 - 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 :: 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) _ _ _) = - -- 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 _ t f) = - changeRegs (gen l . kill l) $ dualUnion (env t) (env f) - last l@(LastSwitch _ tbl) = changeRegs (gen l . kill l) $ dualUnionList $ - map env (catMaybes tbl) - empty = fact_bot dualLiveLattice - + add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs) + where (change1, stack) = add1 (on_stack old) (on_stack new) + (change2, regs) = add1 (in_regs old) (in_regs new) + add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old) + where join = unionUniqSets old new + +dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph +dualLivenessWithInsertion procPoints g = + liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice + (dualLiveTransfers (g_entry g) procPoints) + (insertSpillAndReloadRewrites g procPoints) + +dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive) +dualLiveness procPoints g = + liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints + +dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive) +dualLiveTransfers entry procPoints = mkBTransfer3 first middle last + where first :: CmmNode C O -> DualLive -> DualLive + first (CmmEntry id) live = check live id $ -- live at procPoint => spill + if id /= entry && setMember id procPoints + then DualLive { on_stack = on_stack live `plusRegSet` in_regs live + , in_regs = emptyRegSet } + else live + where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x + + middle :: CmmNode O O -> DualLive -> DualLive + middle m live = changeStack updSlots $ changeRegs (xferLiveMiddle m) (changeRegs regs_in live) + where xferLiveMiddle = case getBTransfer3 xferLive of (_, middle, _) -> middle + regs_in :: RegSet -> RegSet + regs_in live = case m of CmmUnsafeForeignCall {} -> 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" + last :: CmmNode O C -> FactBase DualLive -> DualLive + last l fb = case l of + CmmBranch id -> lkp id + l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty + l@(CmmCall {cml_cont=Just k}) -> call l k + l@(CmmForeignCall {succ=k}) -> call l k + l@(CmmCondBranch _ t f) -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f) + l@(CmmSwitch _ tbl) -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl) + where empty = fact_bot dualLiveLattice + lkp id = empty `fromMaybe` lookupFact id fb + call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet) + 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 id live = - if id /= entry && elemBlockSet id procPoints then - case map reload (uniqSetToList (in_regs live)) of +insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive +insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing + -- Beware: deepBwdRw with one polymorphic function seems more reasonable here, + -- but GHC miscompiles it, see bug #4044. + where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O + first e@(CmmEntry id) live = return $ + if id /= (g_entry graph) && setMember id procPoints then + case map reload (uniqSetToList spill_regs) of [] -> Nothing - is -> Just (mkMiddles is) + is -> Just $ mkFirst e <*> mkMiddles is else Nothing + where + -- If we are splitting procedures, we need the LastForeignCall + -- to spill its results to the stack because they will only + -- be used by a separate procedure (so they can't stay in LocalRegs). + splitting = True + spill_regs = if splitting then in_regs live + else in_regs live `minusRegSet` defs + defs = case mapLookup id firstDefs of + Just defs -> defs + Nothing -> emptyRegSet + -- A LastForeignCall may contain some definitions, which take place + -- on return from the function call. Therefore, we build a map (firstDefs) + -- from BlockId to the set of variables defined on return to the BlockId. + firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph) + addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet + addLive b env = case lastNode b of + CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env + _ -> env + add bid defs env = mapInsert bid defs'' env + where defs'' = case mapLookup bid env of + Just defs' -> timesRegSet defs defs' + Nothing -> defs + + middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O + middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing + middle m@(CmmAssign (CmmLocal reg) _) live = return $ + 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 m@(CmmUnsafeForeignCall _ fs _) live = return $ + 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 _ _ = return Nothing + + nothing _ _ = return Nothing -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) _) = - 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 - --- Generating spill and reload code regSlot :: LocalReg -> CmmExpr regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r) -spill, reload :: LocalReg -> Middle -spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r) -reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r) +spill, reload :: LocalReg -> CmmNode O O +spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r) +reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r) ---------------------------------------------------------------- --- sinking reloads @@ -195,12 +196,12 @@ data AvailRegs = UniverseMinus RegSet availRegsLattice :: DataflowLattice AvailRegs -availRegsLattice = DataflowLattice "register gotten from reloads" empty add False +availRegsLattice = DataflowLattice "register gotten from reloads" empty add 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 + add _ (OldFact old) (NewFact new) = + if join `smallerAvail` old then (SomeChange, join) else (NoChange, old) + where join = interAvail new old interAvail :: AvailRegs -> AvailRegs -> AvailRegs @@ -227,68 +228,58 @@ elemAvail :: AvailRegs -> LocalReg -> Bool elemAvail (UniverseMinus s) r = not $ elemRegSet r s elemAvail (AvailRegs s) r = elemRegSet r s -type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ()) +cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs) +cmmAvailableReloads g = + liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $ + analFwd availRegsLattice availReloadsTransfer -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 +availReloadsTransfer :: FwdTransfer CmmNode AvailRegs +availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail) -avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs -avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id - -middleAvail :: Middle -> AvailRegs -> AvailRegs -middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail +middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs +middleAvail (CmmAssign (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 +middleAvail (CmmAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs +middleAvail (CmmStore 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 +middleAvail (CmmStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r +middleAvail (CmmStore {}) avail = avail +middleAvail (CmmUnsafeForeignCall {}) _ = AvailRegs emptyRegSet +middleAvail (CmmComment {}) avail = avail + +lastAvail :: CmmNode O C -> AvailRegs -> [(Label, AvailRegs)] +lastAvail (CmmCall _ (Just k) _ _ _) _ = [(k, AvailRegs emptyRegSet)] +lastAvail (CmmForeignCall {succ=k}) _ = [(k, AvailRegs emptyRegSet)] +lastAvail l avail = map (\id -> (id, avail)) $ successors l + +insertLateReloads :: CmmGraph -> FuelUniqSM CmmGraph +insertLateReloads g = + liftM fst $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $ + analRewFwd availRegsLattice availReloadsTransfer rewrites + where rewrites = mkFRewrite3 first middle last + first _ _ = return Nothing + middle m avail = return $ maybe_reload_before avail m (mkMiddle m) + last l avail = return $ maybe_reload_before avail l (mkLast l) maybe_reload_before avail node tail = let used = filterRegsUsed (elemAvail avail) node in if isEmptyUniqSet used then Nothing - else Just $ reloadTail used tail + 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 availRewrites bot g - bot = fact_bot availRegsLattice - -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 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 - +removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph +removeDeadAssignmentsAndReloads procPoints g = + liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice + (dualLiveTransfers (g_entry g) procPoints) + rewrites + where rewrites = deepBwdRw3 nothing middle nothing + -- Beware: deepBwdRw with one polymorphic function seems more reasonable here, + -- but GHC panics while compiling, see bug #4045. + middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O + middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph + middle _ _ = return Nothing + + nothing _ _ = return Nothing ---------------------