Commit 0e022e56 authored by Joachim Breitner's avatar Joachim Breitner

Turn EvTerm (almost) into CoreExpr (#14691)

Ideally, I'd like to do

    type EvTerm = CoreExpr

and the type checker builds the evidence terms as it goes. This failed,
becuase the evidence for `Typeable` refers to local identifiers that are
added *after* the typechecker solves constraints. Therefore, `EvTerm`
stays a data type with two constructors: `EvExpr` for `CoreExpr`
evidence, and `EvTypeable` for the others.

Delted `Note [Memoising typeOf]`, its reference (and presumably
relevance) was removed in 8fa4bf9a.

Differential Revision: https://phabricator.haskell.org/D4341
parent 40c753f1
...@@ -30,7 +30,6 @@ import DsUtils ...@@ -30,7 +30,6 @@ import DsUtils
import HsSyn -- lots of things import HsSyn -- lots of things
import CoreSyn -- lots of things import CoreSyn -- lots of things
import Literal ( Literal(MachStr) )
import CoreOpt ( simpleOptExpr ) import CoreOpt ( simpleOptExpr )
import OccurAnal ( occurAnalyseExpr ) import OccurAnal ( occurAnalyseExpr )
import MkCore import MkCore
...@@ -49,7 +48,6 @@ import Coercion ...@@ -49,7 +48,6 @@ import Coercion
import TysWiredIn ( typeNatKind, typeSymbolKind ) import TysWiredIn ( typeNatKind, typeSymbolKind )
import Id import Id
import MkId(proxyHashId) import MkId(proxyHashId)
import Class
import Name import Name
import VarSet import VarSet
import Rules import Rules
...@@ -1156,41 +1154,8 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) ...@@ -1156,41 +1154,8 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
**********************************************************************-} **********************************************************************-}
dsEvTerm :: EvTerm -> DsM CoreExpr dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvId v) = return (Var v) dsEvTerm (EvExpr e) = return e
dsEvTerm (EvCallStack cs) = dsEvCallStack cs dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
dsEvTerm (EvLit (EvNum n)) = mkNaturalExpr n
dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s
dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; return $ mkCastDs tm' co }
dsEvTerm (EvDFunApp df tys tms)
= do { tms' <- mapM dsEvTerm tms
; return $ Var df `mkTyApps` tys `mkApps` tms' }
-- The use of mkApps here is OK vis-a-vis levity polymorphism because
-- the terms are always evidence variables with types of kind Constraint
dsEvTerm (EvCoercion co) = return (Coercion co)
dsEvTerm (EvSuperClass d n)
= do { d' <- dsEvTerm d
; let (cls, tys) = getClassPredTys (exprType d')
sc_sel_id = classSCSelId cls n -- Zero-indexed
; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
dsEvTerm (EvSelector sel_id tys tms)
= do { tms' <- mapM dsEvTerm tms
; return $ Var sel_id `mkTyApps` tys `mkApps` tms' }
dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg
dsEvDelayedError :: Type -> FastString -> CoreExpr
dsEvDelayedError ty msg
= Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
{-********************************************************************** {-**********************************************************************
* * * *
...@@ -1312,58 +1277,3 @@ tyConRep tc ...@@ -1312,58 +1277,3 @@ tyConRep tc
; return (Var tc_rep_id) } ; return (Var tc_rep_id) }
| otherwise | otherwise
= pprPanic "tyConRep" (ppr tc) = pprPanic "tyConRep" (ppr tc)
{- Note [Memoising typeOf]
~~~~~~~~~~~~~~~~~~~~~~~~~~
See #3245, #9203
IMPORTANT: we don't want to recalculate the TypeRep once per call with
the proxy argument. This is what went wrong in #3245 and #9203. So we
help GHC by manually keeping the 'rep' *outside* the lambda.
-}
{-**********************************************************************
* *
Desugaring EvCallStack evidence
* *
**********************************************************************-}
dsEvCallStack :: EvCallStack -> DsM CoreExpr
-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
dsEvCallStack cs = do
df <- getDynFlags
m <- getModule
srcLocDataCon <- dsLookupDataCon srcLocDataConName
let mkSrcLoc l =
liftM (mkCoreConApps srcLocDataCon)
(sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
, mkStringExprFS (moduleNameFS $ moduleName m)
, mkStringExprFS (srcSpanFile l)
, return $ mkIntExprInt df (srcSpanStartLine l)
, return $ mkIntExprInt df (srcSpanStartCol l)
, return $ mkIntExprInt df (srcSpanEndLine l)
, return $ mkIntExprInt df (srcSpanEndCol l)
])
emptyCS <- Var <$> dsLookupGlobalId emptyCallStackName
pushCSVar <- dsLookupGlobalId pushCallStackName
let pushCS name loc rest =
mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
let mkPush name loc tm = do
nameExpr <- mkStringExprFS name
locExpr <- mkSrcLoc loc
case tm of
EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)
_ -> do tmExpr <- dsEvTerm tm
-- at this point tmExpr :: IP sym CallStack
-- but we need the actual CallStack to pass to pushCS,
-- 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 (mkCastDs tmExpr ip_co))
case cs of
EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
EvCsEmpty -> return emptyCS
...@@ -1053,8 +1053,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 ...@@ -1053,8 +1053,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
--------- ---------
ev_term :: EvTerm -> EvTerm -> Bool ev_term :: EvTerm -> EvTerm -> Bool
ev_term (EvId a) (EvId b) = a==b ev_term (EvExpr (Var a)) (EvExpr (Var b)) = a==b
ev_term (EvCoercion a) (EvCoercion b) = a `eqCoercion` b ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b
ev_term _ _ = False ev_term _ _ = False
--------- ---------
......
...@@ -471,6 +471,7 @@ Library ...@@ -471,6 +471,7 @@ Library
TcTypeable TcTypeable
TcType TcType
TcEvidence TcEvidence
TcEvTerm
TcUnify TcUnify
TcInteract TcInteract
TcCanonical TcCanonical
......
...@@ -355,13 +355,13 @@ instCallConstraints orig preds ...@@ -355,13 +355,13 @@ instCallConstraints orig preds
go pred go pred
| Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1 | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
= do { co <- unifyType Nothing ty1 ty2 = do { co <- unifyType Nothing ty1 ty2
; return (EvCoercion co) } ; return (evCoercion co) }
-- Try short-cut #2 -- Try short-cut #2
| Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
, tc `hasKey` heqTyConKey , tc `hasKey` heqTyConKey
= do { co <- unifyType Nothing ty1 ty2 = do { co <- unifyType Nothing ty1 ty2
; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) } ; return (evDFunApp (dataConWrapId heqDataCon) args [evCoercion co]) }
| otherwise | otherwise
= emitWanted orig pred = emitWanted orig pred
......
...@@ -19,6 +19,7 @@ import Type ...@@ -19,6 +19,7 @@ import Type
import TcFlatten import TcFlatten
import TcSMonad import TcSMonad
import TcEvidence import TcEvidence
import TcEvTerm
import Class import Class
import TyCon import TyCon
import TyCoRep -- cleverly decomposes types, good for completeness checking import TyCoRep -- cleverly decomposes types, good for completeness checking
...@@ -152,7 +153,7 @@ canClassNC ev cls tys ...@@ -152,7 +153,7 @@ canClassNC ev cls tys
-- Then we solve the wanted by pushing the call-site -- Then we solve the wanted by pushing the call-site
-- onto the newly emitted CallStack -- onto the newly emitted CallStack
; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvTerm new_ev) ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)
; solveCallStack ev ev_cs ; solveCallStack ev ev_cs
; canClass new_ev cls tys False } ; canClass new_ev cls tys False }
...@@ -171,8 +172,9 @@ solveCallStack ev ev_cs = do ...@@ -171,8 +172,9 @@ solveCallStack ev ev_cs = do
-- We're given ev_cs :: CallStack, but the evidence term should be a -- We're given ev_cs :: CallStack, but the evidence term should be a
-- dictionary, so we have to coerce ev_cs to a dictionary for -- dictionary, so we have to coerce ev_cs to a dictionary for
-- `IP ip CallStack`. See Note [Overview of implicit CallStacks] -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]
let ev_tm = mkEvCast (EvCallStack ev_cs) (wrapIP (ctEvPred ev)) cs_tm <- evCallStack ev_cs
setWantedEvBind (ctEvEvId ev) ev_tm let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
setWantedEvBind (ctEvEvId ev) (EvExpr ev_tm)
canClass :: CtEvidence canClass :: CtEvidence
-> Class -> [Type] -> Class -> [Type]
...@@ -443,7 +445,7 @@ mk_strict_superclasses :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct] ...@@ -443,7 +445,7 @@ mk_strict_superclasses :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct]
mk_strict_superclasses rec_clss ev cls tys mk_strict_superclasses rec_clss ev cls tys
| CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev
= do { sc_evs <- newGivenEvVars (mk_given_loc loc) = do { sc_evs <- newGivenEvVars (mk_given_loc loc)
(mkEvScSelectors (EvId evar) cls tys) (mkEvScSelectors (evId evar) cls tys)
; concatMapM (mk_superclasses rec_clss) sc_evs } ; concatMapM (mk_superclasses rec_clss) sc_evs }
| all noFreeVarsOfType tys | all noFreeVarsOfType tys
...@@ -992,9 +994,9 @@ can_eq_app ev NomEq s1 t1 s2 t2 ...@@ -992,9 +994,9 @@ can_eq_app ev NomEq s1 t1 s2 t2
co_s = mkTcLRCo CLeft co co_s = mkTcLRCo CLeft co
co_t = mkTcLRCo CRight co co_t = mkTcLRCo CRight co
; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2
, EvCoercion co_s ) , evCoercion co_s )
; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
, EvCoercion co_t ) , evCoercion co_t )
; emitWorkNC [evar_t] ; emitWorkNC [evar_t]
; canEqNC evar_s NomEq s1 s2 } ; canEqNC evar_s NomEq s1 s2 }
| otherwise -- Can't happen | otherwise -- Can't happen
...@@ -1264,7 +1266,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 ...@@ -1264,7 +1266,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
-> do { let ev_co = mkCoVarCo evar -> do { let ev_co = mkCoVarCo evar
; given_evs <- newGivenEvVars loc $ ; given_evs <- newGivenEvVars loc $
[ ( mkPrimEqPredRole r ty1 ty2 [ ( mkPrimEqPredRole r ty1 ty2
, EvCoercion (mkNthCo i ev_co) ) , evCoercion $ mkNthCo i ev_co )
| (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]
, r /= Phantom , r /= Phantom
, not (isCoercionTy ty1) && not (isCoercionTy ty2) ] , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]
...@@ -1459,7 +1461,7 @@ canEqTyVar ev eq_rel swapped tv1 co1 ps_ty1 xi2 ps_xi2 ...@@ -1459,7 +1461,7 @@ canEqTyVar ev eq_rel swapped tv1 co1 ps_ty1 xi2 ps_xi2
-- unswapped: tm :: (lhs :: k1) ~ (rhs :: k2) -- unswapped: tm :: (lhs :: k1) ~ (rhs :: k2)
-- swapped : tm :: (rhs :: k2) ~ (lhs :: k1) -- swapped : tm :: (rhs :: k2) ~ (lhs :: k1)
= do { kind_ev_id <- newBoundEvVarId kind_pty = do { kind_ev_id <- newBoundEvVarId kind_pty
(EvCoercion $ (evCoercion $
if isSwapped swapped if isSwapped swapped
then mkTcSymCo $ mkTcKindCo $ mkTcCoVarCo evar then mkTcSymCo $ mkTcKindCo $ mkTcCoVarCo evar
else mkTcKindCo $ mkTcCoVarCo evar) else mkTcKindCo $ mkTcCoVarCo evar)
...@@ -1476,10 +1478,10 @@ canEqTyVar ev eq_rel swapped tv1 co1 ps_ty1 xi2 ps_xi2 ...@@ -1476,10 +1478,10 @@ canEqTyVar ev eq_rel swapped tv1 co1 ps_ty1 xi2 ps_xi2
; type_ev <- newGivenEvVar loc $ ; type_ev <- newGivenEvVar loc $
if isSwapped swapped if isSwapped swapped
then ( mkTcEqPredLikeEv ev rhs' lhs then ( mkTcEqPredLikeEv ev rhs' lhs
, EvCoercion $ , evCoercion $
mkTcCoherenceLeftCo (mkTcCoVarCo evar) homo_co ) mkTcCoherenceLeftCo (mkTcCoVarCo evar) homo_co )
else ( mkTcEqPredLikeEv ev lhs rhs' else ( mkTcEqPredLikeEv ev lhs rhs'
, EvCoercion $ , evCoercion $
mkTcCoherenceRightCo (mkTcCoVarCo evar) homo_co ) mkTcCoherenceRightCo (mkTcCoVarCo evar) homo_co )
-- unswapped: type_ev :: (lhs :: k1) ~ ((rhs |> sym kind_ev_id) :: k1) -- unswapped: type_ev :: (lhs :: k1) ~ ((rhs |> sym kind_ev_id) :: k1)
-- swapped : type_ev :: ((rhs |> sym kind_ev_id) :: k1) ~ (lhs :: k1) -- swapped : type_ev :: ((rhs |> sym kind_ev_id) :: k1) ~ (lhs :: k1)
...@@ -1589,7 +1591,7 @@ canEqReflexive :: CtEvidence -- ty ~ ty ...@@ -1589,7 +1591,7 @@ canEqReflexive :: CtEvidence -- ty ~ ty
-> TcType -- ty -> TcType -- ty
-> TcS (StopOrContinue Ct) -- always Stop -> TcS (StopOrContinue Ct) -- always Stop
canEqReflexive ev eq_rel ty canEqReflexive ev eq_rel ty
= do { setEvBindIfWanted ev (EvCoercion $ = do { setEvBindIfWanted ev (evCoercion $
mkTcReflCo (eqRelRole eq_rel) ty) mkTcReflCo (eqRelRole eq_rel) ty)
; stopWith ev "Solved by reflexivity" } ; stopWith ev "Solved by reflexivity" }
...@@ -1843,7 +1845,7 @@ rewriteEvidence old_ev@(CtDerived {}) new_pred _co ...@@ -1843,7 +1845,7 @@ rewriteEvidence old_ev@(CtDerived {}) new_pred _co
-- rewriteEvidence to put the isTcReflCo test first! -- rewriteEvidence to put the isTcReflCo test first!
-- Why? Because for *Derived* constraints, c, the coercion, which -- Why? Because for *Derived* constraints, c, the coercion, which
-- was produced by flattening, may contain suspended calls to -- was produced by flattening, may contain suspended calls to
-- (ctEvTerm c), which fails for Derived constraints. -- (ctEvExpr c), which fails for Derived constraints.
-- (Getting this wrong caused Trac #7384.) -- (Getting this wrong caused Trac #7384.)
continueWith (old_ev { ctev_pred = new_pred }) continueWith (old_ev { ctev_pred = new_pred })
...@@ -1856,7 +1858,7 @@ rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred c ...@@ -1856,7 +1858,7 @@ rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred c
; continueWith new_ev } ; continueWith new_ev }
where where
-- mkEvCast optimises ReflCo -- mkEvCast optimises ReflCo
new_tm = mkEvCast (EvId old_evar) (tcDowngradeRole Representational new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational
(ctEvRole ev) (ctEvRole ev)
(mkTcSymCo co)) (mkTcSymCo co))
...@@ -1865,8 +1867,8 @@ rewriteEvidence ev@(CtWanted { ctev_dest = dest ...@@ -1865,8 +1867,8 @@ rewriteEvidence ev@(CtWanted { ctev_dest = dest
= do { mb_new_ev <- newWanted loc new_pred = do { mb_new_ev <- newWanted loc new_pred
; MASSERT( tcCoercionRole co == ctEvRole ev ) ; MASSERT( tcCoercionRole co == ctEvRole ev )
; setWantedEvTerm dest ; setWantedEvTerm dest
(mkEvCast (getEvTerm mb_new_ev) (EvExpr $ mkEvCast (getEvExpr mb_new_ev)
(tcDowngradeRole Representational (ctEvRole ev) co)) (tcDowngradeRole Representational (ctEvRole ev) co))
; case mb_new_ev of ; case mb_new_ev of
Fresh new_ev -> continueWith new_ev Fresh new_ev -> continueWith new_ev
Cached _ -> stopWith ev "Cached wanted" } Cached _ -> stopWith ev "Cached wanted" }
...@@ -1905,7 +1907,7 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co ...@@ -1905,7 +1907,7 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
= continueWith (old_ev { ctev_pred = new_pred }) = continueWith (old_ev { ctev_pred = new_pred })
| CtGiven { ctev_evar = old_evar } <- old_ev | CtGiven { ctev_evar = old_evar } <- old_ev
= do { let new_tm = EvCoercion (lhs_co = do { let new_tm = evCoercion (lhs_co
`mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar) `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)
`mkTcTransCo` mkTcSymCo rhs_co) `mkTcTransCo` mkTcSymCo rhs_co)
; new_ev <- newGivenEvVar loc' (new_pred, new_tm) ; new_ev <- newGivenEvVar loc' (new_pred, new_tm)
......
...@@ -31,6 +31,7 @@ import TyCon ...@@ -31,6 +31,7 @@ import TyCon
import Class import Class
import DataCon import DataCon
import TcEvidence import TcEvidence
import TcEvTerm
import HsExpr ( UnboundVar(..) ) import HsExpr ( UnboundVar(..) )
import HsBinds ( PatSynBind(..) ) import HsBinds ( PatSynBind(..) )
import Name import Name
...@@ -806,16 +807,16 @@ addDeferredBinding ctxt err ct ...@@ -806,16 +807,16 @@ addDeferredBinding ctxt err ct
; let err_msg = pprLocErrMsg err ; let err_msg = pprLocErrMsg err
err_fs = mkFastString $ showSDoc dflags $ err_fs = mkFastString $ showSDoc dflags $
err_msg $$ text "(deferred type error)" err_msg $$ text "(deferred type error)"
err_tm = EvDelayedError pred err_fs err_tm = evDelayedError pred err_fs
ev_binds_var = cec_binds ctxt ev_binds_var = cec_binds ctxt
; case dest of ; case dest of
EvVarDest evar EvVarDest evar
-> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm -> addTcEvBind ev_binds_var $ mkWantedEvBind evar (EvExpr err_tm)
HoleDest hole HoleDest hole
-> do { -- See Note [Deferred errors for coercion holes] -> do { -- See Note [Deferred errors for coercion holes]
let co_var = coHoleCoVar hole let co_var = coHoleCoVar hole
; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var (EvExpr err_tm)
; fillCoercionHole hole (mkTcCoVarCo co_var) }} ; fillCoercionHole hole (mkTcCoVarCo co_var) }}
| otherwise -- Do not set any evidence for Given/Derived | otherwise -- Do not set any evidence for Given/Derived
......
-- (those who have too heavy dependencies for TcEvidence)
module TcEvTerm
( evDelayedError, evCallStack )
where
import GhcPrelude
import FastString
import Type
import CoreSyn
import MkCore
import Literal ( Literal(..) )
import TcEvidence
import HscTypes
import DynFlags
import Name
import Module
import CoreUtils
import PrelNames
import SrcLoc
-- Used with Opt_DeferTypeErrors
-- See Note [Deferring coercion errors to runtime]
-- in TcSimplify
evDelayedError :: Type -> FastString -> EvExpr
evDelayedError ty msg
= Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
-- Dictionary for CallStack implicit parameters
evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
EvCallStack -> m EvExpr
-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
evCallStack cs = do
df <- getDynFlags
m <- getModule
srcLocDataCon <- lookupDataCon srcLocDataConName
let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>
sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
, mkStringExprFS (moduleNameFS $ moduleName m)
, mkStringExprFS (srcSpanFile l)
, return $ mkIntExprInt df (srcSpanStartLine l)
, return $ mkIntExprInt df (srcSpanStartCol l)
, return $ mkIntExprInt df (srcSpanEndLine l)
, return $ mkIntExprInt df (srcSpanEndCol l)
]
emptyCS <- Var <$> lookupId emptyCallStackName
pushCSVar <- lookupId pushCallStackName
let pushCS name loc rest =
mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
let mkPush name loc tm = do
nameExpr <- mkStringExprFS name
locExpr <- mkSrcLoc loc
-- at this point tm :: IP sym CallStack
-- but we need the actual CallStack to pass to pushCS,
-- so we use unwrapIP to strip the dictionary wrapper
-- See Note [Overview of implicit CallStacks]
let ip_co = unwrapIP (exprType tm)
return (pushCS nameExpr locExpr (Cast tm ip_co))
case cs of
EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
EvCsEmpty -> return emptyCS
...@@ -17,8 +17,13 @@ module TcEvidence ( ...@@ -17,8 +17,13 @@ module TcEvidence (
isEmptyEvBindMap, isEmptyEvBindMap,
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
sccEvBinds, evBindVar, sccEvBinds, evBindVar,
EvTerm(..), mkEvCast, evVarsOfTerm, mkEvScSelectors,
EvLit(..), evTermCoercion, -- EvTerm (already a CoreExpr)
EvTerm(..), EvExpr,
evId, evCoercion, evCast, evDFunApp, evSelector,
mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable,
evTermCoercion,
EvCallStack(..), EvCallStack(..),
EvTypeable(..), EvTypeable(..),
...@@ -57,12 +62,16 @@ import VarSet ...@@ -57,12 +62,16 @@ import VarSet
import Name import Name
import Pair import Pair
import CoreSyn
import Class ( classSCSelId )
import Id ( isEvVar )
import CoreFVs ( exprSomeFreeVars )
import Util import Util
import Bag import Bag
import Digraph import Digraph
import qualified Data.Data as Data import qualified Data.Data as Data
import Outputable import Outputable
import FastString
import SrcLoc import SrcLoc
import Data.IORef( IORef ) import Data.IORef( IORef )
import UniqSet import UniqSet
...@@ -306,11 +315,11 @@ mkWpCastN co ...@@ -306,11 +315,11 @@ mkWpCastN co
mkWpTyApps :: [Type] -> HsWrapper mkWpTyApps :: [Type] -> HsWrapper
mkWpTyApps tys = mk_co_app_fn WpTyApp tys mkWpTyApps tys = mk_co_app_fn WpTyApp tys
mkWpEvApps :: [EvTerm] -> HsWrapper mkWpEvApps :: [EvExpr] -> HsWrapper
mkWpEvApps args = mk_co_app_fn WpEvApp args mkWpEvApps args = mk_co_app_fn WpEvApp (map EvExpr args)
mkWpEvVarApps :: [EvVar] -> HsWrapper mkWpEvVarApps :: [EvVar] -> HsWrapper
mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map EvId vs) mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs)
mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams :: [TyVar] -> HsWrapper
mkWpTyLams ids = mk_co_lam_fn WpTyLam ids mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
...@@ -465,43 +474,54 @@ evBindVar = eb_lhs ...@@ -465,43 +474,54 @@ evBindVar = eb_lhs
mkWantedEvBind :: EvVar -> EvTerm -> EvBind mkWantedEvBind :: EvVar -> EvTerm -> EvBind
mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm }
-- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm
mkGivenEvBind :: EvVar -> EvExpr -> EvBind
mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = EvExpr tm }
mkGivenEvBind :: EvVar -> EvTerm -> EvBind
mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm }
-- An EvTerm is, conceptually, a CoreExpr that implements the constraint.
-- Unfortunately, we cannot just do
-- type EvTerm = CoreExpr
-- Because of staging problems issues around EvTypeable
data EvTerm data EvTerm
= EvId EvId -- Any sort of evidence Id, including coercions = EvExpr EvExpr
| EvTypeable Type EvTypeable -- Dictionary for (Typeable ty)
| EvCoercion TcCoercion -- coercion bindings deriving Data.Data
-- See Note [Coercion evidence terms]
| EvCast EvTerm TcCoercionR -- d |> co
| EvDFunApp DFunId -- Dictionary instance application type EvExpr = CoreExpr
[Type] [EvTerm]
| EvDelayedError Type FastString -- Used with Opt_DeferTypeErrors -- An EvTerm is (usually) constructed by any of the constructors here
-- See Note [Deferring coercion errors to runtime] -- and those more complicates ones who were moved to module TcEvTerm
-- in TcSimplify
| EvSuperClass EvTerm Int -- n'th superclass. Used for both equalities and -- | Any sort of evidence Id, including coercions
-- dictionaries, even though the former have no