June 2025 - ghc-commits

[Git][ghc/ghc][wip/romes/26039] Bump default language edition to GHC2024
by Rodrigo Mesquita (＠alt-romes) 23 Jun '25

23 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/26039 at Glasgow Haskell Compiler / GHC Commits: 215ad8ab by Rodrigo Mesquita at 2025-06-23T12:21:02+01:00 Bump default language edition to GHC2024 As per the accepted ghc-proposal#632 Fixes #26039 - - - - - 33 changed files: - compiler/GHC/Driver/Flags.hs - testsuite/tests/ado/all.T - testsuite/tests/annotations/should_fail/all.T - testsuite/tests/array/should_run/all.T - testsuite/tests/core-to-stg/all.T - testsuite/tests/deSugar/should_fail/all.T - testsuite/tests/deriving/should_compile/all.T - testsuite/tests/deriving/should_fail/all.T - testsuite/tests/dmdanal/sigs/all.T - testsuite/tests/gadt/all.T - testsuite/tests/ghci.debugger/scripts/all.T - testsuite/tests/ghci/prog-mhu002/all.T - testsuite/tests/ghci/scripts/all.T - testsuite/tests/ghci/should_run/all.T - testsuite/tests/indexed-types/should_compile/all.T - testsuite/tests/linear/should_fail/all.T - testsuite/tests/module/all.T - testsuite/tests/overloadedrecflds/should_fail/all.T - testsuite/tests/parser/should_fail/all.T - testsuite/tests/partial-sigs/should_compile/all.T - testsuite/tests/polykinds/all.T - testsuite/tests/programs/andy_cherry/test.T - testsuite/tests/rename/should_fail/all.T - testsuite/tests/roles/should_fail/all.T - testsuite/tests/showIface/all.T - testsuite/tests/simplCore/T9646/test.T - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/th/all.T - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_run/all.T - testsuite/tests/vdq-rta/should_fail/all.T - testsuite/tests/warnings/should_fail/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/215ad8ab2073024053f43ae10474671… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/215ad8ab2073024053f43ae10474671… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: linters: lint-whitespace: bump upper-bound for containers
by Marge Bot (＠marge-bot) 23 Jun '25

23 Jun '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: ae003a3a by Teo Camarasu at 2025-06-23T05:21:48-04:00 linters: lint-whitespace: bump upper-bound for containers The version of containers was bumped in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13989 - - - - - 112c1262 by Matthew Pickering at 2025-06-23T06:54:44-04:00 Move ModuleGraph into UnitEnv The ModuleGraph is a piece of information associated with the ExternalPackageState and HomeUnitGraph. Therefore we should store it inside the HomeUnitEnv. - - - - - 7ce82af2 by soulomoon at 2025-06-23T06:54:45-04:00 Remove hptAllFamInstances usage during upsweep Fixes #26118 This change eliminates the use of hptAllFamInstances during the upsweep phase, as it could access non-below modules from the home package table. The following updates were made: * Updated checkFamInstConsistency to accept an explicit ModuleEnv FamInstEnv parameter and removed the call to hptAllFamInstances. * Adjusted hugInstancesBelow so we can construct ModuleEnv FamInstEnv from its result, * hptAllFamInstances and allFamInstances functions are removed. - - - - - 16 changed files: - compiler/GHC.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/Home/PackageTable.hs - ghc/GHCi/UI.hs - linters/lint-whitespace/lint-whitespace.cabal Changes: ===================================== compiler/GHC.hs ===================================== @@ -859,6 +859,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_namever = ghcNameVersion dflags1 , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit old_unit_env + , ue_module_graph = ue_module_graph old_unit_env , ue_eps = ue_eps old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } @@ -916,6 +917,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit unit_env0 , ue_eps = ue_eps unit_env0 + , ue_module_graph = ue_module_graph unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -996,7 +998,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do -- invalidateModSummaryCache :: GhcMonad m => m () invalidateModSummaryCache = - modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } + modifySession $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env where inval ms = ms { ms_hs_hash = fingerprint0 } ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -97,10 +97,11 @@ core2core hsc_env guts@(ModGuts { mg_module = mod where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env extra_vars = interactiveInScope (hsc_IC hsc_env) home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot }) - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -457,6 +457,7 @@ addUnit u = do (homeUnitId home_unit) (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env + , ue_module_graph = ue_module_graph old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -2,6 +2,8 @@ module GHC.Driver.Env ( Hsc(..) , HscEnv (..) + , hsc_mod_graph + , setModuleGraph , hscUpdateFlags , hscSetFlags , hsc_home_unit @@ -130,6 +132,9 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env +hsc_mod_graph :: HscEnv -> ModuleGraph +hsc_mod_graph = ue_module_graph . hsc_unit_env + hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG @@ -139,6 +144,9 @@ hscInsertHPT hmi hsc_env = UnitEnv.insertHpt hmi (hsc_unit_env hsc_env) hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } +setModuleGraph :: ModuleGraph -> HscEnv -> HscEnv +setModuleGraph mod_graph hsc_env = hsc_env { hsc_unit_env = (hsc_unit_env hsc_env) { ue_module_graph = mod_graph } } + {- Note [Target code interpreter] @@ -220,15 +228,15 @@ hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) -- | Find all rules in modules that are in the transitive closure of the given -- module. hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase -hugRulesBelow hsc uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> - hugSomeThingsBelowUs (md_rules . hm_details) False hsc uid mn +hugRulesBelow hsc_env uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> + hugSomeThingsBelowUs (md_rules . hm_details) False hsc_env uid mn -- | Get annotations from all modules "below" this one (in the dependency -- sense) within the home units. If the module is @Nothing@, returns /all/ -- annotations in the home units. hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv -hugAnnsBelow hsc uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> - hugSomeThingsBelowUs (md_anns . hm_details) False hsc uid mn +hugAnnsBelow hsc_env uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> + hugSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn -- | Find all COMPLETE pragmas in modules that are in the transitive closure of the -- given module. @@ -237,7 +245,7 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn -- | Find instances visible from the given set of imports -hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst]) +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [(Module, FamInstEnv)]) hugInstancesBelow hsc_env uid mnwib = do let mn = gwib_mod mnwib (insts, famInsts) <- @@ -247,7 +255,7 @@ hugInstancesBelow hsc_env uid mnwib = do -- Don't include instances for the current module in if moduleName (mi_module (hm_iface mod_info)) == mn then [] - else [(md_insts details, md_fam_insts details)]) + else [(md_insts details, [(mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details)])]) True -- Include -hi-boot hsc_env uid @@ -260,7 +268,8 @@ hugInstancesBelow hsc_env uid mnwib = do hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] -- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk -- These things are currently stored in the EPS for home packages. (See #25795 for --- progress in removing these kind of checks) +-- progress in removing these kind of checks; and making these functions of +-- `UnitEnv` rather than `HscEnv`) -- See Note [Downsweep and the ModuleGraph] hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return [] hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn ===================================== compiler/GHC/Driver/Env/Types.hs ===================================== @@ -18,7 +18,6 @@ import GHC.Types.Name.Cache import GHC.Types.Target import GHC.Types.TypeEnv import GHC.Unit.Finder.Types -import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Utils.Logger import GHC.Utils.TmpFs @@ -65,10 +64,6 @@ data HscEnv hsc_targets :: [Target], -- ^ The targets (or roots) of the current session - hsc_mod_graph :: ModuleGraph, - -- ^ The module graph of the current session - -- See Note [Downsweep and the ModuleGraph] for when this is constructed. - hsc_IC :: InteractiveContext, -- ^ The context for evaluating interactive statements @@ -113,3 +108,4 @@ data HscEnv , hsc_llvm_config :: !LlvmConfigCache -- ^ LLVM configuration cache. } + ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -332,7 +332,6 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do return HscEnv { hsc_dflags = top_dynflags , hsc_logger = setLogFlags logger (initLogFlags top_dynflags) , hsc_targets = [] - , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags , hsc_NC = nc_var , hsc_FC = fc_var ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -190,12 +190,12 @@ depanalE diag_wrapper msg excluded_mods allow_dup_roots = do all_errs <- liftIO $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env) logDiagnostics (GhcDriverMessage <$> all_errs) - setSession hsc_env { hsc_mod_graph = mod_graph } + setSession (setModuleGraph mod_graph hsc_env) pure (emptyMessages, mod_graph) else do -- We don't have a complete module dependency graph, -- The graph may be disconnected and is unusable. - setSession hsc_env { hsc_mod_graph = emptyMG } + setSession (setModuleGraph emptyMG hsc_env) pure (errs, emptyMG) @@ -616,7 +616,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- for any client who might interact with GHC via load'. -- See Note [Timing of plugin initialization] initializeSessionPlugins - modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } + modifySession (setModuleGraph mod_graph) guessOutputFile hsc_env <- getSession ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -768,8 +768,9 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) - , hsc_mod_graph = mg } + let hsc_env' = + setModuleGraph mg + hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -671,7 +671,7 @@ dontLeakTheHUG thing_inside = do -- oneshot mode does not support backpack -- and we want to avoid prodding the hsc_mod_graph thunk | isOneShot (ghcMode (hsc_dflags hsc_env)) = False - | mgHasHoles (hsc_mod_graph hsc_env) = True + | mgHasHoles (ue_module_graph old_unit_env) = True | otherwise = False pruneHomeUnitEnv hme = do -- NB: These are empty HPTs because Iface/Load first consults the HPT @@ -683,19 +683,19 @@ dontLeakTheHUG thing_inside = do | otherwise = do hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph old_unit_env) + let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" + , mg_graph = panic "cleanTopEnv: mg_graph" + , mg_has_holes = keepFor20509 } return old_unit_env { ue_home_unit_graph = hug' + , ue_module_graph = new_mod_graph } in do !unit_env <- unit_env_io -- mg_has_holes will be checked again, but nothing else about the module graph - let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" - , mg_graph = panic "cleanTopEnv: mg_graph" - , mg_has_holes = keepFor20509 } pure $ hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets" - , hsc_mod_graph = new_mod_graph , hsc_IC = panic "cleanTopEnv: hsc_IC" , hsc_type_env_vars = case maybe_type_vars of Just vars -> vars ===================================== compiler/GHC/Tc/Instance/Family.hs ===================================== @@ -286,8 +286,8 @@ why we still do redundant checks. -- We don't need to check the current module, this is done in -- tcExtendLocalFamInstEnv. -- See Note [The type family instance consistency story]. -checkFamInstConsistency :: [Module] -> TcM () -checkFamInstConsistency directlyImpMods +checkFamInstConsistency :: ModuleEnv FamInstEnv -> [Module] -> TcM () +checkFamInstConsistency hpt_fam_insts directlyImpMods = do { (eps, hug) <- getEpsAndHug ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) ; let { -- Fetch the iface of a given module. Must succeed as @@ -317,7 +317,6 @@ checkFamInstConsistency directlyImpMods -- See Note [Order of type family consistency checks] } - ; hpt_fam_insts <- liftIO $ HUG.allFamInstances hug ; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods ; traceTc "init_consistent_set" (ppr debug_consistent_set) ; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set)) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -120,7 +120,7 @@ import GHC.Core.TyCo.Ppr( debugPprType ) import GHC.Core.TyCo.Tidy( tidyTopType ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst - , famInstEnvElts, extendFamInstEnvList, normaliseType ) + , famInstEnvElts, extendFamInstEnvList, normaliseType, emptyFamInstEnv, unionFamInstEnv ) import GHC.Parser.Header ( mkPrelImports ) @@ -467,8 +467,8 @@ tcRnImports hsc_env import_decls = do { (rn_imports, imp_user_spec, rdr_env, imports) <- rnImports import_decls -- Get the default declarations for the classes imported by this module -- and group them by class. - ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList)) - <$> tcGetClsDefaults (M.keys $ imp_mods imports) + ; tc_defaults <- NE.groupBy ((==) `on` cd_class) . (concatMap defaultList) + <$> tcGetClsDefaults (M.keys $ imp_mods imports) ; this_mod <- getModule ; gbl_env <- getGblEnv ; let unitId = homeUnitId $ hsc_home_unit hsc_env @@ -480,8 +480,10 @@ tcRnImports hsc_env import_decls -- filtering also ensures that we don't see instances from -- modules batch (@--make@) compiled before this one, but -- which are not below this one. - ; (home_insts, home_fam_insts) <- liftIO $ + ; (home_insts, home_mod_fam_inst_env) <- liftIO $ hugInstancesBelow hsc_env unitId mnwib + ; let home_fam_inst_env = foldl' unionFamInstEnv emptyFamInstEnv $ snd <$> home_mod_fam_inst_env + ; let hpt_fam_insts = mkModuleEnv home_mod_fam_inst_env -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad @@ -507,8 +509,7 @@ tcRnImports hsc_env import_decls tcg_rn_imports = rn_imports, tcg_default = foldMap subsume tc_defaults, tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts + tcg_fam_inst_env = unionFamInstEnv (tcg_fam_inst_env gbl) home_fam_inst_env }) $ do { ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) @@ -538,7 +539,7 @@ tcRnImports hsc_env import_decls $ imports } ; logger <- getLogger ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ()) - $ checkFamInstConsistency dir_imp_mods + $ checkFamInstConsistency hpt_fam_insts dir_imp_mods ; traceRn "rn1: } checking family instance consistency" empty ; gbl_env <- getGblEnv @@ -2109,7 +2110,7 @@ for the unit portion of the graph, if it's not already been performed. withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a withInteractiveModuleNode hsc_env thing_inside = do mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env) - updTopEnv (\env -> env { hsc_mod_graph = mg }) thing_inside + updTopEnv (setModuleGraph mg) thing_inside runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -23,21 +23,22 @@ -- ┌▽────────────┐ │ │ -- │HomeUnitGraph│ │ │ -- └┬────────────┘ │ │ --- ┌▽─────────────────▽┐ │ --- │UnitEnv │ │ --- └┬──────────────────┘ │ --- ┌▽───────────────────────────────────────▽┐ --- │HscEnv │ --- └─────────────────────────────────────────┘ +-- ┌▽─────────────────▽─────────────────────▽┐ +-- │UnitEnv │ +-- └┬─────────────-──────────────────────────┘ +-- │ +-- │ +-- ┌▽──────────────────────────────────────▽┐ +-- │HscEnv │ +-- └────────────────────────────────────────┘ -- @ -- --- The 'UnitEnv' references both the 'HomeUnitGraph' (with all the home unit --- modules) and the 'ExternalPackageState' (information about all --- non-home/external units). The 'HscEnv' references this 'UnitEnv' and the --- 'ModuleGraph' (which describes the relationship between the modules being --- compiled). The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. --- --- TODO: Arguably, the 'ModuleGraph' should be part of 'UnitEnv' rather than being in the 'HscEnv'. +-- The 'UnitEnv' references the 'HomeUnitGraph' (with all the home unit +-- modules), the 'ExternalPackageState' (information about all +-- non-home/external units), and the 'ModuleGraph' (which describes the +-- relationship between the modules being compiled). +-- The 'HscEnv' references this 'UnitEnv'. +-- The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv @@ -119,6 +120,7 @@ import GHC.Unit.Home.ModInfo import GHC.Unit.Home.PackageTable import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv) import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Module.Graph import GHC.Platform import GHC.Settings @@ -163,6 +165,10 @@ data UnitEnv = UnitEnv , ue_current_unit :: UnitId + , ue_module_graph :: ModuleGraph + -- ^ The module graph of the current session + -- See Note [Downsweep and the ModuleGraph] for when this is constructed. + , ue_home_unit_graph :: !HomeUnitGraph -- See Note [Multiple Home Units] @@ -182,6 +188,7 @@ initUnitEnv cur_unit hug namever platform = do return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug + , ue_module_graph = emptyMG , ue_current_unit = cur_unit , ue_platform = platform , ue_namever = namever ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -43,7 +43,6 @@ module GHC.Unit.Home.Graph -- * Very important queries , allInstances - , allFamInstances , allAnns , allCompleteSigs @@ -110,10 +109,6 @@ allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b')) (hptAllInstances (homeUnitEnv_hpt hue)) -allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv) -allFamInstances hug = foldr go (pure emptyModuleEnv) hug where - go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue)) - allAnns :: HomeUnitGraph -> IO AnnEnv allAnns hug = foldr go (pure emptyAnnEnv) hug where go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue)) ===================================== compiler/GHC/Unit/Home/PackageTable.hs ===================================== @@ -41,7 +41,6 @@ module GHC.Unit.Home.PackageTable -- * Queries about home modules , hptCompleteSigs , hptAllInstances - , hptAllFamInstances , hptAllAnnotations -- ** More Traversal-based queries @@ -208,14 +207,6 @@ hptAllInstances hpt = do let (insts, famInsts) = unzip hits return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) --- | Find all the family instance declarations from the HPT -hptAllFamInstances :: HomePackageTable -> IO (ModuleEnv FamInstEnv) -hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiFamInstEnv hmi)]) - where - hmiModule = mi_module . hm_iface - hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv - . md_fam_insts . hm_details - -- | All annotations from the HPT hptAllAnnotations :: HomePackageTable -> IO AnnEnv hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details) ===================================== ghc/GHCi/UI.hs ===================================== @@ -4680,7 +4680,7 @@ clearHPTs = do let pruneHomeUnitEnv hme = liftIO $ do emptyHpt <- emptyHomePackageTable pure hme{ homeUnitEnv_hpt = emptyHpt } - discardMG hsc = hsc { hsc_mod_graph = GHC.emptyMG } + discardMG hsc = setModuleGraph GHC.emptyMG hsc modifySessionM $ \hsc_env -> do hug' <- traverse pruneHomeUnitEnv $ hsc_HUG hsc_env pure $ discardMG $ discardIC $ hscUpdateHUG (const hug') hsc_env ===================================== linters/lint-whitespace/lint-whitespace.cabal ===================================== @@ -24,7 +24,7 @@ executable lint-whitespace process ^>= 1.6, containers - >= 0.6 && <0.8, + >= 0.6 && <0.9, base >= 4.14 && < 5, text View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86769cce03bb76f1729184c439e389… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86769cce03bb76f1729184c439e389… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] linters: lint-whitespace: bump upper-bound for containers
by Marge Bot (＠marge-bot) 23 Jun '25

23 Jun '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ae003a3a by Teo Camarasu at 2025-06-23T05:21:48-04:00 linters: lint-whitespace: bump upper-bound for containers The version of containers was bumped in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13989 - - - - - 1 changed file: - linters/lint-whitespace/lint-whitespace.cabal Changes: ===================================== linters/lint-whitespace/lint-whitespace.cabal ===================================== @@ -24,7 +24,7 @@ executable lint-whitespace process ^>= 1.6, containers - >= 0.6 && <0.8, + >= 0.6 && <0.9, base >= 4.14 && < 5, text View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae003a3af0a5f49504dee0c1d652a44… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae003a3af0a5f49504dee0c1d652a44… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Visible forall in GADTs (#25127)
by Marge Bot (＠marge-bot) 23 Jun '25

23 Jun '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: fbc0b92a by Vladislav Zavialov at 2025-06-22T04:25:16+03:00 Visible forall in GADTs (#25127) Add support for visible dependent quantification `forall a -> t` in types of data constructors, e.g. data KindVal a where K :: forall k. forall (a::k) -> -- now allowed! k -> KindVal a For details, see docs/users_guide/exts/required_type_arguments.rst, which has gained a new subsection. DataCon in compiler/GHC/Core/DataCon.hs --------------------------------------- The main change in this patch is that DataCon, the Core representation of a data constructor, now uses a different type to store user-written type variable binders: - dcUserTyVarBinders :: [InvisTVBinder] + dcUserTyVarBinders :: [TyVarBinder] where type TyVarBinder = VarBndr TyVar ForAllTyFlag type InvisTVBinder = VarBndr TyVar Specificity and data Specificity = InferredSpec | SpecifiedSpec data ForAllTyFlag = Invisible Specificity | Required This change necessitates some boring, mechanical changes scattered throughout the diff: ... is now used in place of ... -----------------+--------------- TyVarBinder | InvisTVBinder IfaceForAllBndr | IfaceForAllSpecBndr Specified | SpecifiedSpec Inferred | InferredSpec mkForAllTys | mkInvisForAllTys additionally, tyVarSpecToBinders -- added or removed calls ifaceForAllSpecToBndrs -- removed calls Visibility casts in mkDataConRep -------------------------------- Type abstractions in Core (/\a. e) always have type (forall a. t) because coreTyLamForAllTyFlag = Specified. This is also true of data constructor workers. So we may be faced with the following: data con worker: (forall a. blah) data con wrapper: (forall a -> blah) In this case the wrapper must use a visibility cast (e |> ForAllCo ...) with appropriately set fco_vis{L,R}. Relevant functions: mkDataConRep in compiler/GHC/Types/Id/Make.hs dataConUserTyVarBindersNeedWrapper in compiler/GHC/Core/DataCon.hs mkForAllVisCos in compiler/GHC/Core/Coercion.hs mkCoreTyLams in compiler/GHC/Core/Make.hs mkWpForAllCast in compiler/GHC/Tc/Types/Evidence.hs More specifically: - dataConUserTyVarBindersNeedWrapper has been updated to answer "yes" if there are visible foralls in the type of the data constructor. - mkDataConRep now uses mkCoreTyLams to generate the big lambda abstractions (/\a b c. e) in the data con wrapper. - mkCoreTyLams is a variant of mkCoreLams that applies visibility casts as needed. It similar in purpose to the pre-existing mkWpForAllCast, so the common bits have been factored out into mkForAllVisCos. ConDecl in compiler/Language/Haskell/Syntax/Decls.hs ---------------------------------------------------- The surface syntax representation of a data constructor declaration is ConDecl. In accordance with the proposal, only GADT syntax is extended with support for visible forall, so we are interested in ConDeclGADT. ConDeclGADT's field con_bndrs has been renamed to con_outer_bndrs and is now accompanied by con_inner_bndrs: con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass) con_inner_bndrs :: [HsForAllTelescope pass] Visible foralls always end up in con_inner_bndrs. The outer binders are stored and processed separately to support implicit quantification and the forall-or-nothing rule, a design established by HsSigType. A side effect of this change is that even in absence of visible foralls, GHC now permits multiple invisible foralls, e.g. data T a where { MkT :: forall a b. forall c d. ... -> T a } But of course, this is done in service of making at least some of these foralls visible. The entire compiler front-end has been updated to deal with con_inner_bndrs. See the following modified or added functions: Parser: mkGadtDecl in compiler/GHC/Parser/PostProcess.hs splitLHsGadtTy in compiler/GHC/Hs/Type.hs Pretty-printer: pprConDecl in compiler/GHC/Hs/Decls.hs pprHsForAllTelescope in compiler/GHC/Hs/Type.hs Renamer: rnConDecl in compiler/GHC/Rename/Module.hs bindHsForAllTelescopes in compiler/GHC/Rename/HsType.hs extractHsForAllTelescopes in compiler/GHC/Rename/HsType.hs Type checker: tcConDecl in compiler/GHC/Tc/TyCl.hs tcGadtConTyVarBndrs in compiler/GHC/Tc/Gen/HsType.hs Template Haskell ---------------- The TH AST is left unchanged for the moment to avoid breakage. An attempt to quote or reify a data constructor declaration with visible forall in its type will result an error: data ThRejectionReason -- in GHC/HsToCore/Errors/Types.hs = ... | ThDataConVisibleForall -- new error constructor However, as noted in the previous section, GHC now permits multiple invisible foralls, and TH was updated accordingly. Updated code: repC in compiler/GHC/HsToCore/Quote.hs reifyDataCon in compiler/GHC/Tc/Gen/Splice.hs ppr @Con in libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs Pattern matching ---------------- Everything described above concerns data constructor declarations, but what about their use sites? Now it is trickier to type check a pattern match fn(Con a b c)=... because we can no longer assume that a,b,c are all value arguments. Indeed, some or all of them may very well turn out to be required type arguments. To that end, see the changes to: tcDataConPat in compiler/GHC/Tc/Gen/Pat.hs splitConTyArgs in compiler/GHC/Tc/Gen/Pat.hs and the new helpers split_con_ty_args, zip_pats_bndrs. This is also the reason the TcRnTooManyTyArgsInConPattern error constructor has been removed. The new code emits TcRnArityMismatch or TcRnIllegalInvisibleTypePattern. Summary ------- DataCon, ConDecl, as well as all related functions have been updated to support required type arguments in data constructors. Test cases: HieGadtConSigs GadtConSigs_th_dump1 GadtConSigs_th_pprint1 T25127_data T25127_data_inst T25127_infix T25127_newtype T25127_fail_th_quote T25127_fail_arity TyAppPat_Tricky Co-authored-by: mniip <mniip(a)mniip.com> - - - - - 81 changed files: - compiler/GHC/Builtin/Types.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/ConLike.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/DataCon.hs-boot - compiler/GHC/Core/Make.hs - compiler/GHC/Core/PatSyn.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Errors/Ppr.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Var.hs-boot - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Pat.hs - docs/users_guide/9.14.1-notes.rst - docs/users_guide/exts/gadt_syntax.rst - docs/users_guide/exts/required_type_arguments.rst - libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs - testsuite/tests/dependent/should_fail/T16326_Fail6.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - + testsuite/tests/hiefile/should_run/HieGadtConSigs.hs - + testsuite/tests/hiefile/should_run/HieGadtConSigs.stdout - testsuite/tests/hiefile/should_run/all.T - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/printer/T18791.stderr - + testsuite/tests/th/GadtConSigs_th_dump1.hs - + testsuite/tests/th/GadtConSigs_th_dump1.stderr - + testsuite/tests/th/GadtConSigs_th_pprint1.hs - + testsuite/tests/th/GadtConSigs_th_pprint1.stderr - testsuite/tests/th/T20868.stdout - testsuite/tests/th/all.T - testsuite/tests/typecheck/should_compile/T23739a.hs - + testsuite/tests/typecheck/should_compile/TyAppPat_Tricky.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/T20443b.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_TooMany.stderr - + testsuite/tests/vdq-rta/should_compile/T25127_data.hs - + testsuite/tests/vdq-rta/should_compile/T25127_data_inst.hs - + testsuite/tests/vdq-rta/should_compile/T25127_infix.hs - + testsuite/tests/vdq-rta/should_compile/T25127_newtype.hs - testsuite/tests/vdq-rta/should_compile/all.T - testsuite/tests/vdq-rta/should_fail/T24159_type_syntax_th_fail.script - + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.hs - + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.stderr - + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.hs - + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.stderr - testsuite/tests/vdq-rta/should_fail/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbc0b92ae38e169ec13fa8b41a255b0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbc0b92ae38e169ec13fa8b41a255b0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/module_graph_mode] Move ModuleGraph into UnitEnv
by Matthew Pickering (＠mpickering) 23 Jun '25

23 Jun '25

Matthew Pickering pushed to branch wip/module_graph_mode at Glasgow Haskell Compiler / GHC Commits: f834b604 by Matthew Pickering at 2025-06-23T08:14:57+01:00 Move ModuleGraph into UnitEnv The ModuleGraph is a piece of information associated with the ExternalPackageState and HomeUnitGraph. Therefore we should store it inside the HomeUnitEnv. - - - - - 12 changed files: - compiler/GHC.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Env.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -859,6 +859,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_namever = ghcNameVersion dflags1 , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit old_unit_env + , ue_module_graph = ue_module_graph old_unit_env , ue_eps = ue_eps old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } @@ -916,6 +917,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit unit_env0 , ue_eps = ue_eps unit_env0 + , ue_module_graph = ue_module_graph unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -996,7 +998,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do -- invalidateModSummaryCache :: GhcMonad m => m () invalidateModSummaryCache = - modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } + modifySession $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env where inval ms = ms { ms_hs_hash = fingerprint0 } ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -97,10 +97,11 @@ core2core hsc_env guts@(ModGuts { mg_module = mod where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env extra_vars = interactiveInScope (hsc_IC hsc_env) home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot }) - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -457,6 +457,7 @@ addUnit u = do (homeUnitId home_unit) (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env + , ue_module_graph = ue_module_graph old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -2,6 +2,8 @@ module GHC.Driver.Env ( Hsc(..) , HscEnv (..) + , hsc_mod_graph + , setModuleGraph , hscUpdateFlags , hscSetFlags , hsc_home_unit @@ -130,6 +132,9 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env +hsc_mod_graph :: HscEnv -> ModuleGraph +hsc_mod_graph = ue_module_graph . hsc_unit_env + hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG @@ -139,6 +144,9 @@ hscInsertHPT hmi hsc_env = UnitEnv.insertHpt hmi (hsc_unit_env hsc_env) hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } +setModuleGraph :: ModuleGraph -> HscEnv -> HscEnv +setModuleGraph mod_graph hsc_env = hsc_env { hsc_unit_env = (hsc_unit_env hsc_env) { ue_module_graph = mod_graph } } + {- Note [Target code interpreter] @@ -220,15 +228,15 @@ hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) -- | Find all rules in modules that are in the transitive closure of the given -- module. hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase -hugRulesBelow hsc uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> - hugSomeThingsBelowUs (md_rules . hm_details) False hsc uid mn +hugRulesBelow hsc_env uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> + hugSomeThingsBelowUs (md_rules . hm_details) False hsc_env uid mn -- | Get annotations from all modules "below" this one (in the dependency -- sense) within the home units. If the module is @Nothing@, returns /all/ -- annotations in the home units. hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv -hugAnnsBelow hsc uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> - hugSomeThingsBelowUs (md_anns . hm_details) False hsc uid mn +hugAnnsBelow hsc_env uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> + hugSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn -- | Find all COMPLETE pragmas in modules that are in the transitive closure of the -- given module. @@ -260,7 +268,8 @@ hugInstancesBelow hsc_env uid mnwib = do hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] -- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk -- These things are currently stored in the EPS for home packages. (See #25795 for --- progress in removing these kind of checks) +-- progress in removing these kind of checks; and making these functions of +-- `UnitEnv` rather than `HscEnv`) -- See Note [Downsweep and the ModuleGraph] hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return [] hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn ===================================== compiler/GHC/Driver/Env/Types.hs ===================================== @@ -18,7 +18,6 @@ import GHC.Types.Name.Cache import GHC.Types.Target import GHC.Types.TypeEnv import GHC.Unit.Finder.Types -import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Utils.Logger import GHC.Utils.TmpFs @@ -65,10 +64,6 @@ data HscEnv hsc_targets :: [Target], -- ^ The targets (or roots) of the current session - hsc_mod_graph :: ModuleGraph, - -- ^ The module graph of the current session - -- See Note [Downsweep and the ModuleGraph] for when this is constructed. - hsc_IC :: InteractiveContext, -- ^ The context for evaluating interactive statements @@ -113,3 +108,4 @@ data HscEnv , hsc_llvm_config :: !LlvmConfigCache -- ^ LLVM configuration cache. } + ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -332,7 +332,6 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do return HscEnv { hsc_dflags = top_dynflags , hsc_logger = setLogFlags logger (initLogFlags top_dynflags) , hsc_targets = [] - , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags , hsc_NC = nc_var , hsc_FC = fc_var ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -190,12 +190,12 @@ depanalE diag_wrapper msg excluded_mods allow_dup_roots = do all_errs <- liftIO $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env) logDiagnostics (GhcDriverMessage <$> all_errs) - setSession hsc_env { hsc_mod_graph = mod_graph } + setSession (setModuleGraph mod_graph hsc_env) pure (emptyMessages, mod_graph) else do -- We don't have a complete module dependency graph, -- The graph may be disconnected and is unusable. - setSession hsc_env { hsc_mod_graph = emptyMG } + setSession (setModuleGraph emptyMG hsc_env) pure (errs, emptyMG) @@ -616,7 +616,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- for any client who might interact with GHC via load'. -- See Note [Timing of plugin initialization] initializeSessionPlugins - modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } + modifySession (setModuleGraph mod_graph) guessOutputFile hsc_env <- getSession ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -768,8 +768,9 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) - , hsc_mod_graph = mg } + let hsc_env' = + setModuleGraph mg + hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -671,7 +671,7 @@ dontLeakTheHUG thing_inside = do -- oneshot mode does not support backpack -- and we want to avoid prodding the hsc_mod_graph thunk | isOneShot (ghcMode (hsc_dflags hsc_env)) = False - | mgHasHoles (hsc_mod_graph hsc_env) = True + | mgHasHoles (ue_module_graph old_unit_env) = True | otherwise = False pruneHomeUnitEnv hme = do -- NB: These are empty HPTs because Iface/Load first consults the HPT @@ -683,19 +683,19 @@ dontLeakTheHUG thing_inside = do | otherwise = do hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph old_unit_env) + let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" + , mg_graph = panic "cleanTopEnv: mg_graph" + , mg_has_holes = keepFor20509 } return old_unit_env { ue_home_unit_graph = hug' + , ue_module_graph = new_mod_graph } in do !unit_env <- unit_env_io -- mg_has_holes will be checked again, but nothing else about the module graph - let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" - , mg_graph = panic "cleanTopEnv: mg_graph" - , mg_has_holes = keepFor20509 } pure $ hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets" - , hsc_mod_graph = new_mod_graph , hsc_IC = panic "cleanTopEnv: hsc_IC" , hsc_type_env_vars = case maybe_type_vars of Just vars -> vars ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -2109,7 +2109,7 @@ for the unit portion of the graph, if it's not already been performed. withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a withInteractiveModuleNode hsc_env thing_inside = do mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env) - updTopEnv (\env -> env { hsc_mod_graph = mg }) thing_inside + updTopEnv (setModuleGraph mg) thing_inside runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -23,21 +23,22 @@ -- ┌▽────────────┐ │ │ -- │HomeUnitGraph│ │ │ -- └┬────────────┘ │ │ --- ┌▽─────────────────▽┐ │ --- │UnitEnv │ │ --- └┬──────────────────┘ │ --- ┌▽───────────────────────────────────────▽┐ --- │HscEnv │ --- └─────────────────────────────────────────┘ +-- ┌▽─────────────────▽─────────────────────▽┐ +-- │UnitEnv │ +-- └┬─────────────-──────────────────────────┘ +-- │ +-- │ +-- ┌▽──────────────────────────────────────▽┐ +-- │HscEnv │ +-- └────────────────────────────────────────┘ -- @ -- --- The 'UnitEnv' references both the 'HomeUnitGraph' (with all the home unit --- modules) and the 'ExternalPackageState' (information about all --- non-home/external units). The 'HscEnv' references this 'UnitEnv' and the --- 'ModuleGraph' (which describes the relationship between the modules being --- compiled). The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. --- --- TODO: Arguably, the 'ModuleGraph' should be part of 'UnitEnv' rather than being in the 'HscEnv'. +-- The 'UnitEnv' references the 'HomeUnitGraph' (with all the home unit +-- modules), the 'ExternalPackageState' (information about all +-- non-home/external units), and the 'ModuleGraph' (which describes the +-- relationship between the modules being compiled). +-- The 'HscEnv' references this 'UnitEnv'. +-- The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv @@ -119,6 +120,7 @@ import GHC.Unit.Home.ModInfo import GHC.Unit.Home.PackageTable import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv) import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Module.Graph import GHC.Platform import GHC.Settings @@ -163,6 +165,10 @@ data UnitEnv = UnitEnv , ue_current_unit :: UnitId + , ue_module_graph :: ModuleGraph + -- ^ The module graph of the current session + -- See Note [Downsweep and the ModuleGraph] for when this is constructed. + , ue_home_unit_graph :: !HomeUnitGraph -- See Note [Multiple Home Units] @@ -182,6 +188,7 @@ initUnitEnv cur_unit hug namever platform = do return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug + , ue_module_graph = emptyMG , ue_current_unit = cur_unit , ue_platform = platform , ue_namever = namever ===================================== ghc/GHCi/UI.hs ===================================== @@ -4680,7 +4680,7 @@ clearHPTs = do let pruneHomeUnitEnv hme = liftIO $ do emptyHpt <- emptyHomePackageTable pure hme{ homeUnitEnv_hpt = emptyHpt } - discardMG hsc = hsc { hsc_mod_graph = GHC.emptyMG } + discardMG hsc = setModuleGraph GHC.emptyMG hsc modifySessionM $ \hsc_env -> do hug' <- traverse pruneHomeUnitEnv $ hsc_HUG hsc_env pure $ discardMG $ discardIC $ hscUpdateHUG (const hug') hsc_env View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f834b60479c749499edf67c690f0a06… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f834b60479c749499edf67c690f0a06… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/src-code-ctxt
by Apoorv Ingle (＠ani) 23 Jun '25

23 Jun '25

Apoorv Ingle pushed new branch wip/src-code-ctxt at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/src-code-ctxt You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] linters: lint-whitespace: bump upper-bound for containers
by Marge Bot (＠marge-bot) 23 Jun '25

23 Jun '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 86769cce by Teo Camarasu at 2025-06-23T00:10:45-04:00 linters: lint-whitespace: bump upper-bound for containers The version of containers was bumped in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13989 - - - - - 1 changed file: - linters/lint-whitespace/lint-whitespace.cabal Changes: ===================================== linters/lint-whitespace/lint-whitespace.cabal ===================================== @@ -24,7 +24,7 @@ executable lint-whitespace process ^>= 1.6, containers - >= 0.6 && <0.8, + >= 0.6 && <0.9, base >= 4.14 && < 5, text View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86769cce03bb76f1729184c439e389a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86769cce03bb76f1729184c439e389a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26115] Work in progress [skip ci]
by Simon Peyton Jones (＠simonpj) 22 Jun '25

22 Jun '25

Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 5c2484eb by Simon Peyton Jones at 2025-06-22T23:56:27+01:00 Work in progress [skip ci] Trying to avoid TcSSpecPrag by solving immediately. Nicer. - - - - - 5 changed files: - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/Constraint.hs Changes: ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -1137,7 +1137,10 @@ matchLocalInst body_pred loc match_local_inst inerts (qci@(QCI { qci_tvs = qtvs , qci_body = qbody , qci_ev = qev }) - :qcis) + : qcis) + | isWanted qev -- Skip Wanteds + = match_local_inst inerts qcis + | let in_scope = mkInScopeSet (qtv_set `unionVarSet` body_pred_tv_set) , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) emptyTvSubstEnv qbody body_pred ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -1875,8 +1875,9 @@ noGivenNewtypeReprEqs tc (IS { inert_cans = inerts }) | otherwise = False - might_help_qc (QCI { qci_body = pred }) - | ClassPred cls [_, t1, t2] <- classifyPredType pred + might_help_qc (QCI { qci_ev = ev, qci_body = pred }) + | isGiven ev + , ClassPred cls [_, t1, t2] <- classifyPredType pred , cls `hasKey` coercibleTyConKey = headed_by_tc t1 t2 | otherwise ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -2380,9 +2380,6 @@ unifyForAllBody :: CtEvidence -> Role -> (UnifyEnv -> TcM a) -- See See (SF5) in Note [Solving forall equalities] in GHC.Tc.Solver.Equality unifyForAllBody ev role unify_body = do { (res, cts, unified) <- wrapUnifierX ev role unify_body - -- Ignore the rewriters. They are used in wrapUnifierTcS only - -- as an optimistion to prioritise the work list; but they are - -- /also/ stored in each individual constraint we return. -- Kick out any inert constraint that we have unified ; _ <- kickOutAfterUnification unified ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -280,7 +280,7 @@ solveNestedImplications implics ; return unsolved_implics } solveImplication :: Implication -- Wanted - -> TcS Implication -- Simplified implication (empty or singleton) + -> TcS Implication -- Simplified implication -- Precondition: The TcS monad contains an empty worklist and given-only inerts -- which after trying to solve this implication we must restore to their original value solveImplication imp@(Implic { ic_tclvl = tclvl @@ -1318,11 +1318,11 @@ try_inert_qcs (QCI { qci_ev = ev_w }) inerts = -- See Note [Solving a Wanted forall-constraint] solveWantedForAll_norm :: WantedCtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> SolverStage Void -solveWantedForAll_norm wtd@(WantedCt { ctev_dest = dest, ctev_loc = loc +solveWantedForAll_norm wtd@(WantedCt { ctev_dest = dest, ctev_loc = ct_loc , ctev_rewriters = rewriters }) tvs theta body_pred = Stage $ - TcS.setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $ + TcS.setSrcSpan (getCtLocEnvLoc loc_env) $ -- This setSrcSpan is important: the emitImplicationTcS uses that -- TcLclEnv for the implication, and that in turn sets the location -- for the Givens when solving the constraint (#21006) @@ -1339,24 +1339,38 @@ solveWantedForAll_norm wtd@(WantedCt { ctev_dest = dest, ctev_loc = loc ; given_ev_vars <- mapM newEvVar inst_theta ; (lvl, (w_id, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ - do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc) + do { let ct_loc' = setCtLocOrigin ct_loc (ScOrigin is_qc NakedSc) -- Set the thing to prove to have a ScOrigin, so we are -- careful about its termination checks. -- See (QC-INV) in Note [Solving a Wanted forall-constraint] - ; wanted_ev <- newWantedNC loc' rewriters inst_pred + ; wanted_ev <- newWantedNC ct_loc' rewriters inst_pred -- NB: inst_pred can be an equality ; return ( wantedCtEvEvId wanted_ev , unitBag (mkNonCanonical $ CtWanted wanted_ev)) } ; traceTcS "solveForAll" (ppr given_ev_vars $$ ppr wanteds $$ ppr w_id) - ; ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds + ; ev_binds_var <- newTcEvBinds + ; solved <- trySolveImplication $ + implicationPrototype loc_env + { ic_tclvl = lvl + , ic_binds = ev_binds_var + , ic_info = skol_info_anon + , ic_warn_inacessible = False + , ic_skols = skol_tvs + , ic_given = given_ev_vars + , ic_wanted = emptyWC { wc_simple = wanteds } } + ; if not solved + then updInertIrreds ( + else + do { ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds ; setWantedEvTerm dest EvCanonical $ EvFun { et_tvs = skol_tvs, et_given = given_ev_vars , et_binds = ev_binds, et_body = w_id } ; stopWith (CtWanted wtd) "Wanted forall-constraint (implication)" } where - is_qc = IsQC (ctLocOrigin loc) + loc_env = ctLocEnv loc + is_qc = IsQC (ctLocOrigin ct_loc) empty_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfTypes (body_pred:theta) `delVarSetList` tvs ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -990,8 +990,9 @@ pendingScDict_maybe _ = Nothing pendingScInst_maybe :: QCInst -> Maybe QCInst -- Same as isPendingScDict, but for QCInsts -pendingScInst_maybe qci@(QCI { qci_pend_sc = f }) - | pendingFuel f = Just (qci { qci_pend_sc = doNotExpand }) +pendingScInst_maybe qci@(QCI { qci_flav = flav, qci_pend_sc = f }) + | Given <- flav -- Do not expand Wanted QCIs + , pendingFuel f = Just (qci { qci_pend_sc = doNotExpand }) | otherwise = Nothing superClassesMightHelp :: WantedConstraints -> Bool View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c2484ebf3115bceda3f39062b9a9b1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c2484ebf3115bceda3f39062b9a9b1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] Clean up a bit
by Alan Zimmerman (＠alanz) 22 Jun '25

22 Jun '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: eadbe239 by Alan Zimmerman at 2025-06-22T22:05:12+01:00 Clean up a bit - - - - - 2 changed files: - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -767,18 +767,6 @@ TH_TY_QUOTE { L _ ITtyQuote } -- ''T TH_QUASIQUOTE { L _ (ITquasiQuote _) } TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } --- Ghc CPP --- '#define' { L _ (ITcppDefine _) } --- '#include' { L _ (ITcppInclude _) } --- '#undef' { L _ (ITcppUndef _) } --- '#error' { L _ (ITcppError _) } --- '#if' { L _ (ITcppIf _) } --- '#ifdef' { L _ (ITcppIfdef _) } --- '#ifndef' { L _ (ITcppIfndef _) } --- '#elif' { L _ (ITcppElif _) } --- '#else' { L _ ITcppElse } --- '#endif' { L _ ITcppEndif } - -- %monad { P p } { >>= } { return } %monad { P PpState } { >>= } { return } %lexer { (lexer True) } { L _ ITeof } @@ -4611,10 +4599,6 @@ amsA' (L l a) = do !cs <- getCommentsFor l return (L (EpAnn (spanAsAnchor l) noAnn cs) a) --- acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P PpState ECP --- acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a --- ; return (ecpFromExp $ expr) } - amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a) amsA (L !l a) bs = do !cs <- getCommentsFor (locA l) ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -2658,15 +2658,6 @@ data PState a = PState { data PpContext = PpContextIf [Located Token] deriving (Show) --- TODO: delete --- initPpState :: PpState --- initPpState = PpState --- { pp_defines = Map.empty --- , pp_continuation = [] --- , pp_context = [] --- , pp_accepting = True --- } - data ALRContext = ALRNoLayout Bool{- does it contain commas? -} Bool{- is it a 'let' block? -} | ALRLayout ALRLayout Int @@ -3104,8 +3095,6 @@ mkParserOpts extensionFlags diag_opts .|. MultilineStringsBit `xoptBit` LangExt.MultilineStrings .|. LevelImportsBit `xoptBit` LangExt.ExplicitLevelImports .|. GhcCppBit `xoptBit` LangExt.GhcCpp - -- .|. (trace ("GhcCppBit:" ++ show (GhcCppBit `xoptBit` LangExt.GhcCpp)) - -- GhcCppBit `xoptBit` LangExt.GhcCpp) optBits = HaddockBit `setBitIf` isHaddock .|. RawTokenStreamBit `setBitIf` rawTokStream @@ -3148,7 +3137,6 @@ extBitEnabled bit opts = xtest bit (pExtsBitmap opts) -- | Set parser options for parsing OPTIONS pragmas initPragState :: p -> ParserOpts -> StringBuffer -> RealSrcLoc -> PState p initPragState p options buf loc = (initParserState p options buf loc) --- initPragState options buf loc = (initParserState options buf (trace ("initPragState:" ++ show bol) loc)) { lex_state = [bol, option_prags, 0] } @@ -3337,9 +3325,6 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, POk s{ context = tl } () [] -> unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s - -- let s' = (trace "popContext empty" s) - -- in - -- unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s' -- Push a new layout context at the indentation of the last token read. pushCurrentContext :: GenSemic -> P p () @@ -3395,8 +3380,6 @@ srcParseFail :: P p a srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, last_loc = last_loc } -> unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s - -- let s' = trace ("srcParseFail") s - -- in unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s' -- A lexical error is reported at a particular position in the source file, -- not over a token range. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eadbe239c57c52d209ea58aa56e2603… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eadbe239c57c52d209ea58aa56e2603… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] Use PPM as Maybe inside PP
by Alan Zimmerman (＠alanz) 22 Jun '25

22 Jun '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: 58b88790 by Alan Zimmerman at 2025-06-22T21:41:14+01:00 Use PPM as Maybe inside PP - - - - - 2 changed files: - compiler/GHC/Parser/PreProcess/Macro.hs - compiler/GHC/Parser/PreProcess/State.hs Changes: ===================================== compiler/GHC/Parser/PreProcess/Macro.hs ===================================== @@ -35,97 +35,90 @@ details import Data.List (intercalate) import Data.Map qualified as Map import Data.Maybe - import Data.Semigroup qualified as S -import GHC.Driver.Errors.Types (PsMessage) -import GHC.Parser.Lexer qualified as Lexer + +import GHC.Base +import GHC.Parser.Lexer (P (..), PState (..), ParseResult (..)) import GHC.Parser.PreProcess.Eval import GHC.Parser.PreProcess.ParsePP import GHC.Parser.PreProcess.Parser qualified as Parser import GHC.Parser.PreProcess.ParserM import GHC.Parser.PreProcess.State import GHC.Prelude -import GHC.Types.Error (MsgEnvelope) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic (panic) -- --------------------------------------------------------------------- --- We evaluate to an Int, which we convert to a bool +-- We evaluate to an Int, which we convert to a bool cppCond :: SrcSpan -> String -> PP Bool cppCond loc str = do - s <- getPpState + r <- runPM $ cppCond' loc str + return $ fromMaybe False r + +cppCond' :: SrcSpan -> String -> PPM Bool +cppCond' loc str = do + s <- liftPM getPpState expanded <- expand loc (pp_defines s) str - case expanded of + v <- case Parser.parseExpr expanded of Left err -> do - Lexer.addError err - return False - Right expanded -> do - v <- case Parser.parseExpr expanded of - Left err -> do - let detail = - if str == expanded || expanded == "" - then - [ text str - ] - else - [ text expanded - , text "expanded from:" - , text str - ] - addGhcCPPError' - loc - "Error evaluating CPP condition:" - ( text err - <+> text "of" - $+$ vcat detail - ) - return 0 - Right tree -> return (eval tree) - return (toBool v) + let detail = + if str == expanded || expanded == "" + then + [text str] + else + [ text expanded + , text "expanded from:" + , text str + ] + liftPM $ + addGhcCPPError' + loc + "Error evaluating CPP condition:" + ( text err + <+> text "of" + $+$ vcat detail + ) + return 0 + Right tree -> return (eval tree) + return (toBool v) -- --------------------------------------------------------------------- -expand :: SrcSpan -> MacroDefines -> String -> PP (Either (MsgEnvelope PsMessage) String) +expand :: SrcSpan -> MacroDefines -> String -> PPM String expand loc s str = do case cppLex False str of Left err -> do - return - ( Left $ - mkGhcCPPError' - loc - "Error evaluating CPP condition:" - (text err <+> text "of" $+$ text str) - ) + liftPM $ + addGhcCPPError' + loc + "Error evaluating CPP condition:" + (text err <+> text "of" $+$ text str) + failPM Right tks -> do - expandedToks <- expandToks loc maxExpansions s tks - case expandedToks of - Left err -> return (Left err) - Right toks -> return $ Right $ combineToks $ map t_str toks + toks <- expandToks loc maxExpansions s tks + return $ combineToks $ map t_str toks maxExpansions :: Int maxExpansions = 15 -expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) [Token]) +expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PPM [Token] expandToks loc 0 _ ts = do - return $ - Left $ - mkGhcCPPError' - loc - "CPP macro expansion limit hit:" - (text (combineToks $ map t_str ts)) + liftPM $ + addGhcCPPError' + loc + "CPP macro expansion limit hit:" + (text (combineToks $ map t_str ts)) + failPM expandToks loc cnt s ts = do - expansion <- doExpandToks loc False s ts - case expansion of - Left err -> return (Left err) - Right (!expansionDone, !r) -> - if expansionDone - then expandToks loc (cnt - 1) s r - else return (Right r) - -doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) (Bool, [Token])) -doExpandToks _loc ed _ [] = return $ Right (ed, []) + (!expansionDone, !r) <- doExpandToks loc False s ts + if expansionDone + then expandToks loc (cnt - 1) s r + else return r + +doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PPM (Bool, [Token]) +doExpandToks _loc ed _ [] = return (ed, []) doExpandToks loc ed s (TIdentifierLParen n : ts) = -- TIdentifierLParen has no meaning here (only in a #define), so -- restore it to its constituent tokens @@ -136,26 +129,26 @@ doExpandToks loc _ s (TIdentifier "defined" : ts) = do case expandedArgs of (Just [[TIdentifier macro_name]], rest0) -> case Map.lookup macro_name s of - Nothing -> return $ Right (True, TInteger "0" : rest0) - Just _ -> return $ Right (True, TInteger "1" : rest0) + Nothing -> return (True, TInteger "0" : rest0) + Just _ -> return (True, TInteger "1" : rest0) (Nothing, TIdentifier macro_name : ts0) -> case Map.lookup macro_name s of - Nothing -> return $ Right (True, TInteger "0" : ts0) - Just _ -> return $ Right (True, TInteger "1" : ts0) + Nothing -> return (True, TInteger "0" : ts0) + Just _ -> return (True, TInteger "1" : ts0) (Nothing, _) -> do - return $ - Left $ - mkGhcCPPError' - loc - "CPP defined: expected an identifier, got:" - (text (concatMap t_str ts)) + liftPM $ + addGhcCPPError' + loc + "CPP defined: expected an identifier, got:" + (text (concatMap t_str ts)) + failPM -- TODO:AZ make part of addGhcCPPError'? (Just args, _) -> do - return $ - Left $ - mkGhcCPPError' - loc - "CPP defined: expected a single arg, got:" - (text (intercalate "," (map (concatMap t_str) args))) + liftPM $ + addGhcCPPError' + loc + "CPP defined: expected a single arg, got:" + (text (intercalate "," (map (concatMap t_str) args))) + failPM -- TODO:AZ make part of addGhcCPPError'? doExpandToks loc ed s (TIdentifier n : ts) = do (args, rest0) <- getExpandArgs loc ts let @@ -168,15 +161,11 @@ doExpandToks loc ed s (TIdentifier n : ts) = do (ed0, r, rest1) = case m_args of Nothing -> (True, rhs, ts) Just _ -> (True, replace_args args m_args rhs, rest0) - expansion <- doExpandToks loc ed' s ts' - case expansion of - Left err -> return $ Left err - Right (ed'', rest) -> return $ Right (ed'', expanded ++ rest) + (ed'', rest) <- doExpandToks loc ed' s ts' + return (ed'', expanded ++ rest) doExpandToks loc ed s (t : ts) = do - expansion <- doExpandToks loc ed s ts - case expansion of - Left err -> return (Left err) - Right (ed', r) -> return $ Right (ed', t : r) + (ed', r) <- doExpandToks loc ed s ts + return (ed', t : r) {- Note: ['defined' unary operator] @@ -248,14 +237,15 @@ inner parentheses do not separate arguments. {- | Look for possible arguments to a macro expansion. The only thing we look for are commas, open parens, and close parens. -} -getExpandArgs :: SrcSpan -> [Token] -> PP (Maybe [[Token]], [Token]) +getExpandArgs :: SrcSpan -> [Token] -> PPM (Maybe [[Token]], [Token]) getExpandArgs loc ts = case pArgs ts of Left err -> do - addGhcCPPError' - loc - "CPP: cannot expand macro arguments:" - (text err <+> text "in" $+$ text (concatMap t_str ts)) + liftPM $ + addGhcCPPError' + loc + "CPP: cannot expand macro arguments:" + (text err <+> text "in" $+$ text (concatMap t_str ts)) return (Nothing, ts) Right r -> return r @@ -336,6 +326,65 @@ isOther (TOpenParen _) = False isOther (TCloseParen _) = False isOther _ = True +-- --------------------------------------------------------------------- + +-- | Wrapper around P Monad to include a Maybe result +type PPM = PM PpState +-- See Note [PPM Monad] + +newtype PM p a = PM {unPM :: PState p -> ParseResult p (Maybe a)} + +instance Functor (PM p) where + fmap = liftM + +instance Applicative (PM p) where + pure = returnP + (<*>) = ap + +instance Monad (PM p) where + (>>=) = thenP + +returnP :: a -> PM p a +returnP a = a `seq` (PM $ \s -> POk s (Just a)) + +failPM :: PM p a +failPM = PM $ \s -> POk s Nothing + +thenP :: PM p a -> (a -> PM p b) -> PM p b +(PM m) `thenP` k = PM $ \s -> + case m s of + POk s1 Nothing -> POk s1 Nothing + POk s1 (Just a) -> (unPM (k a)) s1 + PFailed s1 -> PFailed s1 + +runPM :: PM p a -> P p (Maybe a) +runPM m = P $ \s -> (unPM m) s + +liftPM :: P p a -> PM p a +liftPM m = PM $ \s -> case (unP m) s of + POk s1 a -> POk s1 (Just a) + PFailed s1 -> PFailed s1 + +{- +Note [PPM Monad] +~~~~~~~~~~~~~~~~ + +The PPM monad is a combination of the Lexer P monad and the Maybe +monad. + +It is used when processing GHC_CPP macro conditionals, where we may +find an error processing the condition, such as a CPP parse error, +undefined macro, or similar. + +In this case we do not want to fail the overall GHC Parse, and simply +reporting the error and continuing is not enough, as the CPP +processing needs to be aware that there was a failure in the +processing, and not continue. In particular, this prevents reporting +additional CPP errors after the originating cause, and simplifies the +coding to not have to match on returned Maybe results +-} + + -- --------------------------------------------------------------------- m1 :: Either String [Token] ===================================== compiler/GHC/Parser/PreProcess/State.hs ===================================== @@ -32,10 +32,7 @@ module GHC.Parser.PreProcess.State ( ghcCppEnabled, setInLinePragma, getInLinePragma, - mkGhcCPPError', addGhcCPPError', - mkGhcCPPError, - addGhcCPPError, ) where import Data.List.NonEmpty ((<|)) @@ -59,6 +56,8 @@ import GHC.Utils.Outputable (hang, text, (<+>)) type PP = P PpState +-- --------------------------------------------------------------------- + data CppState = CppIgnoring | CppNormal @@ -268,7 +267,7 @@ parentScope = c :| [] -> c -- Perhaps should return enabled instead _ :| (h : _t) -> h in - POk s new_scope + POk s (new_scope) -- Get the current scope value getScope :: PP PpScope @@ -427,11 +426,11 @@ mkGhcCPPError' loc title detail = detail ) -addGhcCPPError' :: SrcSpan -> String -> SDoc -> P p () +addGhcCPPError' :: SrcSpan -> String -> SDoc -> PP () addGhcCPPError' loc title detail = Lexer.addError $ mkGhcCPPError' loc title detail mkGhcCPPError :: SrcSpan -> SDoc -> MsgEnvelope PsMessage mkGhcCPPError loc err = mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp err -addGhcCPPError :: SrcSpan -> SDoc -> P p () +addGhcCPPError :: SrcSpan -> SDoc -> PP () addGhcCPPError loc err = Lexer.addError $ mkGhcCPPError loc err View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58b88790c7f7484a9b1571d0a3e2b38… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58b88790c7f7484a9b1571d0a3e2b38… You're receiving this email because of your account on gitlab.haskell.org.

1 0