X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FSaAbsInt.lhs;h=14bb2df5d89904bcd7ab80f8a8df11e4073eb29d;hb=d8f550509fe8eaff29424e19250c0187d6e9c3b7;hp=47afd991c4fd37888243cb5553ee3822c81e4801;hpb=01e0566e61e4222600c7ba0a2d35d6102fd1afb5;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 47afd99..14bb2df 100644
--- 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