[project @ 2002-10-09 15:36:47 by simonpj]

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

diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index bac6b14..13e1837 100644 (file)
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -7,6 +7,11 @@ 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"
@@ -17,13 +22,13 @@ 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
@@ -483,4 +489,6 @@ sequenceSa []     = returnSa []
 sequenceSa (m:ms) = m            `thenSa` \ r ->
                    sequenceSa ms `thenSa` \ rs ->
                    returnSa (r:rs)
+
+#endif /* OLD_STRICTNESS */
 \end{code}