[commit: ghc] master: Don't expose strictness when sm_inline is False (d191db4)
git at git.haskell.org
git at git.haskell.org
Wed May 23 14:11:35 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/d191db48c43469ee1818887715bcbc5c0eb1d91f/ghc
>---------------------------------------------------------------
commit d191db48c43469ee1818887715bcbc5c0eb1d91f
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed May 23 13:30:21 2018 +0100
Don't expose strictness when sm_inline is False
This is very much a corner case, but Trac #15163 showed
that if you have a RULE like
forall x. f (g x) = ..x..
and g = undefined, then the simplifier is likely to discard
that 'x' argument. It is usually right to do so; but not here
because then x is used on the right but not bound on the left.
The fix is a narrow one, aimed at this rather pathalogical case.
See Note [Do not expose strictness if sm_inline=False] in
SimplUtils.
>---------------------------------------------------------------
d191db48c43469ee1818887715bcbc5c0eb1d91f
compiler/simplCore/SimplUtils.hs | 81 ++++++++++++++++++++++++++--------------
compiler/simplCore/Simplify.hs | 2 +-
2 files changed, 55 insertions(+), 28 deletions(-)
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index fbf9b3e..3b16628 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -449,23 +449,25 @@ contArgs cont
-------------------
-mkArgInfo :: Id
+mkArgInfo :: SimplEnv
+ -> Id
-> [CoreRule] -- Rules for function
-> Int -- Number of value args
-> SimplCont -- Context of the call
-> ArgInfo
-mkArgInfo fun rules n_val_args call_cont
+mkArgInfo env fun rules n_val_args call_cont
| n_val_args < idArity fun -- Note [Unsaturated functions]
= ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
- , ai_rules = fun_rules, ai_encl = False
+ , ai_rules = fun_rules
+ , ai_encl = False
, ai_strs = vanilla_stricts
, ai_discs = vanilla_discounts }
| otherwise
= ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
, ai_rules = fun_rules
- , ai_encl = interestingArgContext rules call_cont
- , ai_strs = add_type_str fun_ty arg_stricts
+ , ai_encl = interestingArgContext rules call_cont
+ , ai_strs = arg_stricts
, ai_discs = arg_discounts }
where
fun_ty = idType fun
@@ -483,7 +485,11 @@ mkArgInfo fun rules n_val_args call_cont
vanilla_stricts = repeat False
arg_stricts
- = case splitStrictSig (idStrictness fun) of
+ | not (sm_inline (seMode env))
+ = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False]
+ | otherwise
+ = add_type_str fun_ty $
+ case splitStrictSig (idStrictness fun) of
(demands, result_info)
| not (demands `lengthExceeds` n_val_args)
-> -- Enough args, use the strictness given.
@@ -505,26 +511,25 @@ mkArgInfo fun rules n_val_args call_cont
add_type_str :: Type -> [Bool] -> [Bool]
-- If the function arg types are strict, record that in the 'strictness bits'
-- No need to instantiate because unboxed types (which dominate the strict
- -- types) can't instantiate type variables.
- -- add_type_str is done repeatedly (for each call); might be better
- -- once-for-all in the function
+ -- types) can't instantiate type variables.
+ -- add_type_str is done repeatedly (for each call);
+ -- might be better once-for-all in the function
-- But beware primops/datacons with no strictness
- add_type_str
- = go
- where
- go _ [] = []
- go fun_ty strs -- Look through foralls
- | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty -- Includes coercions
- = go fun_ty' strs
- go fun_ty (str:strs) -- Add strict-type info
- | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
- = (str || Just False == isLiftedType_maybe arg_ty) : go fun_ty' strs
- -- If the type is levity-polymorphic, we can't know whether it's
- -- strict. isLiftedType_maybe will return Just False only when
- -- we're sure the type is unlifted.
- go _ strs
- = strs
+ add_type_str _ [] = []
+ add_type_str fun_ty all_strs@(str:strs)
+ | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info
+ = (str || Just False == isLiftedType_maybe arg_ty)
+ : add_type_str fun_ty' strs
+ -- If the type is levity-polymorphic, we can't know whether it's
+ -- strict. isLiftedType_maybe will return Just False only when
+ -- we're sure the type is unlifted.
+
+ | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
+ = add_type_str fun_ty' all_strs -- Look through foralls
+
+ | otherwise
+ = all_strs
{- Note [Unsaturated functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -534,6 +539,28 @@ Consider (test eyeball/inline4)
where f has arity 2. Then we do not want to inline 'x', because
it'll just be floated out again. Even if f has lots of discounts
on its first argument -- it must be saturated for these to kick in
+
+Note [Do not expose strictness if sm_inline=False]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Trac #15163 showed a case in which we had
+
+ {-# INLINE [1] zip #-}
+ zip = undefined
+
+ {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}
+
+If we expose zip's bottoming nature when simplifing the LHS of the
+RULE we get
+ {-# RULES "foo" forall as bs.
+ stream (case zip of {}) = ..blah... #-}
+discarding the arguments to zip. Usually this is fine, but on the
+LHS of a rule it's not, because 'as' and 'bs' are now not bound on
+the LHS.
+
+This is a pretty pathalogical example, so I'm not losing sleep over
+it, but the simplest solution was to check sm_inline; if it is False,
+which it is on the LHS of a rule (see updModeForRules), then don't
+make use of the strictness info for the function.
-}
@@ -784,9 +811,9 @@ updModeForStableUnfoldings inline_rule_act current_mode
updModeForRules :: SimplMode -> SimplMode
-- See Note [Simplifying rules]
updModeForRules current_mode
- = current_mode { sm_phase = InitialPhase
- , sm_inline = False
- , sm_rules = False
+ = current_mode { sm_phase = InitialPhase
+ , sm_inline = False -- See Note [Do not expose strictness if sm_inline=False]
+ , sm_rules = False
, sm_eta_expand = False }
{- Note [Simplifying rules]
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index b50771a..5e514c5 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -1734,7 +1734,7 @@ completeCall env var cont
| otherwise
-- Don't inline; instead rebuild the call
= do { rule_base <- getSimplRules
- ; let info = mkArgInfo var (getRules rule_base var)
+ ; let info = mkArgInfo env var (getRules rule_base var)
n_val_args call_cont
; rebuildCall env info cont }
More information about the ghc-commits
mailing list