diff options
| author | Joachim Breitner <mail@joachim-breitner.de> | 2018-04-09 15:05:00 -0400 |
|---|---|---|
| committer | Joachim Breitner <mail@joachim-breitner.de> | 2018-04-09 15:06:08 -0400 |
| commit | 7c4e7fbf1a3b5dc2dfd856d257f69a99f0f2c548 (patch) | |
| tree | b2a799af081ad076314e49d8dbccb52102533f15 | |
| parent | dbbda65ba43670eb9d17c28b635c646c9ee4def7 (diff) | |
| download | haskell-wip/T15002.tar.gz | |
In CSE: Look past join point lambdaswip/T15002
This is a more promising apporach to fix #15002. If Harbormaster and
perf.haskell.org are happy with it, I’ll add the note explaining why
this is needed.
| -rw-r--r-- | compiler/simplCore/CSE.hs | 12 |
1 files changed, 9 insertions, 3 deletions
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs index 865ab6a852..17d8f4c789 100644 --- a/compiler/simplCore/CSE.hs +++ b/compiler/simplCore/CSE.hs @@ -17,7 +17,7 @@ import Var ( Var ) import VarEnv ( elemInScopeSet, mkInScopeSet ) import Id ( Id, idType, idInlineActivation, isDeadBinder , zapIdOccInfo, zapIdUsageInfo, idInlinePragma - , isJoinId ) + , isJoinId, isJoinId_maybe ) import CoreUtils ( mkAltExpr, eqExpr , exprIsTickedString , stripTicksE, stripTicksT, mkTicks ) @@ -370,8 +370,11 @@ cse_bind toplevel env (in_id, in_rhs) out_id -- See Note [Take care with literal strings] = (env', (out_id, in_rhs)) - | isJoinId in_id - = (env', (out_id, in_rhs)) + | Just arity <- isJoinId_maybe in_id + = let (params, in_body) = collectNBinders arity in_rhs + (env', params') = addBinders env params + out_body = tryForCSE env' in_body + in (env, (out_id, mkLams params' out_body)) | otherwise = (env', (out_id', out_rhs)) @@ -390,6 +393,7 @@ addBinding :: CSEnv -- Includes InId->OutId cloning -- Note [Type-let] in CoreSyn), in which case we can just substitute. addBinding env in_id out_id rhs' | 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 @@ -411,6 +415,8 @@ addBinding env in_id out_id rhs' Var {} -> True _ -> False +-- | Given a binder `let x = e`, this function +-- determines whether we should add `e -> x` to the cseExpr noCSE :: InId -> Bool noCSE id = not (isAlwaysActive (idInlineActivation id)) && not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id))) |