X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FStrictAnal.lhs;h=242a94707430685b8bda5b881909ae633fad4ad3;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=bac6b14ac8941785a7d15c57f2901c1edf9ffcd7;hpb=17fdd8ad14910060688239d99fa12968276d4095;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index bac6b14..242a947 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -7,23 +7,28 @@ The original version(s) of all strictness-analyser code (except the
 Semantique analyser) was written by Andy Gill.
 
 \begin{code}
+#ifndef OLD_STRICTNESS
+module StrictAnal ( ) where
+
+#else
+
 module StrictAnal ( saBinds ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts	( DynFlags, DynFlag(..) )
+import DynFlags	( DynFlags, DynFlag(..) )
 import CoreSyn
 import Id		( setIdStrictness, setInlinePragma, 
 			  idDemandInfo, setIdDemandInfo, isBottomingId,
 			  Id
 			)
-import IdInfo		( neverInlinePrag )
 import CoreLint		( showPass, endPass )
 import ErrUtils		( dumpIfSet_dyn )
 import SaAbsInt
 import SaLib
 import Demand		( Demand, wwStrict, isStrict, isLazy )
-import Util		( zipWith3Equal, stretchZipWith )
+import Util		( zipWith3Equal, stretchZipWith, compareLength )
+import BasicTypes	( Activation( NeverActive ) )
 import Outputable
 import FastTypes
 \end{code}
@@ -80,7 +85,6 @@ strict workers.
 
 \begin{code}
 saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
-
 saBinds dflags binds
   = do {
 	showPass dflags "Strictness analysis";
@@ -191,7 +195,7 @@ saTopBind str_env abs_env (Rec pairs)
 -- This avoids fruitless inlining of top level error functions
 addStrictnessInfoToTopId str_val abs_val bndr
   = if isBottomingId new_id then
-	new_id `setInlinePragma` neverInlinePrag
+	new_id `setInlinePragma` NeverActive
     else
 	new_id
   where
@@ -228,7 +232,9 @@ saApp str_env abs_env (fun, args)
   where
     arg_dmds = case fun of
 		 Var var -> case lookupAbsValEnv str_env var of
-				Just (AbsApproxFun ds _) | length ds >= length args 
+				Just (AbsApproxFun ds _) 
+				   | compareLength ds args /= LT 
+				              -- 'ds' is at least as long as 'args'.
 					-> ds ++ minDemands
 				other   -> minDemands
 		 other -> minDemands
@@ -455,7 +461,7 @@ pp_stats (SaStats tlam dlam tc dc tlet dlet)
 	      ptext SLIT("; Let vars: "),  int (iBox dlet), char '/', int (iBox tlet)
 	]
 
-#else {-OMIT_STRANAL_STATS-}
+#else /* OMIT_STRANAL_STATS */
 -- identity monad
 type SaM a = a
 
@@ -469,7 +475,7 @@ tickLambda var  = panic "OMIT_STRANAL_STATS: tickLambda"
 tickCases  vars = panic "OMIT_STRANAL_STATS: tickCases"
 tickLet    var  = panic "OMIT_STRANAL_STATS: tickLet"
 
-#endif {-OMIT_STRANAL_STATS-}
+#endif /* OMIT_STRANAL_STATS */
 
 mapSa	      :: (a -> SaM b) -> [a] -> SaM [b]
 
@@ -483,4 +489,6 @@ sequenceSa []     = returnSa []
 sequenceSa (m:ms) = m		  `thenSa` \ r ->
 		    sequenceSa ms `thenSa` \ rs ->
 		    returnSa (r:rs)
+
+#endif /* OLD_STRICTNESS */
 \end{code}