X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmLiveZ.hs;h=7bafc919d2ea043b7514eeeaf13a00b8770a9ffd;hb=41f7ea2f3c5bc25a4a910583a9b455e88e983519;hp=07801be49f4d3980c3e982cbef77969f974c3b4a;hpb=fee569a69a4ce8c8d05b8a1fb8069d804dbd2b9c;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs
index 07801be..7bafc91 100644
--- a/compiler/cmm/CmmLiveZ.hs
+++ b/compiler/cmm/CmmLiveZ.hs
@@ -3,20 +3,23 @@ module CmmLiveZ
     ( CmmLive
     , cmmLivenessZ
     , liveLattice
-    , middleLiveness, lastLiveness
+    , middleLiveness, lastLiveness, noLiveOnEntry
     ) 
 where
 
-import Cmm
+import BlockId
 import CmmExpr
 import CmmTx
 import DFMonad
+import Monad
 import PprCmm()
 import PprCmmZ()
-import ZipDataflow0
+import ZipCfg
+import ZipDataflow
 import ZipCfgCmmRep
 
 import Maybes
+import Outputable
 import UniqSet
 
 -----------------------------------------------------------------------------
@@ -28,7 +31,7 @@ type CmmLive = RegSet
 
 -- | The dataflow lattice
 liveLattice :: DataflowLattice CmmLive
-liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add False
+liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add True
     where add new old =
             let join = unionUniqSets new old in
             (if sizeUniqSet join > sizeUniqSet old then aTx else noTx) join
@@ -39,14 +42,23 @@ type BlockEntryLiveness = BlockEnv CmmLive
 -----------------------------------------------------------------------------
 -- | 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.
@@ -54,22 +66,18 @@ gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
 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 (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 (MidAddToContext ra args)     = gen ra . gen args
-        middle (CopyIn _ formals _)          = kill formals
-        middle (CopyOut _ actuals)           = gen actuals
+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)            = emptyUniqSet
-        last (LastJump e)            = gen e $ emptyUniqSet
-        last (LastBranch id)         = 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)