diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2015-12-24 14:40:08 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2015-12-24 14:59:57 +0000 |
| commit | 6ec236b589d541e72eea8df84628206d26e93862 (patch) | |
| tree | deda3c4d974dc1e24c101b60c678797f7e4f91ce | |
| parent | 3017cbcfd10fe0a364cc8b039c07a94c3b9e61cc (diff) | |
| download | haskell-6ec236b589d541e72eea8df84628206d26e93862.tar.gz | |
Improve SimplUtils.interestingArg
There were two problems here:
- We were looking under a lambda without extending
the in-scope env, which triggered a WARNING
But there's no need to look under a lambda.
- We were looking under a letrec without extending
the in-scope env, which triggered the same WARNING
Solution: extend the in-scope env
| -rw-r--r-- | compiler/simplCore/SimplUtils.hs | 29 |
1 files changed, 16 insertions, 13 deletions
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 29336c17d9..09fd1e4d45 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -633,20 +633,23 @@ interestingArg env e = go env 0 e Just (DoneEx e) -> go (zapSubstEnv env) n e Just (ContEx tvs cvs ids e) -> go (setSubstEnv env tvs cvs ids) n e - go _ _ (Lit {}) = ValueArg - go _ _ (Type _) = TrivArg - go _ _ (Coercion _) = TrivArg - go env n (App fn (Type _)) = go env n fn - go env n (App fn (Coercion _)) = go env n fn - go env n (App fn _) = go env (n+1) fn - go env n (Tick _ a) = go env n a - go env n (Cast e _) = go env n e + go _ _ (Lit {}) = ValueArg + go _ _ (Type _) = TrivArg + go _ _ (Coercion _) = TrivArg + go env n (App fn (Type _)) = go env n fn + go env n (App fn _) = go env (n+1) fn + go env n (Tick _ a) = go env n a + go env n (Cast e _) = go env n e go env n (Lam v e) - | isTyVar v = go env n e - | n>0 = go env (n-1) e - | otherwise = ValueArg - go env n (Let _ e) = case go env n e of { ValueArg -> ValueArg; _ -> NonTrivArg } - go _ _ (Case {}) = NonTrivArg + | isTyVar v = go env n e + | n>0 = NonTrivArg -- (\x.b) e is NonTriv + | otherwise = ValueArg + go _ _ (Case {}) = NonTrivArg + go env n (Let b e) = case go env' n e of + ValueArg -> ValueArg + _ -> NonTrivArg + where + env' = env `addNewInScopeIds` bindersOf b go_var n v | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that |