[commit: ghc] wip/impredicativity: Fix problem with RULES desugaring (7807510)

[git at git.haskell.org]

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

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

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

commit 7807510f906202de5e90e7cb1f81b4cedf215670
Author: Alejandro Serrano <trupill at gmail.com>
Date:   Fri Jul 3 14:04:36 2015 +0200

    Fix problem with RULES desugaring
    
    - Revert some changes in which isInstantiationFn is attached to IdInfo.
      It is now only used in those places where a coercion is applied, but
      not in the EvVar itself.
    - Change decomposeRuleLhs to drop less dictionaries that it was doing
      before. When working with instantiation constraints, some dictionaries
      of the form $dict_v = $dict_w are generated and need to be preserved.


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

7807510f906202de5e90e7cb1f81b4cedf215670
 compiler/coreSyn/CoreSubst.hs |  5 +----
 compiler/deSugar/DsBinds.hs   | 11 +++++++----
 compiler/typecheck/TcHsSyn.hs |  6 +-----
 3 files changed, 9 insertions(+), 13 deletions(-)

diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index 058336c..2d9c7e9 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -834,7 +834,7 @@ simpleOptExpr :: CoreExpr -> CoreExpr
 -- may change radically
 
 simpleOptExpr expr
-  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
+  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) $
     simpleOptExprWith init_subst expr
   where
     init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
@@ -1027,9 +1027,6 @@ maybe_substitute subst b r
   , not (isUnLiftedType (idType b)) || exprOkForSpeculation r
   = Just (extendIdSubst subst b r)
 
-  | idIsInstantiationFn b
-  = Just (extendIdSubst subst b r)
-
   | otherwise
   = Nothing
   where
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 8c78fbb..818b516 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -629,6 +629,9 @@ decomposeRuleLhs orig_bndrs orig_lhs
 
    split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
    split_lets e
+     | Let (NonRec d (Var r)) _body <- e
+     , isDictId d, isDictId r
+     = ([], e)
      | Let (NonRec d r) body <- e
      , isDictId d
      , (bs, body') <- split_lets body
@@ -1162,7 +1165,7 @@ to simply never generate the redundant box/unbox in the first place.
 dsEvInstanceOf :: Type -> EvInstanceOf -> CoreExpr -> DsM CoreExpr
 dsEvInstanceOf ty ev e
   = do { e' <- dsEvInstanceOf' ev e
-       ; return $ if False -- ty == exprType e'
+       ; return $ if ty == exprType e'
                   then e  -- No conversion needed
                   else e' }
 
@@ -1173,7 +1176,7 @@ dsEvInstanceOf' (EvInstanceOfVar v) e
 dsEvInstanceOf' (EvInstanceOfEq co) e
   = do { dsTcCoercion co $ \c ->
            case coercionKind c of
-            -- Pair ty1 ty2 | ty1 == ty2 -> e  -- No conversion needed
+            Pair ty1 ty2 | ty1 == ty2 -> e  -- No conversion needed
             _ ->  mkCast e (mkSubCo c) }
 dsEvInstanceOf' (EvInstanceOfInst qvars co qs) e
   = do { qs'  <- mapM dsEvTerm qs
@@ -1181,13 +1184,13 @@ dsEvInstanceOf' (EvInstanceOfInst qvars co qs) e
        ; let exprTy = mkCoreApps e (map Type qvars)
              exprEv = mkCoreApps exprTy qs'
        ; return $ case splitFunTy_maybe (exprType (Var co')) of
-                         -- Just (ty1, ty2) | ty1 == ty2 -> exprEv
+                         Just (ty1, ty2) | ty1 == ty2 -> exprEv
                          _ -> mkCoreApp (Var co') exprEv }
 dsEvInstanceOf' (EvInstanceOfLet tyvars qvars qs rest) e
   = do { q_binds <- dsTcEvBinds qs
        ; let rest' = setIdIsInstantiationFn rest True
        ; let inner = case splitFunTy_maybe (exprType (Var rest')) of
-                       -- Just (ty1, ty2) | ty1 == ty2 -> e
+                       Just (ty1, ty2) | ty1 == ty2 -> e
                        _ -> mkCoreApp (Var rest') e
        ; return $ mkCoreLams (tyvars ++ qvars) (mkCoreLets q_binds inner) }
 
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 80c07b5..8853607 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -273,14 +273,10 @@ zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
 -- Does not extend the ZonkEnv
 zonkEvBndr env var
   = do { let var_ty = varType var
-           -- Remember whether the variable was instantiation fn.
-       ; let var' = case classifyPredType (var_ty) of
-                      InstanceOfPred {} -> setIdIsInstantiationFn var True
-                      _ -> var
        ; ty <-
            {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
            zonkTcTypeToType env var_ty
-       ; return (setVarType var' ty) }
+       ; return (setVarType var ty) }
 
 zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
 zonkEvVarOcc env v = zonkIdOcc env v