- -- | 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)
+