Expose source locations via Implicit Parameters of type GHC.Location.Location

Summary:
IPs with this type will always be solved for the current source
location. If another IP of the same type is in scope, the two locations will be
appended, creating a call-stack. The Location type is kept abstract so users
cannot create them, but a Location can be turned into a list of SrcLocs, which
correspond to individual locations in a program. Each SrcLoc contains a
package/module/file name and start/end lines and columns.

The only thing missing from the SrcLoc in my opinion is the name of the
top-level definition it inhabits. I suspect that would also be useful, but it's
not clear to me how to extract the current top-level binder from within the
constraint solver. (Surely I'm just missing something here?)

I made the (perhaps controversial) decision to have GHC completely ignore
the names of Location IPs, meaning that in the following code:

    bar :: (?myloc :: Location) => String
    bar = foo

    foo :: (?loc :: Location) => String
    foo = show ?loc

if I call `bar`, the resulting call-stack will include locations for

1. the use of `?loc` inside `foo`,
2. `foo`s call-site inside `bar`, and
3. `bar`s call-site, wherever that may be.

This makes Location IPs very special indeed, and I'm happy to change it if the
dissonance is too great.

I've also left out any changes to base to make use of Location IPs, since there
were some concerns about a snowball effect. I think it would be reasonable to
mark this as an experimental feature for now (it is!), and defer using it in
base until we have more experience with it. It is, after all, quite easy to
define your own version of `error`, `undefined`, etc. that use Location IPs.

Test Plan: validate, new test-case is testsuite/tests/typecheck/should_run/IPLocation.hs

Reviewers: austin, hvr, simonpj

Reviewed By: simonpj

Subscribers: simonmar, rodlogic, carter, thomie

Differential Revision: https://phabricator.haskell.org/D578

GHC Trac Issues: #9049

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',''])