, availRegsLattice
, cmmAvailableReloads
, insertLateReloads
+ , insertLateReloads'
, removeDeadAssignmentsAndReloads
)
where
import PprCmm()
import ZipCfg
import ZipCfgCmmRep
-import ZipDataflow
+import ZipDataflow0
import FastString
import Maybes
import qualified Outputable as PP
import Panic
import UniqSet
+import UniqSupply
import Maybe
import Prelude hiding (zip)
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--
availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add True
+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 =
cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
cmmAvailableReloads g = env
where env = runDFA availRegsLattice $
- do run_f_anal 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
+ do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g
+ getAllFacts
+
+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'
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 _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
-insertLateReloads :: LGraph M Last -> DFTx (LGraph M Last)
+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 = functionalDFTx "late reloads" (insert b)
+ 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
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 = foldRegsUsed
- (\u r -> if elemAvail avail r then extendRegSet u r else u)
- emptyRegSet node
- in if fuel == 0 || isEmptyUniqSet used then (h, fuel)
- else (ZHead h (Reload used), fuel-1)
+ 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
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)
projects / ghc-hetmet.git / blobdiff