-----------------------------------------------
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.
-- 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
-- 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.
-- 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_` (
ppr (filter demanded_float (floatBinds floats)) )
tick LetFloatFromLet `thenSmpl_` (
| is_strict
= simplStrictArg AnArg env val_arg arg_se arg_ty 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
where
arg_ty = funArgTy fn_ty