diff options
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 64 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.hs | 26 | ||||
| -rw-r--r-- | compiler/typecheck/Inst.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcBinds.hs | 7 | ||||
| -rw-r--r-- | compiler/typecheck/TcEvidence.hs | 174 | ||||
| -rw-r--r-- | compiler/typecheck/TcExpr.hs | 6 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsSyn.hs | 7 | ||||
| -rw-r--r-- | compiler/typecheck/TcInteract.hs | 46 | ||||
| -rw-r--r-- | docs/users_guide/7.12.1-notes.xml | 43 | ||||
| -rw-r--r-- | docs/users_guide/glasgow_exts.xml | 50 | ||||
| -rw-r--r-- | libraries/base/GHC/SrcLoc.hs | 33 | ||||
| -rw-r--r-- | libraries/base/GHC/Stack.hsc | 57 | ||||
| -rw-r--r-- | libraries/base/base.cabal | 1 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_run/IPLocation.hs | 44 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_run/IPLocation.stdout | 28 | ||||
| -rwxr-xr-x | testsuite/tests/typecheck/should_run/all.T | 1 |
16 files changed, 568 insertions, 21 deletions
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 850760b062..6e9fcdf05a 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -36,19 +36,19 @@ import CoreArity ( etaExpand ) import CoreUnfold import CoreFVs import UniqSupply -import Unique( Unique ) import Digraph - +import PrelNames import TyCon ( isTupleTyCon, tyConDataCons_maybe ) import TcEvidence import TcType import Type import Coercion hiding (substCo) -import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon ) +import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon, mkListTy + , mkBoxedTupleTy, stringTy ) import Id import Class -import DataCon ( dataConWorkId ) +import DataCon ( dataConTyCon, dataConWorkId ) import Name import MkId ( seqId ) import IdInfo ( IdDetails(..) ) @@ -57,6 +57,7 @@ import VarSet import Rules import VarEnv import Outputable +import Module import SrcLoc import Maybes import OrdList @@ -876,6 +877,61 @@ dsEvTerm (EvLit l) = EvNum n -> mkIntegerExpr n EvStr s -> mkStringExprFS s +dsEvTerm (EvCallStack cs) = dsEvCallStack cs + +dsEvCallStack :: EvCallStack -> DsM CoreExpr +-- See Note [Overview of implicit CallStacks] in TcEvidence.hs +dsEvCallStack cs = do + df <- getDynFlags + m <- getModule + srcLocDataCon <- dsLookupDataCon srcLocDataConName + let srcLocTyCon = dataConTyCon srcLocDataCon + let srcLocTy = mkTyConTy srcLocTyCon + let mkSrcLoc l = + liftM (mkCoreConApps srcLocDataCon) + (sequence [ mkStringExprFS (packageKeyFS $ modulePackageKey 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) + ]) + + let callSiteTy = mkBoxedTupleTy [stringTy, srcLocTy] + + matchId <- newSysLocalDs $ mkListTy callSiteTy + + callStackDataCon <- dsLookupDataCon callStackDataConName + let callStackTyCon = dataConTyCon callStackDataCon + let callStackTy = mkTyConTy callStackTyCon + let emptyCS = mkCoreConApps callStackDataCon [mkNilExpr callSiteTy] + let pushCS name loc rest = + mkWildCase rest callStackTy callStackTy + [( DataAlt callStackDataCon + , [matchId] + , mkCoreConApps callStackDataCon + [mkConsExpr callSiteTy + (mkCoreTup [name, loc]) + (Var matchId)] + )] + 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 (mkCast tmExpr ip_co)) + case cs of + EvCsTop name loc tm -> mkPush name loc tm + EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm + EvCsEmpty -> panic "Cannot have an empty CallStack" + --------------------------------------- dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr -- This is the crucial function that moves diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 0964dd42e5..3b40385c22 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -323,6 +323,10 @@ basicKnownKeyNames -- Implicit parameters ipClassName, + -- Source locations + callStackDataConName, callStackTyConName, + srcLocDataConName, + -- Annotation type checking toAnnotationWrapperName @@ -455,6 +459,12 @@ gHC_IP = mkBaseModule (fsLit "GHC.IP") gHC_PARR' :: Module gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") +gHC_SRCLOC :: Module +gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") + +gHC_STACK :: Module +gHC_STACK = mkBaseModule (fsLit "GHC.Stack") + gHC_STATICPTR :: Module gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr") @@ -1167,6 +1177,15 @@ knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolCl ipClassName :: Name ipClassName = clsQual gHC_IP (fsLit "IP") ipClassNameKey +-- Source Locations +callStackDataConName, callStackTyConName, srcLocDataConName :: Name +callStackDataConName + = conName gHC_STACK (fsLit "CallStack") callStackDataConKey +callStackTyConName + = tcQual gHC_STACK (fsLit "CallStack") callStackTyConKey +srcLocDataConName + = conName gHC_SRCLOC (fsLit "SrcLoc") srcLocDataConKey + -- plugins pLUGINS :: Module pLUGINS = mkThisGhcModule (fsLit "Plugins") @@ -1517,6 +1536,9 @@ staticPtrTyConKey = mkPreludeTyConUnique 180 staticPtrInfoTyConKey :: Unique staticPtrInfoTyConKey = mkPreludeTyConUnique 181 +callStackTyConKey :: Unique +callStackTyConKey = mkPreludeTyConUnique 182 + ---------------- Template Haskell ------------------- -- USES TyConUniques 200-299 ----------------------------------------------------- @@ -1589,6 +1611,10 @@ staticPtrInfoDataConKey = mkPreludeDataConUnique 34 fingerprintDataConKey :: Unique fingerprintDataConKey = mkPreludeDataConUnique 35 +callStackDataConKey, srcLocDataConKey :: Unique +callStackDataConKey = mkPreludeDataConUnique 36 +srcLocDataConKey = mkPreludeDataConUnique 37 + {- ************************************************************************ * * diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 524c80635d..b82a70c642 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -646,5 +646,3 @@ tyVarsOfImplic (Implic { ic_skols = skols tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet - - diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index c0011b9a00..f421c74f54 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -56,7 +56,6 @@ import BasicTypes import Outputable import FastString import Type(mkStrLitTy) -import Class(classTyCon) import PrelNames(ipClassName) import TcValidity (checkValidType) @@ -253,10 +252,8 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside -- Coerces a `t` into a dictionry for `IP "x" t`. -- co : t -> IP "x" t - toDict ipClass x ty = - case unwrapNewTyCon_maybe (classTyCon ipClass) of - Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcSymCo $ mkTcUnbranchedAxInstCo Representational ax [x,ty] - Nothing -> panic "The dictionary for `IP` is not a newtype?" + toDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $ + wrapIP $ mkClassPred ipClass [x,ty] {- Note [Implicit parameter untouchables] diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index ca819c3e8a..b6d5d6f5d2 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -16,6 +16,7 @@ module TcEvidence ( EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, EvTerm(..), mkEvCast, evVarsOfTerm, EvLit(..), evTermCoercion, + EvCallStack(..), -- TcCoercion TcCoercion(..), LeftOrRight(..), pickLR, @@ -27,7 +28,8 @@ module TcEvidence ( mkTcAxiomRuleCo, mkTcPhantomCo, tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo, isTcReflCo, getTcCoVar_maybe, - tcCoercionRole, eqVarRole + tcCoercionRole, eqVarRole, + unwrapIP, wrapIP ) where #include "HsVersions.h" @@ -54,6 +56,7 @@ import Data.Traversable (traverse, sequenceA) import qualified Data.Data as Data import Outputable import FastString +import SrcLoc import Data.IORef( IORef ) {- @@ -722,13 +725,27 @@ data EvTerm | EvLit EvLit -- Dictionary for KnownNat and KnownSymbol classes. -- Note [KnownNat & KnownSymbol and EvLit] - deriving( Data.Data, Data.Typeable) + | EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters + + deriving( Data.Data, Data.Typeable ) data EvLit = EvNum Integer | EvStr FastString - deriving( Data.Data, Data.Typeable) + deriving( Data.Data, Data.Typeable ) + +-- | Evidence for @CallStack@ implicit parameters. +data EvCallStack + -- See Note [Overview of implicit CallStacks] + = EvCsEmpty + | EvCsPushCall Name RealSrcSpan EvTerm + -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at + -- @loc@, in a calling context @stk@. + | EvCsTop FastString RealSrcSpan EvTerm + -- ^ @EvCsTop name loc stk@ represents a use of an implicit parameter + -- @?name@, occurring at @loc@, in a calling context @stk@. + deriving( Data.Data, Data.Typeable ) {- Note [Coercion evidence terms] @@ -819,6 +836,119 @@ The story for kind `Symbol` is analogous: * class KnownSymbol * newtype SSymbol * Evidence: EvLit (EvStr n) + + +Note [Overview of implicit CallStacks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(See https://ghc.haskell.org/trac/ghc/wiki/ExplicitCallStack/ImplicitLocations) + +The goal of CallStack evidence terms is to reify locations +in the program source as runtime values, without any support +from the RTS. We accomplish this by assigning a special meaning +to implicit parameters of type GHC.Stack.CallStack. A use of +a CallStack IP, e.g. + + head [] = error (show (?loc :: CallStack)) + head (x:_) = x + +will be solved with the source location that gave rise to the IP +constraint (here, the use of ?loc). If there is already +a CallStack IP in scope, e.g. passed-in as an argument + + head :: (?loc :: CallStack) => [a] -> a + head [] = error (show (?loc :: CallStack)) + head (x:_) = x + +we will push the new location onto the CallStack that was passed +in. These two cases are reflected by the EvCallStack evidence +type. In the first case, we will create an evidence term + + EvCsTop "?loc" <?loc's location> EvCsEmpty + +and in the second we'll have a given constraint + + [G] d :: IP "loc" CallStack + +in scope, and will create an evidence term + + EvCsTop "?loc" <?loc's location> d + +When we call a function that uses a CallStack IP, e.g. + + f = head xs + +we create an evidence term + + EvCsPushCall "head" <head's location> EvCsEmpty + +again pushing onto a given evidence term if one exists. + +This provides a lightweight mechanism for building up call-stacks +explicitly, but is notably limited by the fact that the stack will +stop at the first function whose type does not include a CallStack IP. +For example, using the above definition of head: + + f :: [a] -> a + f = head + + g = f [] + +the resulting CallStack will include use of ?loc inside head and +the call to head inside f, but NOT the call to f inside g, because f +did not explicitly request a CallStack. + +Important Details: +- GHC should NEVER report an insoluble CallStack constraint. + +- A CallStack (defined in GHC.Stack) is a [(String, SrcLoc)], where the String + is the name of the binder that is used at the SrcLoc. SrcLoc is defined in + GHC.SrcLoc and contains the package/module/file name, as well as the full + source-span. Both CallStack and SrcLoc are kept abstract so only GHC can + construct new values. + +- Consider the use of ?stk in: + + head :: (?stk :: CallStack) => [a] -> a + head [] = error (show ?stk) + + When solving the use of ?stk we'll have a given + + [G] d :: IP "stk" CallStack + + in scope. In the interaction phase, GHC would normally solve the use of ?stk + directly from the given, i.e. re-using the dicionary. But this is NOT what we + want! We want to generate a *new* CallStack with ?loc's SrcLoc pushed onto + the given CallStack. So we must take care in TcInteract.interactDict to + prioritize solving wanted CallStacks. + +- We will automatically solve any wanted CallStack regardless of the name of the + IP, i.e. + + f = show (?stk :: CallStack) + g = show (?loc :: CallStack) + + are both valid. However, we will only push new SrcLocs onto existing + CallStacks when the IP names match, e.g. in + + head :: (?loc :: CallStack) => [a] -> a + head [] = error (show (?stk :: CallStack)) + + the printed CallStack will NOT include head's call-site. This reflects the + standard scoping rules of implicit-parameters. (See TcInteract.interactDict) + +- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. + The desugarer will need to unwrap the IP newtype before pushing a new + call-site onto a given stack (See DsBinds.dsEvCallStack) + +- We only want to intercept constraints that arose due to the use of an IP or a + function call. In particular, we do NOT want to intercept the + + (?stk :: CallStack) => [a] -> a + ~ + (?stk :: CallStack) => [a] -> a + + constraint that arises from the ambiguity check on `head`s type signature. + (See TcEvidence.isCallStackIP) -} mkEvCast :: EvTerm -> TcCoercion -> EvTerm @@ -853,10 +983,17 @@ evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo c evVarsOfTerm (EvTupleMk evs) = evVarsOfTerms evs evVarsOfTerm (EvDelayedError _ _) = emptyVarSet evVarsOfTerm (EvLit _) = emptyVarSet +evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs evVarsOfTerms :: [EvTerm] -> VarSet evVarsOfTerms = mapUnionVarSet evVarsOfTerm +evVarsOfCallStack :: EvCallStack -> VarSet +evVarsOfCallStack cs = case cs of + EvCsEmpty -> emptyVarSet + EvCsTop _ _ tm -> evVarsOfTerm tm + EvCsPushCall _ _ tm -> evVarsOfTerm tm + {- ************************************************************************ * * @@ -920,9 +1057,40 @@ instance Outputable EvTerm where ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] ppr (EvLit l) = ppr l + ppr (EvCallStack cs) = ppr cs ppr (EvDelayedError ty msg) = ptext (sLit "error") <+> sep [ char '@' <> ppr ty, ppr msg ] instance Outputable EvLit where ppr (EvNum n) = integer n ppr (EvStr s) = text (show s) + +instance Outputable EvCallStack where + ppr EvCsEmpty + = ptext (sLit "[]") + ppr (EvCsTop name loc tm) + = angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm + ppr (EvCsPushCall name loc tm) + = angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm + +---------------------------------------------------------------------- +-- Helper functions for dealing with IP newtype-dictionaries +---------------------------------------------------------------------- + +-- | Create a 'Coercion' that unwraps an implicit-parameter dictionary +-- to expose the underlying value. We expect the 'Type' to have the form +-- `IP sym ty`, return a 'Coercion' `co :: IP sym ty ~ ty`. +unwrapIP :: Type -> Coercion +unwrapIP ty = + case unwrapNewTyCon_maybe tc of + Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys + Nothing -> pprPanic "unwrapIP" $ + text "The dictionary for" <+> quotes (ppr tc) + <+> text "is not a newtype!" + where + (tc, tys) = splitTyConApp ty + +-- | Create a 'Coercion' that wraps a value in an implicit-parameter +-- dictionary. See 'unwrapIP'. +wrapIP :: Type -> Coercion +wrapIP ty = mkSymCo (unwrapIP ty) diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 360cd085d4..9a4607b123 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -196,10 +196,8 @@ tcExpr (HsIPVar x) res_ty ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. - fromDict ipClass x ty = - case unwrapNewTyCon_maybe (classTyCon ipClass) of - Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcUnbranchedAxInstCo Representational ax [x,ty] - Nothing -> panic "The dictionary for `IP` is not a newtype?" + fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $ + unwrapIP $ mkClassPred ipClass [x,ty] tcExpr (HsLam match) res_ty = do { (co_fn, match') <- tcMatchLambda match res_ty diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 3fa890112d..1f6974c38e 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -1246,6 +1246,13 @@ zonkEvTerm env (EvTupleSel tm n) = do { tm' <- zonkEvTerm env tm zonkEvTerm env (EvTupleMk tms) = do { tms' <- mapM (zonkEvTerm env) tms ; return (EvTupleMk tms') } zonkEvTerm _ (EvLit l) = return (EvLit l) +zonkEvTerm env (EvCallStack cs) + = case cs of + EvCsEmpty -> return (EvCallStack cs) + EvCsTop n l tm -> do { tm' <- zonkEvTerm env tm + ; return (EvCallStack (EvCsTop n l tm')) } + EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm + ; return (EvCallStack (EvCsPushCall n l tm')) } zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d ; return (EvSuperClass d' n) } zonkEvTerm env (EvDFunApp df tys tms) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index c401aca6f2..3212710e77 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -8,6 +8,8 @@ module TcInteract ( #include "HsVersions.h" import BasicTypes () +import HsTypes ( hsIPNameFS ) +import FastString import TcCanonical import TcFlatten import VarSet @@ -18,7 +20,8 @@ import CoAxiom(sfInteractTop, sfInteractInert) import Var import TcType -import PrelNames (knownNatClassName, knownSymbolClassName, ipClassNameKey ) +import PrelNames ( knownNatClassName, knownSymbolClassName, ipClassNameKey, + callStackTyConKey ) import Id( idType ) import Class import TyCon @@ -42,7 +45,6 @@ import Control.Monad import Maybes( isJust ) import Pair (Pair(..)) import Unique( hasKey ) -import FastString ( sLit ) import DynFlags import Util @@ -606,6 +608,26 @@ interactIrred _ wi = pprPanic "interactIrred" (ppr wi) interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) + -- don't ever try to solve CallStack IPs directly from other dicts, + -- we always build new dicts instead. + -- See Note [Overview of implicit CallStacks] + | [_ip, ty] <- tys + , isWanted ev_w + , Just mkEvCs <- isCallStackIP (ctEvLoc ev_w) cls ty + = do let ev_cs = + case lookupInertDict inerts (ctEvLoc ev_w) cls tys of + Just ev | isGiven ev -> mkEvCs (ctEvTerm ev) + _ -> mkEvCs (EvCallStack EvCsEmpty) + + -- now we have 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` + let ip_ty = mkClassPred cls tys + let ev_tm = mkEvCast (EvCallStack ev_cs) (TcCoercion $ wrapIP ip_ty) + addSolvedDict ev_w cls tys + setWantedEvBind (ctEvId ev_w) ev_tm + stopWith ev_w "Wanted CallStack IP" + | Just ctev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys = do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w ; case inert_effect of @@ -1732,3 +1754,23 @@ overlapping checks. There we are interested in validating the following principl But for the Given Overlap check our goal is just related to completeness of constraint solving. -} + +-- | Is the constraint for an implicit CallStack parameter? +isCallStackIP :: CtLoc -> Class -> Type -> Maybe (EvTerm -> EvCallStack) +isCallStackIP loc cls ty + | Just (tc, []) <- splitTyConApp_maybe ty + , cls `hasKey` ipClassNameKey && tc `hasKey` callStackTyConKey + = occOrigin (ctLocOrigin loc) + where + -- We only want to grab constraints that arose due to the use of an IP or a + -- function call. See Note [Overview of implicit CallStacks] + occOrigin (OccurrenceOf n) + = Just (EvCsPushCall n locSpan) + occOrigin (IPOccOrigin n) + = Just (EvCsTop ('?' `consFS` hsIPNameFS n) locSpan) + occOrigin _ + = Nothing + locSpan + = ctLocSpan loc +isCallStackIP _ _ _ + = Nothing diff --git a/docs/users_guide/7.12.1-notes.xml b/docs/users_guide/7.12.1-notes.xml index 0196884591..7f9346edf2 100644 --- a/docs/users_guide/7.12.1-notes.xml +++ b/docs/users_guide/7.12.1-notes.xml @@ -34,6 +34,32 @@ TODO FIXME. </para> </listitem> + <listitem> + <para> + Implicit parameters of the new base type + <literal>GHC.Stack.CallStack</literal> are treated + specially, and automatically solved for the current source + location. For example + <programlisting> + f = print (?stk :: CallStack) + </programlisting> + will print the singleton stack containing the occurrence of + <literal>?stk</literal>. If there is another + <literal>CallStack</literal> implicit in-scope, the new location + will be appended to the existing stack, e.g. + <programlisting> + f :: (?stk :: CallStack) => IO () + f = print (?stk :: CallStack) + </programlisting> + will print the occurrence of <literal>?stk</literal> and the + call-site of <literal>f</literal>. The name of the implicit + parameter does not matter. + </para> + <para> + See the release notes for base for a description of the + <literal>CallStack</literal> type. + </para> + </listitem> </itemizedlist> </sect3> @@ -129,6 +155,23 @@ Version number XXXXX (was 4.7.0.0) </para> </listitem> + <listitem> + <para> + A new module <literal>GHC.SrcLoc</literal> was added, + exporting a new type <literal>SrcLoc</literal>. A + <literal>SrcLoc</literal> contains package, module, + and file names, as well as start and end positions. + </para> + </listitem> + <listitem> + <para> + A new type <literal>CallStack</literal> was added for use + with the new implicit callstack parameters. A + <literal>CallStack</literal> is a + <literal>[(String, SrcLoc)]</literal>, sorted by most-recent + call. + </para> + </listitem> </itemizedlist> </sect3> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 684f8f0263..190af38d67 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -7701,6 +7701,56 @@ inner binding of <literal>?x</literal>, so <literal>(f 9)</literal> will return <literal>14</literal>. </para> </sect3> + +<sect3><title>Special implicit parameters</title> +<para> +GHC treats implicit parameters of type <literal>GHC.Stack.CallStack</literal> +specially, by resolving them to the current location in the program. Consider: +<programlisting> + f :: String + f = show (?loc :: CallStack) +</programlisting> +GHC will automatically resolve <literal>?loc</literal> to its source +location. If another implicit parameter with type <literal>CallStack</literal> is +in scope, GHC will append the two locations, creating an explicit call-stack. For example: +<programlisting> + f :: (?stk :: CallStack) => String + f = show (?stk :: CallStack) +</programlisting> +will produce the location of <literal>?stk</literal>, followed by +<literal>f</literal>'s call-site. Note that the name of the implicit parameter does not +matter (we used <literal>?loc</literal> above), GHC will solve any implicit parameter +with the right type. The name does, however, matter when pushing new locations onto +existing stacks. Consider: +<programlisting> + f :: (?stk :: CallStack) => String + f = show (?loc :: CallStack) +</programlisting> +When we call <literal>f</literal>, the stack will include the use of <literal>?loc</literal>, +but not the call to <literal>f</literal>; in this case the names must match. +</para> +<para> +<literal>CallStack</literal> is kept abstract, but +GHC provides a function +<programlisting> + getCallStack :: CallStack -> [(String, SrcLoc)] +</programlisting> +to access the individual call-sites in the stack. The <literal>String</literal> +is the name of the function that was called, and the <literal>SrcLoc</literal> +provides the package, module, and file name, as well as the line and column +numbers. The stack will never be empty, as the first call-site +will be the location at which the implicit parameter was used. GHC will also +never infer <literal>?loc :: CallStack</literal> as a type constraint, which +means that functions must explicitly ask to be told about their call-sites. +</para> +<para> +A potential "gotcha" when using implicit <literal>CallStack</literal>s is that +the <literal>:type</literal> command in GHCi will not report the +<literal>?loc :: CallStack</literal> constraint, as the typechecker will +immediately solve it. Use <literal>:info</literal> instead to print the +unsolved type. +</para> +</sect3> </sect2> <sect2 id="kinding"> diff --git a/libraries/base/GHC/SrcLoc.hs b/libraries/base/GHC/SrcLoc.hs new file mode 100644 index 0000000000..16ebbab74c --- /dev/null +++ b/libraries/base/GHC/SrcLoc.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE RecordWildCards #-} +module GHC.SrcLoc + ( SrcLoc + , srcLocPackage + , srcLocModule + , srcLocFile + , srcLocStartLine + , srcLocStartCol + , srcLocEndLine + , srcLocEndCol + + -- * Pretty printing + , showSrcLoc + ) where + +-- | A single location in the source code. +data SrcLoc = SrcLoc + { srcLocPackage :: String + , srcLocModule :: String + , srcLocFile :: String + , srcLocStartLine :: Int + , srcLocStartCol :: Int + , srcLocEndLine :: Int + , srcLocEndCol :: Int + } deriving (Show, Eq) + +showSrcLoc :: SrcLoc -> String +showSrcLoc SrcLoc {..} + = concat [ srcLocFile, ":" + , show srcLocStartLine, ":" + , show srcLocStartCol, " in " + , srcLocPackage, ":", srcLocModule + ] diff --git a/libraries/base/GHC/Stack.hsc b/libraries/base/GHC/Stack.hsc index 0aa4d1768d..8c9f0c1f41 100644 --- a/libraries/base/GHC/Stack.hsc +++ b/libraries/base/GHC/Stack.hsc @@ -17,11 +17,17 @@ {-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-} module GHC.Stack ( - -- * Call stack + -- * Call stacks + -- ** Simulated by the RTS currentCallStack, whoCreated, errorWithStackTrace, + -- ** Explicitly created via implicit-parameters + CallStack, + getCallStack, + showCallStack, + -- * Internals CostCentreStack, CostCentre, @@ -36,6 +42,8 @@ module GHC.Stack ( renderStack ) where +import Data.List ( unlines ) + import Foreign import Foreign.C @@ -46,6 +54,8 @@ import GHC.Foreign as GHC import GHC.IO.Encoding import GHC.Exception import GHC.List ( concatMap, null, reverse ) +import GHC.Show +import GHC.SrcLoc #define PROFILING #include "Rts.h" @@ -128,3 +138,48 @@ errorWithStackTrace x = unsafeDupablePerformIO $ do if null stack then throwIO (ErrorCall x) else throwIO (ErrorCall (x ++ '\n' : renderStack stack)) + + +---------------------------------------------------------------------- +-- Explicit call-stacks built via ImplicitParams +---------------------------------------------------------------------- + +-- | @CallStack@s are an alternate method of obtaining the call stack at a given +-- point in the program. +-- +-- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will +-- solve it with the current location. If another @CallStack@ implicit-parameter +-- is in-scope (e.g. as a function argument), the new location will be appended +-- to the one in-scope, creating an explicit call-stack. For example, +-- +-- @ +-- myerror :: (?loc :: CallStack) => String -> a +-- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc) +-- @ +-- ghci> myerror "die" +-- *** Exception: die +-- ?loc, called at MyError.hs:7:51 in main:MyError +-- myerror, called at <interactive>:2:1 in interactive:Ghci1 +-- +-- @CallStack@s do not interact with the RTS and do not require compilation with +-- @-prof@. On the other hand, as they are built up explicitly using +-- implicit-parameters, they will generally not contain as much information as +-- the simulated call-stacks maintained by the RTS. +-- +-- The @CallStack@ type is abstract, but it can be converted into a +-- @[(String, SrcLoc)]@ via 'getCallStack'. The @String@ is the name of function +-- that was called, the 'SrcLoc' is the call-site. The list is ordered with the +-- most recently called function at the head. +-- +-- @since 4.9.0.0 +data CallStack = CallStack { getCallStack :: [(String, SrcLoc)] } + -- See Note [Overview of implicit CallStacks] + deriving (Show, Eq) + +showCallStack :: CallStack -> String +showCallStack (CallStack (root:rest)) + = unlines (showCallSite root : map (indent . showCallSite) rest) + where + indent l = " " ++ l + showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc +showCallStack _ = error "CallStack cannot be empty!" diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index c5c4a159ae..70d719fda1 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -258,6 +258,7 @@ Library GHC.StaticPtr GHC.STRef GHC.Show + GHC.SrcLoc GHC.Stable GHC.Stack GHC.Stats diff --git a/testsuite/tests/typecheck/should_run/IPLocation.hs b/testsuite/tests/typecheck/should_run/IPLocation.hs new file mode 100644 index 0000000000..ffc377b2c9 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/IPLocation.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ImplicitParams, RankNTypes #-} +{-# OPTIONS_GHC -dcore-lint #-} +module Main where + +import GHC.Stack + +f0 = putStrLn $ showCallStack ?loc + -- should just show the location of ?loc + +f1 :: (?loc :: CallStack) => IO () +f1 = putStrLn $ showCallStack ?loc + -- should show the location of ?loc *and* f1's call-site + +f2 :: (?loc :: CallStack) => IO () +f2 = do putStrLn $ showCallStack ?loc + putStrLn $ showCallStack ?loc + -- each ?loc should refer to a different location, but they should + -- share f2's call-site + +f3 :: ((?loc :: CallStack) => () -> IO ()) -> IO () +f3 x = x () + -- the call-site for the functional argument should be added to the + -- stack.. + +f4 :: (?loc :: CallStack) => ((?loc :: CallStack) => () -> IO ()) -> IO () +f4 x = x () + -- as should the call-site for f4 itself + +f5 :: (?loc1 :: CallStack) => ((?loc2 :: CallStack) => () -> IO ()) -> IO () +f5 x = x () + -- we only push new call-sites onto CallStacks with the name IP name + +f6 :: (?loc :: CallStack) => Int -> IO () +f6 0 = putStrLn $ showCallStack ?loc +f6 n = f6 (n-1) + -- recursive functions add a SrcLoc for each recursive call + +main = do f0 + f1 + f2 + f3 (\ () -> putStrLn $ showCallStack ?loc) + f4 (\ () -> putStrLn $ showCallStack ?loc) + f5 (\ () -> putStrLn $ showCallStack ?loc3) + f6 5 diff --git a/testsuite/tests/typecheck/should_run/IPLocation.stdout b/testsuite/tests/typecheck/should_run/IPLocation.stdout new file mode 100644 index 0000000000..6dca7214d6 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/IPLocation.stdout @@ -0,0 +1,28 @@ +?loc, called at IPLocation.hs:7:31 in main:Main + +?loc, called at IPLocation.hs:11:31 in main:Main + f1, called at IPLocation.hs:39:11 in main:Main + +?loc, called at IPLocation.hs:15:34 in main:Main + f2, called at IPLocation.hs:40:11 in main:Main + +?loc, called at IPLocation.hs:16:34 in main:Main + f2, called at IPLocation.hs:40:11 in main:Main + +?loc, called at IPLocation.hs:41:48 in main:Main + x, called at IPLocation.hs:21:8 in main:Main + +?loc, called at IPLocation.hs:42:48 in main:Main + x, called at IPLocation.hs:26:8 in main:Main + f4, called at IPLocation.hs:42:11 in main:Main + +?loc3, called at IPLocation.hs:43:48 in main:Main + +?loc, called at IPLocation.hs:34:33 in main:Main + f6, called at IPLocation.hs:35:8 in main:Main + f6, called at IPLocation.hs:35:8 in main:Main + f6, called at IPLocation.hs:35:8 in main:Main + f6, called at IPLocation.hs:35:8 in main:Main + f6, called at IPLocation.hs:35:8 in main:Main + f6, called at IPLocation.hs:44:11 in main:Main + diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T index 5b20034101..f0a5eb617c 100755 --- a/testsuite/tests/typecheck/should_run/all.T +++ b/testsuite/tests/typecheck/should_run/all.T @@ -85,6 +85,7 @@ test('church', normal, compile_and_run, ['']) test('testeq2', normal, compile_and_run, ['']) test('T1624', normal, compile_and_run, ['']) test('IPRun', normal, compile_and_run, ['']) +test('IPLocation', normal, compile_and_run, ['']) # Support files for T1735 are in directory T1735_Help/ test('T1735', normal, multimod_compile_and_run, ['T1735','']) |