diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2017-05-17 09:44:46 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2017-05-17 09:47:21 +0100 |
| commit | d6461f9684f6f758320a5e5afbf0634fcc2996a5 (patch) | |
| tree | 746371a7a1dc34d12433e7e82a95ede213506a7b /compiler/simplCore | |
| parent | d9e9a9b3016a05e6153de3803998877f91c6cdf4 (diff) | |
| download | haskell-d6461f9684f6f758320a5e5afbf0634fcc2996a5.tar.gz | |
Handle type-lets better
Core allows non-recursive type-lets, thus
let a = TYPE ty in ...
They are substituted away very quickly, but it's convenient for
some passes to produce them (rather than to have to substitute
immediately).
Trac #13708 tried the effect of not running the simplifer at all
(a rather bizarre thing to do, but still). That showed that some
passes crashed because they always treated a let-bounder binder
as an Id. This patch adds some easy fixes.
Diffstat (limited to 'compiler/simplCore')
| -rw-r--r-- | compiler/simplCore/CSE.hs | 14 | ||||
| -rw-r--r-- | compiler/simplCore/FloatIn.hs | 4 |
2 files changed, 11 insertions, 7 deletions
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs index 95df5f8b09..83f5ee6a3b 100644 --- a/compiler/simplCore/CSE.hs +++ b/compiler/simplCore/CSE.hs @@ -352,15 +352,19 @@ cse_bind toplevel env (in_id, in_rhs) out_id (env', out_id') = addBinding env in_id out_id out_rhs addBinding :: CSEnv -- Includes InId->OutId cloning - -> InId + -> InVar -- Could be a let-bound type -> OutId -> OutExpr -- Processed binding -> (CSEnv, OutId) -- Final env, final bndr -- Extend the CSE env with a mapping [rhs -> out-id] -- unless we can instead just substitute [in-id -> rhs] +-- +-- It's possible for the binder to be a type variable (see +-- Note [Type-let] in CoreSyn), in which case we can just substitute. addBinding env in_id out_id rhs' - | noCSE in_id = (env, out_id) - | use_subst = (extendCSSubst env in_id rhs', out_id) - | otherwise = (extendCSEnv env rhs' id_expr', zapped_id) + | not (isId in_id) = (extendCSSubst env in_id rhs', out_id) + | noCSE in_id = (env, out_id) + | use_subst = (extendCSSubst env in_id rhs', out_id) + | otherwise = (extendCSEnv env rhs' id_expr', zapped_id) where id_expr' = varToCoreExpr out_id zapped_id = zapIdUsageInfo out_id @@ -381,7 +385,7 @@ addBinding env in_id out_id rhs' _ -> False noCSE :: InId -> Bool -noCSE id = not (isAlwaysActive (idInlineActivation id)) +noCSE id = not (isAlwaysActive (idInlineActivation id)) -- See Note [CSE for INLINE and NOINLINE] || isAnyInlinePragma (idInlinePragma id) -- See Note [CSE for stable unfoldings] diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs index e765455dfc..02a7f741c5 100644 --- a/compiler/simplCore/FloatIn.hs +++ b/compiler/simplCore/FloatIn.hs @@ -485,7 +485,7 @@ fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs where body_fvs2 = body_fvs `delDVarSet` id - rule_fvs = idRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules] + rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2): free variables of rules] extra_fvs | noFloatIntoRhs NonRecursive id rhs = rule_fvs `unionDVarSet` rhs_fvs | otherwise @@ -515,7 +515,7 @@ fiBind dflags to_drop (AnnRec bindings) body_fvs rhss_fvs = map freeVarsOf rhss -- See Note [extra_fvs (1,2)] - rule_fvs = mapUnionDVarSet idRuleAndUnfoldingVarsDSet ids + rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids extra_fvs = rule_fvs `unionDVarSet` unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings , noFloatIntoRhs Recursive bndr rhs ] |