diff options
| author | Joachim Breitner <mail@joachim-breitner.de> | 2013-12-17 23:27:34 +0100 |
|---|---|---|
| committer | Joachim Breitner <mail@joachim-breitner.de> | 2013-12-17 23:27:34 +0100 |
| commit | 043af4d88ecfa2857519f035dea6f8dd7d0133ef (patch) | |
| tree | 6a8d171c12ee174b3dee54fcfca8aee3f4fc2fca | |
| parent | 95f5aac36296bbe1583dd106fa41a1c2b855895c (diff) | |
| download | haskell-043af4d88ecfa2857519f035dea6f8dd7d0133ef.tar.gz | |
Do not do common context for polymorphic functions
| -rw-r--r-- | compiler/simplCore/CommonContext.lhs | 7 |
1 files changed, 3 insertions, 4 deletions
diff --git a/compiler/simplCore/CommonContext.lhs b/compiler/simplCore/CommonContext.lhs index d884cb108d..9199e70154 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 |