Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 0f713406 by Simon Peyton Jones at 2026-03-25T00:05:18+00:00 Onward more - - - - - 21 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Name.hs - libraries/ghc-internal/src/GHC/Internal/Arr.hs - libraries/ghc-internal/src/GHC/Internal/Data/STRef.hs - libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Event/IntVar.hs - libraries/ghc-internal/src/GHC/Internal/Event/Unique.hs - libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs - libraries/ghc-internal/src/GHC/Internal/Num.hs - libraries/ghc-internal/src/GHC/Internal/ST.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -127,7 +127,6 @@ import GHC.Types.SrcLoc import GHC.Builtin.Uniques import GHC.Builtin.Names.TH( thKnownKeyTable ) -import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( HasDebugCallStack ) @@ -204,13 +203,6 @@ knownKeyOccName std_uniq Just occ -> occ Nothing -> pprPanic "knownKeyOccName" (pprKnownKey std_uniq) -pprKnownKey :: KnownKeyNameKey -> SDoc --- Show it in both base64 and decimal, for debugging -pprKnownKey uniq - = ppr uniq <+> braces (text (show tag) <+> ppr u) - where - (tag, u) = unpkUnique uniq - basicKnownKeyTable :: [(OccName, KnownKeyNameKey)] basicKnownKeyTable = [ (mkTcOcc "Rational", rationalTyConKey) @@ -2280,7 +2272,7 @@ enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 eqClassOpKey = mkPreludeMiscIdUnique 167 geClassOpKey = mkPreludeMiscIdUnique 168 negateClassOpKey = mkPreludeMiscIdUnique 169 -bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) +bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) 02L thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) fmapClassOpKey = mkPreludeMiscIdUnique 173 returnMClassOpKey = mkPreludeMiscIdUnique 174 ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -567,7 +567,8 @@ dsLookupKnownKey :: KnownKeyNameKey -> DsM TyThing dsLookupKnownKey uniq = do { rebindable_path <- goptM Opt_RebindableKnownKeyNames ; mb_rdr_env <- if rebindable_path - then KKNS_InScope <$> dsGetGlobalRdrEnv + then do { rdr_env <- dsGetGlobalRdrEnv + ; return (KKNS_InScope rdr_env) } else return KKNS_FromModule ; dsToIfL $ do { mb_res <- lookupKnownKeyThing mb_rdr_env uniq ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -60,10 +60,11 @@ interfaceErrorHints :: IfaceMessage -> [GhcHint] interfaceErrorHints = \ case Can'tFindInterface err _looking_for -> missingInterfaceErrorHints err - Can'tFindNameInInterface {} -> - noHints - CircularImport {} -> - noHints + Can'tFindNameInInterface {} -> noHints + CircularImport {} -> noHints + MissingKnownKey1 {} -> noHints + MissingKnownKey2 {} -> noHints + KnownKeyScopeError {} -> noHints missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint] missingInterfaceErrorHints = \case @@ -85,8 +86,10 @@ interfaceErrorReason (Can'tFindInterface err _) = missingInterfaceErrorReason err interfaceErrorReason (Can'tFindNameInInterface {}) = ErrorWithoutFlag -interfaceErrorReason (CircularImport {}) - = ErrorWithoutFlag +interfaceErrorReason (CircularImport {}) = ErrorWithoutFlag +interfaceErrorReason (MissingKnownKey1 {}) = ErrorWithoutFlag +interfaceErrorReason (MissingKnownKey2 {}) = ErrorWithoutFlag +interfaceErrorReason (KnownKeyScopeError {}) = ErrorWithoutFlag missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason missingInterfaceErrorReason = \ case @@ -290,6 +293,18 @@ interfaceErrorDiagnostic opts = \ case CircularImport mod -> text "Circular imports: module" <+> quotes (ppr mod) <+> text "depends on itself" + MissingKnownKey1 key -> hang (text "Could not find known key" <+> quotes (pprKnownKey key)) + 2 (text "in the exports of GHC.KnownKeys") + MissingKnownKey2 key -> hang (text "Could not find known key" <+> quotes (pprKnownKey key)) + 2 (text "in the static known-key table") + KnownKeyScopeError _key occ gres + | null gres + -> hang (text "Could not find known-key entity" <+> quotes (ppr occ)) + 2 (vcat [ text "in the top-level global environment" + , text "Consider importing it" ]) + | otherwise + -> hang (text "Known-key entity" <+> quotes (ppr occ)) + 2 (text "is ambiguous in the top-level global environment") lookingForHerald :: InterfaceLookingFor -> SDoc lookingForHerald looking_for = ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -16,7 +16,9 @@ module GHC.Iface.Errors.Types ( import GHC.Prelude -import GHC.Types.Name (Name) +import GHC.Types.Name (Name, KnownKeyNameKey) +import GHC.Types.Name.Occurrence (OccName) +import GHC.Types.Name.Reader (GlobalRdrElt) import GHC.Types.TyThing (TyThing) import GHC.Unit.Types (Module, InstalledModule, UnitId, Unit) import GHC.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnit, UnitInfo) @@ -43,10 +45,24 @@ data IfaceMessage = Can'tFindInterface MissingInterfaceError InterfaceLookingFor + | Can'tFindNameInInterface Name [TyThing] -- possibly relevant TyThings + | CircularImport !Module + + | MissingKnownKey1 KnownKeyNameKey + -- We looked up a known-key, but it wasn't in the + -- known-key map that came from importing GHC.KnownKeyNames + + | MissingKnownKey2 KnownKeyNameKey + -- We looked up a known-key, but it wasn't in + -- the `knownKeyTable` of all known keys + + | KnownKeyScopeError KnownKeyNameKey OccName [GlobalRdrElt] + -- We looked up a known-key in the GlobalRdrEnv, + -- but did not find a unique hit deriving Generic data MissingInterfaceError ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -157,43 +157,35 @@ lookupKnownKeyThing :: HasDebugCallStack => KnownKeyNameSource -> KnownKeyNameKey -> IfM lcl (MaybeErr IfaceMessage TyThing) lookupKnownKeyThing mb_gbl_rdr_env key - = do { name <- lookupKnownKeyName mb_gbl_rdr_env key - ; lookupGlobalName name } + = do { mb_name <- lookupKnownKeyName mb_gbl_rdr_env key + ; case mb_name of + Failed err -> return (Failed err) + Succeeded name -> lookupGlobalName name } lookupKnownKeyName :: HasDebugCallStack => KnownKeyNameSource -> KnownKeyNameKey - -> IfM lcl Name + -> IfM lcl (MaybeErr IfaceMessage Name) lookupKnownKeyName KKNS_FromModule uniq = do { known_key_name_map :: UniqFM KnownKeyNameKey Name <- loadKnownKeyOccMap - ; let name = lookupUFM known_key_name_map uniq - `orElse` pprPanic "lookupKnownKeyThing 1" - (vcat [ text "unique:" <+> ppr uniq - , text "occ-map" <+> ppr known_key_name_map ]) - ; traceIf $ hang (text "lookupKnownKeyThing ImplicitKnownKeyNames") - 2 (ppr name <+> ppr uniq) - ; return name } + ; case lookupUFM known_key_name_map uniq of + Just name -> return (Succeeded name) + Nothing -> return (Failed (MissingKnownKey1 uniq)) } lookupKnownKeyName (KKNS_InScope gbl_rdr_env) uniq -- Just gbl_rdr_env: we have -frebindable-known-key-names on, and -- here is the top-level GlobalRdrEnv -- Look up the known-key OccName in the GlobalRdrEnv -- If we get a unique hit, use it; if not, panic. - | let occ :: OccName - occ = lookupUFM knownKeyUniqMap uniq - `orElse` pprPanic "lookupKnownKeyThing: missing key" - (vcat [ text "unique:" <+> ppr uniq - , text "uniq-map:" <+> ppr knownKeyUniqMap ]) + | Just (occ :: OccName) <- lookupUFM knownKeyUniqMap uniq = case lookupGRE gbl_rdr_env (LookupOccName occ SameNameSpace) of [gre] -> do { let name = greName gre --- ; addUsedGRE NoDeprecationWarnings gre --- -- addUseGRE: don't complain about unused imports --- -- of known-key names when -frebindable-known-key-names ; traceIf $ hang (text "lookupKnownKeyThing NoImplicitKnownKeyNames") 2 (ppr name <+> ppr uniq) - ; return name } - [] -> pprPanic "lookupKnownKeyName: known-key name is not in scope" (ppr occ) - gres -> pprPanic "lookupKnownKeyName: known-key name is ambiguously in scope" (ppr gres) - where + ; return (Succeeded name) } + gres -> return (Failed (KnownKeyScopeError uniq occ gres)) + + | otherwise + = return (Failed (MissingKnownKey2 uniq)) loadKnownKeyOccMap :: IfM lcl KnownKeyNameMap loadKnownKeyOccMap ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -44,9 +44,7 @@ module GHC.Rename.Env ( lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupIfThenElse, - - -- QualifiedDo - lookupQualifiedDo, lookupQualifiedDoName, lookupNameWithQualifier, + lookupNameWithQualifier, -- Constructing usage information DeprecationWarnings(..), @@ -104,7 +102,6 @@ import GHC.Types.CompleteMatch import GHC.Types.PkgQual import GHC.Types.GREInfo -import Control.Arrow ( first ) import Control.Monad import Data.Either ( partitionEithers ) import Data.Function ( on ) @@ -2404,39 +2401,19 @@ lookupSyntax std_uniq = do { (expr, fvs) <- lookupSyntaxExpr std_uniq ; return (SyntaxExprRn expr, fvs) } -{- -Note [QualifiedDo] -~~~~~~~~~~~~~~~~~~ -QualifiedDo is implemented using the same placeholders for operation names in -the AST that were devised for RebindableSyntax. Whenever the renamer checks -which names to use for do syntax, it first checks if the do block is qualified -(e.g. M.do { stmts }), in which case it searches for qualified names. If the -qualified names are not in scope, an error is produced. If the do block is not -qualified, the renamer does the usual search of the names which considers -whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven -by the Opt_QualifiedDo dynamic flag. --} - --- Lookup operations for a qualified do. If the context is not a qualified --- do, then use lookupSyntaxExpr. See Note [QualifiedDo]. -lookupQualifiedDo :: HsStmtContext fn -> KnownKeyNameKey -> RnM (SyntaxExpr GhcRn, FreeVars) -lookupQualifiedDo ctxt std_name - = first mkRnSyntaxExpr <$> lookupQualifiedDoName ctxt std_name - -lookupNameWithQualifier :: KnownKeyNameKey -> ModuleName -> RnM (Name, FreeVars) -lookupNameWithQualifier std_uniq modName +lookupNameWithQualifier :: ModuleName -> KnownKeyNameKey -> RnM (Name, FreeVars) +lookupNameWithQualifier modName std_uniq = do { qname <- lookupOccRnNone $ mkRdrQual modName (knownKeyOccName std_uniq) ; return (qname, unitFV qname) } --- See Note [QualifiedDo]. -lookupQualifiedDoName :: HsStmtContext fn -> KnownKeyNameKey -> RnM (Name, FreeVars) -lookupQualifiedDoName ctxt std_uniq - = case qualifiedDoModuleName_maybe ctxt of - Nothing -> lookupSyntaxName std_uniq - Just modName -> lookupNameWithQualifier std_uniq modName --------------------------------------------------------------------------------- +{- ********************************************************************* +* * + Irrefutability +* * +********************************************************************* -} + -- Helper functions for 'isIrrefutableHsPat'. -- -- (Defined here to avoid import cycles.) @@ -2498,4 +2475,3 @@ in_single_complete_match con_nm = go | otherwise = go comps --------------------------------------------------------------------------------- ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -1266,8 +1266,7 @@ rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside rnStmt ctxt rnBody (L loc (BodyStmt _ (L lb body) _ _)) thing_inside = do { (body', fv_expr) <- rnBody body - ; (then_op, fvs1) <- pprTrace "rnStmt" (ppr loc $$ ppr ctxt) $ - lookupQualifiedDoStmtName ctxt thenMClassOpKey + ; (then_op, fvs1) <- lookupQualifiedDoStmtName ctxt thenMClassOpKey ; (guard_op, fvs2) <- if isComprehensionContext ctxt then lookupQualifiedDoStmtName ctxt guardMIdKey @@ -1418,6 +1417,44 @@ rnParallelStmts ctxt return_op segs thing_inside dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs) +{- Note [Renaming parallel Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Renaming parallel statements is painful. Given, say + [ a+c | a <- as, bs <- bss + | c <- bs, a <- ds ] +Note that + (a) In order to report "Defined but not used" about 'bs', we must + rename each group of Stmts with a thing_inside whose FreeVars + include at least {a,c} + + (b) We want to report that 'a' is illegally bound in both branches + + (c) The 'bs' in the second group must obviously not be captured by + the binding in the first group + +To satisfy (a) we nest the segments. +To satisfy (b) we check for duplicates just before thing_inside. +To satisfy (c) we reset the LocalRdrEnv each time. +-} + +{- ********************************************************************* +* * + Lookups for known-key names +* * +********************************************************************* -} + +{- Note [QualifiedDo] +~~~~~~~~~~~~~~~~~~~~~ +QualifiedDo is implemented using the same placeholders for operation names in +the AST that were devised for RebindableSyntax. Whenever the renamer checks +which names to use for do syntax, it first checks if the do block is qualified +(e.g. M.do { stmts }), in which case it searches for qualified names. If the +qualified names are not in scope, an error is produced. If the do block is not +qualified, the renamer does the usual search of the names which considers +whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven +by the Opt_QualifiedDo dynamic flag. +-} + lookupQualifiedDoStmtName :: HasDebugCallStack => HsStmtContextRn -> KnownKeyNameKey -> RnM (SyntaxExpr GhcRn, FreeVars) lookupQualifiedDoStmtName ctxt n @@ -1435,13 +1472,19 @@ lookupQualifiedDoStmtName ctxt n lookupQualifiedDoStmtNameE :: HasDebugCallStack => HsStmtContextRn -> KnownKeyNameKey -> RnM (HsExpr GhcRn, FreeVars) lookupQualifiedDoStmtNameE ctxt key - -- Respect QualifiedDo - | Just mod_name <- qualifiedDoModuleName_maybe ctxt - = do { (nm, fvs) <- lookupNameWithQualifier key mod_name + = do { (nm, fvs) <- lookupQualifiedDoStmtNameN ctxt key ; return (genHsVar nm, fvs) } +lookupQualifiedDoStmtNameN :: HasDebugCallStack => HsStmtContextRn + -> KnownKeyNameKey -> RnM (Name, FreeVars) +lookupQualifiedDoStmtNameN ctxt key + -- Respect QualifiedDo; see Note [QualifiedDo] + | Just mod_name <- qualifiedDoModuleName_maybe ctxt + = do { (nm, fvs) <- lookupNameWithQualifier mod_name key + ; return (nm, fvs) } + | otherwise -- Respect -XRebindableSyntax - = lookupSyntaxExpr key + = lookupSyntaxName key -- | Is this a context where we respect RebindableSyntax? -- but ListComp are never rebindable @@ -1463,25 +1506,6 @@ rebindableDoStmtContext flavour = case flavour of GhciStmtCtxt -> True -- I suppose? {- -Note [Renaming parallel Stmts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Renaming parallel statements is painful. Given, say - [ a+c | a <- as, bs <- bss - | c <- bs, a <- ds ] -Note that - (a) In order to report "Defined but not used" about 'bs', we must - rename each group of Stmts with a thing_inside whose FreeVars - include at least {a,c} - - (b) We want to report that 'a' is illegally bound in both branches - - (c) The 'bs' in the second group must obviously not be captured by - the binding in the first group - -To satisfy (a) we nest the segments. -To satisfy (b) we check for duplicates just before thing_inside. -To satisfy (c) we reset the LocalRdrEnv each time. - ************************************************************************ * * \subsubsection{mdo expressions} @@ -1612,19 +1636,19 @@ rn_rec_stmt :: AnnoBody body => -- Turns each stmt into a singleton Stmt rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ (L lb body) noret _), _) = do { (body', fv_expr) <- rnBody body - ; (ret_op, fvs1) <- lookupQualifiedDo ctxt returnMClassOpKey + ; (ret_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMClassOpKey ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, L loc (LastStmt noExtField (L lb body') noret ret_op))] } rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ (L lb body) _ _), _) = do { (body', fvs) <- rnBody body - ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMClassOpKey + ; (then_op, fvs1) <- lookupQualifiedDoStmtName ctxt thenMClassOpKey ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, L loc (BodyStmt noExtField (L lb body') then_op noSyntaxExpr))] } rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' (L lb body)), fv_pat) = do { (body', fv_expr) <- rnBody body - ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMClassOpKey + ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMClassOpKey ; (fail_op, fvs2) <- getMonadFailOp ctxt @@ -2032,8 +2056,8 @@ rearrangeForApplicativeDo _ [] = return ([], emptyNameSet) -- If the do-block contains a single @return@ statement, change it to -- @pure@ if ApplicativeDo is turned on. See Note [ApplicativeDo]. rearrangeForApplicativeDo ctxt [(one,_)] = do - (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMClassOpKey - (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAClassOpKey + (return_name, _) <- lookupQualifiedDoStmtNameN (HsDoStmt ctxt) returnMClassOpKey + (pure_name, _) <- lookupQualifiedDoStmtNameN (HsDoStmt ctxt) pureAClassOpKey let monad_names = MonadNames { return_name = return_name , pure_name = pure_name } return $ case needJoin monad_names [one] (Just pure_name) of @@ -2044,8 +2068,8 @@ rearrangeForApplicativeDo ctxt stmts0 = do let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts | otherwise = mkStmtTreeHeuristic stmts traceRn "rearrangeForADo" (ppr stmt_tree) - (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMClassOpKey - (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAClassOpKey + (return_name, _) <- lookupQualifiedDoStmtNameN (HsDoStmt ctxt) returnMClassOpKey + (pure_name, _) <- lookupQualifiedDoStmtNameN (HsDoStmt ctxt) pureAClassOpKey let monad_names = MonadNames { return_name = return_name , pure_name = pure_name } stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs @@ -2199,7 +2223,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) }] False tail' stmtTreeToStmts monad_names ctxt (StmtTreeOne (let_stmt@(L _ LetStmt{}),_)) tail _tail_fvs = do - (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAClassOpKey + (pure_name, _) <- lookupQualifiedDoStmtNameN (HsDoStmt ctxt) pureAClassOpKey return $ case needJoin monad_names tail (Just pure_name) of (False, tail') -> (let_stmt : tail', emptyNameSet) (True, _) -> (let_stmt : tail, emptyNameSet) @@ -2258,7 +2282,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do | otherwise -> do -- Need 'pureAClassOpKey' and not 'returnMClassOpKey' here, so that it requires -- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed). - (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAClassOpKey + (pure_name, _) <- lookupQualifiedDoStmtNameN (HsDoStmt ctxt) pureAClassOpKey let expr = HsApp noExtField (noLocA (genHsVar pure_name)) tup return (expr, emptyFVs) return ( ApplicativeArgMany @@ -2784,7 +2808,7 @@ using fromString: Nothing -> M.fail (fromString "Pattern match error") -} -getMonadFailOp :: HsStmtContext fn -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op +getMonadFailOp :: HsStmtContextRn -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op getMonadFailOp ctxt = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags @@ -2796,7 +2820,7 @@ getMonadFailOp ctxt reallyGetMonadFailOp rebindableSyntax overloadedStrings | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do - (failName, failFvs) <- lookupQualifiedDoName ctxt failMClassOpKey + (failName, failFvs) <- lookupQualifiedDoStmtNameN ctxt failMClassOpKey (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringClassOpKey let arg_lit = mkVarOccFS (fsLit "arg") arg_name <- newSysName arg_lit @@ -2809,7 +2833,7 @@ getMonadFailOp ctxt let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = mkSyntaxExpr failAfterFromStringExpr return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) - | otherwise = lookupQualifiedDo ctxt failMClassOpKey + | otherwise = lookupQualifiedDoStmtName ctxt failMClassOpKey {- ********************************************************************* ===================================== compiler/GHC/Rename/Lit.hs ===================================== @@ -18,7 +18,7 @@ rnQualLit QualLit{..} = do case ql_val of -- See Note [Implementation of QualifiedStrings] HsQualString st s -> (fromStringClassOpKey, HsString st s) - (funName, fvs) <- lookupNameWithQualifier funNameBase ql_mod + (funName, fvs) <- lookupNameWithQualifier ql_mod funNameBase let lit = QualLit{ql_ext = L noAnn funName, ..} let expr = genHsApps funName [genLHsLit hsLit] pure ((lit, expr), fvs) ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -1982,7 +1982,10 @@ findImportUsage rebindable_known_key_names imports used_gres unused_decl :: LImportDecl GhcRn -> ImportDeclUsage unused_decl decl@(L _ (ImportDecl { ideclImportList = imps })) - = (decl, used_gres, unused_names, unused_wcs) + = -- pprTrace "unused_decl" (vcat [ ppr decl + -- , text "used" <+> ppr used_gres + -- , text "unused" <+> ppr unused_names ]) $ + (decl, used_gres, unused_names, unused_wcs) where used_gres = lookupImportMap decl import_usage @@ -2021,6 +2024,7 @@ findImportUsage rebindable_known_key_names imports used_gres (flds, flds_used) = lookupFsEnv acc_fs fs `orElse` (emptyNameSet, Any False) acc_fs' = extendFsEnv acc_fs fs (extendNameSet flds n, Any used S.<> flds_used) in UnusedNames acc_ns acc_wcs acc_fs' + | used = acc ===================================== compiler/GHC/Rename/Pat.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Types.SourceText import GHC.Data.FastString ( uniqCompareFS ) import GHC.Data.List.SetOps( removeDups ) -import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -511,13 +511,17 @@ getKnownKeySource :: TcRn KnownKeyNameSource getKnownKeySource = do { rebindable_path <- goptM Opt_RebindableKnownKeyNames ; if rebindable_path - then KKNS_InScope <$> getGlobalRdrEnv + then do { rdr_env <- getGlobalRdrEnv + ; return (KKNS_InScope rdr_env) } else return KKNS_FromModule } rnLookupKnownKeyName :: HasDebugCallStack => KnownKeyNameKey -> RnM Name rnLookupKnownKeyName uniq = do { kk_source <- getKnownKeySource - ; initIfaceTcRn (lookupKnownKeyName kk_source uniq) } + ; mb_res <- initIfaceTcRn (lookupKnownKeyName kk_source uniq) + ; case mb_res of + Failed err -> failWithTc (TcRnInterfaceError err) + Succeeded name -> return name } rnLookupKnownKeyRdr :: HasDebugCallStack => KnownKeyNameKey -> RnM RdrName rnLookupKnownKeyRdr uniq ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -885,6 +885,9 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "CircularImport" = 75429 GhcDiagnosticCode "HiModuleNameMismatchWarn" = 53693 GhcDiagnosticCode "ExceptionOccurred" = 47808 + GhcDiagnosticCode "MissingKnownKey1" = 74926 + GhcDiagnosticCode "MissingKnownKey2" = 71344 + GhcDiagnosticCode "KnownKeyScopeError" = 99040 -- Out of scope errors GhcDiagnosticCode "NotInScope" = 76037 ===================================== compiler/GHC/Types/Name.hs ===================================== @@ -41,7 +41,7 @@ module GHC.Types.Name ( -- * The main types Name, -- Abstract BuiltInSyntax(..), - KnownKeyNameKey, KnownKeyNameMap, hasKnownKey, + KnownKeyNameKey, KnownKeyNameMap, hasKnownKey, pprKnownKey, -- ** Creating 'Name's mkSystemName, mkSystemNameAt, @@ -441,6 +441,12 @@ mk_known_key_name :: NameSpace -> Module -> FastString -> KnownKeyNameKey -> Nam mk_known_key_name space modu str unique = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan +pprKnownKey :: KnownKeyNameKey -> SDoc +-- Show it in both base64 and decimal, for debugging +pprKnownKey uniq + = ppr uniq <+> braces (text (show tag) <+> ppr u) + where + (tag, u) = unpkUnique uniq {- ********************************************************************* ===================================== libraries/ghc-internal/src/GHC/Internal/Arr.hs ===================================== @@ -63,6 +63,8 @@ import GHC.Internal.Prim.PtrEq (sameMutableArray#) import GHC.Internal.Show import GHC.Internal.Types (Bool, Int(..), Ordering(..), isTrue#) +import GHC.Internal.Base( (>>=) ) -- For known-key names + infixl 9 !, // default () ===================================== libraries/ghc-internal/src/GHC/Internal/Data/STRef.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Internal.Base ((.), (=<<)) import GHC.Internal.Prim (seq) import GHC.Internal.ST import GHC.Internal.STRef +import GHC.Internal.Base( Monad(..) ) -- Used for known-key names -- $setup -- >>> import Prelude ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs ===================================== @@ -41,6 +41,8 @@ import GHC.Internal.TypeLits.Internal import GHC.Internal.TypeNats.Internal import GHC.Internal.Types (Bool(..), Char, Ordering(..), type (~)) +import GHC.Internal.Classes ( (==) ) -- For known-key names in deriving(Eq) + -- | 'Compare' branches on the kind of its arguments to either compare by -- 'Symbol' or 'Nat'. -- ===================================== libraries/ghc-internal/src/GHC/Internal/Event/IntVar.hs ===================================== @@ -9,13 +9,16 @@ module GHC.Internal.Event.IntVar , writeIntVar ) where -import GHC.Internal.Base (return, ($)) +import GHC.Internal.Base ( ($) ) import GHC.Internal.Bits import GHC.Internal.Prim ( MutableByteArray#, RealWorld, newByteArray#, readIntArray#, writeIntArray#, ) import GHC.Internal.Types (Int(..), IO(..)) +import GHC.Internal.Num( fromInteger ) -- For known-key names +import GHC.Internal.Base( Monad(..) ) -- For known-key names + data IntVar = IntVar (MutableByteArray# RealWorld) newIntVar :: Int -> IO IntVar ===================================== libraries/ghc-internal/src/GHC/Internal/Event/Unique.hs ===================================== @@ -19,6 +19,8 @@ import GHC.Internal.Prim ( ) import GHC.Internal.Types(Int(..), IO(..)) +import GHC.Internal.Num( fromInteger ) -- For known-key names + #include "MachDeps.h" data UniqueSource = US (MutableByteArray# RealWorld) ===================================== libraries/ghc-internal/src/GHC/Internal/Float/RealFracMethods.hs ===================================== @@ -73,6 +73,8 @@ import GHC.Internal.Prim ( ) import GHC.Internal.Types (Double(..), Float(..), Int(..), isTrue#) +import GHC.Internal.Num( fromInteger, negate ) -- For known-key names + #if WORD_SIZE_IN_BITS < 64 import GHC.Internal.Prim ( ===================================== libraries/ghc-internal/src/GHC/Internal/Num.hs ===================================== @@ -48,6 +48,8 @@ import GHC.Internal.Prim ( ) import GHC.Internal.Types (Int(..), Word(..)) +import GHC.Internal.Classes ( (==) ) -- Needed for know-key names + infixl 7 * infixl 6 +, - ===================================== libraries/ghc-internal/src/GHC/Internal/ST.hs ===================================== @@ -32,6 +32,8 @@ import GHC.Internal.Magic (runRW#) import GHC.Internal.Prim (State#, noDuplicate#) import GHC.Internal.Show +import GHC.Internal.Num( fromInteger ) -- For known-key names + default () -- The 'ST' monad proper. By default the monad is strict; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f713406ec4952ed099a417b069fae3a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f713406ec4952ed099a417b069fae3a... You're receiving this email because of your account on gitlab.haskell.org.