Commit 92d25672 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Define DsUtils.mkCastDs and use it

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.
parent 4e8d74d2
......@@ -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.
......
......@@ -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
......
......@@ -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).
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment