X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FSaAbsInt.lhs;h=48bb957395afc70426ed17269e68db6343c25d30;hb=0df435464ff825eb66e409fb5668a53cd5362309;hp=faa23467d602e5c8235676f8adf68024d5d47f08;hpb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index faa2346..48bb957 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 OLD_STRICTNESS
+-- If OLD_STRICTNESS is off, omit all exports 
+module SaAbsInt () where
+
+#else
 module SaAbsInt (
 	findStrictness,
 	findDemand, findDemandAlts,
@@ -18,7 +23,9 @@ module SaAbsInt (
 import CmdLineOpts	( opt_AllStrict, opt_NumbersStrict )
 import CoreSyn
 import CoreUnfold	( maybeUnfoldingTemplate )
-import Id		( Id, idType, idStrictness, idUnfolding, isDataConId_maybe )
+import Id		( Id, idType, idUnfolding, isDataConId_maybe,
+			  idStrictness,
+			)
 import DataCon		( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
 import IdInfo		( StrictnessInfo(..) )
 import Demand		( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
@@ -26,12 +33,11 @@ import Demand		( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy,
 			)
 import SaLib
 import TyCon		( isProductTyCon, isRecursiveTyCon )
-import BasicTypes	( NewOrData(..) )
 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}
 
@@ -289,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
@@ -314,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
@@ -451,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
@@ -501,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}
 
@@ -899,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}