Define DsUtils.mkCastDs and use it
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 29 Jul 2015 15:38:44 +0000 (16:38 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 30 Jul 2015 10:03:08 +0000 (11:03 +0100)
This change avoids a spurious WARNing from mkCast.  In the output of
the desugarer (only, I think) we can have a cast where the type of the
expression and cast don't syntactically match, because of an enclosing
type-let binding.

compiler/coreSyn/CoreUtils.hs
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsCCall.hs
compiler/deSugar/DsUtils.hs

index 56de91c..889e239 100644 (file)
@@ -198,9 +198,12 @@ applyTypeToArgs e op_ty args
 -- | Wrap the given expression in the coercion safely, dropping
 -- identity coercions and coalescing nested coercions
 mkCast :: CoreExpr -> Coercion -> CoreExpr
-mkCast e co | ASSERT2( coercionRole co == Representational
-                     , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast") <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) )
-              isReflCo co = e
+mkCast e co
+  | ASSERT2( coercionRole co == Representational
+           , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast")
+             <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) )
+    isReflCo co
+  = e
 
 mkCast (Coercion e_co) co
   | isCoVarType (pSnd (coercionKind co))
@@ -223,11 +226,11 @@ mkCast (Tick t expr) co
 
 mkCast expr co
   = let Pair from_ty _to_ty = coercionKind co in
---    if to_ty `eqType` from_ty
---    then expr
---    else
-        WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co))
-         (Cast expr co)
+    WARN( not (from_ty `eqType` exprType expr),
+          text "Trying to coerce" <+> text "(" <> ppr expr
+          $$ text "::" <+> ppr (exprType expr) <> text ")"
+          $$ ppr co $$ ppr (coercionType co) )
+    (Cast expr co)
 
 -- | Wraps the given expression in the source annotation, dropping the
 -- annotation if possible.
index e5c787a..b6edf7c 100644 (file)
@@ -798,7 +798,7 @@ dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
                                       ; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)
                                       ; return (Lam x e2) }
 dsHsWrapper (WpCast co)       e = ASSERT(tcCoercionRole co == Representational)
-                                  dsTcCoercion co (mkCast e)
+                                  dsTcCoercion co (mkCastDs e)
 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)
@@ -839,7 +839,7 @@ dsEvTerm (EvId v) = return (Var v)
 
 dsEvTerm (EvCast tm co)
   = do { tm' <- dsEvTerm tm
-       ; dsTcCoercion co $ mkCast tm' }
+       ; dsTcCoercion co $ mkCastDs tm' }
                         -- 'v' is always a lifted evidence variable so it is
                         -- unnecessary to call varToCoreExpr v here.
 
@@ -920,7 +920,7 @@ dsEvTypeable ev =
                 $ mkLams [mkWildValBinder proxyT] (Var repName)
 
      -- package up the method as `Typeable` dictionary
-     return $ mkCast method $ mkSymCo $ getTypeableCo tyCl ty
+     return $ mkCastDs method $ mkSymCo $ getTypeableCo tyCl ty
 
   where
   -- co: method -> Typeable k t
@@ -933,7 +933,7 @@ dsEvTypeable ev =
   getRep tc (ev,t) =
     do typeableExpr <- dsEvTerm ev
        let co     = getTypeableCo tc t
-           method = mkCast typeableExpr co
+           method = mkCastDs typeableExpr co
            proxy  = mkTyApps (Var proxyHashId) [typeKind t, t]
        return (mkApps method [proxy])
 
@@ -1042,7 +1042,7 @@ dsEvCallStack cs = do
                   -- so we use unwrapIP to strip the dictionary wrapper
                   -- See Note [Overview of implicit CallStacks]
                   let ip_co = unwrapIP (exprType tmExpr)
-                  return (pushCS nameExpr locExpr (mkCast tmExpr ip_co))
+                  return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co))
   case cs of
     EvCsTop name loc tm -> mkPush name loc tm
     EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
index 19ac062..26551b5 100644 (file)
@@ -21,7 +21,7 @@ module DsCCall
 import CoreSyn
 
 import DsMonad
-
+import DsUtils( mkCastDs )
 import CoreUtils
 import MkCore
 import Var
@@ -138,7 +138,7 @@ unboxArg arg
 
   -- Recursive newtypes
   | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
-  = unboxArg (mkCast arg co)
+  = unboxArg (mkCastDs arg co)
 
   -- Booleans
   | Just tc <- tyConAppTyCon_maybe arg_ty,
@@ -338,7 +338,7 @@ resultWrapper result_ty
   -- Newtypes
   | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
   = do (maybe_ty, wrapper) <- resultWrapper rep_ty
-       return (maybe_ty, \e -> mkCast (wrapper e) (mkSymCo co))
+       return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co))
 
   -- The type might contain foralls (eg. for dummy type arguments,
   -- referring to 'Ptr a' is legal).
index f94b831..8199443 100644 (file)
@@ -24,7 +24,7 @@ module DsUtils (
         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
         wrapBind, wrapBinds,
 
-        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
+        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
 
         seqVar,
 
@@ -44,6 +44,7 @@ import {-# SOURCE #-}   Match ( matchSimply )
 
 import HsSyn
 import TcHsSyn
+import Coercion( Coercion, isReflCo )
 import TcType( tcSplitTyConApp )
 import CoreSyn
 import DsMonad
@@ -549,10 +550,22 @@ mkCoreAppDs fun arg = mkCoreApp fun arg  -- The rest is done in MkCore
 mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
 mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
 
+mkCastDs :: CoreExpr -> Coercion -> CoreExpr
+-- We define a desugarer-specific verison of CoreUtils.mkCast,
+-- because in the immediate output of the desugarer, we can have
+-- apparently-mis-matched coercions:  E.g.
+--     let a = b
+--     in (x :: a) |> (co :: b ~ Int)
+-- Lint know about type-bindings for let and does not complain
+-- So here we do not make the assertion checks that we make in
+-- CoreUtils.mkCast; and we do less peephole optimisation too
+mkCastDs e co | isReflCo co = e
+              | otherwise   = Cast e co
+
 {-
 ************************************************************************
 *                                                                      *
-\subsection[mkSelectorBind]{Make a selector bind}
+               Tuples and selector bindings
 *                                                                      *
 ************************************************************************
 
@@ -720,7 +733,7 @@ mkBigLHsPatTup = mkChunkified mkLHsPatTup
 {-
 ************************************************************************
 *                                                                      *
-\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+        Code for pattern-matching and other failures
 *                                                                      *
 ************************************************************************
 
@@ -805,7 +818,13 @@ entered at most once.  Adding a dummy 'realWorld' token argument makes
 it clear that sharing is not an issue.  And that in turn makes it more
 CPR-friendly.  This matters a lot: if you don't get it right, you lose
 the tail call property.  For example, see Trac #3403.
--}
+
+
+************************************************************************
+*                                                                      *
+              Ticks
+*                                                                      *
+********************************************************************* -}
 
 mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
 mkOptTickBox = flip (foldr Tick)