[project @ 2001-07-26 09:54:39 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 47afd99..14bb2df 100644 (file)
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -4,6 +4,11 @@
 \section[SaAbsInt]{Abstract interpreter for strictness analysis}
 
 \begin{code}
+#ifndef DEBUG
+-- If DEBUG is off, omit all exports 
+module SaAbsInt () where
+
+#else
 module SaAbsInt (
        findStrictness,
        findDemand, findDemandAlts,
@@ -12,7 +17,7 @@ module SaAbsInt (
        fixpoint,
        isBot
     ) where
-
+#endif /* DEBUG */
 #include "HsVersions.h"
 
 import CmdLineOpts     ( opt_AllStrict, opt_NumbersStrict )
@@ -21,12 +26,11 @@ import CoreUnfold   ( maybeUnfoldingTemplate )
 import Id              ( Id, idType, idStrictness, idUnfolding, isDataConId_maybe )
 import DataCon         ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
 import IdInfo          ( StrictnessInfo(..) )
-import Demand          ( Demand(..), wwPrim, wwStrict, wwUnpackData, wwLazy, wwUnpackNew,
+import Demand          ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
                          mkStrictnessInfo, isLazy
                        )
 import SaLib
-import TyCon           ( isProductTyCon, isRecursiveTyCon, isNewTyCon )
-import BasicTypes      ( NewOrData(..) )
+import TyCon           ( isProductTyCon, isRecursiveTyCon )
 import Type            ( splitTyConApp_maybe, 
                          isUnLiftedType, Type )
 import TyCon           ( tyConUnique )
@@ -285,15 +289,16 @@ evalStrictness (WwLazy _) _   = False
 evalStrictness WwStrict   val = isBot val
 evalStrictness WwEnum    val = isBot val
 
-evalStrictness (WwUnpack NewType _ (demand:_)) val
-  = evalStrictness demand val
-
-evalStrictness (WwUnpack DataType _ demand_info) val
+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
+          | length vals /= length 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
@@ -313,15 +318,17 @@ possibly} hit poison.
 evalAbsence (WwLazy True) _ = False    -- Can't possibly hit poison
                                        -- with Absent demand
 
-evalAbsence (WwUnpack NewType _ (demand:_)) val
-  = evalAbsence demand val
-
-evalAbsence (WwUnpack DataType _ demand_info) val
+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 
+          | length vals /= length 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
@@ -507,6 +514,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}
 
@@ -633,8 +645,8 @@ find_strictness id orig_str_ds orig_str_res orig_abs_ds
                -- to be strict in it.  Unless the function diverges.
           WwLazy True  -- Best of all
 
-    mk_dmd (WwUnpack nd u str_ds) 
-          (WwUnpack _ _ abs_ds) = WwUnpack nd u (go str_ds abs_ds)
+    mk_dmd (WwUnpack u str_ds) 
+          (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds)
 
     mk_dmd str_dmd abs_dmd = str_dmd
 \end{code}
@@ -713,19 +725,15 @@ findRecDemand str_fn abs_fn ty
                                -- we don't exploit it yet, so don't bother
 
         Just (tycon,_,data_con,cmpnt_tys)      -- Single constructor case
-          | isNewTyCon tycon                   -- A newtype!
-          ->   ASSERT( null (tail cmpnt_tys) )
-               let
-                   demand = findRecDemand str_fn abs_fn (head cmpnt_tys)
-               in
-               wwUnpackNew demand
+          | isRecursiveTyCon tycon             -- Recursive data type; don't unpack
+          ->   wwStrict                        --      (this applies to newtypes too:
+                                               --      e.g.  data Void = MkVoid Void)
 
           |  null compt_strict_infos           -- A nullary data type
-          || isRecursiveTyCon tycon            -- Recursive data type; don't unpack
           ->   wwStrict
 
           | otherwise                          -- Some other data type
-          ->   wwUnpackData compt_strict_infos
+          ->   wwUnpack compt_strict_infos
 
           where
              prod_len = length cmpnt_tys