From 043af4d88ecfa2857519f035dea6f8dd7d0133ef Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Tue, 17 Dec 2013 23:27:34 +0100
Subject: [PATCH] Do not do common context for polymorphic functions
---
compiler/simplCore/CommonContext.lhs | 7 +++----
1 file changed, 3 insertions(+), 4 deletions(-)
diff --git a/compiler/simplCore/CommonContext.lhs b/compiler/simplCore/CommonContext.lhs
index d884cb108d0..9199e70154a 100644
--- a/compiler/simplCore/CommonContext.lhs
+++ b/compiler/simplCore/CommonContext.lhs
@@ -60,7 +60,7 @@ process v e body
e' = mkLams bndrs fun_body'
v' = setIdType v (exprType e')
body' = replaceContext v v' cts body
- in -- pprTrace "findInterestingLet" (vcat [ppr v, ppr (idArity v), pprConts cts, ppr body])
+ in -- pprTrace "findInterestingLet" (vcat [ppr v, ppr (idArity v), pprConts cts])
(v', mkLams bndrs fun_body', body')
_ -> (v, e, body)
@@ -85,7 +85,6 @@ contextOf v (Var v')
= NeedsArgs (idArity v)
| otherwise
= NoUse
---contextOf v (App f (Type _)) = finish $ contextOf v f
contextOf v (App f a) =
case (contextOf v f, contextOf v a) of
(NoUse, NoUse) -> NoUse
@@ -93,8 +92,8 @@ contextOf v (App f a) =
(NoUse, Building cts) -> Building (PassTo f : cts)
(NoUse, OneUse cts) -> OneUse cts
(NoUse, MultiUse) -> MultiUse
- (NeedsArgs 1, NoUse) -> Building []
- (NeedsArgs i, NoUse) -> NeedsArgs (i-1)
+ (NeedsArgs 1, NoUse) | isValArg a -> Building []
+ (NeedsArgs i, NoUse) | isValArg a -> NeedsArgs (i-1)
(NeedsArgs _, _) -> MultiUse
(Building cts, NoUse) -> Building (AppTo a : cts)
(Building _, _) -> MultiUse
--
GitLab