[project @ 2005-03-10 14:03:28 by simonmar]

[ghc-hetmet.git] / ghc / compiler / stranal / SaAbsInt.lhs

diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 82a2b47..3cd9ba4 100644 (file)
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -4,8 +4,8 @@
 \section[SaAbsInt]{Abstract interpreter for strictness analysis}
 
 \begin{code}
-#ifndef DEBUG
--- If DEBUG is off, omit all exports 
+#ifndef OLD_STRICTNESS
+-- If OLD_STRICTNESS is off, omit all exports 
 module SaAbsInt () where
 
 #else
@@ -17,13 +17,15 @@ module SaAbsInt (
        fixpoint,
        isBot
     ) where
-#endif /* DEBUG */
+
 #include "HsVersions.h"
 
 import CmdLineOpts     ( opt_AllStrict, opt_NumbersStrict )
 import CoreSyn
 import CoreUnfold      ( maybeUnfoldingTemplate )
-import Id              ( Id, idType, idStrictness, idUnfolding, isDataConId_maybe )
+import Id              ( Id, idType, idUnfolding, isDataConWorkId_maybe,
+                         idStrictness,
+                       )
 import DataCon         ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
 import IdInfo          ( StrictnessInfo(..) )
 import Demand          ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
@@ -35,7 +37,7 @@ import Type           ( splitTyConApp_maybe,
                          isUnLiftedType, Type )
 import TyCon           ( tyConUnique )
 import PrelInfo                ( numericTyKeys )
-import Util            ( isIn, nOfThem, zipWithEqual )
+import Util            ( isIn, nOfThem, zipWithEqual, equalLength )
 import Outputable      
 \end{code}
 
@@ -293,8 +295,12 @@ evalStrictness (WwUnpack _ demand_info) val
   = case val of
       AbsTop      -> False
       AbsBot      -> True
-      AbsProd vals -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
-      _                   -> pprTrace "evalStrictness?" empty False
+      AbsProd vals
+          | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalStrictness" (ppr demand_info $$ ppr val)
+                                                 False
+          | otherwise -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
+
+      _                       -> pprTrace "evalStrictness?" empty False
 
 evalStrictness WwPrim val
   = case val of
@@ -318,8 +324,13 @@ evalAbsence (WwUnpack _ demand_info) val
   = case val of
        AbsTop       -> False           -- No poison in here
        AbsBot       -> True            -- Pure poison
-       AbsProd vals -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
-       _            -> panic "evalAbsence: other"
+       AbsProd vals 
+          | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalAbsence" (ppr demand_info $$ ppr val)
+                                                 True
+          | otherwise -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
+       _              -> pprTrace "TELL SIMON: evalAbsence" 
+                               (ppr demand_info $$ ppr val)
+                         True
 
 evalAbsence other val = anyBot val
   -- The demand is conservative; even "Lazy" *might* evaluate the
@@ -342,7 +353,7 @@ evalAbsence other val = anyBot val
 
 absId anal var env
   = case (lookupAbsValEnv env var, 
-         isDataConId_maybe var, 
+         isDataConWorkId_maybe var, 
          idStrictness var, 
          maybeUnfoldingTemplate (idUnfolding var)) of
 
@@ -455,7 +466,7 @@ absEval anal expr@(Case scrut case_bndr alts) env
                -- type; so the constructor in this alternative must be the right one
                -- so we can go ahead and bind the constructor args to the components
                -- of the product value.
-           ASSERT(length arg_vals == length val_bndrs)
+           ASSERT(equalLength arg_vals val_bndrs)
            absEval anal rhs rhs_env
          where
            val_bndrs = filter isId bndrs
@@ -505,6 +516,11 @@ absEval anal (Let (Rec pairs) body) env
     in
     absEval anal body new_env
 
+absEval anal (Note (Coerce _ _) expr) env = AbsTop
+       -- Don't look inside coerces, becuase they
+       -- are usually recursive newtypes
+       -- (Could improve, for the error case, but we're about
+       -- to kill this analyser anyway.)
 absEval anal (Note note expr) env = absEval anal expr env
 \end{code}
 
@@ -903,3 +919,7 @@ used.  But who cares about missing that?
 
 NB: despite only having a two-point domain, we may still have many
 iterations, because there are several variables involved at once.
+
+\begin{code}
+#endif /* OLD_STRICTNESS */
+\end{code}