[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Add structured error messages for GHC.Tc.TyCl.Utils
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Apr 11 08:32:50 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
6a788f0a by Torsten Schmits at 2023-04-07T22:29:28-04:00
Add structured error messages for GHC.Tc.TyCl.Utils
Tracking ticket: #20117
MR: !10251
This converts uses of `mkTcRnUnknownMessage` to newly added constructors
of `TcRnMessage`.
- - - - -
3ba77b36 by sheaf at 2023-04-07T22:30:07-04:00
Renamer: don't call addUsedGRE on an exact Name
When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc,
we could end up calling addUsedGRE on an exact Name, which would then
lead to a panic in the bestImport function: it would be incapable of
processing a GRE which is not local but also not brought into scope
by any imports (as it is referred to by its unique instead).
Fixes #23240
- - - - -
166d19f1 by Cheng Shao at 2023-04-11T04:32:38-04:00
compiler: make WasmCodeGenM an instance of MonadUnique
- - - - -
919e1ece by Cheng Shao at 2023-04-11T04:32:38-04:00
compiler: apply cmm node-splitting for wasm backend
This patch applies cmm node-splitting for wasm32 NCG, which is
required when handling irreducible CFGs. Fixes #23237.
- - - - -
3cf6809e by Bodigrim at 2023-04-11T04:32:41-04:00
Set base 'maintainer' field to CLC
- - - - -
17 changed files:
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/Wasm/Types.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Wasm/ControlFlow/FromCmm.hs
- libraries/base/base.cabal
- testsuite/tests/backpack/should_fail/bkpfail29.stderr
- testsuite/tests/ghc-e/should_fail/ghc-e-fail2.stderr
- testsuite/tests/module/mod27.stderr
- + testsuite/tests/rename/should_compile/T23240.hs
- + testsuite/tests/rename/should_compile/T23240_aux.hs
- testsuite/tests/rename/should_compile/all.T
Changes:
=====================================
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Types.ForeignCall
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Map
+import GHC.Types.Unique.Supply
import GHC.Utils.Outputable hiding ((<>))
import GHC.Utils.Panic
import GHC.Wasm.ControlFlow.FromCmm
@@ -1328,7 +1329,7 @@ lower_CmmUnsafeForeignCall_Drop ::
[CmmActual] ->
WasmCodeGenM w (WasmStatements w)
lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do
- ret_uniq <- wasmUniq
+ ret_uniq <- getUniqueM
let ret_local = LocalReg ret_uniq ret_cmm_ty
lower_CmmUnsafeForeignCall
lbl
@@ -1528,9 +1529,11 @@ lower_CmmGraph :: CLabel -> CmmGraph -> WasmCodeGenM w (FuncBody w)
lower_CmmGraph lbl g = do
ty_word <- wasmWordTypeM
platform <- wasmPlatformM
+ us <- getUniqueSupplyM
body <-
structuredControl
platform
+ us
(\_ -> lower_CmmExpr_Typed lbl ty_word)
(lower_CmmActions lbl)
g
=====================================
compiler/GHC/CmmToAsm/Wasm/Types.hs
=====================================
@@ -45,7 +45,6 @@ module GHC.CmmToAsm.Wasm.Types
wasmStateM,
wasmModifyM,
wasmExecM,
- wasmUniq,
)
where
@@ -466,10 +465,18 @@ wasmStateM = coerce . State
wasmModifyM :: (WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w ()
wasmModifyM = coerce . modify
+wasmEvalM :: WasmCodeGenM w a -> WasmCodeGenState w -> a
+wasmEvalM (WasmCodeGenM s) = evalState s
+
wasmExecM :: WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w
wasmExecM (WasmCodeGenM s) = execState s
-wasmUniq :: WasmCodeGenM w Unique
-wasmUniq = wasmStateM $
- \s at WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of
- (u, us) -> (# u, s {wasmUniqSupply = us} #)
+instance MonadUnique (WasmCodeGenM w) where
+ getUniqueSupplyM = wasmGetsM wasmUniqSupply
+ getUniqueM = wasmStateM $
+ \s at WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of
+ (u, us) -> (# u, s {wasmUniqSupply = us} #)
+ getUniquesM = do
+ u <- getUniqueM
+ s <- WasmCodeGenM get
+ pure $ u:(wasmEvalM getUniquesM s)
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -534,30 +534,29 @@ lookupRecFieldOcc mb_con rdr_name
= return $ mk_unbound_rec_fld con
| Just con <- mb_con
= do { let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name)
- ; res <- lookupExactOrOrig rdr_name ensure_recfld $ -- See Note [Record field names and Template Haskell]
+ ; mb_nm <- lookupExactOrOrig rdr_name ensure_recfld $ -- See Note [Record field names and Template Haskell]
do { flds <- lookupConstructorFields con
; env <- getGlobalRdrEnv
- ; let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name)
- mb_gre = do fl <- find ((== lbl) . flLabel) flds
+ ; let mb_gre = do fl <- find ((== lbl) . flLabel) flds
-- We have the label, now check it is in scope. If
-- there is a qualifier, use pickGREs to check that
-- the qualifier is correct, and return the filtered
-- GRE so we get import usage right (see #17853).
gre <- lookupGRE_FieldLabel env fl
if isQual rdr_name
- then listToMaybe (pickGREs rdr_name [gre])
+ then listToMaybe $ pickGREs rdr_name [gre]
else return gre
; traceRn "lookupRecFieldOcc" $
vcat [ text "mb_con:" <+> ppr mb_con
, text "rdr_name:" <+> ppr rdr_name
, text "flds:" <+> ppr flds
, text "mb_gre:" <+> ppr mb_gre ]
- ; return mb_gre }
- ; case res of
+ ; mapM_ (addUsedGRE True) mb_gre
+ ; return $ flSelector . fieldGRELabel <$> mb_gre }
+ ; case mb_nm of
{ Nothing -> do { addErr (badFieldConErr con lbl)
; return $ mk_unbound_rec_fld con }
- ; Just gre -> do { addUsedGRE True gre
- ; return (flSelector $ fieldGRELabel gre) } } }
+ ; Just nm -> return nm } }
| otherwise -- Can't use the data constructor to disambiguate
= greName <$> lookupGlobalOccRn' (IncludeFields WantField) rdr_name
@@ -572,7 +571,9 @@ lookupRecFieldOcc mb_con rdr_name
mkRecFieldOccFS (getOccFS con) (occNameFS occ)
occ = rdrNameOcc rdr_name
- ensure_recfld gre = do { guard (isRecFldGRE gre) ; return gre }
+ ensure_recfld :: GlobalRdrElt -> Maybe Name
+ ensure_recfld gre = do { guard (isRecFldGRE gre)
+ ; return $ greName gre }
{- Note [DisambiguateRecordFields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -1855,7 +1855,10 @@ mkImportMap gres
RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map
UnhelpfulLoc _ -> imp_map
where
- best_imp_spec = bestImport (bagToList imp_specs)
+ best_imp_spec =
+ case bagToList imp_specs of
+ [] -> pprPanic "mkImportMap: GRE with no ImportSpecs" (ppr gre)
+ is:iss -> bestImport (is NE.:| iss)
add _ gres = gre : gres
warnUnusedImport :: WarningFlag -> GlobalRdrEnv
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1716,6 +1716,18 @@ instance Diagnostic TcRnMessage where
-> mkSimpleDecorated $
text "Illegal" <+> (text $ levelString typeOrKind) <> colon <+> quotes (ppr thing)
+ TcRnTypeSynonymCycle decl_or_tcs
+ -> mkSimpleDecorated $
+ sep [ text "Cycle in type synonym declarations:"
+ , nest 2 (vcat (map ppr_decl decl_or_tcs)) ]
+ where
+ ppr_decl = \case
+ Right (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl
+ Left tc ->
+ let n = tyConName tc
+ in ppr (getSrcSpan n) <> colon <+> ppr (tyConName tc)
+ <+> text "from external module"
+
diagnosticReason = \case
TcRnUnknownMessage m
@@ -2286,6 +2298,8 @@ instance Diagnostic TcRnMessage where
-> WarningWithFlag Opt_WarnUnusedForalls
TcRnDataKindsError{}
-> ErrorWithoutFlag
+ TcRnTypeSynonymCycle{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2883,6 +2897,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnDataKindsError{}
-> [suggestExtension LangExt.DataKinds]
+ TcRnTypeSynonymCycle{}
+ -> noHints
diagnosticCode = constructorCode
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -108,6 +108,7 @@ module GHC.Tc.Errors.Types (
, TyFamsDisabledReason(..)
, HsTypeOrSigType(..)
, HsTyVarBndrExistentialFlag(..)
+ , TySynCycleTyCons
) where
import GHC.Prelude
@@ -3787,6 +3788,15 @@ data TcRnMessage where
-> HsExpr GhcPs -- ^ Section
-> TcRnMessage
+ {-| TcRnTypeSynonymCycle is an error indicating that a cycle between type
+ synonyms has occurred.
+
+ Test cases:
+ mod27, ghc-e-fail2, bkpfail29
+ -}
+ TcRnTypeSynonymCycle :: !TySynCycleTyCons -- ^ The tycons involved in the cycle
+ -> TcRnMessage
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
@@ -5192,3 +5202,6 @@ data HsTyVarBndrExistentialFlag = forall flag. OutputableBndrFlag flag 'Renamed
instance Outputable HsTyVarBndrExistentialFlag where
ppr (HsTyVarBndrExistentialFlag hsTyVarBndr) = ppr hsTyVarBndr
+
+type TySynCycleTyCons =
+ [Either TyCon (LTyClDecl GhcRn)]
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -65,7 +65,6 @@ import GHC.Data.FastString
import GHC.Unit.Module
import GHC.Types.Basic
-import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
@@ -168,7 +167,7 @@ synonymTyConsOfType ty
-- track of the TyCons which are known to be acyclic, or
-- a failure message reporting that a cycle was found.
newtype SynCycleM a = SynCycleM {
- runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
+ runSynCycleM :: SynCycleState -> Either (SrcSpan, TySynCycleTyCons) (a, SynCycleState) }
deriving (Functor)
-- TODO: TyConSet is implemented as IntMap over uniques.
@@ -188,8 +187,8 @@ instance Monad SynCycleM where
runSynCycleM (f x) state'
Left err -> Left err
-failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
-failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)
+failSynCycleM :: SrcSpan -> TySynCycleTyCons -> SynCycleM ()
+failSynCycleM loc seen_tcs = SynCycleM $ \_ -> Left (loc, seen_tcs)
-- | Test if a 'Name' is acyclic, short-circuiting if we've
-- seen it already.
@@ -209,7 +208,7 @@ checkTyConIsAcyclic tc m = SynCycleM $ \s ->
checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
checkSynCycles this_uid tcs tyclds =
case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of
- Left (loc, err) -> setSrcSpan loc $ failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err)
+ Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnTypeSynonymCycle err)
Right _ -> return ()
where
-- Try our best to print the LTyClDecl for locally defined things
@@ -226,9 +225,7 @@ checkSynCycles this_uid tcs tyclds =
go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
go' so_far seen_tcs tc
| tc `elemTyConSet` so_far
- = failSynCycleM (getSrcSpan (head seen_tcs)) $
- sep [ text "Cycle in type synonym declarations:"
- , nest 2 (vcat (map ppr_decl seen_tcs)) ]
+ = failSynCycleM (getSrcSpan (head seen_tcs)) (lookup_decl <$> seen_tcs)
-- Optimization: we don't allow cycles through external packages,
-- so once we find a non-local name we are guaranteed to not
-- have a cycle.
@@ -245,13 +242,10 @@ checkSynCycles this_uid tcs tyclds =
where
n = tyConName tc
mod = nameModule n
- ppr_decl tc =
- case lookupNameEnv lcl_decls n of
- Just (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl
- Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n
- <+> text "from external module"
- where
- n = tyConName tc
+ lookup_decl tc =
+ case lookupNameEnv lcl_decls (tyConName tc) of
+ Just decl -> Right decl
+ Nothing -> Left tc
go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM ()
go_ty so_far seen_tcs ty =
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -578,6 +578,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnRoleAnnotationsDisabled" = 17779
GhcDiagnosticCode "TcRnIncoherentRoles" = 18273
GhcDiagnosticCode "TcRnTyFamNameMismatch" = 88221
+ GhcDiagnosticCode "TcRnTypeSynonymCycle" = 97522
-- TcRnBadFieldAnnotation/BadFieldAnnotationReason
GhcDiagnosticCode "LazyFieldsDisabled" = 81601
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -126,7 +126,6 @@ import GHC.Utils.Panic
import Control.DeepSeq
import Control.Monad ( guard )
import Data.Data
-import Data.List ( sortBy )
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Semigroup as S
@@ -1654,12 +1653,9 @@ data ImpItemSpec
-- only @T@ is named explicitly.
deriving (Eq, Data)
-bestImport :: [ImportSpec] -> ImportSpec
+bestImport :: NE.NonEmpty ImportSpec -> ImportSpec
-- See Note [Choosing the best import declaration]
-bestImport iss
- = case sortBy best iss of
- (is:_) -> is
- [] -> pprPanic "bestImport" (ppr iss)
+bestImport iss = NE.head $ NE.sortBy best iss
where
best :: ImportSpec -> ImportSpec -> Ordering
-- Less means better
=====================================
compiler/GHC/Wasm/ControlFlow/FromCmm.hs
=====================================
@@ -19,12 +19,13 @@ import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dominators
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Reducibility
import GHC.Cmm.Switch
import GHC.CmmToAsm.Wasm.Types
import GHC.Platform
-
+import GHC.Types.Unique.Supply
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr
@@ -140,15 +141,19 @@ emptyPost _ = False
structuredControl :: forall expr stmt m .
Applicative m
=> Platform -- ^ needed for offset calculation
+ -> UniqSupply
-> (Label -> CmmExpr -> m expr) -- ^ translator for expressions
-> (Label -> CmmActions -> m stmt) -- ^ translator for straight-line code
-> CmmGraph -- ^ CFG to be translated
-> m (WasmControl stmt expr '[] '[ 'I32])
-structuredControl platform txExpr txBlock g =
+structuredControl platform us txExpr txBlock g' =
doTree returns dominatorTree emptyContext
where
+ g :: CmmGraph
+ g = gwd_graph gwd
+
gwd :: GraphWithDominators CmmNode
- gwd = graphWithDominators g
+ gwd = initUs_ us $ asReducible $ graphWithDominators g'
dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted
-- with highest reverse-postorder number first
=====================================
libraries/base/base.cabal
=====================================
@@ -5,8 +5,8 @@ version: 4.18.0.0
license: BSD-3-Clause
license-file: LICENSE
-maintainer: libraries at haskell.org
-bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new
+maintainer: Core Libraries Committee <core-libraries-committee at haskell.org>
+bug-reports: https://github.com/haskell/core-libraries-committee/issues
synopsis: Basic libraries
category: Prelude
build-type: Configure
=====================================
testsuite/tests/backpack/should_fail/bkpfail29.stderr
=====================================
@@ -5,7 +5,7 @@
[3 of 3] Processing r
[1 of 4] Compiling A[sig] ( r/A.hsig, nothing )
-bkpfail29.bkp:8:9: error:
+bkpfail29.bkp:8:9: error: [GHC-97522]
• Cycle in type synonym declarations:
bkpfail29.bkp:8:9-18: S from external module
bkpfail29.bkp:7:9-14: T from external module
=====================================
testsuite/tests/ghc-e/should_fail/ghc-e-fail2.stderr
=====================================
@@ -1,5 +1,5 @@
-<interactive>:0:1: error:
+<interactive>:0:1: error: [GHC-97522]
Cycle in type synonym declarations:
<interactive>:0:1-10: type A = A
1
=====================================
testsuite/tests/module/mod27.stderr
=====================================
@@ -1,5 +1,5 @@
-mod27.hs:3:1: error:
+mod27.hs:3:1: error: [GHC-97522]
Cycle in type synonym declarations:
mod27.hs:3:1-18: type T1 = (Int, T2)
mod27.hs:4:1-18: type T2 = (Int, T1)
=====================================
testsuite/tests/rename/should_compile/T23240.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- Crucial to triggering the bug.
+{-# LANGUAGE DisambiguateRecordFields #-}
+
+-- Need to enable the unused imports warning to trigger the bug.
+{-# OPTIONS_GHC -Wunused-imports #-}
+
+module T23240 ( test ) where
+import T23240_aux ( D, mkD )
+
+test :: D
+test = $$mkD
=====================================
testsuite/tests/rename/should_compile/T23240_aux.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module T23240_aux where
+
+import Language.Haskell.TH ( CodeQ )
+
+data D = MkD { myFld :: () }
+mkD :: CodeQ D
+mkD = [|| MkD { myFld = () } ||]
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -209,3 +209,4 @@ test('ImportNullaryRecordWildcard', [extra_files(['NullaryRecordWildcard.hs', 'N
test('GHCINullaryRecordWildcard', combined_output, ghci_script, ['GHCINullaryRecordWildcard.script'])
test('GHCIImplicitImportNullaryRecordWildcard', combined_output, ghci_script, ['GHCIImplicitImportNullaryRecordWildcard.script'])
test('T22122', [expect_broken(22122), extra_files(['T22122_aux.hs'])], multimod_compile, ['T22122', '-v0'])
+test('T23240', [req_th, extra_files(['T23240_aux.hs'])], multimod_compile, ['T23240', '-v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ff849e25c4a5cf4d56611482014c9ddd46c4fa6...3cf6809efb65a286349c4b453bc38ccaed03c90c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ff849e25c4a5cf4d56611482014c9ddd46c4fa6...3cf6809efb65a286349c4b453bc38ccaed03c90c
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/20230411/fc8e74df/attachment-0001.html>
More information about the ghc-commits
mailing list