X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmSpillReload.hs;h=707a571b3fcbf7901dd3745011d49134038dc290;hp=63e005851e629244335d3e72372f09922345e0d3;hb=d3ff015a17804b31727b41e3e9dff03b6a654143;hpb=569348e87434f2a8d9e18dccac8b4a563b4eb363 diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index 63e0058..707a571 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -9,23 +9,32 @@ module CmmSpillReload , availRegsLattice , cmmAvailableReloads + , insertLateReloads + , insertLateReloads' + , removeDeadAssignmentsAndReloads ) where + import CmmExpr import CmmTx import CmmLiveZ import DFMonad -import FastString -import Maybe import MkZipCfg +import PprCmm() +import ZipCfg +import ZipCfgCmmRep +import ZipDataflow0 + +import FastString +import Maybes import Outputable hiding (empty) import qualified Outputable as PP import Panic -import PprCmm() import UniqSet -import ZipCfg -import ZipCfgCmmRep -import ZipDataflow +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 @@ -78,7 +87,6 @@ dualLiveLattice = 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 @@ -93,21 +101,17 @@ dualLiveness = BComp "dual liveness" exit last middle first -- this pass again 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 } + 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 @@ -119,7 +123,6 @@ lastDualLiveness env l = last l 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 emptyRegSet) @@ -149,35 +152,33 @@ insertSpillsAndReloads = BComp "CPS spiller" exit last middle first 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-- @@ -232,17 +233,22 @@ 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 + cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs cmmAvailableReloads g = env where env = runDFA availRegsLattice $ - do run_f_anal transfer (fact_bot availRegsLattice) g + do run_f_anal avail_reloads_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 + +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' @@ -255,11 +261,11 @@ middleAvail :: M -> AvailRegs -> AvailRegs middleAvail (Spill _) = id middleAvail (Reload regs) = agen regs middleAvail (NotSpillOrReload m) = middle m - where middle (MidNop) = id - middle (MidComment {}) = id + 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 @@ -267,6 +273,84 @@ 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)) + 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 + + + +--------------------- +-- 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 @@ -276,10 +360,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) @@ -296,8 +377,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