[commit: ghc] wip/impredicativity: Small optimizations to desugaring of InstanceOf constraints (b425c3f)

[git at git.haskell.org]

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

On branch  : wip/impredicativity
Link       : http://ghc.haskell.org/trac/ghc/changeset/b425c3f0311e93abdfbbed03ff99e275ccc6e8f1/ghc

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

commit b425c3f0311e93abdfbbed03ff99e275ccc6e8f1
Author: Alejandro Serrano <trupill at gmail.com>
Date:   Wed Jul 1 14:30:46 2015 +0200

    Small optimizations to desugaring of InstanceOf constraints


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

b425c3f0311e93abdfbbed03ff99e275ccc6e8f1
 compiler/deSugar/DsBinds.hs   | 26 ++++++++++++++++++++++----
 compiler/typecheck/TcBinds.hs |  3 ---
 2 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 9d4d875..0d55a83 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -37,6 +37,7 @@ import CoreUnfold
 import CoreFVs
 import UniqSupply
 import Digraph
+import Pair
 
 import PrelNames
 import TysPrim ( mkProxyPrimTy )
@@ -801,6 +802,12 @@ dsHsWrapper (WpCast co)       e = ASSERT(tcCoercionRole co == Representational)
 dsHsWrapper (WpEvLam ev)      e = return $ Lam ev e
 dsHsWrapper (WpTyLam tv)      e = return $ Lam tv e
 dsHsWrapper (WpEvApp    tm)   e = liftM (App e) (dsEvTerm tm)
+dsHsWrapper (WpEvRevApp tm@(EvInstanceOf _ _)) e
+  = do { coreTm <- dsEvTerm tm
+       ; case splitFunTy_maybe (exprType coreTm) of
+           -- Do not generate instantiation if type remains the same
+           Just (ty1, ty2) | ty1 == ty2 -> return e
+           _ -> return (mkCoreApp coreTm e) }
 dsHsWrapper (WpEvRevApp tm)   e = liftM (flip mkCoreApp e) (dsEvTerm tm)
 
 --------------------------------------
@@ -1154,21 +1161,32 @@ Maybe simpleOpt should be smarter.  But it seems like a good plan
 to simply never generate the redundant box/unbox in the first place.
 -}
 
+-- In order to get a smaller term to simplify,
+-- we apply a direct simplification at this point,
+-- removing all identity coercions and instantiations.
 dsEvInstanceOf :: Type -> EvInstanceOf -> DsM CoreExpr
 dsEvInstanceOf _  (EvInstanceOfVar v)
   = return (Var v)
 dsEvInstanceOf ty (EvInstanceOfEq co)
   = do { bndr <- newSysLocalDs ty
-       ; expr <- dsTcCoercion co (\c -> mkCast (Var bndr) (mkSubCo c))
+       ; expr <- dsTcCoercion co $ \c ->
+           case coercionKind c of
+            Pair ty1 ty2 | ty1 == ty2 -> Var bndr
+            _ ->  mkCast (Var bndr) (mkSubCo c)
        ; return (mkCoreLams [bndr] expr) }
 dsEvInstanceOf ty (EvInstanceOfInst qvars co qs)
   = do { bndr <- newSysLocalDs ty
        ; qs'  <- mapM dsEvTerm qs
        ; let exprTy = mkCoreApps (Var bndr) (map Type qvars)
              exprEv = mkCoreApps exprTy qs'
-       ; return (mkCoreLams [bndr] (mkCoreApp (Var co) exprEv)) }
+             inner  = case splitFunTy_maybe (exprType (Var co)) of
+                        Just (ty1, ty2) | ty1 == ty2 -> exprEv
+                        _ -> mkCoreApp (Var co) exprEv
+       ; return (mkCoreLams [bndr] inner) }
 dsEvInstanceOf ty (EvInstanceOfLet tyvars qvars qs rest)
   = do { bndr <- newSysLocalDs ty
        ; q_binds <- dsTcEvBinds qs
-       ; return (mkCoreLams (bndr : tyvars ++ qvars) $
-           mkCoreLets q_binds (mkCoreApp (Var rest) (Var bndr))) }
+       ; let inner = case splitFunTy_maybe (exprType (Var rest)) of
+                       Just (ty1, ty2) | ty1 == ty2 -> Var bndr
+                       _ -> mkCoreApp (Var rest) (Var bndr)
+       ; return $ mkCoreLams (bndr : tyvars ++ qvars) (mkCoreLets q_binds inner) }
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 40cf535..6fe2a25 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -428,9 +428,6 @@ tc_single top_lvl sig_fn prag_fn lbind thing_inside
   = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
                                       NonRecursive NonRecursive
                                       [lbind]
-       ; traceTc "tc_single/binds" (ppr binds1)
-       ; traceTc "tc_single/ids" (ppr ids)
-       ; traceTc "tc_single/ids_types" (ppr (map idType ids))
        ; let uids = map (\x -> (x, choose_tc_id_flavour x)) ids
        ; thing <- tcExtendLetEnv top_lvl uids thing_inside
        ; return (binds1, thing) }