[project @ 1999-11-01 17:09:54 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 67872b9..081e039 100644 (file)
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -11,7 +11,7 @@ module StrictAnal ( saBinds ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( opt_D_dump_stranal, opt_D_simplifier_stats,  opt_D_verbose_core2core )
+import CmdLineOpts     ( opt_D_dump_stranal, opt_D_dump_simpl_stats,  opt_D_verbose_core2core )
 import CoreSyn
 import Id              ( idType, setIdStrictness,
                          getIdDemandInfo, setIdDemandInfo,
@@ -19,6 +19,7 @@ import Id             ( idType, setIdStrictness,
                        )
 import IdInfo          ( mkStrictnessInfo )
 import CoreLint                ( beginPass, endPass )
+import Type            ( repType, splitFunTys )
 import ErrUtils                ( dumpIfSet )
 import SaAbsInt
 import SaLib
@@ -89,7 +90,7 @@ saBinds binds
        -- Mark each binder with its strictness
 #ifndef OMIT_STRANAL_STATS
        let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
-       dumpIfSet opt_D_simplifier_stats "Strictness analysis statistics"
+       dumpIfSet opt_D_dump_simpl_stats "Strictness analysis statistics"
                  (pp_stats sa_stats);
 #else
        let { binds_w_strictness = saTopBindsBinds binds };
@@ -324,12 +325,24 @@ addStrictnessInfoToId
        -> Id                   -- Augmented with strictness
 
 addStrictnessInfoToId str_val abs_val binder body
-  = case (collectTyAndValBinders body) of
-       (_, lambda_bounds, rhs) -> binder `setIdStrictness` 
-                                  mkStrictnessInfo strictness
-               where
-                   tys        = map idType lambda_bounds
-                   strictness = findStrictness tys str_val abs_val
+  = binder `setIdStrictness` mkStrictnessInfo strictness
+  where
+    arg_tys = collect_arg_tys (idType binder)
+    strictness = findStrictness arg_tys str_val abs_val
+
+    collect_arg_tys ty
+       | null arg_tys = []
+       | otherwise    = arg_tys ++ collect_arg_tys res_ty
+       where
+         (arg_tys, res_ty) = splitFunTys (repType ty)
+    -- repType looks through for-alls and new-types.  And since we look on the
+    -- type info, we aren't confused by INLINE prags.
+    -- In particular, foldr is marked INLINE,
+    -- but we still want it to be strict in its third arg, so that
+    -- foldr k z (case e of p -> build g) 
+    -- gets transformed to
+    -- case e of p -> foldr k z (build g)
+    -- [foldr is only inlined late in compilation, after strictness analysis]
 \end{code}
 
 \begin{code}