[commit: ghc] wip/common-context: Do not do common context for polymorphic functions (043af4d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/common-context
Link       : http://ghc.haskell.org/trac/ghc/changeset/043af4d88ecfa2857519f035dea6f8dd7d0133ef/ghc

>---------------------------------------------------------------

commit 043af4d88ecfa2857519f035dea6f8dd7d0133ef
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Dec 17 23:27:34 2013 +0100

    Do not do common context for polymorphic functions


>---------------------------------------------------------------

043af4d88ecfa2857519f035dea6f8dd7d0133ef
 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 d884cb1..9199e70 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