[project @ 2002-11-19 15:57:10 by simonpj]

-----------------------------------------------
	Fix a terrible and long-standing strictness bug
	-----------------------------------------------

		MERGE TO STABLE

Simplify.simplifyArg was floating out lets from a lazy argument.
Not only is this unprofitable, but it can actually be wrong it
the floated let has a strict-demand flag on it.  (Simplify.simplLazyBind
goes to some trouble to check for this case.)

The situation is this

	lazy_fn (let v = <expensive> in str_fn v v)

Here, the strictness analyser may put a 'demanded' flag on
v, and if is is *then* floated we'll get

	let v* = <expensive>
	in
	lazy_fn (str_fn v v)

and then <expensive> will always be evaluated.

This bug has been in the compiler at least a year (since Sept 01), but
in fact it's quite hard to make a test case for it, because the same
bug meant that the let was floated out *before* strictness analysis
giving

	let v = <expensive>
	in
	lazy_fn (str_fn v v)

and now v won't get a strict-demand flag.  So it's only if the let
shows up (by inlining) after strictness analysis but not before.

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 303fd65..588f71d 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -507,10 +507,10 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
                -- There's a subtlety here.  There may be a binding (x* = e) in the
                -- floats, where the '*' means 'will be demanded'.  So is it safe
                -- to float it out?  Answer no, but it won't matter because
-               -- we only float if arg' is a WHNF,
+               -- we only float if (a) arg' is a WHNF, or (b) it's going to top level
                -- and so there can't be any 'will be demanded' bindings in the floats.
-               -- Hence the assert
-        WARN( any demanded_float (floatBinds floats), 
+               -- Hence the warning
+        WARN( not is_top_level && any demanded_float (floatBinds floats), 
              ppr (filter demanded_float (floatBinds floats)) )
 
        tick LetFloatFromLet                    `thenSmpl_` (
@@ -1047,11 +1047,14 @@ simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside
   | is_strict 
   = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside
 
-  | otherwise
-  = simplExprF (setInScope arg_se env) val_arg
-              (mkStop arg_ty AnArg)            `thenSmpl` \ (floats, arg1) ->
-    addFloats env floats                       $ \ env ->
-    thing_inside env arg1
+  | otherwise  -- Lazy argument
+               -- DO NOT float anything outside, hence simplExprC
+               -- There is no benefit (unlike in a let-binding), and we'd
+               -- have to be very careful about bogus strictness through 
+               -- floating a demanded let.
+  = simplExprC (setInScope arg_se env) val_arg
+              (mkStop arg_ty AnArg)            `thenSmpl` \ arg1 ->
+   thing_inside env arg1
   where
     arg_ty = funArgTy fn_ty