( CmmLive
, cmmLivenessZ
, liveLattice
- , middleLiveness, lastLiveness
+ , middleLiveness, lastLiveness, noLiveOnEntry
)
where
-import Cmm
+import BlockId
import CmmExpr
import CmmTx
import DFMonad
-import Maybes
+import Monad
import PprCmm()
import PprCmmZ()
-import UniqSet
+import ZipCfg
import ZipDataflow
import ZipCfgCmmRep
+import Maybes
+import Outputable
+import UniqSet
+
-----------------------------------------------------------------------------
-- Calculating what variables are live on entry to a basic block
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- | Calculated liveness info for a CmmGraph
-----------------------------------------------------------------------------
-cmmLivenessZ :: CmmGraph -> BlockEntryLiveness
-cmmLivenessZ g = env
- where env = runDFA liveLattice $
- do run_b_anal transfer g
- allFacts
- transfer = BComp "liveness analysis" exit last middle first
- exit = emptyUniqSet
- first live _ = live
- middle = flip middleLiveness
- last = flip lastLiveness
+cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness
+cmmLivenessZ g@(LGraph entry _ _) =
+ liftM (check . zdfFpFacts) (res :: FuelMonad (CmmBackwardFixedPoint CmmLive))
+ where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers
+ emptyUniqSet (graphOfLGraph g)
+ transfers = BackwardTransfers first middle last
+ first live _ = live
+ middle = flip middleLiveness
+ last = flip lastLiveness
+ check facts =
+ noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts
+
+-- | On entry to the procedure, there had better not be any LocalReg's live-in.
+noLiveOnEntry :: BlockId -> CmmLive -> a -> a
+noLiveOnEntry bid in_fact x =
+ if isEmptyUniqSet in_fact then x
+ else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
-- | The transfer equations use the traditional 'gen' and 'kill'
-- notations, which should be familiar from the dragon book.
gen a live = foldRegsUsed extendRegSet live a
kill a live = foldRegsUsed delOneFromUniqSet live a
+-- Why aren't these function using the typeclasses on Middle and Last?
middleLiveness :: Middle -> CmmLive -> CmmLive
-middleLiveness m = middle m
- where middle (MidNop) = id
- middle (MidComment {}) = id
- middle (MidAssign lhs expr) = gen expr . kill lhs
- middle (MidStore addr rval) = gen addr . gen rval
- middle (MidUnsafeCall tgt ress args) = gen tgt . gen args . kill ress
- middle (CopyIn _ formals _) = kill formals
- middle (CopyOut _ formals) = gen formals
+middleLiveness (MidComment {}) live = live
+middleLiveness (MidAssign lhs expr) live = gen expr $ kill lhs live
+middleLiveness (MidStore addr rval) live = gen addr $ gen rval live
+middleLiveness (MidForeignCall _ tgt _ args) _ = gen tgt $ gen args emptyUniqSet
lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive
lastLiveness l env = last l
- where last (LastReturn ress) = gen ress emptyUniqSet
- last (LastJump e args) = gen e $ gen args emptyUniqSet
- last (LastBranch id args) = gen args $ env id
- last (LastCall tgt (Just k)) = gen tgt $ env k
- last (LastCall tgt Nothing) = gen tgt $ emptyUniqSet
- last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f)
- last (LastSwitch e tbl) = gen e $ unionManyUniqSets $ map env (catMaybes tbl)
+ where last (LastBranch id) = env id
+ last (LastCall tgt Nothing _ _) = gen tgt $ emptyUniqSet
+ last (LastCall tgt (Just k) _ _) = gen tgt $ env k
+ last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f)
+ last (LastSwitch e tbl) =
+ gen e $ unionManyUniqSets $ map env (catMaybes tbl)