Fix an egregious strictness analyser bug (Trac #4924)

[ghc-hetmet.git] / compiler / cmm / CmmLiveZ.hs

diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs
index 00a6491..ea9b2e5 100644 (file)
--- a/compiler/cmm/CmmLiveZ.hs
+++ b/compiler/cmm/CmmLiveZ.hs
@@ -1,23 +1,27 @@
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+
 module CmmLiveZ
     ( CmmLive
     , cmmLivenessZ
     , liveLattice
-    , middleLiveness, lastLiveness
+    , middleLiveness, noLiveOnEntry
     ) 
 where
 
-import Cmm
+import BlockId
 import CmmExpr
 import CmmTx
 import DFMonad
-import Maybes
+import Control.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
 -----------------------------------------------------------------------------
@@ -38,39 +42,43 @@ 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 (flip const) mid last
+        mid  m = gen_kill m . midLive  m
+        last l = gen_kill l . lastLive l 
+        check facts   =
+          noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts
+
+gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
+gen_kill a = gen a . kill a
+
+middleLiveness :: Middle -> CmmLive -> CmmLive
+middleLiveness = gen_kill
+
+-- | 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, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
-gen  a live = foldRegsUsed extendRegSet      live a
-kill a live = foldRegsUsed delOneFromUniqSet live a
+gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
+gen  a live = foldRegsUsed    extendRegSet      live a
+kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
+kill a live = foldRegsDefd delOneFromUniqSet live a
 
-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
+midLive :: Middle -> CmmLive -> CmmLive
+midLive (MidForeignCall {}) _ = emptyUniqSet
+midLive _                live = live
 
-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)
+lastLive :: Last -> (BlockId -> CmmLive) -> CmmLive
+lastLive l env = last l
+  where last (LastBranch id)        = env id
+        last (LastCall _ _  _ _ _)  = emptyUniqSet
+        last (LastCondBranch _ t f) = unionUniqSets (env t) (env f)
+        last (LastSwitch _ tbl)     = unionManyUniqSets $ map env (catMaybes tbl)