- liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
- where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dual liveness with insertion"
- dualLiveLattice (dualLiveTransfers procPoints)
- (insertSpillAndReloadRewrites procPoints) empty g
- empty = fact_bot dualLiveLattice
--- = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
-
-dualLiveness :: BlockSet -> Graph M Last -> FuelMonad (BlockEnv DualLive)
-dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ())
- where res = zdfSolveFrom emptyBlockEnv "dual liveness" dualLiveLattice
- (dualLiveTransfers procPoints) empty g
- empty = fact_bot dualLiveLattice
-
-dualLiveTransfers :: BlockSet -> BackwardTransfers M Last DualLive
-dualLiveTransfers procPoints = BackwardTransfers first middle last
- where last = lastDualLiveness
- middle = middleDualLiveness
- first live _id =
- if elemBlockSet _id procPoints then -- live at procPoint => spill
- DualLive { on_stack = on_stack live `plusRegSet` in_regs live
- , in_regs = emptyRegSet }
- else live
-
-
-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
- pprTrace "Offending party:" (ppr k <+> ppr live) $
- 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
-
-insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive Graph
-insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
- where middle = middleInsertSpillsAndReloads
- last = \_ _ -> Nothing
- exit = Nothing
- first live id =
- if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
- Just $ graphOfMiddles $ [Reload reloads]
+ 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