[Git][ghc/ghc][wip/T23109] More wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon May 13 16:43:44 UTC 2024
Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC
Commits:
4ff0a37c by Simon Peyton Jones at 2024-05-13T17:43:22+01:00
More wibbles
- - - - -
10 changed files:
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- − compiler/GHC/Tc/Types/EvTerm.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -36,7 +36,6 @@ import GHC.Tc.Utils.TcType
import GHC.Tc.Zonk.TcType
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.EvTerm
import GHC.Tc.Instance.Family
import GHC.Tc.Utils.Instantiate
import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit )
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Core.Reduction ( Reduction(..) )
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Core.Class ( Class )
+import GHC.Core.DataCon ( dataConWorkId )
import GHC.Core.Coercion( mkSymCo )
import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy)
import GHC.Core.TyCo.Ppr( pprTyVars )
@@ -302,11 +303,11 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
-> LHsExpr GhcTc -- def'n of IP variable
-> LHsExpr GhcTc -- dictionary for IP
toDict dict_ty (L loc expr)
- = L loc $ HsApp (L loc inst_con) (L loc expr)
+ = L loc $ HsApp noExtField (L loc inst_con) (L loc expr)
where
- (_, con, tys) = dcomposeIP dict_ty
+ (_, con, tys) = decomposeIP dict_ty
inst_con = mkHsWrap (mkWpTyApps tys) $
- HsVar noExtField (L loc (dataConWorkId con)))
+ HsVar noExtField (noLocA (dataConWorkId con))
-- Why an HsWrapper? See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
tcValBinds :: TopLevelFlag
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -47,7 +47,7 @@ import GHC.Tc.Errors
import GHC.Tc.Errors.Types
import GHC.Tc.Types.Evidence
import GHC.Tc.Solver.Solve ( solveSimpleGivens, solveSimpleWanteds )
-import GHC.Tc.Solver.Dict ( makeSuperClasses, solveCallStack )
+import GHC.Tc.Solver.Dict ( makeSuperClasses )
import GHC.Tc.Solver.Rewrite ( rewriteType )
import GHC.Tc.Utils.Unify ( buildTvImplication )
import GHC.Tc.Utils.TcMType as TcM
@@ -700,23 +700,26 @@ type CtDefaultingStrategy = Ct -> MaybeT TcS ()
-- | Default @ExceptionContext@ constraints to @emptyExceptionContext at .
defaultExceptionContext :: CtDefaultingStrategy
defaultExceptionContext ct
- = do { ClassPred cls tys <- pure $ classifyPredType (ctPred ct)
+ = do { let ev = ctEvidence ct
+ pred = ctEvPred ev
+ ; ClassPred cls tys <- pure $ classifyPredType pred
; Just {} <- pure $ isExceptionContextPred cls tys
- ; emptyEC <- Var <$> lift (lookupId emptyExceptionContextName)
- ; let ev = ctEvidence ct
- ; let ev_tm = mkEvCast emptyEC (wrapIP (ctEvPred ev))
- ; lift $ warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct)
- ; lift $ setEvBindIfWanted ev False ev_tm
- }
+ ; lift $ do { empty_id <- lookupId emptyExceptionContextName
+ ; warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct)
+ ; setEvBindIfWanted ev False (EvExpr (evWrapIP pred (Var empty_id)))
+ } }
-- | Default any remaining @CallStack@ constraints to empty @CallStack at s.
-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
defaultCallStack :: CtDefaultingStrategy
defaultCallStack ct
- = do { ClassPred cls tys <- pure $ classifyPredType (ctPred ct)
+ = do { let ev = ctEvidence ct
+ pred = ctEvPred ev
+ ; ClassPred cls tys <- pure $ classifyPredType pred
; Just {} <- pure $ isCallStackPred cls tys
- ; lift $ solveCallStack (ctEvidence ct) EvCsEmpty
- }
+ ; lift $ do { empty_id <- lookupId emptyCallStackName
+ ; setEvBindIfWanted ev True (EvExpr (evWrapIP pred (Var empty_id)))
+ } }
defaultConstraints :: [CtDefaultingStrategy]
-> WantedConstraints
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -6,7 +6,6 @@ module GHC.Tc.Solver.Dict (
checkInstanceOK,
matchLocalInst, chooseInstance,
makeSuperClasses, mkStrictSuperClasses,
- solveCallStack -- For GHC.Tc.Solver
) where
import GHC.Prelude
@@ -17,7 +16,6 @@ import GHC.Tc.Instance.Class( safeOverlap, matchEqualityInst )
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
-import GHC.Tc.Types.EvTerm( evCallStack )
import GHC.Tc.Solver.InertSet
import GHC.Tc.Solver.Monad
import GHC.Tc.Solver.Types
@@ -27,6 +25,7 @@ import GHC.Tc.Utils.Unify( uType )
import GHC.Hs.Type( HsIPName(..) )
import GHC.Core
+import GHC.Core.Make
import GHC.Core.Type
import GHC.Core.InstEnv ( DFunInstType )
import GHC.Core.Class
@@ -34,6 +33,7 @@ import GHC.Core.Predicate
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Core.Unify ( ruleMatchTyKiX )
+import GHC.Types.TyThing( lookupDataCon, lookupId )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Var
@@ -42,6 +42,8 @@ import GHC.Types.Var.Set
import GHC.Types.SrcLoc
import GHC.Types.Var.Env
+import GHC.Builtin.Names( srcLocDataConName, pushCallStackName )
+
import GHC.Utils.Monad ( concatMapM, foldlM )
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -50,6 +52,7 @@ import GHC.Utils.Misc
import GHC.Unit.Module
import GHC.Data.Bag
+import GHC.Data.FastString( FastString )
import GHC.Driver.DynFlags
@@ -138,31 +141,16 @@ canDictCt ev cls tys
-- doNotExpand: We have already expanded superclasses for /this/ dict
-- so set the fuel to doNotExpand to avoid repeating expansion
- | CtWanted { ctev_rewriters = rewriters } <- ev
+ | isWanted ev
, Just ip_name <- isCallStackPred cls tys
- , isPushCallStackOrigin orig
+ , isPushCallStackOrigin (ctEvOrigin ev)
-- 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 { -- 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
-
+ do { new_ev <- solveCallStack ip_name ev
; continueWith (DictCt { di_ev = new_ev, di_cls = cls
, di_tys = tys, di_pend_sc = doNotExpand }) }
-- doNotExpand: No superclasses for class CallStack
@@ -176,20 +164,67 @@ canDictCt ev cls tys
-- See Invariants in `CCDictCan.cc_pend_sc`
; continueWith (DictCt { di_ev = ev, di_cls = cls
, di_tys = tys, di_pend_sc = fuel }) }
+
+
+{- *********************************************************************
+* *
+* Implicit parameters and call stacks
+* *
+********************************************************************* -}
+
+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))
- ; setEvBindIfWanted ev True ev_tm }
+solveCallStack _ ev@(CtGiven {}) = pprPanic "solveCallStack" (ppr ev)
+ -- Caller only uses solveCallStack for Wanted constraints
{- Note [Shadowing of implicit parameters]
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -2987,7 +2987,7 @@ tryFunDeps work_item@(EqCt { eq_lhs = lhs, eq_ev = ev })
--------------------
improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS Bool
--- See Note [FunDep and implicit parameter reactions]
+-- See Note [FunDep and implicit parameter reactions] in GHC.Tc.Solver.Dict
improveTopFunEqs fam_tc args (EqCt { eq_ev = ev, eq_rhs = rhs })
| isGiven ev
= return False -- See Note [No Given/Given fundeps]
@@ -3088,7 +3088,7 @@ improveLocalFunEqs :: InertCans -> TyCon -> [TcType] -> EqCt -> TcS Bool
-- the current work item with inert CFunEqs
-- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y'
--
--- See Note [FunDep and implicit parameter reactions]
+-- See Note [FunDep and implicit parameter reactions] in GHC.Tc.Solver.Dict
improveLocalFunEqs inerts fam_tc args (EqCt { eq_ev = work_ev, eq_rhs = rhs })
| null improvement_eqns
= return False
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1909,7 +1909,7 @@ emitFunDepWanteds :: CtEvidence -- The work item
-> TcS Bool -- True <=> some unification happened
emitFunDepWanteds _ [] = return False -- common case noop
--- See Note [FunDep and implicit parameter reactions]
+-- See Note [FunDep and implicit parameter reactions] in GHC.Tc.Solver.Dict
emitFunDepWanteds ev fd_eqns
= unifyFunDeps ev Nominal do_fundeps
=====================================
compiler/GHC/Tc/Types/EvTerm.hs deleted
=====================================
@@ -1,72 +0,0 @@
-
--- (those who have too heavy dependencies for GHC.Tc.Types.Evidence)
-module GHC.Tc.Types.EvTerm
- ( evDelayedError, evCallStack )
-where
-
-import GHC.Prelude
-
-import GHC.Driver.DynFlags
-
-import GHC.Tc.Types.Evidence
-
-import GHC.Unit
-
-import GHC.Builtin.Names
-import GHC.Builtin.Types ( unitTy )
-
-import GHC.Core.Type
-import GHC.Core
-import GHC.Core.Make
-import GHC.Core.Utils
-
-import GHC.Types.SrcLoc
-import GHC.Types.TyThing
-
--- Used with Opt_DeferTypeErrors
--- See Note [Deferring coercion errors to runtime]
--- in GHC.Tc.Solver
-evDelayedError :: Type -> String -> EvTerm
-evDelayedError ty msg
- = EvExpr $
- let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg
- in mkWildCase fail_expr (unrestricted unitTy) ty []
- -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils
- -- c.f. mkErrorAppDs in GHC.HsToCore.Utils
-
--- Dictionary for CallStack implicit parameters
-evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
- EvCallStack -> m EvExpr
--- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-evCallStack EvCsEmpty =
- Var <$> lookupId emptyCallStackName
-evCallStack (EvCsPushCall fs loc tm) = do
- df <- getDynFlags
- let platform = targetPlatform df
- m <- getModule
- srcLocDataCon <- lookupDataCon srcLocDataConName
- let mkSrcLoc l = mkCoreConApps 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)
- ]
-
- 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))
-
- mkPush fs loc tm
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -27,8 +27,9 @@ module GHC.Tc.Types.Evidence (
-- * EvTerm (already a CoreExpr)
EvTerm(..), EvExpr,
- evId, evCoercion, evCast, evDFunApp, evDictApp, evSelector,
+ evId, evCoercion, evCast, evDFunApp, evDictApp, evSelector, evDelayedError,
mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars,
+ decomposeIP, evWrapIP, evUnwrapIP,
evTermCoercion, evTermCoercion_maybe,
EvCallStack(..),
@@ -42,7 +43,6 @@ module GHC.Tc.Types.Evidence (
TcMCoercion, TcMCoercionN, TcMCoercionR,
Role(..), LeftOrRight(..), pickLR,
maybeSymCo,
- unwrapIP, wrapIP,
-- * QuoteWrapper
QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy
@@ -58,8 +58,9 @@ import GHC.Core.Coercion
import GHC.Core.Ppr () -- Instance OutputableBndr TyVar
import GHC.Core.Type
import GHC.Core.TyCon
-import GHC.Core.Class( classTyCon )
-import GHC.Core.DataCon ( dataConWrapId )
+import GHC.Core.Make ( mkWildCase, mkRuntimeErrorApp, tYPE_ERROR_ID )
+import GHC.Core.Class ( classTyCon, classMethods )
+import GHC.Core.DataCon ( DataCon, dataConWrapId )
import GHC.Core.Class (Class, classSCSelId )
import GHC.Core.FVs ( exprSomeFreeVars )
import GHC.Core.InstEnv ( Canonical )
@@ -73,9 +74,9 @@ import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Core.Predicate
import GHC.Types.Basic
-import GHC.Types.Name( Name )
import GHC.Builtin.Names
+import GHC.Builtin.Types( unitTy )
import GHC.Utils.Misc
import GHC.Utils.Panic
@@ -855,6 +856,16 @@ evTermCoercion tm = case evTermCoercion_maybe tm of
Just co -> co
Nothing -> pprPanic "evTermCoercion" (ppr tm)
+-- Used with Opt_DeferTypeErrors
+-- See Note [Deferring coercion errors to runtime]
+-- in GHC.Tc.Solver
+evDelayedError :: Type -> String -> EvTerm
+evDelayedError ty msg
+ = EvExpr $
+ let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg
+ in mkWildCase fail_expr (unrestricted unitTy) ty []
+ -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils
+ -- c.f. mkErrorAppDs in GHC.HsToCore.Utils
{- *********************************************************************
* *
@@ -1011,13 +1022,32 @@ instance Outputable EvTypeable where
-- `MkIP` is the data constructor for class IP
decomposeIP :: Type -> (Id, DataCon, [Type])
decomposeIP ty
- = assertPpr (isIPTyCon tc && isUnaryClassTyCon tc) (ppr tc) $
- case classOpMethods (classTyCon tc) of
- [ip_op] -> (ip_op, tyConSingleDataCon tc, tys)
- _ -> pprPanic "unwrapIP" (ppr tc)
+ | Just cls <- tyConClass_maybe tc
+ , [ip_op] <- classMethods cls
+ = assertPpr (isIPClass cls && isUnaryClassTyCon tc) (ppr tc) $
+ (ip_op, tyConSingleDataCon tc, tys)
+ | otherwise = pprPanic "decomposeIP" (ppr tc)
where
(tc, tys) = splitTyConApp ty
+evWrapIP :: PredType -> EvExpr -> EvExpr
+-- Given pred = IP s ty
+ -- et_tm :: ty
+-- Return an EvTerm of type (IP s ty)
+evWrapIP pred ev_tm
+ = mkConApp con (map Type tys ++ [ev_tm])
+ where
+ (_, con, tys) = decomposeIP pred
+
+evUnwrapIP :: PredType -> EvExpr -> EvExpr
+-- Given pred = IP s ty
+ -- et_tm :: (IP s ty)
+-- Return an EvTerm of type ty
+evUnwrapIP pred ev_tm
+ = mkApps (Var ip_sel) (map Type tys ++ [ev_tm])
+ where
+ (ip_sel, _, tys) = decomposeIP pred
+
----------------------------------------------------------------------
-- A datatype used to pass information when desugaring quotations
----------------------------------------------------------------------
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -533,7 +533,7 @@ mkDictSelId name clas
-- The strictness signature is of the form U(AAAVAAAA) -> T
-- where the V depends on which item we are selecting
-- It's worth giving one, so that absence info etc is generated
- -- even if the selector isn't inlined
+ -- even if the selector isn't inlined, which of course it isn't!
strict_sig = mkClosedDmdSig [arg_dmd] topDiv
arg_dmd | unary_cls = evalDmd
@@ -921,6 +921,9 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
-- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module.
= False
+ | isUnaryClassTyCon tycon -- See Note [Unary class magic]
+ = False
+
| otherwise
= (not new_tycon
-- (Most) newtypes have only a worker, with the exception
=====================================
compiler/ghc.cabal.in
=====================================
@@ -818,7 +818,6 @@ Library
GHC.Tc.Types
GHC.Tc.Types.Constraint
GHC.Tc.Types.Evidence
- GHC.Tc.Types.EvTerm
GHC.Tc.Types.Origin
GHC.Tc.Types.Rank
GHC.Tc.Types.CtLocEnv
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ff0a37c434d3e3adfb720aa656321555e202fd1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ff0a37c434d3e3adfb720aa656321555e202fd1
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/20240513/689a7372/attachment-0001.html>
More information about the ghc-commits
mailing list