[Git][ghc/ghc][wip/T25281] Make it right
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Sep 30 16:38:36 UTC 2024
Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC
Commits:
f82443b9 by Simon Peyton Jones at 2024-09-30T17:38:00+01:00
Make it right
- - - - -
12 changed files:
- compiler/GHC/Core/LateCC/OverloadedCalls.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- testsuite/tests/pmcheck/should_compile/T24891.hs
Changes:
=====================================
compiler/GHC/Core/LateCC/OverloadedCalls.hs
=====================================
@@ -80,7 +80,7 @@ overloadedCallsCC =
-- check if any of the arguments v1 ... vN are dictionaries.
let
(f, xs) = collectArgs app
- resultTy = applyTypeToArgs empty (exprType f) xs
+ resultTy = applyTypeToArgs (exprType f) xs
-- Recursively process the arguments first for no particular reason
args <- mapM processExpr xs
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -2258,7 +2258,7 @@ etaInfoAppTy :: Type -> EtaInfo -> Type
-- If e :: ty
-- then etaInfoApp e eis :: etaInfoApp ty eis
etaInfoAppTy ty (EI bs mco)
- = applyTypeToArgs (text "etaInfoAppTy") ty1 (map varToCoreExpr bs)
+ = applyTypeToArgs ty1 (map varToCoreExpr bs)
where
ty1 = case mco of
MRefl -> ty
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -82,8 +82,7 @@ module GHC.Core.Type (
coAxNthLHS,
stripCoercionTy,
- splitInvisPiTys, splitInvisPiTysN,
- invisibleTyBndrCount,
+ splitInvisPiTys, splitInvisPiTysN, invisibleBndrCount,
filterOutInvisibleTypes, filterOutInferredTypes,
partitionInvisibleTypes, partitionInvisibles,
tyConForAllTyFlags, appTyForAllTyFlags,
@@ -2097,12 +2096,12 @@ getRuntimeArgTys = go
| otherwise
= []
-invisibleTyBndrCount :: Type -> Int
+invisibleBndrCount :: Type -> Int
-- Returns the number of leading invisible forall'd binders in the type
-- Includes invisible predicate arguments; e.g. for
-- e.g. forall {k}. (k ~ *) => k -> k
-- returns 2 not 1
-invisibleTyBndrCount ty = length (fst (splitInvisPiTys ty))
+invisibleBndrCount ty = length (fst (splitInvisPiTys ty))
-- | Like 'splitPiTys', but returns only *invisible* binders, including constraints.
-- Stops at the first visible binder.
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -142,7 +142,7 @@ exprType (Tick _ e) = exprType e
exprType (Lam binder expr) = mkLamType binder (exprType expr)
exprType e@(App _ _)
= case collectArgs e of
- (fun, args) -> applyTypeToArgs (pprCoreExpr e) (exprType fun) args
+ (fun, args) -> applyTypeToArgs (exprType fun) args
exprType (Type ty) = pprPanic "exprType" (ppr ty)
coreAltType :: CoreAlt -> Type
@@ -221,11 +221,10 @@ Various possibilities suggest themselves:
Note that there might be existentially quantified coercion variables, too.
-}
-applyTypeToArgs :: HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type
+applyTypeToArgs :: HasDebugCallStack => Type -> [CoreExpr] -> Type
-- ^ Determines the type resulting from applying an expression with given type
--- to given argument expressions.
--- The first argument is just for debugging, and gives some context
-applyTypeToArgs pp_e op_ty args
+applyTypeToArgs op_ty args
= go op_ty args
where
go op_ty [] = op_ty
@@ -244,8 +243,7 @@ applyTypeToArgs pp_e op_ty args
go_ty_args op_ty rev_tys args
= go (piResultTys op_ty (reverse rev_tys)) args
- panic_msg as = vcat [ text "Expression:" <+> pp_e
- , text "Type:" <+> ppr op_ty
+ panic_msg as = vcat [ text "Type:" <+> ppr op_ty
, text "Args:" <+> ppr args
, text "Args':" <+> ppr as ]
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -76,7 +76,6 @@ import GHC.Builtin.Names
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import Control.Arrow( first )
import Control.Monad
import Data.Maybe( isJust )
import qualified Data.Set as S
@@ -695,10 +694,11 @@ ds_app (XExpr (ConLikeTc con tvs tys)) _hs_args core_args
; return (mkApps core_fun core_args) }
ds_app (HsRecSel _ (FieldOcc { foExt = sel_id })) _hs_args core_args
- = ds_app_rec_sel sel_id core_args
+ = ds_app_rec_sel sel_id sel_id core_args
ds_app (HsVar _ lfun) hs_args core_args
- = ds_app_var lfun hs_args core_args
+ = do { tracePm "ds_app" (ppr lfun <+> ppr core_args)
+ ; ds_app_var lfun hs_args core_args }
ds_app e _hs_args core_args
= do { core_e <- dsExpr e
@@ -723,24 +723,27 @@ ds_app_var (L loc fun_id) hs_args core_args
-- Alas, we cannot simply look at the unfolding of $dHasField below because it
-- has not been set yet, so we have to reconstruct the selector Id from the types.
| fun_id `hasKey` getFieldClassOpKey
- , (_k : Type x_ty : Type r_ty : _a_ty : _dict : rest_args) <- core_args
+ , (_k : _rrep : _arep : Type x_ty : Type r_ty : _) <- core_args
+ -- getField :: forall {k} {r_rep} {a_rep} (x::k) (r :: TYPE r_rep) (a :: TYPE a_rep) .
+ -- HasField x r a => r -> a
= do { fam_inst_envs <- dsGetFamInstEnvs
; rdr_env <- dsGetGlobalRdrEnv
-- Look up the field named x/"sel" in the type r/T
+ ; tracePm "getfield" (ppr core_args $$ ppr x_ty $$ ppr r_ty)
; case lookupHasFieldLabel fam_inst_envs x_ty r_ty of
Just fl | isJust (lookupGRE_FieldLabel rdr_env fl)
-- isJust: Make sure the field is actually visible in this module;
-- otherwise this might not be the implicit HasField instance
-> do { sel_id <- dsLookupGlobalId (flSelector fl)
- ; ds_app_rec_sel sel_id rest_args }
+ ; tracePm "getfield2" (ppr sel_id)
+ ; ds_app_rec_sel sel_id fun_id core_args }
_ -> ds_app_finish fun_id core_args }
-----------------------
-- Warn about identities for (fromInteger :: Integer -> Integer) etc
-- They all have a type like: forall <tvs>. <cxt> => arg_ty -> res_ty
| idName fun_id `elem` numericConversionNames
- , let (inst_fun_ty, _) = apply_type_args fun_id core_args
- , (_, conv_ty) <- splitInvisPiTys inst_fun_ty
+ , let (conv_ty, _) = apply_invis_args fun_id core_args
, Just (arg_ty, res_ty) <- splitVisibleFunTy_maybe conv_ty
= do { dflags <- getDynFlags
; when (wopt Opt_WarnIdentities dflags
@@ -793,7 +796,7 @@ ds_app_finish :: Id -> [CoreExpr] -> DsM CoreExpr
-- We are about to construct an application that may include evidence applications
-- `f dict`. If the dictionary is non-specialisable, instead construct
-- nospec f dict
--- See Note [nospecId magic] in GHC.Types.Id.Make for what `nospec` does.
+-- See Note [nospecId magic] gin GHC.Types.Id.Make for what `nospec` does.
-- See Note [Desugaring non-canonical evidence]
ds_app_finish fun_id core_args
= do { unspecables <- getUnspecables
@@ -812,60 +815,61 @@ ds_app_finish fun_id core_args
; return (mkCoreApps fun core_args) }
---------------
-ds_app_rec_sel :: Id -> [CoreExpr] -> DsM CoreExpr
+ds_app_rec_sel :: Id -- The record selector Id itself
+ -> Id -- The function at the the head
+ -> [CoreExpr] -- Its arguments
+ -> DsM CoreExpr
-- Desugar an application with HsRecSelId at the head
-ds_app_rec_sel sel_id core_args
+ds_app_rec_sel sel_id fun_id core_args
| RecSelId{ sel_cons = rec_sel_info } <- idDetails sel_id
, RSI { rsi_undef = cons_wo_field } <- rec_sel_info
= do { -- Record selectors are warned about if they are not present in all of the
- -- parent data type's constructor, or always in case of pattern synonym record
+ -- parent data type's constructors, or always in case of pattern synonym record
-- selectors (regulated by a flag). However, this only produces a warning if
-- it's not a part of a record selector application. For example:
-- data T = T1 | T2 {s :: Bool}
-- g y = map s y -- Warn here
-- f x = s x -- No warning here
- ; let (fun_ty, val_args) = apply_type_args sel_id core_args
+ ; let (fun_ty, val_args) = apply_invis_args fun_id core_args
- -- Type-based check.
- -- See (3) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ ; tracePm "ds_app_rec_sel" (ppr fun_ty $$ ppr val_args)
; case val_args of
-- There is a value argument
+ -- See (IRS2) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
(arg:_) -> pmcRecSel sel_id arg
-- No value argument, but the selector is
-- applied to all its type arguments
+ -- See (IRS3) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
[] | Just (val_arg_ty, _) <- splitVisibleFunTy_maybe fun_ty
-> do { dummy <- newSysLocalDs (Scaled ManyTy val_arg_ty)
; pmcRecSel sel_id (Var dummy) }
-- Not even applied to all its type args
- -- See (4) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ -- See (IRS4) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
_ -> unless (null cons_wo_field) $
do { dflags <- getDynFlags
; let maxCons = maxUncoveredPatterns dflags
; diagnosticDs $ DsIncompleteRecordSelector (idName sel_id) cons_wo_field maxCons }
- ; ds_app_finish sel_id core_args }
+ ; ds_app_finish fun_id core_args }
| otherwise
= pprPanic "ds_app_rec_sel" (ppr sel_id $$ ppr (idDetails sel_id))
where
-apply_type_args :: Id -> [CoreExpr] -> (Type, [CoreExpr])
+apply_invis_args :: Id -> [CoreExpr] -> (Type, [CoreExpr])
-- Apply function to the initial /type/ args;
-- return the type of the instantiated function,
-- and the remaining args
-- e.g. apply_type_args (++) [Type Int, Var xs]
-- = ([Int] -> [Int] -> [Int], [Var xs])
-apply_type_args fun args
- = (piResultTys (idType fun) arg_tys, rest_args)
+apply_invis_args fun_id args
+ = (applyTypeToArgs fun_ty invis_args, rest_args)
where
- (arg_tys, rest_args) = go args
-
- go :: [CoreExpr] -> ([Type], [CoreExpr])
- go (Type ty : args) = first (ty :) (go args)
- go args = ([], args)
+ fun_ty = idType fun_id
+ (invis_args, rest_args) = splitAt (invisibleBndrCount fun_ty) args
------------------------------
splitHsWrapperArgs :: HsWrapper -> [CoreArg] -> DsM (HsWrapper, [CoreArg])
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -36,9 +36,6 @@ module GHC.HsToCore.Monad (
-- Getting and setting pattern match oracle states
getPmNablas, updPmNablas,
- -- Locally suppress -Wincomplete-record-selectors warnings
- getSuppressIncompleteRecSelsDs, suppressIncompleteRecSelsDs,
-
-- Tracking evidence variable coherence
addUnspecables, getUnspecables,
@@ -409,7 +406,6 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, dsl_loc = real_span
, dsl_nablas = initNablas
, dsl_unspecables = mempty
- , dsl_suppress_incomplete_rec_sel = False
}
in (gbl_env, lcl_env)
@@ -478,13 +474,6 @@ addUnspecables unspecables = updLclEnv (\env -> env{ dsl_unspecables = unspecabl
getUnspecables :: DsM (S.Set EvId)
getUnspecables = dsl_unspecables <$> getLclEnv
-suppressIncompleteRecSelsDs :: DsM a -> DsM a
-suppressIncompleteRecSelsDs = updLclEnv (\dsl -> dsl { dsl_suppress_incomplete_rec_sel = True })
-
--- | Get the current pattern match oracle state. See 'dsl_nablas'.
-getSuppressIncompleteRecSelsDs :: DsM Bool
-getSuppressIncompleteRecSelsDs = do { env <- getLclEnv; return (dsl_suppress_incomplete_rec_sel env) }
-
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv
; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -272,7 +272,7 @@ We should warn in `solveDot`, but not in `accessDot`.
Here is how we achieve all this in the implementation:
- 1. When renaming a record selector in `mkOneRecordSelector`,
+(IRS1) When renaming a record selector in `mkOneRecordSelector`,
we precompute the constructors the selector succeeds on.
That would be `T2` for `sel` because `sel (T2 42)` succeeds,
and `Yes` for `sel2` because `sel2 (Yes 13)` succeeds.
@@ -286,7 +286,7 @@ They are ordered by specificity, so we prefer (2) over (3) over (4).
Item (5) below describes how we resolve the overlap.
(-XOverloadedRecordDot is discussed separately in Item (6) and (7).)
- 2. In function `ldi`, we have a record selector application `sel arg`.
+(IRS2) In function `ldi`, we have a record selector application `sel arg`.
This situation is detected `GHC.HsToCore.Expr.ds_app_rec_sel`, when the
record selector is applied to at least one argument. We call out to the
pattern-match checker to determine whether use of the selector is safe,
@@ -311,14 +311,14 @@ Item (5) below describes how we resolve the overlap.
reduced problem, the match is exhaustive and the use of the record selector
safe.
- 3. In function `resTy`, the record selector is unsaturated, but the result type
+(IRS3) In function `resTy`, the record selector is unsaturated, but the result type
ensures a safe use of the selector.
This situation is also detected in `GHC.HsToCore.Expr.ds_app_rec_sel`.
THe selector is elaborated with its type arguments; we simply match on
desugared Core `sel @Bool :: T Bool -> Int` to learn the result type `T Bool`.
We again call `pmcRecSel`, but this time with a fresh dummy Id `ds::T Bool`.
- 4. In case of an unsaturated record selector that is *not* applied to any type
+(IRS4) In case of an unsaturated record selector that is *not* applied to any type
argument after elaboration (e.g. in `urgh2 = sel2 :: Dot -> Int`), we simply
produce a warning about all `sel_cons`; no need to call `pmcRecSel`.
This happens in the `HsRecSel` case of `dsExpr`.
@@ -382,7 +382,7 @@ Finally, there are 2 more items addressing -XOverloadedRecordDot:
pmcRecSel :: Id -- ^ Id of the selector
-> CoreExpr -- ^ Core expression of the argument to the selector
-> DsM ()
--- See (IRS4) in Note [Detecting incomplete record selectors]
+-- See (IRS2,3) in Note [Detecting incomplete record selectors]
pmcRecSel sel_id arg
| RecSelId{ sel_cons = rec_sel_info } <- idDetails sel_id
, RSI { rsi_def = cons_w_field, rsi_undef = cons_wo_field } <- rec_sel_info
=====================================
compiler/GHC/HsToCore/Types.hs
=====================================
@@ -80,9 +80,6 @@ data DsLclEnv
-- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc".
-- The set of reaching values Nablas is augmented as we walk inwards, refined
-- through each pattern match in turn
- , dsl_suppress_incomplete_rec_sel :: Bool
- -- ^ Whether to suppress -Wincomplete-record-selectors warnings.
- -- See (5) of Note [Detecting incomplete record selectors]
, dsl_unspecables :: S.Set EvVar
-- ^ See Note [Desugaring non-canonical evidence]: this field collects
-- all un-specialisable evidence variables in scope.
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1982,11 +1982,11 @@ checkExpectedKind hs_ty ty act_kind exp_kind
; return (res_ty `mkCastTy` co_k) } }
where
-- We need to make sure that both kinds have the same number of implicit
- -- foralls out front. If the actual kind has more, instantiate accordingly.
- -- Otherwise, just pass the type & kind through: the errors are caught
- -- in unifyType.
- n_exp_invis_bndrs = invisibleTyBndrCount exp_kind
- n_act_invis_bndrs = invisibleTyBndrCount act_kind
+ -- foralls and constraints out front. If the actual kind has more, instantiate
+ -- accordingly. Otherwise, just pass the type & kind through: the errors
+ -- are caught in unifyType.
+ n_exp_invis_bndrs = invisibleBndrCount exp_kind
+ n_act_invis_bndrs = invisibleBndrCount act_kind
n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs
@@ -2707,8 +2707,8 @@ checkExpectedResKind sig_kind res_ki
; let -- Drop invisible binders from sig_kind until they match up
-- with res_ki. By analogy with checkExpectedKind.
- n_res_invis_bndrs = invisibleTyBndrCount actual_res_ki
- n_sig_invis_bndrs = invisibleTyBndrCount sig_kind
+ n_res_invis_bndrs = invisibleBndrCount actual_res_ki
+ n_sig_invis_bndrs = invisibleBndrCount sig_kind
n_to_inst = n_sig_invis_bndrs - n_res_invis_bndrs
(_, sig_kind') = splitInvisPiTysN n_to_inst sig_kind
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -507,7 +507,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_ext = lwarn
fst $ splitForAllForAllTyBinders dfun_ty
visible_skol_tvs = drop n_inferred skol_tvs
- ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs)
+ ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleBndrCount dfun_ty) $$ ppr skol_tvs)
-- Next, process any associated types.
; (datafam_stuff, tyfam_insts)
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -489,7 +489,11 @@ tcInstInvisibleTyBinders ty kind
= do { (extra_args, kind') <- tcInstInvisibleTyBindersN n_invis kind
; return (mkAppTys ty extra_args, kind') }
where
- n_invis = invisibleTyBndrCount kind
+ n_invis = invisibleBndrCount kind
+ -- We are re-using tcInstInvisibleTyBindersN, which is
+ -- needed elsewhere; so all that matters is that n_invis
+ -- is big enough! Does not matter if it is too big.
+ -- 10,000 would do equally well :-)
tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind)
-- Called only to instantiate kinds, in user-written type signatures
=====================================
testsuite/tests/pmcheck/should_compile/T24891.hs
=====================================
@@ -12,6 +12,7 @@ data T a where
f :: T Bool -> Int
f x = x.sel -- warn, but only once, suggesting to match on T3
+{-
data Dot = No | Yes {sel2 :: Int}
ldiDot :: Dot -> Int
@@ -28,3 +29,4 @@ data Dot2 t = No2 | Yes2 {sel3 :: t}
accessDot2 :: HasField "sel2" t Int => Dot2 t -> Int
accessDot2 x = x.sel3.sel2 -- warn about x.sel3
+-}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f82443b9fec721308f3f46e7beb3a1346c91b57a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f82443b9fec721308f3f46e7beb3a1346c91b57a
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/20240930/163b3c37/attachment-0001.html>
More information about the ghc-commits
mailing list