- ghc-commits - Haskell.org

[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

[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: 906d4f40 by Alan Zimmerman at 2025-06-22T21:30:39+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 @@ -338,6 +328,44 @@ isOther _ = True -- --------------------------------------------------------------------- +type PPM = PM PpState + +-- | The parsing monad, isomorphic to @StateT PState Maybe@. +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 + +-- --------------------------------------------------------------------- + m1 :: Either String [Token] m1 = cppLex False "`" ===================================== 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/906d4f40f99fb4b2833a303bc06ff7c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/906d4f40f99fb4b2833a303bc06ff7c… 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) 22 Jun '25

22 Jun '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: fbf23539 by Teo Camarasu at 2025-06-22T13:03:25-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/fbf235390bde1df50270fb9b8aaf13a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbf235390bde1df50270fb9b8aaf13a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/riscv-vectors] 4 commits: Give up with vectors passed by reference
by Sven Tennie (＠supersven) 22 Jun '25

22 Jun '25

Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC Commits: eef2ec66 by Sven Tennie at 2025-06-22T13:41:41+02:00 Give up with vectors passed by reference - - - - - 3e510f90 by Sven Tennie at 2025-06-22T16:11:22+02:00 Adjust test - - - - - 6c85b16d by Sven Tennie at 2025-06-22T16:11:40+02:00 Fix warnings - - - - - 7f5ae460 by Sven Tennie at 2025-06-22T17:35:12+02:00 Use OrdList to insert vector configs - - - - - 6 changed files: - compiler/GHC/CmmToAsm/RV64/CodeGen.hs - compiler/GHC/CmmToAsm/RV64/Instr.hs - compiler/GHC/CmmToAsm/RV64/Ppr.hs - testsuite/tests/simd/should_run/VectorCCallConv.hs - + testsuite/tests/simd/should_run/VectorCCallConv.stdout - testsuite/tests/simd/should_run/VectorCCallConv_c.c Changes: ===================================== compiler/GHC/CmmToAsm/RV64/CodeGen.hs ===================================== @@ -1934,6 +1934,27 @@ genCondBranch true false expr = -- ----------------------------------------------------------------------------- -- Generating C calls +-- Note [RISC-V vector C calling convention] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- In short: +-- 1. The first 16 vector arguments are passed in registers v8 - v23 +-- 2. If there are free general registers, the pointers (references) to more +-- vectors are passed in them +-- 3. Otherwise, the pointers are passed on stack +-- +-- (1) is easy to accomplish. (2) and (3) require the vector register to be +-- stored with its full width. This width is unknown at compile time. So, the +-- natural way of storing it as temporary variable on the C stack conflicts +-- with GHC wanting to know the exact stack size at compile time. +-- +-- One could consider to allocate space for the vector registers to be passed +-- by reference on the heap. However, this turned out to be very complex and is +-- left for later versions of this NCG. +-- +-- For now, we expect that 16 vector arguments is probably sufficient for very +-- most function types. + -- | Generate a call to a C function. -- -- - Integer values are passed in GP registers a0-a7. @@ -2033,27 +2054,6 @@ genCCall target@(ForeignTarget expr _cconv) dest_regs arg_regs = do `appOL` moveStackUp stackSpaceWords return code where - -- TODO: Deallocate heap-allocated vectors after the main call - allocVectorHeap :: (Reg, Format, ForeignHint, InstrBlock) -> NatM (Reg, Format, ForeignHint, InstrBlock) - allocVectorHeap arg@(r, format, hint, code_r) | isVecFormat format = do - platform <- getPlatform - resRegUnq <- getUniqueM - let resLocalReg = LocalReg resRegUnq b64 - resReg = getRegisterReg platform (CmmLocal resLocalReg) - callCode <- mkCCall "malloc_vlen_vector" [resLocalReg] [] - let code = callCode `appOL` code_r `appOL` toOL [VS1R (OpReg format r) (OpAddr (AddrReg resReg))] - pure (resReg, II64, hint, code) - allocVectorHeap _ = panic "Unsupported general case" - - mkCCall :: FastString -> [CmmFormal] -> [CmmActual] -> NatM InstrBlock - mkCCall name dest_regs arg_regs = do - config <- getConfig - target <- - cmmMakeDynamicReference config CallReference - $ mkForeignLabel name ForeignLabelInThisPackage IsFunction - let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn - genCCall (ForeignTarget target cconv) dest_regs arg_regs - -- Implementation of the RISCV ABI calling convention. -- https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/948463cd5dbebea7c… passArguments :: [Reg] -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock) @@ -2135,23 +2135,11 @@ genCCall target@(ForeignTarget expr _cconv) dest_regs arg_regs = do `snocOL` ann (text "Pass vector argument: " <> ppr r) mov passArguments gpRegs fpRegs vRegs args stackSpaceWords (vReg : accumRegs) accumCode' - -- No more vector but free gp regs, and we want to pass a vector argument: Pass vector on heap and move its address to gp vector. - passArguments (gpReg : gpRegs) fpRegs [] (arg@(r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode - | isVecFormat format = do - (r', format', _hint, code_r') <- allocVectorHeap arg - let code = code_r' `appOL` toOL [MOV (OpReg II64 gpReg) (OpReg II64 r')] - passArguments gpRegs fpRegs [] args stackSpaceWords (gpReg : accumRegs) (accumCode `appOL` code) - - -- No more vector and gp regs, and we want to pass a vector argument: Pass vector address on stack and the vector itself on heap. - -- We need to put its address in the next slot - -- In RISC-V terms we pass an "aggregate by reference" - passArguments [] fpRegs [] (arg@(r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode - | isVecFormat format = do - (r', format', _hint, code_r') <- allocVectorHeap arg - let spOffet = 8 * stackSpaceWords - str = STR format' (OpReg II64 r') (OpAddr (AddrRegImm spMachReg (ImmInt spOffet))) - code = code_r' `snocOL` str - passArguments [] fpRegs [] args (stackSpaceWords + 1) accumRegs (accumCode `appOL` code) + -- No more free vector argument registers , and we want to pass a vector argument. + -- See Note [RISC-V vector C calling convention] + passArguments _gpRegs _fpRegs [] ((_r, format, _hint, _code_r) : _args) _stackSpaceWords _accumRegs _accumCode + | isVecFormat format = + panic "C call: no free vector argument registers. We only support 16 vector arguments (registers v8 - v23)." passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") @@ -2704,7 +2692,6 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks = VFMIN {} -> 2 VFMAX {} -> 2 VRGATHER {} -> 2 - VS1R {} -> 1 VFMA {} -> 3 -- estimate the subsituted size for jumps to lables -- jumps to registers have size 1 ===================================== compiler/GHC/CmmToAsm/RV64/Instr.hs ===================================== @@ -132,7 +132,6 @@ regUsageOfInstr platform instr = case instr of -- allocator doesn't use the src* registers as dst. (Otherwise, we end up -- with an illegal instruction.) VRGATHER dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst ++ regOp src1 ++ regOp src2) - VS1R src dst -> usage (regOp src ++ regOp dst, []) FMA _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) VFMA _ op1 op2 op3 -> @@ -249,7 +248,6 @@ patchRegsOfInstr instr env = case instr of VFMIN o1 o2 o3 -> VFMIN (patchOp o1) (patchOp o2) (patchOp o3) VFMAX o1 o2 o3 -> VFMAX (patchOp o1) (patchOp o2) (patchOp o3) VRGATHER o1 o2 o3 -> VRGATHER (patchOp o1) (patchOp o2) (patchOp o3) - VS1R o1 o2 -> VS1R (patchOp o1) (patchOp o2) FMA s o1 o2 o3 o4 -> FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) VFMA s o1 o2 o3 -> @@ -701,7 +699,6 @@ data Instr | VFMAX Operand Operand Operand | VFMA FMASign Operand Operand Operand | VRGATHER Operand Operand Operand - | VS1R Operand Operand data Signage = Signed | Unsigned deriving (Eq, Show) @@ -793,7 +790,6 @@ instrCon i = VFMIN {} -> "VFMIN" VFMAX {} -> "VFMAX" VRGATHER {} -> "VRGATHER" - VS1R {} -> "VS1R" FMA variant _ _ _ _ -> case variant of FMAdd -> "FMADD" ===================================== compiler/GHC/CmmToAsm/RV64/Ppr.hs ===================================== @@ -22,6 +22,7 @@ import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment) import GHC.Types.Unique (getUnique, pprUniqueAlways) import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Data.OrdList pprNatCmmDecl :: forall doc. (IsDoc doc) => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) = @@ -143,7 +144,7 @@ pprBasicBlock :: pprBasicBlock config info_env (BasicBlock blockid instrs) = maybe_infotable $ pprLabel platform asmLbl - $$ vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} instrs')) + $$ (vcat . fromOL) (mapOL (pprInstr platform) (id {-detectTrivialDeadlock-} instrs')) $$ ppWhen (ncgDwarfEnabled config) ( -- Emit both end labels since this may end up being a standalone @@ -154,7 +155,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) = ) ) where - instrs' = injectVectorConfig optInstrs + instrs' = injectVectorConfig (toOL optInstrs) -- TODO: Check if we can filter more instructions here. -- TODO: Shouldn't this be a more general check on a higher level? And, is this still needed? -- Filter out identity moves. E.g. mov x18, x18 will be dropped. @@ -163,34 +164,34 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) = f (MOV o1 o2) | o1 == o2 = False f _ = True - injectVectorConfig :: [Instr] -> [Instr] - injectVectorConfig instrs = fst $ foldl injectVectorConfig' ([], Nothing) instrs + injectVectorConfig :: OrdList Instr -> OrdList Instr + injectVectorConfig instrs = fst $ foldlOL injectVectorConfig' (nilOL, Nothing) instrs -- TODO: Fuse this with optInstrs -- TODO: Check config and only run this when vectors are configured -- TODO: Check if vectorMinBits is sufficient for the vector config - injectVectorConfig' :: ([Instr], Maybe Format) -> Instr -> ([Instr], Maybe Format) + injectVectorConfig' :: (OrdList Instr, Maybe Format) -> Instr -> (OrdList Instr, Maybe Format) injectVectorConfig' (accInstr, configuredVecFmt) currInstr = let configuredVecFmt' Nothing = Nothing configuredVecFmt' (Just fmt') = if isJumpishInstr currInstr then Nothing else Just fmt' in case (configuredVecFmt, instrVecFormat platform currInstr) of - (fmtA, Nothing) -> + (_fmtA, Nothing) -> -- no vector instruction ( accInstr - -- TODO: The performance of this appending is probably horrible. Check OrdList. - ++ [ -- (MULTILINE_COMMENT (text "No vector instruction" <> colon <+> text (instrCon currInstr) <+> pprInstr platform currInstr <> dot <> text "Current context" <> colon <+> ppr fmtA <> comma <+> text "New context" <+> ppr (configuredVecFmt' configuredVecFmt))), - currInstr - ], + `appOL` toOL + [ -- (MULTILINE_COMMENT (text "No vector instruction" <> colon <+> text (instrCon currInstr) <+> pprInstr platform currInstr)), + currInstr + ], configuredVecFmt' configuredVecFmt ) (Nothing, Just fmtB) -> -- vector instruction, but no active config ( accInstr - -- TODO: The performance of this appending is probably horrible. Check OrdList. - ++ [ COMMENT (text "No active vector config. Setting" <+> ppr fmtB), - (configVec fmtB), - currInstr - ], + `appOL` toOL + [ COMMENT (text "No active vector config. Setting" <+> ppr fmtB), + (configVec fmtB), + currInstr + ], configuredVecFmt' (Just fmtB) ) (Just fmtA, Just fmtB) -> @@ -198,15 +199,20 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) = then -- vectors already correctly configured ( accInstr - -- TODO: The performance of this appending is probably horrible. Check OrdList. - ++ [COMMENT (text "Active vector config. Keeping" <+> ppr fmtB), currInstr], + `appOL` toOL + [ COMMENT (text "Active vector config. Keeping" <+> ppr fmtB), + currInstr + ], configuredVecFmt' (Just fmtA) ) else -- re-configure ( accInstr - -- TODO: The performance of this appending is probably horrible. Check OrdList. - ++ [(COMMENT (text "Wrong active vector config. Setting" <+> ppr fmtB)), (configVec fmtB), currInstr], + `appOL` toOL + [ (COMMENT (text "Wrong active vector config. Setting" <+> ppr fmtB)), + (configVec fmtB), + currInstr + ], configuredVecFmt' (Just fmtB) ) @@ -876,8 +882,6 @@ pprInstr platform instr = case instr of VFMAX o1 o2 o3 -> pprPanic "RV64.pprInstr - VFMAX wrong operands." (pprOps platform [o1, o2, o3]) VRGATHER o1 o2 o3 | allVectorRegOps [o1, o2, o3] -> op3 (text "\tvrgather.vv") o1 o2 o3 VRGATHER o1 o2 o3 -> pprPanic "RV64.pprInstr - VRGATHER wrong operands." (pprOps platform [o1, o2, o3]) - VS1R o1 o2 | isVectorRegOp o1 -> op2 (text "\tvs1r.v") o1 o2 - VS1R o1 o2 -> pprPanic "RV64.pprInstr - VS1R wrong operands." (pprOps platform [o1, o2]) instr -> panic $ "RV64.pprInstr - Unknown instruction: " ++ instrCon instr where op1 op o1 = line $ op <+> pprOp platform o1 ===================================== testsuite/tests/simd/should_run/VectorCCallConv.hs ===================================== @@ -9,16 +9,10 @@ module Main where import Data.Int import GHC.Int import GHC.Prim +import System.IO foreign import ccall "printVecs_int64x2_c" printVecs_int64x2# :: - Int64X2# -> -- v1 - Int64X2# -> -- v2 - Int64X2# -> -- v3 - Int64X2# -> -- v4 - Int64X2# -> -- v5 - Int64X2# -> -- v6 - Int64X2# -> -- v7 Int64X2# -> -- v8 Int64X2# -> -- v9 Int64X2# -> -- v10 @@ -35,75 +29,38 @@ foreign import ccall "printVecs_int64x2_c" Int64X2# -> -- v21 Int64X2# -> -- v22 Int64X2# -> -- v23 - Int64X2# -> -- v24 - Int64X2# -> -- v25 - -- Int64X2# -> -- v26 - -- Int64X2# -> -- v27 - -- Int64X2# -> -- v28 - -- Int64X2# -> -- v29 - -- Int64X2# -> -- v30 - -- Int64X2# -> - -- Int64X2# -> - -- Int64X2# -> - -- Int64X2# -> - -- Int64X2# -> - -- Int64X2# -> IO () --- foreign import ccall "return_int64X2" --- return_int64X2# :: (# #) -> Int64X2# --- --- unpackInt64X2 :: Int64X2# -> (Int64, Int64) --- unpackInt64X2 v = case unpackInt64X2# v of --- (# x0, x1 #) -> (I64# x0, I64# x1) +foreign import ccall "return_int64X2" + return_int64X2# :: (# #) -> Int64X2# + +unpackInt64X2 :: Int64X2# -> (Int64, Int64) +unpackInt64X2 v = case unpackInt64X2# v of + (# x0, x1 #) -> (I64# x0, I64# x1) main :: IO () main = do - let v1 = packInt64X2# (# 0#Int64, 1#Int64 #) - v2 = packInt64X2# (# 2#Int64, 3#Int64 #) - v3 = packInt64X2# (# 4#Int64, 5#Int64 #) - v4 = packInt64X2# (# 6#Int64, 7#Int64 #) - v5 = packInt64X2# (# 8#Int64, 9#Int64 #) - v6 = packInt64X2# (# 10#Int64, 11#Int64 #) - v7 = packInt64X2# (# 12#Int64, 13#Int64 #) - v8 = packInt64X2# (# 14#Int64, 15#Int64 #) - v9 = packInt64X2# (# 16#Int64, 17#Int64 #) - v10 = packInt64X2# (# 18#Int64, 19#Int64 #) - v11 = packInt64X2# (# 20#Int64, 21#Int64 #) - v12 = packInt64X2# (# 22#Int64, 23#Int64 #) - v13 = packInt64X2# (# 24#Int64, 25#Int64 #) - v14 = packInt64X2# (# 26#Int64, 27#Int64 #) - v15 = packInt64X2# (# 28#Int64, 29#Int64 #) - v16 = packInt64X2# (# 30#Int64, 31#Int64 #) - v17 = packInt64X2# (# 32#Int64, 33#Int64 #) - v18 = packInt64X2# (# 34#Int64, 35#Int64 #) - v19 = packInt64X2# (# 36#Int64, 37#Int64 #) - v20 = packInt64X2# (# 38#Int64, 39#Int64 #) - v21 = packInt64X2# (# 40#Int64, 41#Int64 #) - v22 = packInt64X2# (# 42#Int64, 43#Int64 #) - v23 = packInt64X2# (# 44#Int64, 45#Int64 #) - v24 = packInt64X2# (# 46#Int64, 47#Int64 #) - v25 = packInt64X2# (# 48#Int64, 49#Int64 #) - v26 = packInt64X2# (# 50#Int64, 51#Int64 #) - v27 = packInt64X2# (# 52#Int64, 53#Int64 #) - v28 = packInt64X2# (# 54#Int64, 55#Int64 #) - v29 = packInt64X2# (# 56#Int64, 57#Int64 #) - v30 = packInt64X2# (# 58#Int64, 59#Int64 #) - -- v31 = packInt64X2# (# 60#Int64, 61#Int64 #) - -- v32 = packInt64X2# (# 62#Int64, 63#Int64 #) - -- v33 = packInt64X2# (# 64#Int64, 65#Int64 #) - -- v34 = packInt64X2# (# 66#Int64, 67#Int64 #) - -- v35 = packInt64X2# (# 68#Int64, 69#Int64 #) - -- v36 = packInt64X2# (# 70#Int64, 71#Int64 #) + -- Use some negative values to fill more bits and discover possible overlaps. + let v8 = packInt64X2# (# 0#Int64, -1#Int64 #) + v9 = packInt64X2# (# -2#Int64, 3#Int64 #) + v10 = packInt64X2# (# -4#Int64, 5#Int64 #) + v11 = packInt64X2# (# -6#Int64, 7#Int64 #) + v12 = packInt64X2# (# -8#Int64, 9#Int64 #) + v13 = packInt64X2# (# -10#Int64, 11#Int64 #) + v14 = packInt64X2# (# -12#Int64, 13#Int64 #) + v15 = packInt64X2# (# -14#Int64, 15#Int64 #) + v16 = packInt64X2# (# -16#Int64, 17#Int64 #) + v17 = packInt64X2# (# -18#Int64, 19#Int64 #) + v18 = packInt64X2# (# -20#Int64, 21#Int64 #) + v19 = packInt64X2# (# -22#Int64, 23#Int64 #) + v20 = packInt64X2# (# -24#Int64, 25#Int64 #) + v21 = packInt64X2# (# -26#Int64, 27#Int64 #) + v22 = packInt64X2# (# -28#Int64, 29#Int64 #) + v23 = packInt64X2# (# -30#Int64, 31#Int64 #) + print "Arguments" + hFlush stdout printVecs_int64x2# - v1 - v2 - v3 - v4 - v5 - v6 - v7 v8 v9 v10 @@ -120,22 +77,7 @@ main = do v21 v22 v23 - v24 - v25 - --- v26 - --- v27 --- v28 --- v29 --- v30 - --- v31 --- v32 --- v33 --- v34 --- v35 --- v26 --- let v = return_int64X2# --- print $ unpackInt64X2 v + print "Return values" + let v = return_int64X2# (# #) + print $ unpackInt64X2 v ===================================== testsuite/tests/simd/should_run/VectorCCallConv.stdout ===================================== @@ -0,0 +1,19 @@ +"Arguments" +[0, -1] +[-2, 3] +[-4, 5] +[-6, 7] +[-8, 9] +[-10, 11] +[-12, 13] +[-14, 15] +[-16, 17] +[-18, 19] +[-20, 21] +[-22, 23] +[-24, 25] +[-26, 27] +[-28, 29] +[-30, 31] +"Return values" +(-9223372036854775808,9223372036854775807) ===================================== testsuite/tests/simd/should_run/VectorCCallConv_c.c ===================================== @@ -19,10 +19,7 @@ void printVecs_int64x2_c(vint64m1_t v8, vint64m1_t v9, vint64m1_t v10, vint64m1_t v14, vint64m1_t v15, vint64m1_t v16, vint64m1_t v17, vint64m1_t v18, vint64m1_t v19, vint64m1_t v20, vint64m1_t v21, vint64m1_t v22, - vint64m1_t v23, vint64m1_t a0, vint64m1_t a1, - vint64m1_t a2, vint64m1_t a3, vint64m1_t a4, - vint64m1_t a5, vint64m1_t a6, vint64m1_t a7, - vint64m1_t s0) { + vint64m1_t v23) { printVec_int64(v8, 2); printVec_int64(v9, 2); printVec_int64(v10, 2); @@ -39,31 +36,11 @@ void printVecs_int64x2_c(vint64m1_t v8, vint64m1_t v9, vint64m1_t v10, printVec_int64(v21, 2); printVec_int64(v22, 2); printVec_int64(v23, 2); - printVec_int64(a0, 2); - printVec_int64(a1, 2); - printVec_int64(a2, 2); - printVec_int64(a3, 2); - printVec_int64(a4, 2); - printVec_int64(a5, 2); - printVec_int64(a6, 2); - printVec_int64(a7, 2); - printVec_int64(s0, 2); - // printVec_int64(v26, 2); - // printVec_int64(v27, 2); - // printVec_int64(v28, 2); - // printVec_int64(v29, 2); - // printVec_int64(v30, 2); - // printVec_int64(v31, 2); - // printVec_int64(v32, 2); - // printVec_int64(v33, 2); - // printVec_int64(v34, 2); - // printVec_int64(v35, 2); - // printVec_int64(v36, 2); - // + fflush(stdout); } -// vint64m1_t return_int64X2() { -// int64_t v[] = {INT64_MIN, INT64_MAX}; -// return __riscv_vle64_v_i64m1(v, 2); -// } +vint64m1_t return_int64X2() { + int64_t v[] = {INT64_MIN, INT64_MAX}; + return __riscv_vle64_v_i64m1(v, 2); +} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8497fb6f9fd87f0b1f1a61b0d541c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8497fb6f9fd87f0b1f1a61b0d541c… You're receiving this email because of your account on gitlab.haskell.org.

1 0