[Git][ghc/ghc][wip/T23109] Yet more rebase wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Feb 4 22:50:29 UTC 2025
Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC
Commits:
2a5950e8 by Simon Peyton Jones at 2025-02-04T22:49:49+00:00
Yet more rebase wibbles
- - - - -
3 changed files:
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Types/Evidence.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/Default.hs
=====================================
@@ -400,7 +400,7 @@ defaultExceptionContext ct
= do { warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct)
; empty_ec_id <- lookupId emptyExceptionContextName
; let ev = ctEvidence ct
- ev_tm = mkEvCast (Var empty_ec_id) (wrapIP (ctEvPred ev))
+ ev_tm = EvExpr (evWrapIP (ctEvPred ev) (Var empty_ec_id))
; setEvBindIfWanted ev EvCanonical ev_tm
-- EvCanonical: see Note [CallStack and ExecptionContext hack]
-- in GHC.Tc.Solver.Dict
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -2,7 +2,7 @@
-- | Solving Class constraints CDictCan
module GHC.Tc.Solver.Dict (
- solveDict, solveDictNC,
+ solveDict, solveDictNC, solveCallStack,
checkInstanceOK,
matchLocalInst, chooseInstance,
makeSuperClasses, mkStrictSuperClasses,
@@ -41,8 +41,9 @@ import GHC.Types.Var
import GHC.Types.Id( mkTemplateLocals )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
+import GHC.Types.SrcLoc
-import GHC.Builtin.Names( srcLocDataConName, pushCallStackName )
+import GHC.Builtin.Names( srcLocDataConName, pushCallStackName, emptyCallStackName )
import GHC.Utils.Monad ( concatMapM, foldlM )
import GHC.Utils.Outputable
@@ -52,7 +53,6 @@ import GHC.Utils.Misc
import GHC.Unit.Module
import GHC.Data.Bag
-import GHC.Data.FastString( FastString )
import GHC.Driver.DynFlags
@@ -141,16 +141,32 @@ canDictCt ev cls tys
-- doNotExpand: We have already expanded superclasses for /this/ dict
-- so set the fuel to doNotExpand to avoid repeating expansion
- | isWanted ev
+ | CtWanted { ctev_rewriters = rewriters } <- ev
, Just ip_name <- isCallStackPred cls tys
- , isPushCallStackOrigin (ctEvOrigin ev)
+ , isPushCallStackOrigin orig
-- If we're given a CallStack constraint that arose from a function
-- call, we need to push the current call-site onto the stack instead
-- of solving it directly from a given.
-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types
= Stage $
- do { new_ev <- solveCallStack ip_name ev
+ do { -- First we emit a new constraint that will capture the
+ -- given CallStack.
+
+ let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))
+ -- We change the origin to IPOccOrigin so
+ -- this rule does not fire again.
+ -- See Note [Overview of implicit CallStacks]
+ -- in GHC.Tc.Types.Evidence
+
+ ; new_ev <- newWantedEvVarNC new_loc rewriters pred
+
+ -- Then we solve the wanted by pushing the call-site
+ -- onto the newly emitted CallStack
+ ; let ev_cs = EvCsPushCall (callStackOriginFS orig)
+ (ctLocSpan loc) (ctEvExpr new_ev)
+ ; solveCallStack ev ev_cs
+
; continueWith (DictCt { di_ev = new_ev, di_cls = cls
, di_tys = tys, di_pend_sc = doNotExpand }) }
-- doNotExpand: No superclasses for class CallStack
@@ -165,6 +181,10 @@ canDictCt ev cls tys
; continueWith (DictCt { di_ev = ev, di_cls = cls
, di_tys = tys, di_pend_sc = fuel }) }
+ where
+ loc = ctEvLoc ev
+ orig = ctLocOrigin loc
+ pred = ctEvPred ev
{- *********************************************************************
* *
@@ -172,67 +192,49 @@ canDictCt ev cls tys
* *
********************************************************************* -}
-solveCallStack :: FastString -> CtEvidence -> TcS CtEvidence
--- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-solveCallStack ip_name ev@(CtWanted { ctev_rewriters = rewriters })
- -- 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]
- = do { df <- getDynFlags
-
- ; -- First we emit a new constraint that will capture the
- -- given CallStack.
- let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))
- -- We change the origin to IPOccOrigin so
- -- this rule does not fire again.
- -- See Note [Overview of implicit CallStacks]
- -- in GHC.Tc.Types.Evidence
-
- ; outer_ev <- newWantedEvVarNC new_loc rewriters pred
-
- -- Then we solve the wanted by pushing the call-site
- -- onto the newly emitted CallStack
- ; let fs = callStackOriginFS orig
- span = ctLocSpan loc
- platform = targetPlatform df
- ; m <- getModule
- ; srcLocDataCon <- lookupDataCon srcLocDataConName
- ; push_cs_id <- lookupId pushCallStackName
- ; name_expr <- mkStringExprFS fs
- ; loc_expr <- mkCoreConApps srcLocDataCon <$>
- sequence [ mkStringExprFS (unitFS $ moduleUnit m)
- , mkStringExprFS (moduleNameFS $ moduleName m)
- , mkStringExprFS (srcSpanFile span)
- , return $ mkIntExprInt platform (srcSpanStartLine span)
- , return $ mkIntExprInt platform (srcSpanStartCol span)
- , return $ mkIntExprInt platform (srcSpanEndLine span)
- , return $ mkIntExprInt platform (srcSpanEndCol span) ]
-
- -- At this point outer_ev :: IP sym CallStack
- -- but we need the actual CallStack to pass to
- -- pushCallStack :: (String,SrcLoc) -> CallStack -> CallStack
- -- See Note [Overview of implicit CallStacks]
- ; let outer_stk, inner_stk :: EvExpr -- Both of type CallStack
- outer_stk = evUnwrapIP pred (ctEvExpr outer_ev)
- inner_stk = mkCoreApps (Var push_cs_id) [mkCoreTup [name_expr, loc_expr], outer_stk]
-
- ; setEvBindIfWanted ev True (EvExpr (evWrapIP pred inner_stk))
- ; return outer_ev }
- where
- loc = ctEvLoc ev
- orig = ctLocOrigin loc
- pred = ctEvPred ev
-
solveCallStack :: CtEvidence -> EvCallStack -> TcS ()
-- Also called from GHC.Tc.Solver when defaulting call stacks
solveCallStack ev ev_cs
-- 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]
- = do { cs_tm <- evCallStack ev_cs
- ; let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
+ = do { inner_stk <- evCallStack pred ev_cs
+ ; let ev_tm = EvExpr (evWrapIP pred inner_stk)
; setEvBindIfWanted ev EvCanonical ev_tm }
-- EvCanonical: see Note [CallStack and ExecptionContext hack]
+ where
+ pred = ctEvPred ev
+
+-- Dictionary for CallStack implicit parameters
+evCallStack :: TcPredType -> EvCallStack -> TcS EvExpr
+-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
+evCallStack _ EvCsEmpty
+ = Var <$> lookupId emptyCallStackName
+evCallStack pred (EvCsPushCall fs loc tm)
+ = do { df <- getDynFlags
+ ; m <- getModule
+ ; srcLocDataCon <- lookupDataCon srcLocDataConName
+ ; let platform = targetPlatform df
+ mkSrcLoc l = mkCoreConWrapApps srcLocDataCon <$>
+ sequence [ mkStringExprFS (unitFS $ moduleUnit m)
+ , mkStringExprFS (moduleNameFS $ moduleName m)
+ , mkStringExprFS (srcSpanFile l)
+ , return $ mkIntExprInt platform (srcSpanStartLine l)
+ , return $ mkIntExprInt platform (srcSpanStartCol l)
+ , return $ mkIntExprInt platform (srcSpanEndLine l)
+ , return $ mkIntExprInt platform (srcSpanEndCol l)
+ ]
+
+ ; push_cs_id <- lookupId pushCallStackName
+ ; name_expr <- mkStringExprFS fs
+ ; loc_expr <- mkSrcLoc loc
+ -- At this point tm :: IP sym CallStack
+ -- but we need the actual CallStack to pass to pushCS,
+ -- so we use evUwrapIP to strip the dictionary wrapper
+ -- See Note [Overview of implicit CallStacks]
+ ; let outer_stk = evUnwrapIP pred tm
+ ; return (mkCoreApps (Var push_cs_id)
+ [mkCoreTup [name_expr, loc_expr], outer_stk]) }
{- Note [CallStack and ExecptionContext hack]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -510,9 +510,6 @@ data EvTerm
type EvExpr = CoreExpr
--- An EvTerm is (usually) constructed by any of the constructors here
--- and those more complicated ones who were moved to module GHC.Tc.Types.EvTerm
-
-- | Any sort of evidence Id, including coercions
evId :: EvId -> EvExpr
evId = Var
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a5950e85b96bf7bd2de87b3adae13753128cc31
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a5950e85b96bf7bd2de87b3adae13753128cc31
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250204/ce11e257/attachment-0001.html>
More information about the ghc-commits
mailing list