- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/fix-ar
by Cheng Shao (＠TerrorJack) 13 Jun '25

13 Jun '25

Cheng Shao pushed new branch wip/fix-ar at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fix-ar 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 Rodrigo Mesquita (＠alt-romes) 13 Jun '25

13 Jun '25

Rodrigo Mesquita pushed to branch wip/module_graph_mode at Glasgow Haskell Compiler / GHC Commits: a27803fa by Matthew Pickering at 2025-06-13T20:14:56+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/a27803fa7ab18582f61558aaf3799d9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a27803fa7ab18582f61558aaf3799d9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26118-remove-hptallfaminstances-usage-during-upsweep] Remove unused hptAllFamInstances and allFamInstances functions
by Patrick (＠soulomoon) 13 Jun '25

13 Jun '25

Patrick pushed to branch wip/T26118-remove-hptallfaminstances-usage-during-upsweep at Glasgow Haskell Compiler / GHC Commits: c589f636 by soulomoon at 2025-06-14T01:32:16+08:00 Remove unused hptAllFamInstances and allFamInstances functions - - - - - 2 changed files: - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/Home/PackageTable.hs Changes: ===================================== 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) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c589f636786ecb43f15c7a3623cb143… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c589f636786ecb43f15c7a3623cb143… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26115] More wibbles
by Simon Peyton Jones (＠simonpj) 13 Jun '25

13 Jun '25

Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 3405e84e by Simon Peyton Jones at 2025-06-13T17:43:53+01:00 More wibbles - - - - - 3 changed files: - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/HsToCore/Binds.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -29,13 +29,11 @@ import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable , mkCast, exprType , stripTicksTop, mkInScopeSetBndrs ) import GHC.Core.FVs -import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Core.Opt.Arity( collectBindersPushingCo ) --- import GHC.Core.Ppr( pprIds ) import GHC.Builtin.Types ( unboxedUnitTy ) -import GHC.Data.Maybe ( maybeToList, isJust ) +import GHC.Data.Maybe ( isJust ) import GHC.Data.Bag import GHC.Data.OrdList import GHC.Data.List.SetOps @@ -46,7 +44,7 @@ import GHC.Types.Unique.DFM import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar ) +import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id @@ -56,6 +54,7 @@ import GHC.Types.Error import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad ( foldlM ) import GHC.Utils.Misc +import GHC.Utils.FV import GHC.Utils.Outputable import GHC.Utils.Panic @@ -1612,12 +1611,17 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs is_dfun = isDFunId fn dflags = se_dflags env this_mod = se_module env + subst = se_subst env + in_scope = Core.substInScopeSet subst -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs -- See Note [Account for casts in binding] + not_in_scope :: InterestingVarFun + not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope) + ---------------------------------------------------------- -- Specialise to one particular call pattern spec_call :: SpecInfo -- Accumulating parameter @@ -1628,25 +1632,40 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs do { let all_call_args | is_dfun = saturating_call_args -- See Note [Specialising DFuns] | otherwise = call_args saturating_call_args = call_args ++ map mk_extra_dfun_arg (dropList call_args rhs_bndrs) - mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType (tyVarKind bndr) -- ToDo: right? - | otherwise = UnspecArg (idType bndr) - - ; (useful, rule_bndrs, rule_lhs_args, spec_bndrs1, spec_args) <- specHeader env all_call_args - --- ; pprTrace "spec_call" (vcat --- [ text "fun: " <+> ppr fn --- , text "call info: " <+> ppr _ci --- , text "useful: " <+> ppr useful --- , text "rule_bndrs:" <+> ppr rule_bndrs --- , text "lhs_args: " <+> ppr rule_lhs_args --- , text "spec_bndrs1:" <+> ppr spec_bndrs1 --- , text "spec_args: " <+> ppr spec_args --- , text "dx_binds: " <+> ppr dx_binds --- , text "rhs_bndrs" <+> ppr rhs_bndrs --- , text "rhs_body" <+> ppr rhs_body --- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) --- , ppr dx_binds ]) $ --- return () + mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType + | otherwise = UnspecArg + + -- Find qvars, the type variables to add to the binders for the rule + -- Namely those free in `ty` that aren't in scope + -- See (MP2) in Note [Specialising polymorphic dictionaries] + ; let poly_qvars = scopedSort $ fvVarList $ specArgsFVs not_in_scope call_args + poly_qvar_es = map varToCoreExpr poly_qvars -- Account for CoVars + + subst' = subst `Core.extendSubstInScopeList` poly_qvars + -- Maybe we should clone the poly_qvars telescope? + + -- Any free Ids will have caused the call to be dropped + ; massertPpr (all isTyCoVar poly_qvars) + (ppr fn $$ ppr all_call_args $$ ppr poly_qvars) + + ; (useful, subst'', rule_bndrs, rule_lhs_args, spec_bndrs, spec_args) + <- specHeader subst' rhs_bndrs all_call_args + ; (rule_bndrs, rule_lhs_args, spec_bndrs, spec_args) + <- return ( poly_qvars ++ rule_bndrs, poly_qvar_es ++ rule_lhs_args + , poly_qvars ++ spec_bndrs, poly_qvar_es ++ spec_args ) + + ; pprTrace "spec_call" (vcat + [ text "fun: " <+> ppr fn + , text "call info: " <+> ppr _ci + , text "poly_qvars: " <+> ppr poly_qvars + , text "useful: " <+> ppr useful + , text "rule_bndrs:" <+> ppr rule_bndrs + , text "rule_lhs_args:" <+> ppr rule_lhs_args + , text "spec_bndrs:" <+> ppr spec_bndrs + , text "spec_args: " <+> ppr spec_args + , text "rhs_bndrs" <+> ppr rhs_bndrs + , text "rhs_body" <+> ppr rhs_body ]) $ + return () ; let all_rules = rules_acc ++ existing_rules -- all_rules: we look both in the rules_acc (generated by this invocation @@ -1657,27 +1676,28 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs then return spec_acc else do { -- Run the specialiser on the specialised RHS - -- The "1" suffix is before we maybe add the void arg - ; (rhs_body', rhs_uds) <- specRhs env rhs_bndrs rhs_body spec_args + (rhs_body', rhs_uds) <- specExpr (env { se_subst = subst'' }) $ + mkLams (dropList spec_args rhs_bndrs) rhs_body + -- Add the { d1' = dx1; d2' = dx2 } usage stuff -- to the rhs_uds; see Note [Specialising Calls] ; let (spec_uds, dumped_dbs) = dumpUDs spec_bndrs1 rhs_uds - spec_rhs1 = mkLams spec_bndrs1 $ - wrapDictBindsE dumped_dbs rhs_body' - spec_fn_ty1 = exprType spec_rhs1 + spec_rhs = mkLams spec_bndrs $ + wrapDictBindsE dumped_dbs rhs_body' + spec_fn_ty = exprType spec_rhs -- Maybe add a void arg to the specialised function, -- to avoid unlifted bindings -- See Note [Specialisations Must Be Lifted] -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg - add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn) - (spec_bndrs, spec_rhs, spec_fn_ty) - | add_void_arg = ( voidPrimId : spec_bndrs1 - , Lam voidArgId spec_rhs1 - , mkVisFunTyMany unboxedUnitTy spec_fn_ty1) - | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) + add_void_arg = isUnliftedType spec_fn_ty && not (isJoinId fn) + (spec_bndrs1, spec_rhs1, spec_fn_ty1) + | add_void_arg = ( voidPrimId : spec_bndrs + , Lam voidArgId spec_rhs + , mkVisFunTyMany unboxedUnitTy spec_fn_ty) + | otherwise = (spec_bndrs, spec_rhs, spec_fn_ty) - join_arity_decr = length rule_lhs_args - length spec_bndrs + join_arity_decr = length rule_lhs_args - length spec_bndrs1 -------------------------------------- -- Add a suitable unfolding; see Note [Inline specialisations] @@ -1685,7 +1705,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- arguments, not forgetting to wrap the dx_binds around the outside (#22358) simpl_opts = initSimpleOpts dflags wrap_unf_body body = body `mkApps` spec_args - spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body + spec_unf = specUnfolding simpl_opts spec_bndrs1 wrap_unf_body rule_lhs_args fn_unf -------------------------------------- @@ -1693,7 +1713,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- See Note [Arity decrease] in GHC.Core.Opt.Simplify -- Copy InlinePragma information from the parent Id. -- So if f has INLINE[1] so does spec_fn - arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs + arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs1 spec_inl_prag | not is_local -- See Note [Specialising imported functions] @@ -1715,7 +1735,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs DFunId unary -> DFunId unary _ -> VanillaId - ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info + ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty1 spec_fn_details spec_fn_info ; let -- The rule to put in the function's specialisation is: -- forall x @b d1' d2'. @@ -1728,12 +1748,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs spec_rule = mkSpecRule dflags this_mod True inl_act herald fn rule_bndrs rule_lhs_args - (mkVarApps (Var spec_fn) spec_bndrs) + (mkVarApps (Var spec_fn) spec_bndrs1) spec_f_w_arity = spec_fn _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type - , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty + , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty1 , ppr rhs_bndrs, ppr call_args , ppr spec_rule , text "acc" <+> ppr rules_acc @@ -1742,7 +1762,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ; -- pprTrace "spec_call: rule" _rule_trace_doc return ( spec_rule : rules_acc - , (spec_f_w_arity, spec_rhs) : pairs_acc + , (spec_f_w_arity, spec_rhs1) : pairs_acc , spec_uds `thenUDs` uds_acc ) } } @@ -1763,13 +1783,16 @@ alreadyCovered env bndrs fn args is_active rules where in_scope = substInScopeSet (se_subst env) -specRhs :: SpecEnv -> [Var] -> CoreExpr -> [CoreExpr] - -> SpecM (CoreExpr, UsageDetails) +{- +specRhs :: SpecEnv -> [InVar] -> InExpr -> [OutExpr] + -> SpecM (OutExpr, UsageDetails) -specRhs env bndrs body [] - = specLam env bndrs body +specRhs env bndrs body [] -- Like specExpr (Lam bndrs body) + = specLam env' bndrs' body + where + (env', bndrs') = substBndrs env bndrs -specRhs env [] body args +specRhs _env [] body args = -- The caller should have ensured that there are no more -- args than we have binders on the RHS pprPanic "specRhs:too many args" (ppr args $$ ppr body) @@ -1781,15 +1804,22 @@ specRhs env@(SE { se_subst = subst }) (bndr:bndrs) body (arg:args) | otherwise -- Non-trivial argument; it must be a dictionary - = do { fresh_dict_id <- newIdBndr "dx" (idType bndr) - ; let fresh_dict_id' = fresh_dict_id `addDictUnfolding` arg - dict_bind = mkDB (NonRec fresh_dict_id' arg) - env2 = env1 { se_subst = Core.extendSubst subst bndr (Var fresh_dict_id') - `Core.extendSubstInScope` fresh_dict_id' } + = do { fresh_id <- newIdBndr "dx" (exprType arg) + ; let fresh_id' = fresh_id `addDictUnfolding` arg + dict_bind = mkDB (NonRec fresh_id' arg) + env' = env { se_subst = Core.extendSubst subst bndr (Var fresh_id') + `Core.extendSubstInScope` fresh_id' } -- Ensure the new unfolding is in the in-scope set - ; (body', uds) <- specRhs env2 bndrs body args + ; (body', uds) <- specRhs env' bndrs body args ; return (body', dict_bind `consDictBind` uds) } +consDictBind :: DictBind -> UsageDetails -> UsageDetails +consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}} + = uds { ud_binds = FDB{ fdb_binds = db `consOL` binds + , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } } + +-} + -- Convenience function for invoking lookupRule from Specialise -- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr] specLookupRule :: SpecEnv -> Id -> [CoreExpr] @@ -2105,17 +2135,20 @@ defeated specialisation! Hence the use of collectBindersPushingCo. Note [Evidence foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (#12212) that we are specialising - f :: forall a b. (Num a, F a ~ F b) => blah + f :: forall a b. (Num a, F a ~# F b) => blah with a=b=Int. Then the RULE will be something like - RULE forall (d:Num Int) (g :: F Int ~ F Int). + RULE forall (d:Num Int) (g :: F Int ~# F Int). f Int Int d g = f_spec +where that `g` is really (Coercion (CoVar g)), since `g` is a +coercion variable and can't appear as (Var g). + But both varToCoreExpr (when constructing the LHS args), and the simplifier (when simplifying the LHS args), will transform to RULE forall (d:Num Int) (g :: F Int ~ F Int). f Int Int d <F Int> = f_spec by replacing g with Refl. So now 'g' is unbound, which results in a later crash. So we use Refl right off the bat, and do not forall-quantify 'g': - * varToCoreExpr generates a Refl + * varToCoreExpr generates a (Coercion Refl) * exprsFreeIdsList returns the Ids bound by the args, which won't include g @@ -2447,7 +2480,7 @@ data SpecArg SpecType Type -- | Type arguments that should remain polymorphic. - | UnspecType Kind + | UnspecType -- | Dictionaries that should be specialised. mkCallUDs ensures -- that only "interesting" dictionary arguments get a SpecDict; @@ -2455,25 +2488,25 @@ data SpecArg | SpecDict DictExpr -- | Value arguments that should not be specialised. - | UnspecArg Type + | UnspecArg instance Outputable SpecArg where - ppr (SpecType t) = text "SpecType" <+> ppr t - ppr (UnspecType k) = text "UnspecType" - ppr (SpecDict d) = text "SpecDict" <+> ppr d - ppr (UnspecArg t) = text "UnspecArg" - -specArgFreeIds :: SpecArg -> IdSet -specArgFreeIds (SpecType {}) = emptyVarSet -specArgFreeIds (SpecDict dx) = exprFreeIds dx -specArgFreeIds (UnspecType {}) = emptyVarSet -specArgFreeIds (UnspecArg {}) = emptyVarSet - -specArgFreeVars :: SpecArg -> VarSet -specArgFreeVars (SpecType ty) = tyCoVarsOfType ty -specArgFreeVars (UnspecType ki) = tyCoVarsOfType ki -specArgFreeVars (SpecDict dx) = exprFreeVars dx -specArgFreeVars (UnspecArg ty) = tyCoVarsOfType ty + ppr (SpecType t) = text "SpecType" <+> ppr t + ppr (SpecDict d) = text "SpecDict" <+> ppr d + ppr UnspecType = text "UnspecType" + ppr UnspecArg = text "UnspecArg" + +specArgsFVs :: InterestingVarFun -> [SpecArg] -> FV +-- Find the free vars of the SpecArgs that are not already in scope +specArgsFVs interesting args + = filterFV interesting $ + foldr (unionFV . get) emptyFV args + where + get :: SpecArg -> FV + get (SpecType ty) = tyCoFVsOfType ty + get (SpecDict dx) = exprFVs dx + get UnspecType = emptyFV + get UnspecArg = emptyFV isSpecDict :: SpecArg -> Bool isSpecDict (SpecDict {}) = True @@ -2523,12 +2556,15 @@ isSpecDict _ = False -- , [T1, T2, c, i, dEqT1, dShow1] -- ) specHeader - :: SpecEnv + :: Core.Subst -- This substitution applies to the [InBndr] + -> [InBndr] -- Binders from the original function `f` -> [SpecArg] -- From the CallInfo -> SpecM ( Bool -- True <=> some useful specialisation happened -- Not the same as any (isSpecDict args) because -- the args might be longer than bndrs + , Core.Subst -- Apply this to the body + -- RULE helpers , [OutBndr] -- Binders for the RULE , [OutExpr] -- Args for the LHS of the rule @@ -2539,63 +2575,57 @@ specHeader -- Same length as "Args for LHS of rule" ) +-- If we run out of binders, stop immediately +-- See Note [Specialisation Must Preserve Sharing] +specHeader subst [] _ = pure (False, subst, [], [], [], []) +specHeader subst _ [] = pure (False, subst, [], [], [], []) + -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details. -specHeader env (SpecType ty : args) - = do { -- Find qvars, the type variables to add to the binders for the rule - -- Namely those free in `ty` that aren't in scope - -- See (MP2) in Note [Specialising polymorphic dictionaries] - let in_scope = Core.substInScopeSet (se_subst env) - qvars = scopedSort $ - filterOut (`elemInScopeSet` in_scope) $ - tyCoVarsOfTypeList ty - ; (useful, rule_bs, rule_args, spec_bs, spec_args) <- specHeader env args - ; pure ( useful - , qvars ++ rule_bs - , Type ty : rule_args - , qvars ++ spec_bs - , Type ty : spec_args - ) - } +specHeader subst (bndr:bndrs) (SpecType ty : args) + = do { let subst1 = Core.extendTvSubst subst bndr ty + ; (useful, subst2, rule_bs, rule_args, spec_bs, spec_args) + <- specHeader subst1 bndrs args + ; pure ( useful, subst2 + , rule_bs, Type ty : rule_args + , spec_bs, Type ty : spec_args ) } -- Next we have a type that we don't want to specialise. We need to perform -- a substitution on it (in case the type refers to 'a'). Additionally, we need -- to produce a binder, LHS argument and RHS argument for the resulting rule, -- /and/ a binder for the specialised body. -specHeader env (UnspecType kind : args) - = do { (useful, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env' bndrs args - ; tv <- newTyVarBndr kind - ; pure ( useful - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , bndr' : spec_bs - , varToCoreExpr bndr' : spec_args - ) - } +specHeader subst (bndr:bndrs) (UnspecType : args) + = do { let (subst1, bndr') = Core.substBndr subst bndr + ; (useful, subst2, rule_bs, rule_es, spec_bs, spec_args) + <- specHeader subst1 bndrs args + ; let ty_e' = Type (mkTyVarTy bndr') + ; pure ( useful, subst2 + , bndr' : rule_bs, ty_e' : rule_es + , bndr' : spec_bs, ty_e' : spec_args ) } + +specHeader subst (bndr:bndrs) (_ : args) + | isDeadBinder bndr + , let (subst1, bndr') = Core.substBndr subst bndr + , Just rubbish_lit <- mkLitRubbish (idType bndr') + = -- See Note [Drop dead args from specialisations] + do { (useful, subst2, rule_bs, rule_es, spec_bs, spec_args) <- specHeader subst1 bndrs args + ; pure ( useful, subst2 + , bndr' : rule_bs, Var bndr' : rule_es + , spec_bs, rubbish_lit : spec_args ) } -- Next we want to specialise the 'Eq a' dict away. We need to construct -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details. -specHeader env (SpecDict dict_arg : args) - | not (isDeadBinder bndr) - , allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d) - -- See Note [Weird special case for SpecDict] - = do { (_, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env bndrs args - ; new_dict_id <- newIdBndr "dx" (exprType dict_arg) - ; let new_dict_expr = varToCoreExpr new_dict_id - -- See Note [Evidence foralls] - ; pure ( True -- Ha! A useful specialisation! - , exprFreeIdsList new_dict_expr ++ rule_bs - , new_dict_expr : rule_es - , spec_bs - , dict_arg : spec_args - ) - } +specHeader subst (bndr:bndrs) (SpecDict dict_arg : args) + = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) + -- zapIdOccInfo: see Note [Zap occ info in rule binders] + ; (_, subst2, rule_bs, rule_es, spec_bs, spec_args) <- specHeader subst1 bndrs args + ; pure ( True, subst2 -- Ha! A useful specialisation! + , bndr' : rule_bs, Var bndr' : rule_es + , spec_bs, dict_arg : spec_args ) } -- Finally, we don't want to specialise on this argument 'i': --- - It's an UnSpecArg, or --- - It's a dead dictionary -- We need to produce a binder, LHS and RHS argument for the RULE, and -- a binder for the specialised body. -- @@ -2603,46 +2633,21 @@ specHeader env (SpecDict dict_arg : args) -- why 'i' doesn't appear in our RULE above. But we have no guarantee that -- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so -- this case must be here. -specHeader env (arg : args) - -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead - = do { -- see Note [Zap occ info in rule binders] - ; (useful, rule_bs, rule_es, spec_bs, spec_args) <- specHeader env bndrs args - - ; spec_bndr <- case arg of - SpecDict d -> newIdBndr "dx" (exprType d) - UnspecArg t -> newIdBndr "x" t - ; let bndr_ty = idType bndr' - - -- See Note [Drop dead args from specialisations] - -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let - (mb_spec_bndr, spec_arg) - | isDeadBinder bndr - , Just lit_expr <- mkLitRubbish bndr_ty - = (Nothing, lit_expr) - | otherwise - = (Just bndr', varToCoreExpr bndr') - - ; pure ( useful - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , case mb_spec_bndr of - Just b -> b : spec_bs - Nothing -> spec_bs - , spec_arg : spec_args - ) - } +specHeader subst (bndr:bndrs) (UnspecArg : args) + = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) + -- zapIdOccInfo: see Note [Zap occ info in rule binders] + ; (useful, subst2, rule_bs, rule_es, spec_bs, spec_args) <- specHeader subst1 bndrs args --- If we run out of binders, stop immediately --- See Note [Specialisation Must Preserve Sharing] -specHeader env [] _ = pure (False, env, [], [], [], [], [], []) + ; let dummy_arg = varToCoreExpr bndr' + -- dummy_arg is usually just (Var bndr), + -- but if bndr :: t1 ~# t2, it'll be (Coercion (CoVar bndr)) + -- or even Coercion Refl (if t1=t2) + -- See Note [Evidence foralls] + bndrs = exprFreeIdsList dummy_arg --- Return all remaining binders from the original function. These have the --- invariant that they should all correspond to unspecialised arguments, so --- it's safe to stop processing at this point. -specHeader env bndrs [] - = pure (False, env', bndrs', [], [], [], [], []) - where - (env', bndrs') = substBndrs env bndrs + ; pure ( useful, subst2 + , bndrs ++ rule_bs, dummy_arg : rule_es + , bndrs ++ spec_bs, dummy_arg : spec_args ) } {- @@ -2672,12 +2677,12 @@ bindAuxiliaryDict env@(SE { se_subst = subst }) -- Ensure the new unfolding is in the in-scope set in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $ (env', Just dict_bind, Var fresh_dict_id') --} addDictUnfolding :: Id -> CoreExpr -> Id -- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting] -- and Note [Specialisation modulo dictionary selectors] addDictUnfolding id rhs = id `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs +-} {- Note [Make the new dictionaries interesting] @@ -2985,14 +2990,12 @@ singleCall spec_env id args = MkUD {ud_binds = emptyFDBs, ud_calls = unitDVarEnv id $ CIS id $ unitBag (CI { ci_key = args - , ci_fvs = call_fvs }) } + , ci_fvs = fvVarSet call_fvs }) } where - call_fvs = foldr (unionVarSet . free_var_fn) emptyVarSet args - - free_var_fn = - if gopt Opt_PolymorphicSpecialisation (se_dflags spec_env) - then specArgFreeIds - else specArgFreeVars + call_fvs | gopt Opt_PolymorphicSpecialisation (se_dflags spec_env) + = specArgsFVs isLocalVar args + | otherwise + = specArgsFVs isLocalId args -- specArgFreeIds: we specifically look for free Ids, not TyVars -- see (MP1) in Note [Specialising polymorphic dictionaries] @@ -3033,9 +3036,9 @@ mkCallUDs' env f args | binderVar bndr `elemVarSet` constrained_tyvars = SpecType ty | otherwise - = UnspecType (typeKind ty) + = UnspecType mk_spec_arg non_type_arg (Named bndr) - = = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr) + = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr) -- For "invisibleFunArg", which are the type-class dictionaries, -- we decide on a case by case basis if we want to specialise @@ -3046,7 +3049,7 @@ mkCallUDs' env f args -- See Note [Interesting dictionary arguments] = SpecDict arg - | otherwise = UnspecArg (exprType arg) + | otherwise = UnspecArg {- Note [Ticks on applications] @@ -3285,11 +3288,6 @@ snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs = uds { ud_binds = FDB { fdb_binds = binds `appOL` (toOL dbs) , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } } -consDictBind :: DictBind -> UsageDetails -> UsageDetails -consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}} - = uds { ud_binds = FDB{ fdb_binds = db `consOL` binds - , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } } - wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind] wrapDictBinds (FDB { fdb_binds = dbs }) binds = foldr add binds dbs @@ -3402,10 +3400,10 @@ beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 }) go _ _ = False go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2) - go_arg (UnspecType {}) (UnspecType {}) = True - go_arg (SpecDict {}) (SpecDict {}) = True - go_arg (UnspecArg {}) (UnspecArg {}) = True - go_arg _ _ = False + go_arg (SpecDict {}) (SpecDict {}) = True + go_arg UnspecType UnspecType = True + go_arg UnspecArg UnspecArg = True + go_arg _ _ = False ---------------------- splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet) @@ -3471,9 +3469,9 @@ mapAndCombineSM f (x:xs) = do (y, uds1) <- f x (ys, uds2) <- mapAndCombineSM f xs return (y:ys, uds1 `thenUDs` uds2) -extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv -extendTvSubst env tv ty - = env { se_subst = Core.extendTvSubst (se_subst env) tv ty } +-- extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv +-- extendTvSubst env tv ty +-- = env { se_subst = Core.extendTvSubst (se_subst env) tv ty } extendInScope :: SpecEnv -> OutId -> SpecEnv extendInScope env@(SE { se_subst = subst }) bndr @@ -3521,18 +3519,6 @@ newSpecIdSM old_name new_ty details info ; return (assert (not (isCoVarType new_ty)) $ mkLocalVar details new_name ManyTy new_ty info) } -newIdBndr :: String -> Type -> SpecM (SpecEnv, CoreBndr) --- Make up completely fresh binders for the dictionaries --- Their bindings are going to float outwards -newIdBndr env@(SE { se_subst = subst }) str ty - = do { uniq <- getUniqueM - ; return (mkUserLocal (mkVarOcc str) uniq ManyTy ty noSrcSpan) } - -newTyVarBndr :: Kind -> SpecM TyVar -newTyVarBndr kind - = do { uniq <- getUniqueM - ; let name = mkInternalName uniq (mkTyVarOcc "a") noSrcSpan - ; return (mkTyVar name kind } {- Old (but interesting) stuff about unboxed bindings ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -163,12 +163,14 @@ extendIdSubstList (Subst in_scope ids tvs cvs) prs -- | Add a substitution appropriate to the thing being substituted -- (whether an expression, type, or coercion). See also -- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' -extendSubst :: Subst -> Var -> CoreArg -> Subst +extendSubst :: HasDebugCallStack => Subst -> Var -> CoreArg -> Subst extendSubst subst var arg = case arg of - Type ty -> assert (isTyVar var) $ extendTvSubst subst var ty - Coercion co -> assert (isCoVar var) $ extendCvSubst subst var co - _ -> assert (isId var) $ extendIdSubst subst var arg + Type ty -> assertPpr (isTyVar var) doc $ extendTvSubst subst var ty + Coercion co -> assertPpr (isCoVar var) doc $ extendCvSubst subst var co + _ -> assertPpr (isId var) doc $ extendIdSubst subst var arg + where + doc = ppr var <+> text ":=" <+> ppr arg extendSubstWithVar :: Subst -> Var -> Var -> Subst extendSubstWithVar subst v1 v2 ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -1056,25 +1056,6 @@ dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl) dsSpec_help (idName poly_id) poly_id poly_rhs spec_inl spec_bndrs (core_app (Var poly_id)) -{- - do { dflags <- getDynFlags - ; case decomposeRuleLhs dflags spec_bndrs (core_app (Var poly_id)) - (mkVarSet spec_bndrs) of { - Left msg -> do { diagnosticDs msg; return Nothing } ; - Right (rule_bndrs, poly_id, rule_lhs_args) -> - - do { tracePm "dsSpec(old route)" $ - vcat [ text "poly_id" <+> ppr poly_id - , text "spec_bndrs" <+> ppr spec_bndrs - , text "the_call" <+> ppr (core_app (Var poly_id)) - , text "rule_bndrs" <+> ppr rule_bndrs - , text "rule_lhs_args" <+> ppr rule_lhs_args ] - - ; finishSpecPrag (idName poly_id) poly_rhs - rule_bndrs poly_id rule_lhs_args - spec_bndrs core_app spec_inl } } } --} - dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm , spe_fn_id = poly_id , spe_inl = inl View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3405e84ed1b7d4afd30b577c38b2bb5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3405e84ed1b7d4afd30b577c38b2bb5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/visible-forall-gadts] 11 commits: Hadrian: Add option to generate .hie files for stage1 libraries
by Vladislav Zavialov (＠int-index) 13 Jun '25

13 Jun '25

Vladislav Zavialov pushed to branch wip/int-index/visible-forall-gadts at Glasgow Haskell Compiler / GHC Commits: 35826d8b by Matthew Pickering at 2025-06-08T22:00:41+01:00 Hadrian: Add option to generate .hie files for stage1 libraries The +hie_files flavour transformer can be enabled to produce hie files for stage1 libraries. The hie files are produced in the "extra-compilation-artifacts" folder and copied into the resulting bindist. At the moment the hie files are not produced for the release flavour, they add about 170M to the final bindist. Towards #16901 - - - - - e2467dbd by Ryan Hendrickson at 2025-06-09T13:07:05-04:00 Fix various failures to -fprint-unicode-syntax - - - - - 1d99d3e4 by maralorn at 2025-06-12T03:47:39-04:00 Add necessary flag for js linking - - - - - 974d5734 by maralorn at 2025-06-12T03:47:39-04:00 Don’t use additional linker flags to detect presence of -fno-pie in configure.ac This mirrors the behavior of ghc-toolchain - - - - - 1e9eb118 by Andrew Lelechenko at 2025-06-12T03:48:21-04:00 Add HasCallStack to Control.Monad.Fail.fail CLC proposal https://github.com/haskell/core-libraries-committee/issues/327 2% compile-time allocations increase in T3064, likely because `fail` is now marginally more expensive to compile. Metric Increase: T3064 - - - - - 6d12060f by meooow25 at 2025-06-12T14:26:07-04:00 Bump containers submodule to 0.8 Also * Disable -Wunused-imports for containers * Allow containers-0.8 for in-tree packages * Bump some submodules so that they allow containers-0.8. These are not at any particular versions. * Remove unused deps containers and split from ucd2haskell * Fix tests affected by the new containers and hpc-bin - - - - - 537bd233 by Peng Fan at 2025-06-12T14:27:02-04:00 NCG/LA64: Optimize code generation and reduce build-directory size. 1. makeFarBranches: Prioritize fewer instruction sequences. 2. Prefer instructions with immediate numbers to reduce register moves, e.g. andi,ori,xori,addi. 3. Ppr: Remove unnecessary judgments. 4. genJump: Avoid "ld+jr" as much as possible. 5. BCOND and BCOND1: Implement conditional jumps with two jump ranges, with limited choice of the shortest. 6. Implement FSQRT, CLT, CTZ. 7. Remove unnecessary code. - - - - - 19f20861 by Simon Peyton Jones at 2025-06-13T09:51:11-04:00 Improve redundant constraints for instance decls Addresses #25992, which showed that the default methods of an instance decl could make GHC fail to report redundant constraints. Figuring out how to do this led me to refactor the computation of redundant constraints. See the entirely rewritten Note [Tracking redundant constraints] in GHC.Tc.Solver.Solve - - - - - 1d02798e by Matthew Pickering at 2025-06-13T09:51:54-04:00 Refactor the treatment of nested Template Haskell splices * The difference between a normal splice, a quasiquoter and implicit splice caused by lifting is stored in the AST after renaming. * Information that the renamer learns about splices is stored in the relevant splice extension points (XUntypedSpliceExpr, XQuasiQuote). * Normal splices and quasi quotes record the flavour of splice (exp/pat/dec etc) * Implicit lifting stores information about why the lift was attempted, so if it fails, that can be reported to the user. * After renaming, the decision taken to attempt to implicitly lift a variable is stored in the `XXUntypedSplice` extension field in the `HsImplicitLiftSplice` constructor. * Since all the information is stored in the AST, in `HsUntypedSplice`, the type of `PendingRnSplice` now just stores a `HsUntypedSplice`. * Error messages since the original program can be easily printed, this is noticeable in the case of implicit lifting. * The user-written syntax is directly type-checked. Before, some desugaring took place in the * Fixes .hie files to work better with nested splices (nested splices are not indexed) * The location of the quoter in a quasiquote is now located, so error messages will precisely point to it (and again, it is indexed by hie files) In the future, the typechecked AST should also retain information about the splices and the specific desugaring being left to the desugarer. Also, `runRnSplice` should call `tcUntypedSplice`, otherwise the typechecking logic is duplicated (see the `QQError` and `QQTopError` tests for a difference caused by this). - - - - - f93798ba by Cheng Shao at 2025-06-13T09:52:35-04:00 libffi: update to 3.5.1 Bumps libffi submodule. - - - - - a013284c by Vladislav Zavialov at 2025-06-13T18:24:15+03:00 Visible forall in GADTs 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> - - - - - 195 changed files: - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/CmmToAsm/LA64.hs - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - compiler/GHC/CmmToAsm/LA64/Instr.hs - compiler/GHC/CmmToAsm/LA64/Ppr.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/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Expr.hs-boot - compiler/GHC/Hs/Instances.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/Iface/Type.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.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/Gen/Splice.hs-boot - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/TH.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/ThLevelIndex.hs - compiler/GHC/Types/Var.hs-boot - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Pat.hs - compiler/ghc.cabal.in - docs/users_guide/9.14.1-notes.rst - docs/users_guide/exts/gadt_syntax.rst - docs/users_guide/exts/required_type_arguments.rst - ghc/ghc-bin.cabal.in - hadrian/doc/flavours.md - hadrian/doc/user-settings.md - hadrian/hadrian.cabal - hadrian/src/Context.hs - hadrian/src/Context/Path.hs - hadrian/src/Flavour.hs - hadrian/src/Flavour/Type.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Flavours/Release.hs - hadrian/src/Settings/Warnings.hs - libffi-tarballs - libraries/base/changelog.md - libraries/base/tests/IO/withBinaryFile002.stderr - libraries/base/tests/IO/withFile002.stderr - libraries/base/tests/IO/withFileBlocking002.stderr - libraries/containers - libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fail.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs-boot - libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - m4/fp_gcc_supports_no_pie.m4 - m4/fptools_set_c_ld_flags.m4 - testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr - testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr - testsuite/tests/dependent/should_fail/T13135_simple.stderr - testsuite/tests/dependent/should_fail/T16326_Fail6.stderr - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/ghci/scripts/T12550.stdout - testsuite/tests/ghci/scripts/T8959b.stderr - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/scripts/print-unicode-syntax.script - + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr - + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout - testsuite/tests/ghci/should_run/T11825.stdout - 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/hpc/fork/hpc_fork.stdout - testsuite/tests/hpc/function/tough.stdout - testsuite/tests/hpc/function2/tough2.stdout - testsuite/tests/hpc/simple/hpc001.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/linear/should_fail/LinearTHFail.stderr - testsuite/tests/linters/notes.stdout - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/partial-sigs/should_fail/T10999.stderr - testsuite/tests/perf/compiler/hard_hole_fits.stderr - testsuite/tests/printer/T18791.stderr - testsuite/tests/quasiquotation/T3953.stderr - + testsuite/tests/quotes/QQError.hs - + testsuite/tests/quotes/QQError.stderr - testsuite/tests/quotes/T10384.stderr - testsuite/tests/quotes/TH_localname.stderr - testsuite/tests/quotes/all.T - testsuite/tests/rebindable/DoRestrictedM.hs - + 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/QQInQuote.hs - + testsuite/tests/th/QQTopError.hs - + testsuite/tests/th/QQTopError.stderr - testsuite/tests/th/T10598_TH.stderr - testsuite/tests/th/T14681.stderr - testsuite/tests/th/T15321.stderr - testsuite/tests/th/T17804.stderr - testsuite/tests/th/T20868.stdout - testsuite/tests/th/T5508.stderr - testsuite/tests/th/TH_Lift.stderr - testsuite/tests/th/all.T - testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.stderr - testsuite/tests/typecheck/should_compile/T23739a.hs - + testsuite/tests/typecheck/should_compile/T25992.hs - + testsuite/tests/typecheck/should_compile/T25992.stderr - + testsuite/tests/typecheck/should_compile/TyAppPat_Tricky.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T20443b.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_TooMany.stderr - testsuite/tests/typecheck/should_fail/tcfail097.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/ghc-toolchain/src/GHC/Toolchain/Tools/Link.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 - utils/haddock/haddock-library/haddock-library.cabal - utils/haddock/hypsrc-test/ref/src/Quasiquoter.html - utils/hpc - utils/hsc2hs - utils/iserv/iserv.cabal.in The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8a533e6a533b7742040aae4757aae… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8a533e6a533b7742040aae4757aae… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/torsten.schmits/worker-debug] Link package DB bytecode in make mode
by Torsten Schmits (＠torsten.schmits) 13 Jun '25

13 Jun '25

Torsten Schmits pushed to branch wip/torsten.schmits/worker-debug at Glasgow Haskell Compiler / GHC Commits: f9587b0f by Torsten Schmits at 2025-06-13T16:30:07+02:00 Link package DB bytecode in make mode - - - - - 1 changed file: - compiler/GHC/Linker/Deps.hs Changes: ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -156,9 +156,10 @@ get_link_deps opts pls maybe_normal_osuf span mods = do listToUDFM [(moduleName (mi_module (hm_iface m)), m) | m <- mmods] link_libs = uniqDSetToList (unionManyUniqDSets (init_pkg_set : pkgs)) + deps <- oneshot_deps opts link_libs pure $ LinkModules (LinkHomeModule <$> link_mods) : - (LinkLibrary <$> link_libs) + deps -- This code is used in `--make` mode to calculate the home package and unit dependencies -- for a set of modules. @@ -168,15 +169,15 @@ get_link_deps opts pls maybe_normal_osuf span mods = do -- It is also a matter of correctness to use the module graph so that dependencies between home units -- is resolved correctly. - make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) + make_deps_loop :: (UniqDSet Module, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet Module, Set.Set NodeKey) make_deps_loop found [] = found make_deps_loop found@(found_units, found_mods) (nk:nexts) | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts | otherwise = case fmap mkNodeKey <$> mgReachable mod_graph (NodeKey_Module nk) of Nothing -> - let (ModNodeKeyWithUid _ uid) = nk - in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts + let (ModNodeKeyWithUid GWIB {gwib_mod} uid) = nk + in make_deps_loop (addOneToUniqDSet found_units (Module (RealUnit (Definite uid)) gwib_mod), found_mods) nexts Just trans_deps -> let deps = Set.insert (NodeKey_Module nk) (Set.fromList trans_deps) -- See #936 and the ghci.prog007 test for why we have to continue traversing through @@ -195,7 +196,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do let iface = hm_iface hmi case mi_hsc_src iface of HsBootFile -> throwProgramError opts $ link_boot_mod_error (mi_module iface) - _ -> pure (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface), hmi) + _ -> pure (mkUniqDSet [usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface, not (unitEnv_member (moduleUnitId usg_mod) (ue_home_unit_graph unit_env))], hmi) Nothing -> throwProgramError opts $ text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid @@ -344,7 +345,7 @@ oneshot_deps_loop opts (mod : mods) acc = do try_iface = liftIO (ldLoadIface opts load_reason mod) >>= \case - Failed err -> throwE (NoInterface err) + Failed _ -> add_library Succeeded iface -> location >>= \case InstalledFound loc _ -> with_iface loc iface View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9587b0fcc14565953326d0032a3e92… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9587b0fcc14565953326d0032a3e92… 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 Rodrigo Mesquita (＠alt-romes) 13 Jun '25

13 Jun '25

Rodrigo Mesquita pushed to branch wip/module_graph_mode at Glasgow Haskell Compiler / GHC Commits: 0f7cdd19 by Matthew Pickering at 2025-06-13T15:15:30+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 } @@ -996,7 +997,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/0f7cdd19e4404be66b92c338cbd9b39… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f7cdd19e4404be66b92c338cbd9b39… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/torsten.schmits/worker-debug] Link package DB bytecode in make mode
by Torsten Schmits (＠torsten.schmits) 13 Jun '25

13 Jun '25

Torsten Schmits pushed to branch wip/torsten.schmits/worker-debug at Glasgow Haskell Compiler / GHC Commits: 66de4a3a by Torsten Schmits at 2025-06-13T16:11:51+02:00 Link package DB bytecode in make mode - - - - - 1 changed file: - compiler/GHC/Linker/Deps.hs Changes: ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -156,9 +156,10 @@ get_link_deps opts pls maybe_normal_osuf span mods = do listToUDFM [(moduleName (mi_module (hm_iface m)), m) | m <- mmods] link_libs = uniqDSetToList (unionManyUniqDSets (init_pkg_set : pkgs)) + deps <- oneshot_deps opts link_libs pure $ LinkModules (LinkHomeModule <$> link_mods) : - (LinkLibrary <$> link_libs) + deps -- This code is used in `--make` mode to calculate the home package and unit dependencies -- for a set of modules. @@ -168,15 +169,15 @@ get_link_deps opts pls maybe_normal_osuf span mods = do -- It is also a matter of correctness to use the module graph so that dependencies between home units -- is resolved correctly. - make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) + make_deps_loop :: (UniqDSet Module, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet Module, Set.Set NodeKey) make_deps_loop found [] = found make_deps_loop found@(found_units, found_mods) (nk:nexts) | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts | otherwise = case fmap mkNodeKey <$> mgReachable mod_graph (NodeKey_Module nk) of Nothing -> - let (ModNodeKeyWithUid _ uid) = nk - in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts + let (ModNodeKeyWithUid GWIB {gwib_mod} uid) = nk + in make_deps_loop (addOneToUniqDSet found_units (Module (RealUnit (Definite uid)) gwib_mod), found_mods) nexts Just trans_deps -> let deps = Set.insert (NodeKey_Module nk) (Set.fromList trans_deps) -- See #936 and the ghci.prog007 test for why we have to continue traversing through @@ -195,7 +196,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do let iface = hm_iface hmi case mi_hsc_src iface of HsBootFile -> throwProgramError opts $ link_boot_mod_error (mi_module iface) - _ -> pure (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface), hmi) + _ -> pure ( mkUniqDSet $ [usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface], hmi) Nothing -> throwProgramError opts $ text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66de4a3ad9b15d48c86c69269ba2796… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66de4a3ad9b15d48c86c69269ba2796… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/torsten.schmits/worker-debug] Deleted 1 commit: debug retainers
by Torsten Schmits (＠torsten.schmits) 13 Jun '25

13 Jun '25

Torsten Schmits pushed to branch wip/torsten.schmits/worker-debug at Glasgow Haskell Compiler / GHC WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below. Deleted commits: 6d8c65a7 by Torsten Schmits at 2025-05-16T18:47:18+02:00 debug retainers - - - - - 1 changed file: - compiler/GHC.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -625,7 +625,9 @@ setUnitDynFlagsNoCheck uid dflags1 = do let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env) let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env) + !all_ids = hsc_all_home_unit_ids hsc_env + !all_ids' = seq (ppr all_ids) all_ids + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs all_ids' updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants let upd hue = View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d8c65a7096bba40ba1ba208e8fbfb0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d8c65a7096bba40ba1ba208e8fbfb0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T130103] rts/linker/LoadArchive: Don't rely on file extensions for identification
by Ben Gamari (＠bgamari) 13 Jun '25

13 Jun '25

Ben Gamari pushed to branch wip/T130103 at Glasgow Haskell Compiler / GHC Commits: c77b9301 by Ben Gamari at 2025-06-13T09:58:47-04:00 rts/linker/LoadArchive: Don't rely on file extensions for identification Previously archive members would be identified via their file extension, as described in #13103. We now instead use a more principled approach, relying on the magic number in the member's header. As well, we refactor treatment of archive format detection to improve code clarity and error handling. Closes #13103. - - - - - 1 changed file: - rts/linker/LoadArchive.c Changes: ===================================== rts/linker/LoadArchive.c ===================================== @@ -33,6 +33,7 @@ #define DEBUG_LOG(...) IF_DEBUG(linker, debugBelch("loadArchive: " __VA_ARGS__)) + #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) /* Read 4 bytes and convert to host byte order */ static uint32_t read4Bytes(const char buf[static 4]) @@ -40,7 +41,7 @@ static uint32_t read4Bytes(const char buf[static 4]) return ntohl(*(uint32_t*)buf); } -static bool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) +static bool loadFatArchive(char input[static 20], FILE* f, pathchar* path) { uint32_t nfat_arch, nfat_offset, cputype, cpusubtype; #if defined(i386_HOST_ARCH) @@ -58,8 +59,9 @@ static bool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) #error Unknown Darwin architecture #endif - nfat_arch = read4Bytes(tmp + 4); + nfat_arch = read4Bytes(input + 4); DEBUG_LOG("found a fat archive containing %d architectures\n", nfat_arch); + char tmp[20]; nfat_offset = 0; for (uint32_t i = 0; i < nfat_arch; i++) { /* search for the right arch */ @@ -108,7 +110,40 @@ static bool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) } #endif -static StgBool readThinArchiveMember(int n, int memberSize, pathchar* path, +enum ObjectFileFormat { + NotObject, + PortableExecutable, + ELF, + MachO32, + MachO64, +}; + +static enum ObjectFileFormat identifyObjectFile_(char* buf, size_t sz) +{ + if (sz > 4 && ((uint32_t*)buf)[0] == 0x5a4d) { + return PortableExecutable; + } + if (sz > 4 && memcmp(buf, "\x7f" "ELF", 4) == 0) { + return ELF; + } + if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedface) { + return MachO32; + } + if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedfacf) { + return MachO64; + } + return NotObject; +} + +static enum ObjectFileFormat identifyObjectFile(FILE *f) +{ + char buf[32]; + ssize_t sz = fread(buf, 1, 32, f); + CHECK(fseek(f, -sz, SEEK_CUR) == 0); + return identifyObjectFile_(buf, sz); +} + +static bool readThinArchiveMember(int n, int memberSize, pathchar* path, char* fileName, char* image) { bool has_succeeded = false; @@ -149,7 +184,7 @@ inner_fail: return has_succeeded; } -static bool checkFatArchive(char magic[static 20], FILE* f, pathchar* path) +static bool checkFatArchive(char magic[static 4], FILE* f, pathchar* path) { bool success = false; #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) @@ -241,46 +276,21 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, return true; } -HsInt loadArchive_ (pathchar *path) -{ - char *image = NULL; - HsInt retcode = 0; - int memberSize; - int memberIdx = 0; - FILE *f = NULL; - int n; - size_t thisFileNameSize = (size_t)-1; /* shut up bogus GCC warning */ - char *fileName; - size_t fileNameSize; - bool isGnuIndex, isThin, isImportLib; - char *gnuFileIndex; - int gnuFileIndexSize; - int misalignment = 0; - - DEBUG_LOG("start\n"); - DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); +enum ArchiveFormat { + StandardArchive, + ThinArchive, + FatArchive, +}; - /* Check that we haven't already loaded this archive. - Ignore requests to load multiple times */ - if (isAlreadyLoaded(path)) { - IF_DEBUG(linker, - debugBelch("ignoring repeated load of %" PATH_FMT "\n", path)); - return 1; /* success */ +static bool identifyArchiveFormat(FILE *f, pathchar *path, enum ArchiveFormat *out) +{ + char tmp[8]; + size_t n = fread(tmp, 1, 8, f); + if (n != 8) { + errorBelch("loadArchive: Failed reading header from `%" PATH_FMT "'", path); \ + return false; } - gnuFileIndex = NULL; - gnuFileIndexSize = 0; - - fileNameSize = 32; - fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)"); - - isThin = false; - isImportLib = false; - - f = pathopen(path, WSTR("rb")); - if (!f) - FAIL("loadObj: can't read `%" PATH_FMT "'", path); - /* Check if this is an archive by looking for the magic "!<arch>\n" * string. Usually, if this fails, we belch an error and return. On * Darwin however, we may have a fat archive, which contains archives for @@ -299,12 +309,10 @@ HsInt loadArchive_ (pathchar *path) * its magic "!<arch>\n" string and continue processing just as if * we had a single architecture archive. */ - - n = fread ( tmp, 1, 8, f ); - if (n != 8) { - FAIL("Failed reading header from `%" PATH_FMT "'", path); + if (strncmp(tmp, "!<arch>\n", 8) == 0) { + *out = StandardArchive; + return true; } - if (strncmp(tmp, "!<arch>\n", 8) == 0) {} /* Check if this is a thin archive by looking for the magic string "!<thin>\n" * * ar thin libraries have the exact same format as normal archives except they @@ -321,16 +329,59 @@ HsInt loadArchive_ (pathchar *path) * */ else if (strncmp(tmp, "!<thin>\n", 8) == 0) { - isThin = true; + *out = ThinArchive; + return true; } else { bool success = checkFatArchive(tmp, f, path); - if (!success) - goto fail; + if (!success) { + return false; + } + *out = FatArchive; + return true; } +} + +HsInt loadArchive_ (pathchar *path) +{ + char *image = NULL; + HsInt retcode = 0; + int memberIdx = 0; + FILE *f = NULL; + size_t thisFileNameSize = (size_t) -1; /* shut up bogus GCC warning */ + int misalignment = 0; + + DEBUG_LOG("start\n"); + DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); + + /* Check that we haven't already loaded this archive. + Ignore requests to load multiple times */ + if (isAlreadyLoaded(path)) { + IF_DEBUG(linker, + debugBelch("ignoring repeated load of %" PATH_FMT "\n", path)); + return 1; /* success */ + } + + char *gnuFileIndex = NULL; + int gnuFileIndexSize = 0; + + size_t fileNameSize = 32; + char *fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)"); + + f = pathopen(path, WSTR("rb")); + if (!f) + FAIL("loadObj: can't read `%" PATH_FMT "'", path); + + enum ArchiveFormat archive_fmt; + if (!identifyArchiveFormat(f, path, &archive_fmt)) { + FAIL("failed to identify archive format of %" PATH_FMT ".", path); + } + bool isThin = archive_fmt == ThinArchive; + DEBUG_LOG("loading archive contents\n"); while (1) { + size_t n; DEBUG_LOG("reading at %ld\n", ftell(f)); n = fread ( fileName, 1, 16, f ); if (n != 16) { @@ -350,6 +401,7 @@ HsInt loadArchive_ (pathchar *path) } #endif + char tmp[32]; n = fread ( tmp, 1, 12, f ); if (n != 12) FAIL("Failed reading mod time from `%" PATH_FMT "'", path); @@ -368,9 +420,16 @@ HsInt loadArchive_ (pathchar *path) tmp[10] = '\0'; for (n = 0; isdigit(tmp[n]); n++); tmp[n] = '\0'; - memberSize = atoi(tmp); + size_t memberSize; + { + char *end; + memberSize = strtol(tmp, &end, 10); + if (tmp == end) { + FAIL("Failed to decode member size"); + } + } - DEBUG_LOG("size of this archive member is %d\n", memberSize); + DEBUG_LOG("size of this archive member is %zd\n", memberSize); n = fread ( tmp, 1, 2, f ); if (n != 2) FAIL("Failed reading magic from `%" PATH_FMT "'", path); @@ -378,7 +437,7 @@ HsInt loadArchive_ (pathchar *path) FAIL("Failed reading magic from `%" PATH_FMT "' at %ld. Got %c%c", path, ftell(f), tmp[0], tmp[1]); - isGnuIndex = false; + bool isGnuIndex = false; /* Check for BSD-variant large filenames */ if (0 == strncmp(fileName, "#1/", 3)) { size_t n = 0; @@ -459,12 +518,7 @@ HsInt loadArchive_ (pathchar *path) DEBUG_LOG("Found member file `%s'\n", fileName); - /* TODO: Stop relying on file extensions to determine input formats. - Instead try to match file headers. See #13103. */ - isObject = (thisFileNameSize >= 2 && strncmp(fileName + thisFileNameSize - 2, ".o" , 2) == 0) - || (thisFileNameSize >= 3 && strncmp(fileName + thisFileNameSize - 3, ".lo" , 3) == 0) - || (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".p_o", 4) == 0) - || (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".obj", 4) == 0); + enum ObjectFileFormat object_fmt = identifyObjectFile(f); #if defined(OBJFORMAT_PEi386) /* @@ -478,13 +532,15 @@ HsInt loadArchive_ (pathchar *path) * * Linker members (e.g. filename / are skipped since they are not needed) */ - isImportLib = thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".dll", 4) == 0; + bool isImportLib = thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".dll", 4) == 0; +#else + bool isImportLib = false; #endif // windows DEBUG_LOG("\tthisFileNameSize = %d\n", (int)thisFileNameSize); - DEBUG_LOG("\tisObject = %d\n", isObject); + DEBUG_LOG("\tisObject = %d\n", object_fmt); - if (isObject) { + if (object_fmt != NotObject) { DEBUG_LOG("Member is an object file...loading...\n"); #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) @@ -509,7 +565,7 @@ HsInt loadArchive_ (pathchar *path) } else { - n = fread ( image, 1, memberSize, f ); + size_t n = fread ( image, 1, memberSize, f ); if (n != memberSize) { FAIL("error whilst reading `%" PATH_FMT "'", path); } @@ -527,9 +583,11 @@ HsInt loadArchive_ (pathchar *path) ObjectCode *oc = mkOc(STATIC_OBJECT, path, image, memberSize, false, archiveMemberName, misalignment); #if defined(OBJFORMAT_MACHO) + ASSERT(object_fmt == MachO32 || object_fmt == MachO64); ocInit_MachO( oc ); #endif #if defined(OBJFORMAT_ELF) + ASSERT(object_fmt == ELF); ocInit_ELF( oc ); #endif @@ -574,7 +632,7 @@ while reading filename from `%" PATH_FMT "'", path); "Skipping...\n"); n = fseek(f, memberSize, SEEK_CUR); if (n != 0) - FAIL("error whilst seeking by %d in `%" PATH_FMT "'", + FAIL("error whilst seeking by %zd in `%" PATH_FMT "'", memberSize, path); } #endif @@ -585,7 +643,7 @@ while reading filename from `%" PATH_FMT "'", path); if (!isThin || thisFileNameSize == 0) { n = fseek(f, memberSize, SEEK_CUR); if (n != 0) - FAIL("error whilst seeking by %d in `%" PATH_FMT "'", + FAIL("error whilst seeking by %zd in `%" PATH_FMT "'", memberSize, path); } } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c77b93013bcef8098a21f5d830aa4f4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c77b93013bcef8098a21f5d830aa4f4… You're receiving this email because of your account on gitlab.haskell.org.

1 0