[Git][ghc/ghc][wip/T25281] More improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Sep 26 15:51:46 UTC 2024
Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC
Commits:
13ba3beb by Simon Peyton Jones at 2024-09-26T16:51:22+01:00
More improvements
- - - - -
8 changed files:
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/TyThing.hs
Changes:
=====================================
compiler/GHC/Core/ConLike.hs
=====================================
@@ -23,7 +23,6 @@ module GHC.Core.ConLike (
, conLikeFullSig
, conLikeResTy
, conLikeFieldType
- , conLikesWithFields
, conLikeIsInfix
, conLikeHasBuilder
) where
@@ -231,15 +230,6 @@ conLikeFieldType :: ConLike -> FieldLabelString -> Type
conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label
conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label
-
--- | The ConLikes that have *all* the given fields
-conLikesWithFields :: [ConLike] -> [FieldLabelString]
- -> ( [ConLike] -- ConLikes containing the fields
- , [ConLike] ) -- ConLikes not containing the fields
-conLikesWithFields con_likes lbls = List.partition has_flds con_likes
- where has_flds dc = all (has_fld dc) lbls
- has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
-
conLikeIsInfix :: ConLike -> Bool
conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -619,7 +619,7 @@ ds_app (XExpr (ConLikeTc con tvs tys)) _hs_args core_args
; return (mkApps core_fun core_args) }
ds_app (HsRecSel _ fld_occ@(FieldOcc { foExt = fun_id })) hs_args core_args
- | RecSelId {sel_cons = (_, cons_wo_field)} <- idDetails fun_id
+ | RecSelId {sel_cons = RSI { rsi_undef = cons_wo_field}} <- idDetails fun_id
= do { dflags <- getDynFlags
-- Record selectors are warned about if they are not present in all of the
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -216,27 +216,28 @@ incomplete record selectors to consider:
when renaming a record selector in `mkOneRecordSelector`
(IRS2) Emitting a warning whenever a `HasField` constraint is solved.
- This is checked in `matchHasField` and emitted only for when
- the constraint is resolved with an implicit instance rather than a
- custom one (since otherwise the warning will be emitted in
- the custom implementation anyways)
+ Implemented in GHC.Tc.Instance.Class.matchHasField`
+ The warning is emitted only when the constraint is resolved with an
+ /implicit/ instance rather than a user-supplied one (since otherwise the
+ warning will be emitted in the custom implementation anyways)
e.g.
g :: HasField "x" t Int => t -> Int
g = getField @"x"
f :: T -> Int
- f = g -- warning will be emitted here
-
-(IRS3) Emitting a warning for a general occurrence of the record selector
- This is done during the renaming of a `HsRecSel` expression in `dsExpr`
- and simply pulls the information about incompleteness from the `Id`
+ f = g -- Warning will be emitted here when solving the
+ -- (HasField "x" T Int) constraint arising from
+ -- the call of g, because `x` is only partial
+(IRS3) Emitting a warning for a general occurrence of the record selector.
+ Implemented in the `HsRecSel` case of `GHC.HsToCore.Expr.ds_app`.
e.g.
l :: T -> Int
l a = x a -- warning will be emitted here
(IRS4) Emitting a warning for a record selector `sel` applied to a variable `y`.
+ Implemented in `pmcRecSel` in this module.
In that case we want to use the long-distance information from the
pattern match checker to rule out impossible constructors
(See Note [Long-distance information]). We first add constraints to
@@ -256,27 +257,29 @@ pmcRecSel :: Id -- ^ Id of the selector
-> DsM ()
-- See (IRS4) in Note [Detecting incomplete record selectors]
pmcRecSel sel_id arg
- | RecSelId{ sel_cons = (cons_w_field, _ : _) } <- idDetails sel_id = do
- !missing <- getLdiNablas
-
- tracePm "pmcRecSel {" (ppr sel_id)
- CheckResult{ cr_ret = PmRecSel{ pr_arg_var = arg_id }, cr_uncov = uncov_nablas }
- <- unCA (checkRecSel (PmRecSel () arg cons_w_field)) missing
- tracePm "}: " $ ppr uncov_nablas
-
- inhabited <- isInhabited uncov_nablas
- when inhabited $ warn_incomplete arg_id uncov_nablas
- where
- sel_name = varName sel_id
- warn_incomplete arg_id uncov_nablas = do
- dflags <- getDynFlags
- let maxConstructors = maxUncoveredPatterns dflags
- unc_examples <- getNFirstUncovered MinimalCover [arg_id] (maxConstructors + 1) uncov_nablas
- let cons = [con | unc_example <- unc_examples
- , Just (PACA (PmAltConLike con) _ _) <- [lookupSolution unc_example arg_id]]
- not_full_examples = length cons == (maxConstructors + 1)
- cons' = take maxConstructors cons
- diagnosticDs $ DsIncompleteRecordSelector sel_name cons' not_full_examples
+ | RecSelId{ sel_cons = RSI { rsi_def = cons_w_field, rsi_undef = cons_wo_field } }
+ <- idDetails sel_id
+ , not (null cons_wo_field)
+ = do { !missing <- getLdiNablas
+
+ ; tracePm "pmcRecSel {" (ppr sel_id)
+ ; CheckResult{ cr_ret = PmRecSel{ pr_arg_var = arg_id }, cr_uncov = uncov_nablas }
+ <- unCA (checkRecSel (PmRecSel () arg cons_w_field)) missing
+ ; tracePm "}: " $ ppr uncov_nablas
+
+ ; inhabited <- isInhabited uncov_nablas
+ ; when inhabited $ warn_incomplete arg_id uncov_nablas }
+ where
+ sel_name = varName sel_id
+ warn_incomplete arg_id uncov_nablas = do
+ dflags <- getDynFlags
+ let maxConstructors = maxUncoveredPatterns dflags
+ unc_examples <- getNFirstUncovered MinimalCover [arg_id] (maxConstructors + 1) uncov_nablas
+ let cons = [con | unc_example <- unc_examples
+ , Just (PACA (PmAltConLike con) _ _) <- [lookupSolution unc_example arg_id]]
+ not_full_examples = length cons == (maxConstructors + 1)
+ cons' = take maxConstructors cons
+ diagnosticDs $ DsIncompleteRecordSelector sel_name cons' not_full_examples
pmcRecSel _ _ = return ()
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1713,14 +1713,13 @@ tcIdDetails nm _ (IfRecSelId tc _first_con naughty fl)
= do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
(fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
tc
- ; let all_cons = recSelParentCons tc'
- cons_partitioned
- = conLikesWithFields all_cons [flLabel fl]
+ ; let all_cons = recSelParentCons tc'
+ cons_partitioned = conLikesRecSelInfo all_cons [flLabel fl]
; return (RecSelId
- { sel_tycon = tc'
- , sel_naughty = naughty
+ { sel_tycon = tc'
+ , sel_naughty = naughty
, sel_fieldLabel = fl { flSelector = nm }
- , sel_cons = cons_partitioned }
+ , sel_cons = cons_partitioned }
-- Reconstructed here since we don't want Uniques in the Iface file
) }
where
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -1295,7 +1295,7 @@ matchHasField dflags short_cut clas tys
then do { -- See Note [Unused name reporting and HasField]
addUsedGRE AllDeprecationWarnings gre
; keepAlive name
- ; unless (null $ snd $ sel_cons $ idDetails sel_id)
+ ; unless (null $ rsi_undef $ sel_cons $ idDetails sel_id)
$ addDiagnostic $ TcRnHasFieldResolvedIncomplete name
-- Only emit an incomplete selector warning if it's an implicit instance
-- See (IRS2) in Note [Detecting incomplete record selectors]
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -881,14 +881,15 @@ mkOneRecordSelector all_cons idDetails fl has_sel
sel_id = mkExportedLocalId rec_details sel_name sel_ty
-- Find a representative constructor, con1
- cons_partitioned@(cons_w_field, _) = conLikesWithFields all_cons [lbl]
+ rec_sel_info@(RSI { rsi_def = cons_w_field })
+ = conLikesRecSelInfo all_cons [lbl]
con1 = assert (not (null cons_w_field)) $ head cons_w_field
-- Construct the IdDetails
rec_details = RecSelId { sel_tycon = idDetails
, sel_naughty = is_naughty
, sel_fieldLabel = fl
- , sel_cons = cons_partitioned }
+ , sel_cons = rec_sel_info }
-- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -21,8 +21,10 @@ module GHC.Types.Id.Info (
-- * The IdDetails type
IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,
JoinArity, isJoinIdDetails_maybe,
+
RecSelParent(..), recSelParentName, recSelFirstConName,
recSelParentCons, idDetailsConcreteTvs,
+ RecSelInfo(..), conLikesRecSelInfo,
-- * The IdInfo type
IdInfo, -- Abstract
@@ -116,6 +118,7 @@ import GHC.StgToCmm.Types (LambdaFormInfo)
import Data.Data ( Data )
import Data.Word
+import Data.List as List( partition )
-- infixl so you can say (id `set` a `set` b)
infixl 1 `setRuleInfo`,
@@ -151,12 +154,9 @@ data IdDetails
, sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in:
-- data T = forall a. MkT { x :: a }
-- See Note [Naughty record selectors] in GHC.Tc.TyCl
- , sel_cons :: ([ConLike], [ConLike])
- -- If record selector is not defined for all constructors
- -- of a parent type, this is the pair of lists of constructors that
- -- it is and is not defined for. Otherwise, it's Nothing.
- -- Cached here based on the RecSelParent.
- } -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ , sel_cons :: RecSelInfo
+ -- Partiality info, cached here based on the RecSelParent.
+ }
| DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/
| DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/
@@ -224,6 +224,11 @@ data IdDetails
-- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current
-- module.
+data RecSelInfo
+ = RSI { rsi_def :: [ConLike] -- Record selector defined for these
+ , rsi_undef :: [ConLike] -- Record selector not defined for these
+ }
+
idDetailsConcreteTvs :: IdDetails -> ConcreteTyVars
idDetailsConcreteTvs = \ case
PrimOpId _ conc_tvs -> conc_tvs
@@ -232,6 +237,16 @@ idDetailsConcreteTvs = \ case
DataConWrapId dc -> dataConConcreteTyVars dc
_ -> noConcreteTyVars
+-- | The ConLikes that have *all* the given fields
+conLikesRecSelInfo :: [ConLike] -> [FieldLabelString] -> RecSelInfo
+conLikesRecSelInfo con_likes lbls
+ = RSI { rsi_def = defs, rsi_undef = undefs }
+ where
+ !(defs,undefs) = List.partition has_flds con_likes
+
+ has_flds dc = all (has_fld dc) lbls
+ has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
+
{- Note [CBV Function Ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Types/TyThing.hs
=====================================
@@ -355,12 +355,12 @@ tyThingGREInfo = \case
RecSelPatSyn ps -> unitUniqSet $ PatSynName (patSynName ps)
RecSelData tc ->
let dcs = map RealDataCon $ tyConDataCons tc in
- case conLikesWithFields dcs [flLabel fl] of
- ([], _) -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $
+ case rsi_def (conLikesRecSelInfo dcs [flLabel fl]) of
+ [] -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $
vcat [ text "id:" <+> ppr id
, text "fl:" <+> ppr fl
, text "dcs:" <+> ppr dcs ]
- (cons, _) -> mkUniqSet $ map conLikeConLikeName cons
+ cons -> mkUniqSet $ map conLikeConLikeName cons
in IAmRecField $
RecFieldInfo
{ recFieldLabel = fl
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13ba3beb17d7fbfea216f32006436a352e6fd07a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13ba3beb17d7fbfea216f32006436a352e6fd07a
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/20240926/17796861/attachment-0001.html>
More information about the ghc-commits
mailing list