[commit: ghc] wip/14691: Implement evCallStack (e99186f)
git at git.haskell.org
git at git.haskell.org
Sun Jan 21 14:03:37 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/14691
Link : http://ghc.haskell.org/trac/ghc/changeset/e99186f4d0043254db457a50853acfac824dc11b/ghc
>---------------------------------------------------------------
commit e99186f4d0043254db457a50853acfac824dc11b
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Sun Jan 21 09:03:00 2018 -0500
Implement evCallStack
>---------------------------------------------------------------
e99186f4d0043254db457a50853acfac824dc11b
compiler/deSugar/DsBinds.hs | 47 +------------------------------------
compiler/typecheck/TcCanonical.hs | 3 ++-
compiler/typecheck/TcEvTerm.hs | 49 +++++++++++++++++++++++++++++++++++----
compiler/typecheck/TcSMonad.hs | 4 ++++
4 files changed, 52 insertions(+), 51 deletions(-)
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 55765f3..b87d5ad 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -1307,6 +1307,7 @@ tyConRep tc
; return (Var tc_rep_id) }
| otherwise
= pprPanic "tyConRep" (ppr tc)
+-}
{- Note [Memoising typeOf]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1317,49 +1318,3 @@ 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
--}
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 1a5a4fd..0b85567 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -172,7 +172,8 @@ solveCallStack ev ev_cs = do
-- 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
-- `IP ip CallStack`. See Note [Overview of implicit CallStacks]
- let ev_tm = mkEvCast (evCallStack ev_cs) (wrapIP (ctEvPred ev))
+ cs_tm <- evCallStack ev_cs
+ let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
setWantedEvBind (ctEvEvId ev) ev_tm
canClass :: CtEvidence
diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs
index f79b742..7e148f6 100644
--- a/compiler/typecheck/TcEvTerm.hs
+++ b/compiler/typecheck/TcEvTerm.hs
@@ -1,4 +1,4 @@
--- | Smart constructors for EvTerm
+
-- (those who have too heavy dependencies for TcEvidence)
module TcEvTerm
( evDelayedError, evCallStack, evTypeable)
@@ -10,9 +10,16 @@ import GhcPrelude
import FastString
import Type
import CoreSyn
-import MkCore ( tYPE_ERROR_ID )
+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]
@@ -25,8 +32,42 @@ evDelayedError ty msg
litMsg = Lit (MachStr (fastStringToByteString msg))
-- Dictionary for CallStack implicit parameters
-evCallStack :: EvCallStack -> EvTerm
-evCallStack = undefined
+evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
+ EvCallStack -> m CoreExpr
+-- 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
-- Dictionary for (Typeable ty)
evTypeable :: Type -> EvTypeable -> EvTerm
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 196ee27..14e010d 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -143,6 +143,7 @@ import TyCon
import TcErrors ( solverDepthErrorTcS )
import Name
+import Module ( HasModule, getModule )
import RdrName ( GlobalRdrEnv, GlobalRdrElt )
import qualified RnEnv as TcM
import Var
@@ -2385,6 +2386,9 @@ instance MonadFail.MonadFail TcS where
instance MonadUnique TcS where
getUniqueSupplyM = wrapTcS getUniqueSupplyM
+instance HasModule TcS where
+ getModule = wrapTcS getModule
+
instance MonadThings TcS where
lookupThing n = wrapTcS (lookupThing n)
More information about the ghc-commits
mailing list