[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Add `IfaceWarnings` to represent the `ModIface`-storable parts
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jun 19 21:48:54 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
0cbc3ae0 by Gergő Érdi at 2023-06-19T09:11:38-04:00
Add `IfaceWarnings` to represent the `ModIface`-storable parts
of a `Warnings GhcRn`.
Fixes #23516
- - - - -
52fe555e by Arnaud Spiwack at 2023-06-19T17:48:41-04:00
Avoid desugaring non-recursive lets into recursive lets
This prepares for having linear let expressions in the frontend.
When desugaring lets, SPECIALISE statements create more copies of a
let binding. Because of the rewrite rules attached to the bindings,
there are dependencies between the generated binds.
Before this commit, we simply wrapped all these in a mutually
recursive let block, and left it to the simplified to sort it out.
With this commit: we are careful to generate the bindings in
dependency order, so that we can wrap them in consecutive lets (if the
source is non-recursive).
- - - - -
727206c5 by Ben Gamari at 2023-06-19T17:48:43-04:00
rts: Do not call exit() from SIGINT handler
Previously `shutdown_handler` would call `stg_exit` if the scheduler was
Oalready found to be in `SCHED_INTERRUPTING` state (or higher). However,
`stg_exit` is not signal-safe as it calls `exit` (which calls `atexit`
handlers). The only safe thing to do in this situation is to call
`_exit`, which terminates with minimal cleanup.
Fixes #23417.
- - - - -
4e3265fd by mangoiv at 2023-06-19T17:48:43-04:00
[feat] add a hint to `HasField` error message
- add a hint that indicates that the record that the record dot is used
on might just be missing a field
- as the intention of the programmer is not entirely clear, it is only
shown if the type is known
- This addresses in part issue #22382
- - - - -
16 changed files:
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/SourceText.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/GHC/Unit/Module/Warnings.hs
- rts/posix/Signals.c
- testsuite/tests/ghci/should_run/T16096.stdout
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
Changes:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -117,10 +117,56 @@ dsTopLHsBinds binds
top_level_err bindsType (L loc bind)
= putSrcSpanDs (locA loc) $
diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)
+{-
+Note [Return bindings in dependency order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The desugarer tries to desugar a non-recursive let-binding to a collection of
+one or more non-recursive let-bindings. The alternative is to generate a letrec
+and wait for the occurrence analyser to sort it out later, but it is pretty easy
+to arrange that the [(Id,CoreExpr)] pairs returned by dsLHsBinds are returned in
+dependency order
+
+It's most important for linear types, where non-recursive lets can be linear
+whereas recursive-let can't. Since we check the output of the desugarer for
+linearity (see also Note [Linting linearity]), desugaring non-recursive lets to
+recursive lets would break linearity checks. An alternative is to refine the
+typing rule for recursive lets so that we don't have to care (see in particular
+#23218 and #18694), but the outcome of this line of work is still unclear. In
+the meantime, being a little precise in the desugarer is cheap. (paragraph
+written on 2023-06-09)
+
+In dsLHSBinds (and dependencies), a single binding can be desugared to multiple
+bindings. For instance because the source binding has the {-# SPECIALIZE #-}
+pragma. In:
+
+f _ = …
+ where
+ {-# SPECIALIZE g :: F Int -> F Int #-}
+ g :: C a => F a -> F a
+ g _ = …
+
+The g binding desugars to
+
+let {
+ $sg = … } in
+
+ g
+ [RULES: "SPEC g" g @Int $dC = $sg]
+ g = …
+In order to avoid generating a letrec that will immediately be reordered, we
+make sure to return the binding in dependency order [$sg, g].
+
+This only matters when the source binding is non-recursive as recursive bindings
+are always desugared to a single mutually recursive block.
+
+-}
-- | Desugar all other kind of bindings, Ids of strict binds are returned to
-- later be forced in the binding group body, see Note [Desugar Strict binds]
+--
+-- Invariant: the desugared bindings are returned in dependency order,
+-- see Note [Return bindings in dependency order]
dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds binds
= do { ds_bs <- mapBagM dsLHsBind binds
@@ -134,6 +180,9 @@ dsLHsBind (L loc bind) = do dflags <- getDynFlags
putSrcSpanDs (locA loc) $ dsHsBind dflags bind
-- | Desugar a single binding (or group of recursive binds).
+--
+-- Invariant: the desugared bindings are returned in dependency order,
+-- see Note [Return bindings in dependency order]
dsHsBind :: DynFlags
-> HsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
@@ -263,7 +312,7 @@ dsAbsBinds dflags tyvars dicts exports
(isDefaultMethod prags)
(dictArity dicts) rhs
- ; return (force_vars', main_bind : fromOL spec_binds) } }
+ ; return (force_vars', fromOL spec_binds ++ [main_bind]) } }
-- Another common case: no tyvars, no dicts
-- In this case we can have a much simpler desugaring
@@ -322,7 +371,7 @@ dsAbsBinds dflags tyvars dicts exports
-- Kill the INLINE pragma because it applies to
-- the user written (local) function. The global
-- Id is just the selector. Hmm.
- ; return ((global', rhs) : fromOL spec_binds) } }
+ ; return (fromOL spec_binds ++ [(global', rhs)]) } }
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -160,17 +160,20 @@ ds_val_bind (is_rec, binds) body
-- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType
case prs of
[] -> return body
- _ -> return (Let (Rec prs) body') }
- -- Use a Rec regardless of is_rec.
- -- Why? Because it allows the binds to be all
- -- mixed up, which is what happens in one rare case
- -- Namely, for an AbsBind with no tyvars and no dicts,
- -- but which does have dictionary bindings.
- -- See notes with GHC.Tc.Solver.inferLoop [NO TYVARS]
- -- It turned out that wrapping a Rec here was the easiest solution
- --
- -- NB The previous case dealt with unlifted bindings, so we
- -- only have to deal with lifted ones now; so Rec is ok
+ _ -> return (mkLets (mk_binds is_rec prs) body') }
+ -- We can make a non-recursive let because we make sure to return
+ -- the bindings in dependency order in dsLHsBinds, see Note [Return bindings in dependency order]
+
+-- | Helper function. You can use the result of 'mk_binds' with 'mkLets' for
+-- instance.
+--
+-- * @'mk_binds' 'Recursive' binds@ makes a single mutually-recursive
+-- bindings with all the rhs/lhs pairs in @binds@
+-- * @'mk_binds' 'NonRecursive' binds@ makes one non-recursive binding
+-- for each rhs/lhs pairs in @binds@
+mk_binds :: RecFlag -> [(b, (Expr b))] -> [Bind b]
+mk_binds Recursive binds = [Rec binds]
+mk_binds NonRecursive binds = map (uncurry NonRec) binds
------------------
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -102,7 +102,6 @@ import GHC.Types.PkgQual
import GHC.Unit.External
import GHC.Unit.Module
-import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
import GHC.Unit.State
@@ -1206,16 +1205,6 @@ pprTrustInfo trust = text "trusted:" <+> ppr trust
pprTrustPkg :: Bool -> SDoc
pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg
-instance Outputable (Warnings pass) where
- ppr = pprWarns
-
-pprWarns :: Warnings pass -> SDoc
-pprWarns NoWarnings = Outputable.empty
-pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt
-pprWarns (WarnSome prs) = text "Warnings:"
- <+> vcat (map pprWarning prs)
- where pprWarning (name, txt) = ppr name <+> ppr txt
-
pprIfaceAnnotation :: IfaceAnnotation -> SDoc
pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
= ppr target <+> text "annotated by" <+> ppr serialized
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -66,6 +66,8 @@ import GHC.Types.SourceFile
import GHC.Types.TyThing
import GHC.Types.HpcInfo
import GHC.Types.CompleteMatch
+import GHC.Types.SourceText
+import GHC.Types.SrcLoc ( unLoc )
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -291,7 +293,7 @@ mkIface_ hsc_env
-- The order of fixities returned from nonDetNameEnvElts is not
-- deterministic, so we sort by OccName to canonicalize it.
-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details.
- warns = src_warns
+ warns = toIfaceWarnings src_warns
iface_rules = map coreRuleToIfaceRule rules
iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode (instEnvElts insts)
iface_fam_insts = map famInstToIfaceFamInst fam_insts
@@ -393,6 +395,21 @@ ifaceRoughMatchTcs tcs = map do_rough tcs
do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n)
--------------------------
+toIfaceWarnings :: Warnings GhcRn -> IfaceWarnings
+toIfaceWarnings NoWarnings = IfNoWarnings
+toIfaceWarnings (WarnAll txt) = IfWarnAll (toIfaceWarningTxt txt)
+toIfaceWarnings (WarnSome prs) = IfWarnSome [(occ, toIfaceWarningTxt txt) | (occ, txt) <- prs]
+
+toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
+toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc <$> mb_cat) (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs)
+
+toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])
+toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names)
+
+toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral
+toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs
+
coreRuleToIfaceRule :: CoreRule -> IfaceRule
-- A plugin that installs a BuiltinRule in a CoreDoPluginPass should
-- ensure that there's another CoreDoPluginPass that removes the rule.
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -962,7 +962,7 @@ addFingerprints hsc_env iface0
eps <- hscEPS hsc_env
let
decls = mi_decls iface0
- warn_fn = mkIfaceWarnCache (mi_warns iface0)
+ warn_fn = mkIfaceWarnCache (fromIfaceWarnings $ mi_warns iface0)
fix_fn = mkIfaceFixCache (mi_fixities iface0)
-- The ABI of a declaration represents everything that is made
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -16,6 +16,7 @@ module GHC.Iface.Syntax (
IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
+ IfaceWarnings(..), IfaceWarningTxt(..), IfaceStringLiteral(..),
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
IfaceClassBody(..), IfaceBooleanFormula(..),
IfaceBang(..),
@@ -33,6 +34,7 @@ module GHC.Iface.Syntax (
ifaceDeclImplicitBndrs, visibleIfConDecls,
ifaceDeclFingerprints,
fromIfaceBooleanFormula,
+ fromIfaceWarnings,
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
@@ -66,7 +68,9 @@ import GHC.Types.ForeignCall
import GHC.Types.Annotations( AnnPayload, AnnTarget )
import GHC.Types.Basic
import GHC.Unit.Module
+import GHC.Unit.Module.Warnings
import GHC.Types.SrcLoc
+import GHC.Types.SourceText
import GHC.Data.BooleanFormula ( BooleanFormula(..), pprBooleanFormula, isTrue )
import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike )
import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag )
@@ -74,6 +78,8 @@ import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import GHC.Builtin.Types ( constraintKindTyConName )
import GHC.Stg.InferTags.TagSig
import GHC.Parser.Annotation (noLocA)
+import GHC.Hs.Extension ( GhcRn )
+import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )
import GHC.Utils.Lexeme (isLexSym)
import GHC.Utils.Fingerprint
@@ -338,6 +344,18 @@ data IfaceRule
ifRuleOrph :: IsOrphan -- Just like IfaceClsInst
}
+data IfaceWarnings
+ = IfNoWarnings
+ | IfWarnAll IfaceWarningTxt
+ | IfWarnSome [(OccName, IfaceWarningTxt)]
+
+data IfaceWarningTxt
+ = IfWarningTxt (Maybe WarningCategory) SourceText [(IfaceStringLiteral, [IfExtName])]
+ | IfDeprecatedTxt SourceText [(IfaceStringLiteral, [IfExtName])]
+
+data IfaceStringLiteral
+ = IfStringLiteral SourceText FastString
+
data IfaceAnnotation
= IfaceAnnotation {
ifAnnotatedTarget :: IfaceAnnTarget,
@@ -564,6 +582,24 @@ ifaceDeclFingerprints hash decl
unsafeDupablePerformIO
. computeFingerprint (panic "ifaceDeclFingerprints")
+fromIfaceWarnings :: IfaceWarnings -> Warnings GhcRn
+fromIfaceWarnings = \case
+ IfNoWarnings -> NoWarnings
+ IfWarnAll txt -> WarnAll (fromIfaceWarningTxt txt)
+ IfWarnSome prs -> WarnSome [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- prs]
+
+fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
+fromIfaceWarningTxt = \case
+ IfWarningTxt mb_cat src strs -> WarningTxt (noLoc <$> mb_cat) (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs)
+ IfDeprecatedTxt src strs -> DeprecatedTxt (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs)
+
+fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn
+fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names)
+
+fromIfaceStringLiteral :: IfaceStringLiteral -> StringLiteral
+fromIfaceStringLiteral (IfStringLiteral st fs) = StringLiteral st fs Nothing
+
+
{-
************************************************************************
* *
@@ -715,6 +751,25 @@ pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs
text "--" <+> text "incompatible with:"
<+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps
+instance Outputable IfaceWarnings where
+ ppr = \case
+ IfNoWarnings -> empty
+ IfWarnAll txt -> text "Warn all" <+> ppr txt
+ IfWarnSome prs -> text "Warnings:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- prs]
+
+instance Outputable IfaceWarningTxt where
+ ppr = \case
+ IfWarningTxt _ _ ws -> pp_ws ws
+ IfDeprecatedTxt _ ds -> pp_ws ds
+ where
+ pp_ws [msg] = pp_with_name msg
+ pp_ws msgs = brackets $ vcat . punctuate comma . map pp_with_name $ msgs
+
+ pp_with_name = ppr . fst
+
+instance Outputable IfaceStringLiteral where
+ ppr (IfStringLiteral st fs) = pprWithSourceText st (ftext fs)
+
instance Outputable IfaceAnnotation where
ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value
@@ -2265,6 +2320,28 @@ instance Binary IfaceRule where
a8 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
+instance Binary IfaceWarnings where
+ put_ bh = \case
+ IfNoWarnings -> putByte bh 0
+ IfWarnAll txt -> putByte bh 1 *> put_ bh txt
+ IfWarnSome prs -> putByte bh 2 *> put_ bh prs
+ get bh = getByte bh >>= \case
+ 0 -> pure IfNoWarnings
+ 1 -> pure IfWarnAll <*> get bh
+ _ -> pure IfWarnSome <*> get bh
+
+instance Binary IfaceWarningTxt where
+ put_ bh = \case
+ IfWarningTxt a1 a2 a3 -> putByte bh 0 *> put_ bh a1 *> put_ bh a2 *> put_ bh a3
+ IfDeprecatedTxt a1 a2 -> putByte bh 1 *> put_ bh a1 *> put_ bh a2
+ get bh = getByte bh >>= \case
+ 0 -> pure IfWarningTxt <*> get bh <*> get bh <*> get bh
+ _ -> pure IfDeprecatedTxt <*> get bh <*> get bh
+
+instance Binary IfaceStringLiteral where
+ put_ bh (IfStringLiteral a1 a2) = put_ bh a1 *> put_ bh a2
+ get bh = IfStringLiteral <$> get bh <*> get bh
+
instance Binary IfaceAnnotation where
put_ bh (IfaceAnnotation a1 a2) = do
put_ bh a1
@@ -2822,5 +2899,19 @@ instance NFData IfaceClsInst where
rnf (IfaceClsInst f1 f2 f3 f4 f5) =
f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` ()
+instance NFData IfaceWarnings where
+ rnf = \case
+ IfNoWarnings -> ()
+ IfWarnAll txt -> rnf txt
+ IfWarnSome txts -> rnf txts
+
+instance NFData IfaceWarningTxt where
+ rnf = \case
+ IfWarningTxt f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
+ IfDeprecatedTxt f1 f2 -> rnf f1 `seq` rnf f2
+
+instance NFData IfaceStringLiteral where
+ rnf (IfStringLiteral f1 f2) = rnf f1 `seq` rnf f2
+
instance NFData IfaceAnnotation where
rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` ()
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -47,6 +47,7 @@ import GHC.Tc.Zonk.TcType ( tcInitTidyEnv )
import GHC.Hs
import GHC.Iface.Load ( loadSrcInterface )
+import GHC.Iface.Syntax ( fromIfaceWarnings )
import GHC.Builtin.Names
import GHC.Parser.PostProcess ( setRdrNameSpace )
import GHC.Core.Type
@@ -422,7 +423,7 @@ rnImportDecl this_mod
imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv)
-- Complain if we import a deprecated module
- case mi_warns iface of
+ case fromIfaceWarnings (mi_warns iface) of
WarnAll txt -> addDiagnostic (TcRnDeprecatedModule imp_mod_name txt)
_ -> return ()
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -2316,7 +2316,7 @@ mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) = case (NE.nonEm
(Nothing, _) -> do -- No matches but perhaps several unifiers
{ (_, rel_binds, item) <- relevantBindings True ctxt item
; candidate_insts <- get_candidate_instances
- ; (imp_errs, field_suggestions) <- record_field_suggestions
+ ; (imp_errs, field_suggestions) <- record_field_suggestions item
; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) }
-- Some matches => overlap errors
@@ -2352,13 +2352,33 @@ mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) = case (NE.nonEm
| otherwise = False
-- See Note [Out-of-scope fields with -XOverloadedRecordDot]
- record_field_suggestions :: TcM ([ImportError], [GhcHint])
- record_field_suggestions = flip (maybe $ return ([], noHints)) record_field $ \name ->
+ record_field_suggestions :: ErrorItem -> TcM ([ImportError], [GhcHint])
+ record_field_suggestions item = flip (maybe $ return ([], noHints)) record_field $ \name ->
do { glb_env <- getGlobalRdrEnv
; lcl_env <- getLocalRdrEnv
- ; if occ_name_in_scope glb_env lcl_env name
- then return ([], noHints)
- else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name) }
+ ; let field_name_hints = report_no_fieldnames item
+ ; (errs, hints) <- if occ_name_in_scope glb_env lcl_env name
+ then return ([], noHints)
+ else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name)
+ ; pure (errs, hints ++ field_name_hints)
+ }
+
+ -- get type names from instance
+ -- resolve the type - if it's in scope is it a record?
+ -- if it's a record, report an error - the record name + the field that could not be found
+ report_no_fieldnames :: ErrorItem -> [GhcHint]
+ report_no_fieldnames item
+ | Just (EvVarDest evvar) <- ei_evdest item
+ -- we can assume that here we have a `HasField @Symbol x r a` instance
+ -- because of HasFieldOrigin in record_field
+ , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar)
+ , Just (r_tycon, _) <- tcSplitTyConApp_maybe r
+ , Just x_name <- isStrLitTy x
+ -- we check that this is a record type by checking whether it has any
+ -- fields (in scope)
+ , not . null $ tyConFieldLabels r_tycon
+ = [RemindRecordMissingField x_name r a]
+ | otherwise = []
occ_name_in_scope glb_env lcl_env occ_name = not $
null (lookupGRE_OccName (IncludeFields WantNormal) glb_env occ_name) &&
=====================================
compiler/GHC/Types/Hint.hs
=====================================
@@ -35,7 +35,7 @@ import GHC.Hs.Extension (GhcTc, GhcRn)
import GHC.Core.Coercion
import GHC.Core.FamInstEnv (FamFlavor)
import GHC.Core.TyCon (TyCon)
-import GHC.Core.Type (PredType)
+import GHC.Core.Type (PredType, Type)
import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName)
import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec)
@@ -44,7 +44,7 @@ import GHC.Types.Basic (Activation, RuleName)
import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) )
import GHC.Parser.Errors.Basic
import GHC.Utils.Outputable
-import GHC.Data.FastString (fsLit)
+import GHC.Data.FastString (fsLit, FastString)
import Data.Typeable ( Typeable )
@@ -465,6 +465,9 @@ data GhcHint
{-| Suggest eta-reducing a type synonym used in the implementation
of abstract data. -}
| SuggestEtaReduceAbsDataTySyn TyCon
+ {-| Remind the user that there is no field of a type and name in the record,
+ constructors are in the usual order $x$, $r$, $a$ -}
+ | RemindRecordMissingField FastString Type Type
{-| Suggest binding the type variable on the LHS of the type declaration
-}
| SuggestBindTyVarOnLhs RdrName
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -14,6 +14,7 @@ import GHC.Types.Hint
import GHC.Core.FamInstEnv (FamFlavor(..))
import GHC.Core.TyCon
+import GHC.Core.TyCo.Rep ( mkVisFunTyMany )
import GHC.Hs.Expr () -- instance Outputable
import GHC.Tc.Types.Origin ( ClsInstOrQC(..) )
import GHC.Types.Id
@@ -251,6 +252,12 @@ instance Outputable GhcHint where
SuggestEtaReduceAbsDataTySyn tc
-> text "If possible, eta-reduce the type synonym" <+> ppr_tc <+> text "so that it is nullary."
where ppr_tc = quotes (ppr $ tyConName tc)
+ RemindRecordMissingField x r a ->
+ text "NB: There is no field selector" <+> ppr_sel
+ <+> text "in scope for record type" <+> ppr_r
+ where ppr_sel = quotes (ftext x <+> dcolon <+> ppr_arr_r_a)
+ ppr_arr_r_a = ppr $ mkVisFunTyMany r a
+ ppr_r = quotes $ ppr r
SuggestBindTyVarOnLhs tv
-> text "Bind" <+> quotes (ppr tv) <+> text "on the LHS of the type declaration"
=====================================
compiler/GHC/Types/SourceText.hs
=====================================
@@ -1,5 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Source text
--
@@ -39,6 +41,7 @@ import Data.Function (on)
import Data.Data
import GHC.Real ( Ratio(..) )
import GHC.Types.SrcLoc
+import Control.DeepSeq
{-
Note [Pragma source text]
@@ -107,6 +110,11 @@ instance Outputable SourceText where
ppr (SourceText s) = text "SourceText" <+> ftext s
ppr NoSourceText = text "NoSourceText"
+instance NFData SourceText where
+ rnf = \case
+ SourceText s -> rnf s
+ NoSourceText -> ()
+
instance Binary SourceText where
put_ bh NoSourceText = putByte bh 0
put_ bh (SourceText s) = do
@@ -315,12 +323,3 @@ instance Eq StringLiteral where
instance Outputable StringLiteral where
ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)
-
-instance Binary StringLiteral where
- put_ bh (StringLiteral st fs _) = do
- put_ bh st
- put_ bh fs
- get bh = do
- st <- get bh
- fs <- get bh
- return (StringLiteral st fs Nothing)
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -185,7 +185,7 @@ data ModIface_ (phase :: ModIfacePhase)
-- ^ Fixities
-- NOT STRICT! we read this field lazily from the interface file
- mi_warns :: (Warnings GhcRn),
+ mi_warns :: IfaceWarnings,
-- ^ Warnings
-- NOT STRICT! we read this field lazily from the interface file
@@ -479,7 +479,7 @@ instance Binary ModIface where
mi_finsts = hasFamInsts,
mi_exp_hash = exp_hash,
mi_orphan_hash = orphan_hash,
- mi_warn_fn = mkIfaceWarnCache warns,
+ mi_warn_fn = mkIfaceWarnCache $ fromIfaceWarnings warns,
mi_fix_fn = mkIfaceFixCache fixities,
mi_hash_fn = mkIfaceHashCache decls
}})
@@ -498,7 +498,7 @@ emptyPartialModIface mod
mi_exports = [],
mi_used_th = False,
mi_fixities = [],
- mi_warns = NoWarnings,
+ mi_warns = IfNoWarnings,
mi_anns = [],
mi_insts = [],
mi_fam_insts = [],
@@ -567,7 +567,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
`seq` mi_exports
`seq` rnf mi_used_th
`seq` mi_fixities
- `seq` mi_warns
+ `seq` rnf mi_warns
`seq` rnf mi_anns
`seq` rnf mi_decls
`seq` rnf mi_extra_decls
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -5,6 +5,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE LambdaCase #-}
-- | Warnings for a module
module GHC.Unit.Module.Warnings
@@ -40,7 +41,6 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Hs.Doc
-import GHC.Hs.Extension
import GHC.Utils.Outputable
import GHC.Utils.Binary
@@ -51,6 +51,7 @@ import Language.Haskell.Syntax.Extension
import Data.Data
import Data.List (isPrefixOf)
import GHC.Generics ( Generic )
+import Control.DeepSeq
{-
@@ -103,7 +104,7 @@ the possibility of them being infinite.
-- See Note [Warning categories]
newtype WarningCategory = WarningCategory FastString
- deriving (Binary, Data, Eq, Outputable, Show, Uniquable)
+ deriving (Binary, Data, Eq, Outputable, Show, Uniquable, NFData)
mkWarningCategory :: FastString -> WarningCategory
mkWarningCategory = WarningCategory
@@ -203,29 +204,6 @@ instance Outputable (WarningTxt pass) where
NoSourceText -> pp_ws ds
SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
-instance Binary (WarningTxt GhcRn) where
- put_ bh (WarningTxt c s w) = do
- putByte bh 0
- put_ bh $ unLoc <$> c
- put_ bh $ unLoc s
- put_ bh $ unLoc <$> w
- put_ bh (DeprecatedTxt s d) = do
- putByte bh 1
- put_ bh $ unLoc s
- put_ bh $ unLoc <$> d
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do c <- fmap noLoc <$> get bh
- s <- noLoc <$> get bh
- w <- fmap noLoc <$> get bh
- return (WarningTxt c s w)
- _ -> do s <- noLoc <$> get bh
- d <- fmap noLoc <$> get bh
- return (DeprecatedTxt s d)
-
-
pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [l] = ppr $ unLoc l
pp_ws ws
@@ -271,24 +249,6 @@ data Warnings pass
deriving instance Eq (IdP pass) => Eq (Warnings pass)
-instance Binary (Warnings GhcRn) where
- put_ bh NoWarnings = putByte bh 0
- put_ bh (WarnAll t) = do
- putByte bh 1
- put_ bh t
- put_ bh (WarnSome ts) = do
- putByte bh 2
- put_ bh ts
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return NoWarnings
- 1 -> do aa <- get bh
- return (WarnAll aa)
- _ -> do aa <- get bh
- return (WarnSome aa)
-
-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
mkIfaceWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p)
mkIfaceWarnCache NoWarnings = \_ -> Nothing
=====================================
rts/posix/Signals.c
=====================================
@@ -522,7 +522,9 @@ shutdown_handler(int sig STG_UNUSED)
// extreme prejudice. So the first ^C tries to exit the program
// cleanly, and the second one just kills it.
if (getSchedState() >= SCHED_INTERRUPTING) {
- stg_exit(EXIT_INTERRUPTED);
+ // N.B. we cannot use stg_exit() here as it calls exit() which is not
+ // signal-safe. See #23417.
+ _exit(EXIT_INTERRUPTED);
} else {
interruptStgRts();
}
=====================================
testsuite/tests/ghci/should_run/T16096.stdout
=====================================
@@ -1,6 +1,6 @@
==================== Desugared ====================
-letrec {
+let {
x :: [GHC.Types.Int]
[LclId]
x = let {
@@ -11,7 +11,7 @@ letrec {
x :: [GHC.Types.Int]
[LclId]
x = GHC.Enum.enumFrom @GHC.Types.Int $dEnum (GHC.Types.I# 1#); } in
- x; } in
+ x } in
GHC.Base.returnIO
@[GHC.Types.Any]
(GHC.Types.:
@@ -27,7 +27,7 @@ GHC.Base.returnIO
==================== Desugared ====================
-letrec {
+let {
x :: [GHC.Types.Int]
[LclId]
x = let {
@@ -38,7 +38,7 @@ letrec {
x :: [GHC.Types.Int]
[LclId]
x = GHC.Enum.enumFrom @GHC.Types.Int $dEnum (GHC.Types.I# 1#); } in
- x; } in
+ x } in
GHC.Base.returnIO
@[GHC.Types.Any]
(GHC.Types.:
=====================================
testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
=====================================
@@ -18,6 +18,7 @@ RecordDotSyntaxFail8.hs:37:3: error: [GHC-39999]
RecordDotSyntaxFail8.hs:37:11: error: [GHC-39999]
• No instance for ‘HasField "quux" Quux a0’
arising from selecting the field ‘quux’
+ NB: There is no field selector ‘quux :: Quux -> a0’ in scope for record type ‘Quux’
• In the second argument of ‘($)’, namely ‘....baz.quux’
In a stmt of a 'do' block: print $ ....baz.quux
In the expression:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e47ff7b14e61ee55b498d8348d6081c96bb8945d...4e3265fda3e8cb57ccc47a12cb0a45ae2a91c4a4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e47ff7b14e61ee55b498d8348d6081c96bb8945d...4e3265fda3e8cb57ccc47a12cb0a45ae2a91c4a4
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/20230619/d594ffc1/attachment-0001.html>
More information about the ghc-commits
mailing list