From: simonpj <unknown>
Date: Tue, 19 Nov 2002 15:57:10 +0000 (+0000)
Subject: [project @ 2002-11-19 15:57:10 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~1428
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0316a9e603115e6d3f04bd03824a1ca9430b0f0f;p=ghc-hetmet.git

[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
--- 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