X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmSpillReload.hs;h=4e2dd38fd363d0c88d35a7f2dea8361bff8582da;hb=9176377bf7d989919fe7d27cad1f56bd9c4e7b6b;hp=4067f89fb1f712c9d004deb45c3ade1cd523680b;hpb=fee569a69a4ce8c8d05b8a1fb8069d804dbd2b9c;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index 4067f89..4e2dd38 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -1,62 +1,58 @@ +{-# LANGUAGE GADTs,NoMonoLocalBinds #-} +-- Norman likes local bindings +-- If this module lives on I'd like to get rid of this flag in due course + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#if __GLASGOW_HASKELL__ >= 701 +-- GHC 7.0.1 improved incomplete pattern warnings with GADTs +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +#endif 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 - , insertLateReloads' , removeDeadAssignmentsAndReloads ) where +import BlockId +import Cmm import CmmExpr -import CmmTx -import CmmLiveZ -import DFMonad -import MkZipCfg -import PprCmm() -import ZipCfg -import ZipCfgCmmRep -import ZipDataflow0 - -import FastString -import Maybes +import CmmLive +import OptimizationFuel + +import Control.Monad import Outputable hiding (empty) import qualified Outputable as PP -import Panic import UniqSet -import UniqSupply - -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 --- 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 --- 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. +import Compiler.Hoopl +import Data.Maybe +import Prelude hiding (succ, zip) + +{- 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 } @@ -69,127 +65,128 @@ 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 +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 - -dualLivenessWithInsertion :: BPass M Last DualLive -dualLivenessWithInsertion = 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 - 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 (Spill regs) = live' - -- live-in on-stack requirements are satisfied; - -- live-out in-regs obligations are created - where live' = DualLive { on_stack = on_stack live `minusRegSet` regs - , in_regs = in_regs live `plusRegSet` regs } - -middleDualLiveness live (Reload regs) = live' - -- live-in in-regs requirements are satisfied; - -- live-out on-stack obligations are created - 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) = 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 - let live = env k in - if isEmptyUniqSet (in_regs live) then - DualLive (on_stack live) (gen tgt 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 $ - 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 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 [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 = 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 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 (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 - + 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 :: 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 $ 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 + +regSlot :: LocalReg -> CmmExpr +regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ 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 @@ -205,12 +202,12 @@ data AvailRegs = UniverseMinus RegSet availRegsLattice :: DataflowLattice AvailRegs -availRegsLattice = DataflowLattice "register gotten from reloads" empty add True +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 @@ -229,142 +226,71 @@ 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 -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 - -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 - 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 - -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 - -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)) +cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs) +cmmAvailableReloads g = + liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $ + analFwd availRegsLattice availReloadsTransfer + +availReloadsTransfer :: FwdTransfer CmmNode AvailRegs +availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail) + +middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs +middleAvail (CmmAssign (CmmLocal r) (CmmLoad l _)) avail + | l `isStackSlotOf` r = extendAvail avail r +middleAvail (CmmAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs +middleAvail (CmmStore l (CmmReg (CmmLocal r))) avail + | l `isStackSlotOf` r = avail +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 $ 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 - 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 - + else Just $ reloadTail used tail + reloadTail regset t = foldl rel t $ uniqSetToList regset + where rel t r = mkMiddle (reload r) <*> t +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 ---------------------- --- register usage + nothing _ _ = return Nothing -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 -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 - -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