GHC gets a new constraint solver. More efficient and smaller in size.

compiler/basicTypes/DataCon.lhs

@@ -858,16 +858,17 @@ dataConCannotMatch tys con
   | all isTyVarTy tys = False	-- Also common
   | otherwise
   = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
-                   | (ty1, ty2) <- concatMap (predEqs . predTypePredTree) theta ]
+                   | (ty1, ty2) <- concatMap predEqs theta ]
   where
     dc_tvs  = dataConUnivTyVars con
     theta   = dataConTheta con
     subst   = zipTopTvSubst dc_tvs tys
 
     -- TODO: could gather equalities from superclasses too
-    predEqs (EqPred ty1 ty2) = [(ty1, ty2)]
-    predEqs (TuplePred ts)   = concatMap predEqs ts
-    predEqs _                = []
+    predEqs pred = case classifyPredType pred of
+                     EqPred ty1 ty2 -> [(ty1, ty2)]
+                     TuplePred ts   -> concatMap predEqs ts
+                     _              -> []
 \end{code}
 
 %************************************************************************

compiler/basicTypes/MkId.lhs

@@ -48,7 +48,7 @@ import Type
 import Coercion
 import TcType
 import MkCore
-import CoreUtils	( exprType, mkCoerce )
+import CoreUtils	( exprType, mkCast )
 import CoreUnfold
 import Literal
 import TyCon
@@ -683,7 +683,7 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 wrapNewTypeBody tycon args result_expr
   = ASSERT( isNewTyCon tycon )
     wrapFamInstBody tycon args $
-    mkCoerce (mkSymCo co) result_expr
+    mkCast result_expr (mkSymCo co)
   where
     co = mkAxInstCo (newTyConCo tycon) args
 
@@ -695,7 +695,7 @@ wrapNewTypeBody tycon args result_expr
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
   = ASSERT( isNewTyCon tycon )
-    mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr
+    mkCast result_expr (mkAxInstCo (newTyConCo tycon) args)
 
 -- If the type constructor is a representation type of a data instance, wrap
 -- the expression into a cast adjusting the expression type, which is an
@@ -705,14 +705,14 @@ unwrapNewTypeBody tycon args result_expr
 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 wrapFamInstBody tycon args body
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCoerce (mkSymCo (mkAxInstCo co_con args)) body
+  = mkCast body (mkSymCo (mkAxInstCo co_con args))
   | otherwise
   = body
 
 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapFamInstScrut tycon args scrut
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCoerce (mkAxInstCo co_con args) scrut
+  = mkCast scrut (mkAxInstCo co_con args)
   | otherwise
   = scrut
 \end{code}

compiler/codeGen/CgCase.lhs

@@ -47,6 +47,7 @@ import Type
 import TyCon
 import Util
 import Outputable
+import FastString
 
 import Control.Monad (when)
 \end{code}
@@ -127,6 +128,13 @@ allocating more heap than strictly necessary, but it will sometimes
 eliminate a heap check altogether.
 
 \begin{code}
+cgCase (StgApp _v []) _live_in_whole_case _live_in_alts bndr
+       (PrimAlt _) [(DEFAULT,bndrs,_,rhs)]
+  | isVoidArg (idCgRep bndr)
+  = ASSERT( null bndrs )
+    WARN( True, ptext (sLit "Case of void constant; missing optimisation somewhere") <+> ppr bndr)
+    cgExpr rhs
+
 cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
        alt_type@(PrimAlt _) alts
   -- Note [ticket #3132]: we might be looking at a case of a lifted Id
@@ -147,17 +155,18 @@ cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
   -- the HValue really is a MutVar#.  The types are compatible though,
   -- so we can just generate an assignment.
   || reps_compatible
-  =
-     do	{ -- Careful! we can't just bind the default binder to the same thing
+  =  do { when (not reps_compatible) $
+            panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
+
+          -- Careful! we can't just bind the default binder to the same thing
 	  -- as the scrutinee, since it might be a stack location, and having
 	  -- two bindings pointing at the same stack locn doesn't work (it
 	  -- confuses nukeDeadBindings).  Hence, use a new temp.
-          when (not reps_compatible) $
-            panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
 	; v_info <- getCgIdInfo v
 	; amode <- idInfoToAmode v_info
 	; tmp_reg <- bindNewToTemp bndr
 	; stmtC (CmmAssign (CmmLocal tmp_reg) amode)
+
 	; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
   where
     reps_compatible = idCgRep v == idCgRep bndr
@@ -327,6 +336,7 @@ cgInlinePrimOp primop args bndr (PrimAlt _) live_in_alts alts
   = ASSERT( con == DEFAULT && isSingleton alts && null bs )
     do	{ 	-- VOID RESULT; just sequencing, 
 		-- so get in there and do it
+		-- The bndr should not occur, so no need to bind it
 	  cgPrimOp [] primop args live_in_alts
 	; cgExpr rhs }
   where

compiler/coreSyn/CoreLint.lhs

@@ -297,6 +297,21 @@ lintCoreExpr (Let (Rec pairs) body)
     (_, dups) = removeDups compare bndrs
 
 lintCoreExpr e@(App _ _)
+{- DV: This grievous hack (from ghc-constraint-solver should not be needed: 
+    | Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments
+                   -- of kind (* -> *) but its type insists on *. When we have polymorphic kinds,
+                   -- we should do this properly
+    , Just dc <- isDataConWorkId_maybe x
+    , dc == eqBoxDataCon
+    , [Type arg_ty1, Type arg_ty2, co_e] <- args
+    = do arg_ty1' <- lintInTy arg_ty1
+         arg_ty2' <- lintInTy arg_ty2
+         unless (typeKind arg_ty1' `eqKind` typeKind arg_ty2')
+                (addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2))
+         
+         lintCoreArg (mkCoercionType arg_ty1' arg_ty2' `mkFunTy` mkEqPred (arg_ty1', arg_ty2')) co_e
+    | otherwise
+-}
     = do { fun_ty <- lintCoreExpr fun
          ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
   where
@@ -460,13 +475,10 @@ checkTyKind tyvar arg_ty
 checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType)
 checkTyCoKind tv co
   = do { (t1,t2) <- lintCoercion co
-       ; k1      <- lintType t1
-       ; k2      <- lintType t2
-       ; unless ((k1 `isSubKind` tyvar_kind) && (k2 `isSubKind` tyvar_kind))
+            -- t1,t2 have the same kind
+       ; unless (typeKind t1 `isSubKind` tyVarKind tv)
                 (addErrL (mkTyCoAppErrMsg tv co))
        ; return (t1,t2) }
-  where 
-    tyvar_kind = tyVarKind tv
 
 checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)]
 checkTyCoKinds = zipWithM checkTyCoKind
@@ -688,6 +700,29 @@ lintTyBndrKind tv =
   else lintKind ki  -- type forall
 
 -------------------
+{-
+lint_prim_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType)
+lint_prim_eq_co tc co arg_cos = case arg_cos of 
+  [co1,co2] -> do { (t1,s1) <- lintCoercion co1
+                  ; (t2,s2) <- lintCoercion co2
+                  ; checkL (typeKind t1 `eqKind` typeKind t2) $ 
+                    ptext (sLit "Mismatched arg kinds in coercion application:") <+> ppr co
+                  ; return (mkTyConApp tc [t1,t2], mkTyConApp tc [s1,s2]) }
+  _ -> failWithL (ptext (sLit "Unsaturated or oversaturated ~# coercion") <+> ppr co)
+
+lint_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType) 
+lint_eq_co tc co arg_cos = case arg_cos of 
+  [co1,co2] -> do { (t1,s1) <- lintCoercion co1
+                  ; (t2,s2) <- lintCoercion co2
+                  ; checkL (typeKind t1 `eqKind` typeKind t2) $
+                    ptext (sLit "Mismatched arg kinds in coercion application:") <+> ppr co
+                  ; return (mkTyConApp tc [t1,t2], mkTyConApp tc [s1,s2]) }
+  [co1] -> do { (t1,s1) <- lintCoercion co1
+              ; return (mkTyConApp tc [t1], mkTyConApp tc [s1]) }
+  [] -> return (mkTyConApp tc [], mkTyConApp tc [])
+  _ -> failWithL (ptext (sLit "Oversaturated ~ coercion") <+> ppr co) 
+-}
+
 lintKindCoercion :: OutCoercion -> LintM OutKind
 -- Kind coercions are only reflexivity because they mean kind
 -- instantiation.  See Note [Kind coercions] in Coercion
@@ -700,11 +735,28 @@ lintKindCoercion co
 
 lintCoercion :: OutCoercion -> LintM (OutType, OutType)
 -- Check the kind of a coercion term, returning the kind
+-- Post-condition: the returned OutTypes are lint-free
+--                 and have the same kind as each other
 lintCoercion (Refl ty)
-  = do { _k <- lintType ty
+  = do { _ <- lintType ty
        ; return (ty, ty) }
 
 lintCoercion co@(TyConAppCo tc cos)
+{- DV: This grievous hack (from ghc-constraint-solver) should not be needed any more:
+  | tc `hasKey` eqPrimTyConKey      -- Just as in lintType, treat applications of (~) and (~#)
+  = lint_prim_eq_co tc co cos       -- specially to allow for polymorphism. This hack will 
+                                    -- hopefully go away when we merge in kind polymorphism.
+  | tc `hasKey` eqTyConKey
+  = lint_eq_co tc co cos
+
+  | otherwise
+  = do { (ss,ts) <- mapAndUnzipM lintCoercion cos
+       ; let kind_to_check = if (tc `hasKey` funTyConKey) && (length cos == 2)
+                             then mkArrowKinds [argTypeKind,openTypeKind] liftedTypeKind
+                             else tyConKind tc -- TODO: Fix this when kind polymorphism is in! 
+       ; check_co_app co kind_to_check ss
+       ; return (mkTyConApp tc ss, mkTyConApp tc ts) }
+-}
   = do   -- We use the kind of the type constructor to know how many
          -- kind coercions we have (one kind coercion for one kind
          -- instantiation).
@@ -721,6 +773,7 @@ lintCoercion co@(TyConAppCo tc cos)
        ; check_co_app co ki (kis ++ ss)
        ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) }
 
+
 lintCoercion co@(AppCo co1 co2)
   = do { (s1,t1) <- lintCoercion co1
        ; (s2,t2) <- lintCoercion co2
@@ -740,7 +793,8 @@ lintCoercion (CoVarCo cv)
                   2 (ptext (sLit "With offending type:") <+> ppr (varType cv)))
   | otherwise
   = do { checkTyCoVarInScope cv
-       ; return (coVarKind cv) }
+       ; cv' <- lookupIdInScope cv 
+       ; return (coVarKind cv') }
 
 lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
                                    , co_ax_lhs = lhs
@@ -759,8 +813,8 @@ lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
     (kcos, tcos) = splitAt (length kvs) cos
 
 lintCoercion (UnsafeCo ty1 ty2)
-  = do { _k1 <- lintType ty1
-       ; _k2 <- lintType ty2
+  = do { _ <- lintType ty1
+       ; _ <- lintType ty2
        ; return (ty1, ty2) }
 
 lintCoercion (SymCo co) 
@@ -794,7 +848,7 @@ lintCoercion (InstCo co arg_ty)
 	  Nothing -> failWithL (ptext (sLit "Bad argument of inst")) }
 
 ----------
-checkTcApp :: Coercion -> Int -> Type -> LintM Type
+checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType
 checkTcApp co n ty
   | Just tys <- tyConAppArgs_maybe ty
   , n < length tys
@@ -988,10 +1042,10 @@ updateTvSubst subst' m =
 getTvSubst :: LintM TvSubst
 getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
 
-applySubstTy :: Type -> LintM Type
+applySubstTy :: InType -> LintM OutType
 applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) }
 
-applySubstCo :: Coercion -> LintM Coercion
+applySubstCo :: InCoercion -> LintM OutCoercion
 applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) }
 
 extendSubstL :: TyVar -> Type -> LintM a -> LintM a

compiler/coreSyn/CoreSubst.lhs

@@ -949,7 +949,8 @@ simple_opt_expr' subst expr
       = case altcon of
           DEFAULT -> go rhs
           _       -> mkLets (catMaybes mb_binds) $ simple_opt_expr subst' rhs
-            where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst (zipEqual "simpleOptExpr" bs es)
+            where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst 
+                                                 (zipEqual "simpleOptExpr" bs es)
 
       | otherwise
       = Case e' b' (substTy subst ty)
@@ -1016,9 +1017,11 @@ simple_opt_bind' subst (NonRec b r)
 
 ----------------------
 simple_opt_out_bind :: Subst -> (InVar, OutExpr) -> (Subst, Maybe CoreBind)
-simple_opt_out_bind subst (b, r') = case maybe_substitute subst b r' of
-      Just ext_subst -> (ext_subst, Nothing)
-      Nothing        -> (subst', Just (NonRec b2 r'))
+simple_opt_out_bind subst (b, r') 
+  | Just ext_subst <- maybe_substitute subst b r'
+  = (ext_subst, Nothing)
+  | otherwise
+  = (subst', Just (NonRec b2 r'))
   where
     (subst', b') = subst_opt_bndr subst b
     b2 = add_info subst' b b'
@@ -1038,6 +1041,8 @@ maybe_substitute subst b r
     Just (extendCvSubst subst b co)
 
   | isId b              -- let x = e in <body>
+  , not (isCoVar b)	-- See Note [Do not inline CoVars unconditionally]
+    		 	-- in SimplUtils
   , safe_to_inline (idOccInfo b) 
   , isAlwaysActive (idInlineActivation b)	-- Note [Inline prag in simplOpt]
   , not (isStableUnfolding (idUnfolding b))
@@ -1257,7 +1262,7 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
 
           -- Cast the value arguments (which include dictionaries)
         new_val_args = zipWith cast_arg arg_tys val_args
-        cast_arg arg_ty arg = mkCoerce (theta_subst arg_ty) arg
+        cast_arg arg_ty arg = mkCast arg (theta_subst arg_ty)
 
         dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
                          ppr arg_tys, ppr dc_args,        ppr _dc_univ_args,

compiler/coreSyn/CoreUtils.lhs

@@ -9,7 +9,8 @@ Utility functions on @Core@ syntax
 -- | Commonly useful utilites for manipulating the Core language
 module CoreUtils (
         -- * Constructing expressions
-        mkTick, mkTickNoHNF, mkCoerce,
+        mkCast,
+        mkTick, mkTickNoHNF,
         bindNonRec, needsCaseBinding,
         mkAltExpr, mkPiType, mkPiTypes,
 
@@ -190,15 +191,27 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
 \begin{code}
 -- | Wrap the given expression in the coercion safely, dropping
 -- identity coercions and coalescing nested coercions
-mkCoerce :: Coercion -> CoreExpr -> CoreExpr
-mkCoerce co e | isReflCo co = e
-mkCoerce co (Cast expr co2)
+mkCast :: CoreExpr -> Coercion -> CoreExpr
+mkCast e co | isReflCo co = e
+
+mkCast (Coercion e_co) co 
+  = Coercion new_co
+  where
+       -- g :: (s1 ~# s2) ~# (t1 ~#  t2)
+       -- g1 :: s1 ~# t1
+       -- g2 :: s2 ~# t2
+       new_co = mkSymCo g1 `mkTransCo` e_co `mkTransCo` g2
+       [_reflk, g1, g2] = decomposeCo 3 co
+            -- Remember, (~#) :: forall k. k -> k -> *
+            -- so it takes *three* arguments, not two
+
+mkCast (Cast expr co2) co
   = ASSERT(let { Pair  from_ty  _to_ty  = coercionKind co;
                  Pair _from_ty2  to_ty2 = coercionKind co2} in
            from_ty `eqType` to_ty2 )
-    mkCoerce (mkTransCo co2 co) expr
+    mkCast expr (mkTransCo co2 co)
 
-mkCoerce co expr
+mkCast expr co
   = let Pair from_ty _to_ty = coercionKind co in
 --    if to_ty `eqType` from_ty
 --    then expr
@@ -1504,7 +1517,7 @@ tryEtaReduce bndrs body
     -- See Note [Eta reduction with casted arguments]
     -- for why we have an accumulating coercion
     go [] fun co
-      | ok_fun fun = Just (mkCoerce co fun)
+      | ok_fun fun = Just (mkCast fun co)
 
     go (b : bs) (App fun arg) co
       | Just co' <- ok_arg b arg co

compiler/deSugar/Desugar.lhs

@@ -153,16 +153,21 @@ deSugar hsc_env
         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
         -- Lint result if necessary, and print
+{-
         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
                (vcat [ pprCoreBindings final_pgm
                      , pprRules rules_for_imps ])
+-}
 
+#ifdef DEBUG
+        ; endPass dflags CoreDesugar final_pgm rules_for_imps 
+#endif
         ; (ds_binds, ds_rules_for_imps, ds_vects) 
             <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
                          -- The simpleOptPgm gets rid of type 
                          -- bindings plus any stupid dead code
 
-        ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
+        ; endPass dflags CoreDesugarOpt ds_binds ds_rules_for_imps
 
         ; let used_names = mkUsedNames tcg_env
         ; deps <- mkDependencies tcg_env

compiler/deSugar/DsBinds.lhs

@@ -186,10 +186,14 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
 --------------------------------------
 dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"	-- Zonker has got rid of this
-dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
+dsTcEvBinds (EvBinds bs)   = -- pprTrace "EvBinds bs = "  (ppr bs) $ 
+                             dsEvBinds bs
 
 dsEvBinds :: Bag EvBind -> DsM [CoreBind]
-dsEvBinds bs = return (map dsEvGroup sccs)
+dsEvBinds bs = do { let core_binds = map dsEvSCC sccs 
+--                   ; pprTrace "dsEvBinds, result = " (vcat (map ppr core_binds)) $ 
+                  ; return core_binds }
+--                   ; return (map dsEvGroup sccs)
   where
     sccs :: [SCC EvBind]
     sccs = stronglyConnCompFromEdgedVertices edges
@@ -202,19 +206,19 @@ dsEvBinds bs = return (map dsEvGroup sccs)
 
     free_vars_of :: EvTerm -> [EvVar]
     free_vars_of (EvId v)           = [v]
-    free_vars_of (EvCast v co)      = v : varSetElems (tyCoVarsOfCo co)
-    free_vars_of (EvCoercionBox co) = varSetElems (tyCoVarsOfCo co)
+    free_vars_of (EvCast v co)      = v : varSetElems (coVarsOfCo co)
+    free_vars_of (EvCoercionBox co) = varSetElems (coVarsOfCo co)
     free_vars_of (EvDFunApp _ _ vs) = vs
     free_vars_of (EvTupleSel v _)   = [v]
     free_vars_of (EvTupleMk vs)     = vs
     free_vars_of (EvSuperClass d _) = [d]
 
-dsEvGroup :: SCC EvBind -> CoreBind
+dsEvSCC :: SCC EvBind -> CoreBind
 
-dsEvGroup (AcyclicSCC (EvBind v r))
+dsEvSCC (AcyclicSCC (EvBind v r))
   = NonRec v (dsEvTerm r)
 
-dsEvGroup (CyclicSCC bs)
+dsEvSCC (CyclicSCC bs)
   = Rec (map ds_pair bs)
   where
     ds_pair (EvBind v r) = (v, dsEvTerm r)
@@ -251,8 +255,12 @@ dsLCoercion co k
 
 ---------------------------------------
 dsEvTerm :: EvTerm -> CoreExpr
-dsEvTerm (EvId v)                = Var v
-dsEvTerm (EvCast v co)           = dsLCoercion co $ Cast (Var v)
+dsEvTerm (EvId v) = Var v
+
+dsEvTerm (EvCast v co) 
+  = dsLCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
+                                    -- unnecessary to call varToCoreExpr v here.
+
 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
 dsEvTerm (EvCoercionBox co)      = dsLCoercion co mkEqBox
 dsEvTerm (EvTupleSel v n)
@@ -686,12 +694,13 @@ dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
 dsHsWrapper WpHole 	      = return (\e -> e)
 dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
 dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+--                                   ; pprTrace "Desugared core bindings = " (vcat (map ppr ds_ev_binds)) $ 
                                    ; return (mkCoreLets ds_ev_binds) }
 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 
                                    ; k2 <- dsHsWrapper c2
                                    ; return (k1 . k2) }
 dsHsWrapper (WpCast co)
-  = return (\e -> dsLCoercion co (Cast e)) 
+  = return (\e -> dsLCoercion co (mkCast e)) 
 dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e) 
 dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e) 
 dsHsWrapper (WpEvApp evtrm)

compiler/deSugar/DsCCall.lhs

@@ -142,7 +142,7 @@ unboxArg arg
 
   -- Recursive newtypes
   | Just(_rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
-  = unboxArg (mkCoerce co arg)
+  = unboxArg (mkCast arg co)
       
   -- Booleans
   | Just tc <- tyConAppTyCon_maybe arg_ty, 
@@ -342,7 +342,7 @@ resultWrapper result_ty
   -- Recursive newtypes
   | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
   = do (maybe_ty, wrapper) <- resultWrapper rep_ty
-       return (maybe_ty, \e -> mkCoerce (mkSymCo co) (wrapper e))
+       return (maybe_ty, \e -> mkCast (wrapper e) (mkSymCo co))
 
   -- The type might contain foralls (eg. for dummy type arguments,
   -- referring to 'Ptr a' is legal).

compiler/deSugar/DsUtils.lhs

@@ -642,7 +642,7 @@ mkSelectorBinds ticks pat val_expr
                                 (Var bndr_var) error_expr
         return (bndr_var, mkOptTickBox tick rhs_expr)
       where
-        error_expr = mkCoerce co (Var err_var)
+        error_expr = mkCast (Var err_var) co
         co         = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
 
     is_simple_lpat p = is_simple_pat (unLoc p)

compiler/hsSyn/HsBinds.lhs

@@ -486,19 +486,21 @@ data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
      -- The Unique is only for debug printing
 
 -----------------
-type EvBindMap = VarEnv EvBind
+newtype EvBindMap = EvBindMap { ev_bind_varenv :: VarEnv EvBind } -- Map from evidence variables to evidence terms
 
 emptyEvBindMap :: EvBindMap
-emptyEvBindMap = emptyVarEnv
+emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv }
 
 extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
-extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)
+extendEvBinds bs v t 
+  = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) }
 
 lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
-lookupEvBind = lookupVarEnv
+lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs)
 
 evBindMapBinds :: EvBindMap -> Bag EvBind
-evBindMapBinds = foldVarEnv consBag emptyBag
+evBindMapBinds bs 
+  = foldVarEnv consBag emptyBag (ev_bind_varenv bs)
 
 -----------------
 instance Data TcEvBinds where
@@ -551,6 +553,11 @@ Conclusion: a new wanted coercion variable should be made mutable.
 
 
 \begin{code}
+mkEvCast :: EvVar -> LCoercion -> EvTerm
+mkEvCast ev lco
+  | isReflCo lco = EvId ev
+  | otherwise    = EvCast ev lco
+
 emptyTcEvBinds :: TcEvBinds
 emptyTcEvBinds = EvBinds emptyBag
 

compiler/prelude/TysPrim.lhs

@@ -242,7 +242,17 @@ funTyConName :: Name
 funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
 
 funTyCon :: TyCon
-funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind)
+funTyCon = mkFunTyCon funTyConName $ 
+           mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
+        -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
+	-- But if we do that we get kind errors when saying
+	--	instance Control.Arrow (->)
+	-- becuase the expected kind is (*->*->*).  The trouble is that the
+	-- expected/actual stuff in the unifier does not go contra-variant, whereas
+	-- the kind sub-typing does.  Sigh.  It really only matters if you use (->) in
+	-- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
+        -- because they are never in scope in the source
+
 -- One step to remove subkinding.
 -- (->) :: * -> * -> *
 -- but we should have (and want) the following typing rule for fully applied arrows

compiler/simplCore/CoreMonad.lhs

@@ -251,8 +251,9 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
-  | CoreDesugar	 -- Not strictly a core-to-core pass, but produces
-                 -- Core output, and hence useful to pass to endPass
+  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
+  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
+                       --                 Core output, and hence useful to pass to endPass
 
   | CoreTidy
   | CorePrep
@@ -274,6 +275,7 @@ coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse 
 coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
 coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds 
+coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds 
 coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
 coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
 
@@ -295,7 +297,8 @@ instance Outputable CoreToDo where
   ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
   ppr CoreCSE                  = ptext (sLit "Common sub-expression")
   ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
-  ppr CoreDesugar              = ptext (sLit "Desugar")
+  ppr CoreDesugar              = ptext (sLit "Desugar (before optimization)")
+  ppr CoreDesugarOpt           = ptext (sLit "Desugar (after optimization)")
   ppr CoreTidy                 = ptext (sLit "Tidy Core")
   ppr CorePrep 		       = ptext (sLit "CorePrep")
   ppr CoreDoPrintCore          = ptext (sLit "Print core")

compiler/simplCore/OccurAnal.lhs

@@ -28,7 +28,7 @@ module OccurAnal (
 
 import CoreSyn
 import CoreFVs
-import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce )
+import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCast )
 import Id
 import Name( localiseName )
 import BasicTypes
@@ -1345,7 +1345,7 @@ wrapProxy (bndr, rhs_var, co) (body_usg, body)
   where
     (body_usg', tagged_bndr) = tagBinder body_usg bndr
     rhs_usg = unitVarEnv rhs_var NoOccInfo	-- We don't need exact info
-    rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
+    rhs = mkCast (Var (zapIdOccInfo rhs_var)) co -- See Note [Zap case binders in proxy bindings]
 \end{code}
 
 

compiler/simplCore/SimplUtils.lhs

@@ -1062,7 +1062,7 @@ mkLam _env bndrs body
       | not (any bad bndrs)
 	-- Note [Casts and lambdas]
       = do { lam <- mkLam' dflags bndrs body
-           ; return (mkCoerce (mkPiCos bndrs co) lam) }
+           ; return (mkCast lam (mkPiCos bndrs co)) }
       where
         co_vars  = tyCoVarsOfCo co
 	bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars      

compiler/simplCore/Simplify.lhs

@@ -983,26 +983,12 @@ simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
 --  =  Coercion (syn (nth 0 g) ; co ; nth 1 g) 
 simplCoercionF env co cont 
   = do { co' <- simplCoercion env co
-       ; simpl_co co' cont }
-  where
-    simpl_co co (CoerceIt g cont)
-       = simpl_co new_co cont
-     where
-       -- g :: (s1 ~# s2) ~# (t1 ~#  t2)
-       -- g1 :: s1 ~# t1
-       -- g2 :: s2 ~# t2
-       new_co = mkSymCo g1 `mkTransCo` co `mkTransCo` g2
-       [_reflk, g1, g2] = decomposeCo 3 g
-            -- Remember, (~#) :: forall k. k -> k -> *
-            -- so it takes *three* arguments, not two
-
-    simpl_co co cont
-       = seqCo co `seq` rebuild env (Coercion co) cont
+       ; rebuild env (Coercion co') cont }
 
 simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
 simplCoercion env co
   = let opt_co = optCoercion (getCvSubst env) co
-    in opt_co `seq` return opt_co
+    in seqCo opt_co `seq` return opt_co
 
 -----------------------------------
 -- | Push a TickIt context outwards past applications and cases, as
@@ -1162,7 +1148,8 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
 rebuild env expr cont
   = case cont of
       Stop {}                      -> return (env, expr)
-      CoerceIt co cont             -> rebuild env (Cast expr co) cont
+      CoerceIt co cont             -> rebuild env (mkCast expr co) cont 
+                                         -- NB: mkCast implements the (Coercion co |> g) optimisation
       Select _ bndr alts se cont   -> rebuildCase (se `setFloats` env) expr bndr alts cont
       StrictArg info _ cont        -> rebuildCall env (info `addArgTo` expr) cont
       StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
@@ -1242,7 +1229,7 @@ simplCast env body co0 cont0
            -- t2 ~ s2 with left and right on the curried form:
            --    (->) t1 t2 ~ (->) s1 s2
            [co1, co2] = decomposeCo 2 co
-           new_arg    = mkCoerce (mkSymCo co1) arg'
+           new_arg    = mkCast arg' (mkSymCo co1)
            arg'       = substExpr (text "move-cast") arg_se' arg
            arg_se'    = arg_se `setInScope` env
 
@@ -1447,7 +1434,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
     cont_ty = contResultType env res_ty cont
     co      = mkUnsafeCo res_ty cont_ty
     mk_coerce expr | cont_ty `eqType` res_ty = expr
-                   | otherwise = mkCoerce co expr
+                   | otherwise = mkCast expr co
 
 rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
   = do { arg_ty' <- if isSimplified dup_flag then return arg_ty

compiler/typecheck/Inst.lhs

@@ -29,12 +29,13 @@ module Inst (
        
        tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVarXs, tyVarsOfEvVarX,
        tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication,
+       tyVarsOfCt, tyVarsOfCts, tyVarsOfCDict, tyVarsOfCDicts,
 
        tidyWantedEvVar, tidyWantedEvVars, tidyWC,
-       tidyEvVar, tidyImplication, tidyFlavoredEvVar,
+       tidyEvVar, tidyImplication, tidyCt,
 
-       substWantedEvVar, substWantedEvVars, substFlavoredEvVar,