- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] Update "loading compiled code" GHCi documentation
by Hannes Siebenhandl (＠fendor) 27 May '25

27 May '25

Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC Commits: b1feabf0 by fendor at 2025-05-27T17:57:05+02:00 Update "loading compiled code" GHCi documentation To use object code in GHCi, the module needs to be compiled for use in GHCi. To do that, users need to compile their modules with: * `-dynamic` * `-this-unit-id interactive-session` Otherwise, the interface files will not match. - - - - - 1 changed file: - docs/users_guide/ghci.rst Changes: ===================================== docs/users_guide/ghci.rst ===================================== @@ -251,8 +251,8 @@ We can compile ``D``, then load the whole program, like this: .. code-block:: none - ghci> :! ghc -c -dynamic D.hs - ghci> :load A + ghci> :! ghc -c -this-unit-id interactive-session -dynamic D.hs + ghci> :load A B C D Compiling B ( B.hs, interpreted ) Compiling C ( C.hs, interpreted ) Compiling A ( A.hs, interpreted ) @@ -268,6 +268,10 @@ Note the :ghc-flag:`-dynamic` flag to GHC: GHCi uses dynamically-linked object code (if you are on a platform that supports it), and so in order to use compiled code with GHCi it must be compiled for dynamic linking. +Also, note the :ghc-flag:`-this-unit-id ⟨unit-id⟩` `interactive-session` to GHC: GHCi +can only use the object code of a module loaded via :ghci-cmd:`:load`, +if the object code has been compiled for the `interactive-session`. + At any time you can use the command :ghci-cmd:`:show modules` to get a list of the modules currently loaded into GHCi: @@ -301,8 +305,8 @@ So let's try compiling one of the other modules: .. code-block:: none - *ghci> :! ghc -c C.hs - *ghci> :load A + *ghci> :! ghc -c -this-unit-id interactive-session -dynamic C.hs + *ghci> :load A B C D Compiling D ( D.hs, interpreted ) Compiling B ( B.hs, interpreted ) Compiling C ( C.hs, interpreted ) @@ -316,7 +320,7 @@ rejected ``C``\'s object file. Ok, so let's also compile ``D``: .. code-block:: none - *ghci> :! ghc -c D.hs + *ghci> :! ghc -c -this-unit-id interactive-session -dynamic D.hs *ghci> :reload Ok, modules loaded: A, B, C, D. @@ -325,7 +329,7 @@ picked up by :ghci-cmd:`:reload`, only :ghci-cmd:`:load`: .. code-block:: none - *ghci> :load A + *ghci> :load A B C D Compiling B ( B.hs, interpreted ) Compiling A ( A.hs, interpreted ) Ok, modules loaded: A, B, C (C.o), D (D.o). View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b1feabf08cafcd5b77985e1b57f7b2b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b1feabf08cafcd5b77985e1b57f7b2b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] 2 commits: Make GHCi commands compatible with multiple home units
by Hannes Siebenhandl (＠fendor) 27 May '25

27 May '25

Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC Commits: 0fbcc2e9 by fendor at 2025-05-27T16:16:15+02:00 Make GHCi commands compatible with multiple home units === Design We enable all GHCi features that were previously guarded by the `inMulti` option. GHCi supported multiple home units up to a certain degree for quite a while now. The supported feature set was limited, due to a design impasse: One of the home units must be "active", e.g., there must be one `HomeUnit` whose `UnitId` is "active" which is returned when calling ```haskell do hscActiveUnitId <$> getSession ``` This makes sense in a GHC session, since you are always compiling a particular Module, but it makes less intuitive sense in an interactive session. Given an expression to evaluate, we can't easily tell in which "context" the expression should be parsed, typechecked and evaluated. That's why initially, most of GHCi features, except for `:reload`ing were disabled if the GHCi session had more than one `HomeUnitEnv`. We lift this restriction, enabling all features of GHCi for the multiple home unit case. To do this, we fundamentally change the `HomeUnitEnv` graph to be multiple home unit first. Instead of differentiating the case were we have a single home unit and multiple, we now always set up a multiple home unit session that scales seamlessly to an arbitrary amount of home units. We introduce two new `HomeUnitEnv`s that are always added to the `HomeUnitGraph`. They are: The "interactive-ghci", called the `interactiveGhciUnit`, contains the same `DynFlags` that are used by the `InteractiveContext` for interactive evaluation of expressions. This `HomeUnitEnv` is only used on the prompt of GHCi, so we may refer to it as "interactive-prompt" unit. See Note [Relation between the `InteractiveContext` and `interactiveGhciUnitId`] for discussing its role. And the "interactive-session"", called `interactiveSessionUnit` or `interactiveSessionUnitId`, which is used for loading Scripts into GHCi that are not `Target`s of any home unit, via `:load` or `:add`. Both of these "interactive" home units depend on all other `HomeUnitEnv`s that are passed as arguments on the cli. Additionally, the "interactive-ghci" unit depends on `interactive-session`. We always evaluate expressions in the context of the "interactive-ghci" session. Since "interactive-ghci" depends on all home units, we can import any `Module` from the other home units with ease. As we have a clear `HomeUnitGraph` hierarchy, we can set `interactiveGhciUnitId` as the active home unit for the full duration of the GHCi session. In GHCi, we always set `interactiveGhciUnitId` to be the currently active home unit. === Implementation Details Given this design idea, the implementation is relatively straight forward. The core insight is that a `ModuleName` is not sufficient to identify a `Module` in the `HomeUnitGraph`. Thus, large parts of the PR is simply about refactoring usages of `ModuleName` to prefer `Module`, which has a `Unit` attached and is unique over the `HomeUnitGraph`. Consequentially, most usages of `lookupHPT` are likely to be incorrect and have been replaced by `lookupHugByModule` which is keyed by a `Module`. In `GHCi/UI.hs`, we make sure there is only one location where we are actually translating `ModuleName` to a `Module`: * `lookupQualifiedModuleName` If a `ModuleName` is ambiguous, we detect this and report it to the user. To avoid repeated lookups of `ModuleName`s, we store the `Module` in the `InteractiveImport`, which additionally simplifies the interface loading. A subtle detail is that the `DynFlags` of the `InteractiveContext` are now stored both in the `HomeUnitGraph` and in the `InteractiveContext`. In UI.hs, there are multiple code paths where we are careful to update the `DynFlags` in both locations. Most importantly in `addToProgramDynFlags`. --- There is one metric increase in this commit: ------------------------- Metric Increase: T4029 ------------------------- It is an increase from 14.4 MB to 16.1 MB (+11.8%) which sounds like a pretty big regression at first. However, we argue this increase is solely caused by using more data structures for managing multiple home units in the GHCi session. In particular, due to the design decision of using three home units, the base memory usage increases... but by how much? A big contributor is the `UnitState`, of which we have three now, which on its own 260 KB per instance. That makes an additional memory usage of 520 KB, already explaining a third of the overall memory usage increase. Then we store more elements in the `HomeUnitGraph`, we have more `HomeUnitEnv` entries, etc... While we didn't chase down each byte, we looked at the memory usage over time for both `-hi` and `-hT` profiles and can say with confidence while the memory usage increased slightly, we did not introduce any space leak, as the graph looks almost identical as the memory usage graph of GHC HEAD. - - - - - c3ed675a by fendor at 2025-05-27T16:16:24+02:00 Update "loading compiled code" GHCi documentation To use object code in GHCi, the module needs to be compiled for use in GHCi. To do that, users need to compile their modules with: * `-dynamic` * `-this-unit-id interactive-session` Otherwise, the interface files will not match. - - - - - 21 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Name/Ppr.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/Types.hs - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - ghc/GHCi/UI/Info.hs - ghc/GHCi/UI/Monad.hs - ghc/Main.hs - testsuite/tests/linters/notes.stdout Changes: ===================================== compiler/GHC.hs ===================================== @@ -38,7 +38,9 @@ module GHC ( setSessionDynFlags, setUnitDynFlags, getProgramDynFlags, setProgramDynFlags, + setProgramHUG, setProgramHUG_, getInteractiveDynFlags, setInteractiveDynFlags, + normaliseInteractiveDynFlags, initialiseInteractiveDynFlags, interpretPackageEnv, -- * Logging @@ -55,6 +57,7 @@ module GHC ( addTarget, removeTarget, guessTarget, + guessTargetId, -- * Loading\/compiling the program depanal, depanalE, @@ -83,6 +86,7 @@ module GHC ( getModuleGraph, isLoaded, isLoadedModule, + isLoadedHomeModule, topSortModuleGraph, -- * Inspecting modules @@ -155,6 +159,7 @@ module GHC ( getBindings, getInsts, getNamePprCtx, findModule, lookupModule, findQualifiedModule, lookupQualifiedModule, + lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames, renamePkgQualM, renameRawPkgQualM, isModuleTrusted, moduleTrustReqs, getNamesInScope, @@ -443,6 +448,7 @@ import Control.Concurrent import Control.Monad import Control.Monad.Catch as MC import Data.Foldable +import Data.Function ((&)) import Data.IORef import Data.List (isPrefixOf) import Data.Typeable ( Typeable ) @@ -458,7 +464,7 @@ import System.Environment ( getEnv, getProgName ) import System.Exit ( exitWith, ExitCode(..) ) import System.FilePath import System.IO.Error ( isDoesNotExistError ) -import GHC.Unit.Home.PackageTable + -- %************************************************************************ -- %* * @@ -861,6 +867,113 @@ setProgramDynFlags_ invalidate_needed dflags = do when invalidate_needed $ invalidateModSummaryCache return changed +-- | Sets the program 'HomeUnitGraph'. +-- +-- Sets the given 'HomeUnitGraph' as the 'HomeUnitGraph' of the current +-- session. If the package flags change, we reinitialise the 'UnitState' +-- of all 'HomeUnitEnv's in the current session. +-- +-- This function unconditionally invalidates the module graph cache. +-- +-- Precondition: the given 'HomeUnitGraph' must have the same keys as the 'HomeUnitGraph' +-- of the current session. I.e., assuming the new 'HomeUnitGraph' is called +-- 'new_hug', then: +-- +-- @ +-- do +-- hug <- hsc_HUG \<$\> getSession +-- pure $ unitEnv_keys new_hug == unitEnv_keys hug +-- @ +-- +-- If this precondition is violated, the function will crash. +-- +-- Conceptually, similar to 'setProgramDynFlags', but performs the same check +-- for all 'HomeUnitEnv's. +setProgramHUG :: GhcMonad m => HomeUnitGraph -> m Bool +setProgramHUG = + setProgramHUG_ True + +-- | Same as 'setProgramHUG', but gives you control over whether you want to +-- invalidate the module graph cache. +setProgramHUG_ :: GhcMonad m => Bool -> HomeUnitGraph -> m Bool +setProgramHUG_ invalidate_needed new_hug0 = do + logger <- getLogger + + hug0 <- hsc_HUG <$> getSession + (changed, new_hug1) <- checkNewHugDynFlags logger hug0 new_hug0 + + if changed + then do + unit_env0 <- hsc_unit_env <$> getSession + home_unit_graph <- HUG.unitEnv_traverseWithKey + (updateHomeUnit logger unit_env0 new_hug1) + (ue_home_unit_graph unit_env0) + + let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit unit_env0) home_unit_graph + let unit_env = UnitEnv + { ue_platform = targetPlatform dflags1 + , ue_namever = ghcNameVersion dflags1 + , ue_home_unit_graph = home_unit_graph + , ue_current_unit = ue_currentUnit unit_env0 + , ue_eps = ue_eps unit_env0 + } + modifySession $ \h -> + -- hscSetFlags takes care of updating the logger as well. + hscSetFlags dflags1 h{ hsc_unit_env = unit_env } + else do + modifySession (\env -> + env + -- Set the new 'HomeUnitGraph'. + & hscUpdateHUG (const new_hug1) + -- hscSetActiveUnitId makes sure that the 'hsc_dflags' + -- are up-to-date. + & hscSetActiveUnitId (hscActiveUnitId env) + -- Make sure the logger is also updated. + & hscUpdateLoggerFlags) + + when invalidate_needed $ invalidateModSummaryCache + pure changed + where + checkNewHugDynFlags :: GhcMonad m => Logger -> HomeUnitGraph -> HomeUnitGraph -> m (Bool, HomeUnitGraph) + checkNewHugDynFlags logger old_hug new_hug = do + -- Traverse the new HUG and check its 'DynFlags'. + -- The old 'HUG' is used to check whether package flags have changed. + hugWithCheck <- HUG.unitEnv_traverseWithKey + (\unitId homeUnit -> do + let newFlags = homeUnitEnv_dflags homeUnit + oldFlags = homeUnitEnv_dflags (HUG.unitEnv_lookup unitId old_hug) + checkedFlags <- checkNewDynFlags logger newFlags + pure + ( packageFlagsChanged oldFlags checkedFlags + , homeUnit { homeUnitEnv_dflags = checkedFlags } + ) + ) + new_hug + let + -- Did any of the package flags change? + changed = or $ fmap fst hugWithCheck + hug = fmap snd hugWithCheck + pure (changed, hug) + + updateHomeUnit :: GhcMonad m => Logger -> UnitEnv -> HomeUnitGraph -> (UnitId -> HomeUnitEnv -> m HomeUnitEnv) + updateHomeUnit logger unit_env updates = \uid homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + dflags = case HUG.unitEnv_lookup_maybe uid updates of + Nothing -> homeUnitEnv_dflags homeUnitEnv + Just env -> homeUnitEnv_dflags env + old_hpt = homeUnitEnv_hpt homeUnitEnv + home_units = HUG.allUnits (ue_home_unit_graph unit_env) + + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants + pure HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = old_hpt + , homeUnitEnv_home_unit = Just home_unit + } -- When changing the DynFlags, we want the changes to apply to future -- loads, but without completely discarding the program. But the @@ -900,24 +1013,8 @@ getProgramDynFlags = getSessionDynFlags setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do logger <- getLogger - dflags' <- checkNewDynFlags logger dflags - dflags'' <- checkNewInteractiveDynFlags logger dflags' - modifySessionM $ \hsc_env0 -> do - let ic0 = hsc_IC hsc_env0 - - -- Initialise (load) plugins in the interactive environment with the new - -- DynFlags - plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ - hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }} - - -- Update both plugins cache and DynFlags in the interactive context. - return $ hsc_env0 - { hsc_IC = ic0 - { ic_plugins = hsc_plugins plugin_env - , ic_dflags = hsc_dflags plugin_env - } - } - + icdflags <- normaliseInteractiveDynFlags logger dflags + modifySessionM (initialiseInteractiveDynFlags icdflags) -- | Get the 'DynFlags' used to evaluate interactive expressions. getInteractiveDynFlags :: GhcMonad m => m DynFlags @@ -1022,6 +1119,36 @@ normalise_hyp fp ----------------------------------------------------------------------------- +-- | Normalise the 'DynFlags' for us in an interactive context. +-- +-- Makes sure unsupported Flags and other incosistencies are reported and removed. +normaliseInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +normaliseInteractiveDynFlags logger dflags = do + dflags' <- checkNewDynFlags logger dflags + checkNewInteractiveDynFlags logger dflags' + +-- | Given a set of normalised 'DynFlags' (see 'normaliseInteractiveDynFlags') +-- for the interactive context, initialize the 'InteractiveContext'. +-- +-- Initialized plugins and sets the 'DynFlags' as the 'ic_dflags' of the +-- 'InteractiveContext'. +initialiseInteractiveDynFlags :: GhcMonad m => DynFlags -> HscEnv -> m HscEnv +initialiseInteractiveDynFlags dflags hsc_env0 = do + let ic0 = hsc_IC hsc_env0 + + -- Initialise (load) plugins in the interactive environment with the new + -- DynFlags + plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ + hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags }} + + -- Update both plugins cache and DynFlags in the interactive context. + return $ hsc_env0 + { hsc_IC = ic0 + { ic_plugins = hsc_plugins plugin_env + , ic_dflags = hsc_dflags plugin_env + } + } + -- | Checks the set of new DynFlags for possibly erroneous option -- combinations when invoking 'setSessionDynFlags' and friends, and if -- found, returns a fixed copy (if possible). @@ -1084,7 +1211,7 @@ removeTarget target_id where filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ] --- | Attempts to guess what Target a string refers to. This function +-- | Attempts to guess what 'Target' a string refers to. This function -- implements the @--make@/GHCi command-line syntax for filenames: -- -- - if the string looks like a Haskell source filename, then interpret it @@ -1093,27 +1220,52 @@ removeTarget target_id -- - if adding a .hs or .lhs suffix yields the name of an existing file, -- then use that -- --- - otherwise interpret the string as a module name +-- - If it looks like a module name, interpret it as such -- +-- - otherwise, this function throws a 'GhcException'. guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target guessTarget str mUnitId (Just phase) = do tuid <- unitIdOrHomeUnit mUnitId return (Target (TargetFile str (Just phase)) True tuid Nothing) -guessTarget str mUnitId Nothing +guessTarget str mUnitId Nothing = do + targetId <- guessTargetId str + toTarget targetId + where + obj_allowed + | '*':_ <- str = False + | otherwise = True + toTarget tid = do + tuid <- unitIdOrHomeUnit mUnitId + pure $ Target tid obj_allowed tuid Nothing + +-- | Attempts to guess what 'TargetId' a string refers to. This function +-- implements the @--make@/GHCi command-line syntax for filenames: +-- +-- - if the string looks like a Haskell source filename, then interpret it +-- as such +-- +-- - if adding a .hs or .lhs suffix yields the name of an existing file, +-- then use that +-- +-- - If it looks like a module name, interpret it as such +-- +-- - otherwise, this function throws a 'GhcException'. +guessTargetId :: GhcMonad m => String -> m TargetId +guessTargetId str | isHaskellSrcFilename file - = target (TargetFile file Nothing) + = pure (TargetFile file Nothing) | otherwise = do exists <- liftIO $ doesFileExist hs_file if exists - then target (TargetFile hs_file Nothing) + then pure (TargetFile hs_file Nothing) else do exists <- liftIO $ doesFileExist lhs_file if exists - then target (TargetFile lhs_file Nothing) + then pure (TargetFile lhs_file Nothing) else do if looksLikeModuleName file - then target (TargetModule (mkModuleName file)) + then pure (TargetModule (mkModuleName file)) else do dflags <- getDynFlags liftIO $ throwGhcExceptionIO @@ -1121,16 +1273,12 @@ guessTarget str mUnitId Nothing text "target" <+> quotes (text file) <+> text "is not a module name or a source file")) where - (file,obj_allowed) - | '*':rest <- str = (rest, False) - | otherwise = (str, True) + file + | '*':rest <- str = rest + | otherwise = str - hs_file = file <.> "hs" - lhs_file = file <.> "lhs" - - target tid = do - tuid <- unitIdOrHomeUnit mUnitId - pure $ Target tid obj_allowed tuid Nothing + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" -- | Unwrap 'UnitId' or retrieve the 'UnitId' -- of the current 'HomeUnit'. @@ -1251,11 +1399,11 @@ type TypecheckedSource = LHsBinds GhcTc -- -- This function ignores boot modules and requires that there is only one -- non-boot module with the given name. -getModSummary :: GhcMonad m => ModuleName -> m ModSummary +getModSummary :: GhcMonad m => Module -> m ModSummary getModSummary mod = do mg <- liftM hsc_mod_graph getSession let mods_by_name = [ ms | ms <- mgModSummaries mg - , ms_mod_name ms == mod + , ms_mod ms == mod , isBootSummary ms == NotBoot ] case mods_by_name of [] -> do dflags <- getDynFlags @@ -1286,7 +1434,9 @@ typecheckModule pmod = do liftIO $ do let ms = modSummary pmod let lcl_dflags = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.) - let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env + let lcl_hsc_env = + hscSetFlags lcl_dflags $ + hscSetActiveUnitId (toUnitId $ moduleUnit $ ms_mod ms) hsc_env let lcl_logger = hsc_logger lcl_hsc_env (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $ HsParsedModule { hpm_module = parsedSource pmod, @@ -1428,17 +1578,28 @@ compileCore simplify fn = do getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary getModuleGraph = liftM hsc_mod_graph getSession +{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-} -- | Return @True@ \<==> module is loaded. isLoaded :: GhcMonad m => ModuleName -> m Bool isLoaded m = withSession $ \hsc_env -> liftIO $ do - hmi <- lookupHpt (hsc_HPT hsc_env) m - return $! isJust hmi + hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m + return $! not (null hmis) +-- | Check whether a 'ModuleName' is found in the 'HomePackageTable' +-- for the given 'UnitId'. isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m return $! isJust hmi +-- | Check whether 'Module' is part of the 'HomeUnitGraph'. +-- +-- Similar to 'isLoadedModule', but for 'Module's. +isLoadedHomeModule :: GhcMonad m => Module -> m Bool +isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do + hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env) + return $! isJust hmi + -- | Return the bindings for the current interactive session. getBindings :: GhcMonad m => m [TyThing] getBindings = withSession $ \hsc_env -> @@ -1470,7 +1631,7 @@ data ModuleInfo = ModuleInfo { -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do - if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env + if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env) then liftIO $ getHomeModuleInfo hsc_env mdl else liftIO $ getPackageModuleInfo hsc_env mdl @@ -1826,6 +1987,50 @@ lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> liftIO $ do Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing +-- | Lookup the given 'ModuleName' in the 'HomeUnitGraph'. +-- +-- Returns 'Nothing' if no 'Module' has the given 'ModuleName'. +-- Otherwise, returns all 'Module's that have the given 'ModuleName'. +-- +-- A 'ModuleName' is generally not enough to uniquely identify a 'Module', since +-- there can be multiple units exposing the same 'ModuleName' in the case of +-- multiple home units. +-- Thus, this function may return more than one possible 'Module'. +-- We leave it up to the caller to decide how to handle the ambiguity. +-- For example, GHCi may prompt the user to clarify which 'Module' is the correct one. +-- +lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module]) +lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do + trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name) + HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case + [] -> return Nothing + mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos)) + +-- | Given a 'ModuleName' and 'PkgQual', lookup all 'Module's that may fit the criteria. +-- +-- Identically to 'lookupLoadedHomeModuleByModuleName', there may be more than one +-- 'Module' in the 'HomeUnitGraph' that has the given 'ModuleName'. +-- +-- The result is guaranteed to be non-empty, if no 'Module' can be found, +-- this function throws an error. +lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module] +lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do + home <- lookupLoadedHomeModuleByModuleName mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + let fc = hsc_FC hsc_env + let units = hsc_units hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + res <- findExposedPackageModule fc fopts units mod_name NoPkgQual + case res of + Found _ m -> return [m] + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err +lookupAllQualifiedModuleNames pkgqual mod_name = do + m <- findQualifiedModule pkgqual mod_name + pure [m] + -- | Check that a module is safe to import (according to Safe Haskell). -- -- We return True to indicate the import is safe and False otherwise ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -277,11 +277,20 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do where -- - mkEdge :: InteractiveImport -> (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName)) + mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName)) -- A simple edge to a module from the same home unit mkEdge (IIModule n) = - let unitId = homeUnitId $ hsc_home_unit hsc_env - in (unitId, NormalLevel, NoPkgQual, GWIB (noLoc n) NotBoot) + let + mod_node_key = ModNodeKeyWithUid + { mnkModuleName = GWIB (moduleName n) NotBoot + , mnkUnitId = + -- 'toUnitId' is safe here, as we can't import modules that + -- don't have a 'UnitId'. + toUnitId (moduleUnit n) + } + mod_node_edge = + ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key) + in Left mod_node_edge -- A complete import statement mkEdge (IIDecl i) = let lvl = convImportLevel (ideclLevelSpec i) @@ -289,37 +298,41 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do is_boot = ideclSource i mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i) unitId = homeUnitId $ hsc_home_unit hsc_env - in (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) + in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) loopFromInteractive :: HscEnv - -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] + -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] -> M.Map NodeKey ModuleGraphNode -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode) loopFromInteractive _ [] cached_nodes = return ([], cached_nodes) -loopFromInteractive hsc_env (edge:edges) cached_nodes = do - let (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) = edge - let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) - let k _ loc mod = - let key = moduleToMnk mod is_boot - in return $ FoundHome (ModuleNodeFixed key loc) - found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg [] - case found of - -- Case 1: Home modules have to already be in the cache. - FoundHome (ModuleNodeFixed mod _) -> do - let edge = ModuleNodeEdge lvl (NodeKey_Module mod) - -- Note: Does not perform any further downsweep as the module must already be in the cache. - (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes - return (edge : edges, cached_nodes') - -- Case 2: External units may not be in the cache, if we haven't already initialised the - -- module graph. We can construct the module graph for those here by calling loopUnit. - External uid -> do - let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env - cached_nodes' = loopUnit hsc_env' cached_nodes [uid] - edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid) - (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes' - return (edge : edges, cached_nodes') - -- And if it's not found.. just carry on and hope. - _ -> loopFromInteractive hsc_env edges cached_nodes +loopFromInteractive hsc_env (edge:edges) cached_nodes = + case edge of + Left edge -> do + (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes + return (edge : edges, cached_nodes') + Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do + let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) + let k _ loc mod = + let key = moduleToMnk mod is_boot + in return $ FoundHome (ModuleNodeFixed key loc) + found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg [] + case found of + -- Case 1: Home modules have to already be in the cache. + FoundHome (ModuleNodeFixed mod _) -> do + let edge = ModuleNodeEdge lvl (NodeKey_Module mod) + -- Note: Does not perform any further downsweep as the module must already be in the cache. + (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes + return (edge : edges, cached_nodes') + -- Case 2: External units may not be in the cache, if we haven't already initialised the + -- module graph. We can construct the module graph for those here by calling loopUnit. + External uid -> do + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + cached_nodes' = loopUnit hsc_env' cached_nodes [uid] + edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid) + (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes' + return (edge : edges, cached_nodes') + -- And if it's not found.. just carry on and hope. + _ -> loopFromInteractive hsc_env edges cached_nodes -- | Create a module graph from a list of installed modules. ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -162,6 +162,7 @@ module GHC.Driver.Session ( updOptLevel, setTmpDir, setUnitId, + setHomeUnitId, TurnOnFlag, turnOn, @@ -3114,6 +3115,9 @@ parseUnitArg = setUnitId :: String -> DynFlags -> DynFlags setUnitId p d = d { homeUnitId_ = stringToUnitId p } +setHomeUnitId :: UnitId -> DynFlags -> DynFlags +setHomeUnitId p d = d { homeUnitId_ = p } + setWorkingDirectory :: String -> DynFlags -> DynFlags setWorkingDirectory p d = d { workingDirectory = Just p } ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -918,12 +918,10 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do case mb_found of InstalledFound loc -> do -- See Note [Home module load error] - case mhome_unit of - Just home_unit - | isHomeInstalledModule home_unit mod - , not (isOneShot (ghcMode dflags)) - -> return (Failed (HomeModError mod loc)) - _ -> do + if HUG.memberHugUnitId (moduleUnit mod) (hsc_HUG hsc_env) + && not (isOneShot (ghcMode dflags)) + then return (Failed (HomeModError mod loc)) + else do r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) case r of Failed err ===================================== compiler/GHC/Rename/Unbound.hs ===================================== @@ -364,7 +364,7 @@ importSuggestions looking_for ic currMod imports rdr_name pick_interactive :: InteractiveImport -> Bool pick_interactive (IIDecl d) | mod_name == Just (unLoc (ideclName d)) = True | mod_name == fmap unLoc (ideclAs d) = True - pick_interactive (IIModule m) | mod_name == Just m = True + pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True pick_interactive _ = False -- We want to keep only one for each original module; preferably one with an ===================================== compiler/GHC/Runtime/Context.hs ===================================== @@ -115,6 +115,51 @@ The details are a bit tricky though: modules. +Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'InteractiveContext' is used to store 'DynFlags', 'Plugins' and similar +information about the so-called interactive "home unit". We are using +quotes here, since, originally, GHC wasn't aware of more than one 'HomeUnitEnv's. +So the 'InteractiveContext' was a hack/solution to have 'DynFlags' and 'Plugins' +independent of the 'DynFlags' and 'Plugins' stored in 'HscEnv'. +Nowadays, GHC has support for multiple home units via the 'HomeUnitGraph', thus, +this part of the 'InteractiveContext' is strictly speaking redundant, as we +can simply manage one 'HomeUnitEnv' for the 'DynFlags' and 'Plugins' that are +currently stored in the 'InteractiveContext'. + +As a matter of fact, that's exactly what we do nowadays. +That means, we can also lift other restrictions in the future, for example +allowing @:seti@ commands to modify the package-flags, since we now have a +separate 'UnitState' for the interactive session. +However, we did not rip out 'ic_dflags' and 'ic_plugins', yet, as it makes +it easier to access them for functions that want to use the interactive 'DynFlags', +such as 'runInteractiveHsc' and 'mkInteractiveHscEnv', without having to look that +information up in the 'HomeUnitGraph'. +It is reasonable to change this in the future, and remove 'ic_dflags' and 'ic_plugins'. + +We keep 'ic_dflags' and 'ic_plugins' around, but we also store a 'HomeUnitEnv' +for the 'DynFlags' and 'Plugins' of the interactive session. + +It is important to keep the 'DynFlags' in these two places consistent. + +In other words, whenever you update the 'DynFlags' of the 'interactiveGhciUnitId' +in the 'HscEnv', then you also need to update the 'DynFlags' of the +'InteractiveContext'. +The easiest way to update them is via 'setInteractiveDynFlags'. +However, careful, footgun! It is very easy to call 'setInteractiveDynFlags' +and forget to call 'normaliseInteractiveDynFlags' on the 'DynFlags' in the +'HscEnv'! This is important, because you may, accidentally, have enabled +Language Extensions that are not supported in the interactive ghc session, +which we do not want. + +To summarise, the 'ic_dflags' and 'ic_plugins' are currently used to +conveniently cache them for easy access. +The 'ic_dflags' must be identical to the 'DynFlags' stored in the 'HscEnv' +for the 'HomeUnitEnv' identified by 'interactiveGhciUnitId'. + +See Note [Multiple Home Units aware GHCi] for the design and rationale for +the current 'interactiveGhciUnitId'. + Note [Interactively-bound Ids in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Ids bound by previous Stmts in GHCi are currently @@ -296,7 +341,7 @@ data InteractiveImport -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope - | IIModule ModuleName + | IIModule Module -- ^ Bring into scope the entire top-level envt of -- of this module, including the things imported -- into it. ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -119,7 +119,6 @@ import GHC.Unit import GHC.Unit.Module.Graph import GHC.Unit.Module.ModIface import GHC.Unit.Home.ModInfo -import GHC.Unit.Home.PackageTable import GHC.Tc.Module ( runTcInteractive, tcRnTypeSkolemising, loadUnqualIfaces ) import GHC.Tc.Solver (simplifyWantedsTcM) @@ -823,16 +822,17 @@ findGlobalRdrEnv hsc_env imports idecls :: [LImportDecl GhcPs] idecls = [noLocA d | IIDecl d <- imports] - imods :: [ModuleName] + imods :: [Module] imods = [m | IIModule m <- imports] - mkEnv mod = mkTopLevEnv hsc_env mod >>= \case - Left err -> pure $ Left (mod, err) - Right env -> pure $ Right env + mkEnv mod = do + mkTopLevEnv hsc_env mod >>= \case + Left err -> pure $ Left (moduleName mod, err) + Right env -> pure $ Right env -mkTopLevEnv :: HscEnv -> ModuleName -> IO (Either String GlobalRdrEnv) +mkTopLevEnv :: HscEnv -> Module -> IO (Either String GlobalRdrEnv) mkTopLevEnv hsc_env modl - = lookupHpt hpt modl >>= \case + = HUG.lookupHugByModule modl hug >>= \case Nothing -> pure $ Left "not a home module" Just details -> case mi_top_env (hm_iface details) of @@ -841,7 +841,7 @@ mkTopLevEnv hsc_env modl let exports_env = mkGlobalRdrEnv $ gresFromAvails hsc_env Nothing (getDetOrdAvails exports) pure $ Right $ plusGlobalRdrEnv imports_env exports_env where - hpt = hsc_HPT hsc_env + hug = hsc_HUG hsc_env -- | Make the top-level environment with all bindings imported by this module. -- Exported bindings from this module are not included in the result. @@ -877,11 +877,9 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } -> -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h -> - if notHomeModule (hsc_home_unit h) modl - then return False - else liftIO (HUG.lookupHugByModule modl (hsc_HUG h)) >>= \case - Just hmi -> return (isJust $ homeModInfoByteCode hmi) - _not_a_home_module -> return False + liftIO (HUG.lookupHugByModule modl (hsc_HUG h)) >>= \case + Just hmi -> return (isJust $ homeModInfoByteCode hmi) + _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) -- Filter the instances by the ones whose tycons (or classes resp) ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -77,7 +77,7 @@ import Control.Monad import Data.Char import GHC.Unit.Module -import GHC.Unit.Home.PackageTable (lookupHpt) +import qualified GHC.Unit.Home.Graph as HUG import Data.Array import Data.Coerce (coerce) @@ -436,8 +436,7 @@ schemeER_wrk d p rhs = schemeE d 0 p rhs -- If that is 'Nothing', consider breakpoints to be disabled and skip the -- instruction. -- --- If the breakpoint is inlined from another module, look it up in the home --- package table. +-- If the breakpoint is inlined from another module, look it up in the HUG (home unit graph). -- If the module doesn't exist there, or its module pointer is null (which means -- that the 'ModBreaks' value is uninitialized), skip the instruction. break_info :: @@ -450,7 +449,7 @@ break_info hsc_env mod current_mod current_mod_breaks | mod == current_mod = pure $ check_mod_ptr =<< current_mod_breaks | otherwise - = ioToBc (lookupHpt (hsc_HPT hsc_env) (moduleName mod)) >>= \case + = ioToBc (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case Just hp -> pure $ check_mod_ptr (getModBreaks hp) Nothing -> pure Nothing where ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -461,7 +461,7 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache -- all the units we want to link together, without their dependencies let root_units = filter (/= ue_currentUnit unit_env) - $ filter (/= interactiveUnitId) + $ filter (/= interactiveUnitId) -- TODO @fendor: what does this do? $ nub $ rts_wired_units ++ reverse obj_units ++ reverse units ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -150,7 +150,6 @@ import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Types.Annotations import GHC.Types.SrcLoc import GHC.Types.SourceFile -import GHC.Types.PkgQual import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Env as UnitEnv @@ -2119,15 +2118,18 @@ runTcInteractive hsc_env thing_inside , let local_gres = filter isLocalGRE gres , not (null local_gres) ]) ] - ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface - : dep_orphs (mi_deps iface)) - (loadSrcInterface (text "runTcInteractive") m - NotBoot mb_pkg) + ; let getOrphansForModuleName m mb_pkg = do + iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg + pure $ mi_module iface : dep_orphs (mi_deps iface) + + getOrphansForModule m = do + iface <- loadModuleInterface (text "runTcInteractive") m + pure $ mi_module iface : dep_orphs (mi_deps iface) ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> case i of -- force above: see #15111 - IIModule n -> getOrphans n NoPkgQual - IIDecl i -> getOrphans (unLoc (ideclName i)) + IIModule n -> getOrphansForModule n + IIDecl i -> getOrphansForModuleName (unLoc (ideclName i)) (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) ===================================== compiler/GHC/Types/Name/Ppr.hs ===================================== @@ -13,6 +13,7 @@ import GHC.Data.FastString import GHC.Unit import GHC.Unit.Env +import qualified GHC.Unit.Home.Graph as HUG import GHC.Types.Name import GHC.Types.Name.Reader @@ -72,12 +73,11 @@ mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrE mkNamePprCtx ptc unit_env env = QueryQualify (mkQualName env) - (mkQualModule unit_state home_unit) + (mkQualModule unit_state unit_env) (mkQualPackage unit_state) (mkPromTick ptc env) where unit_state = ue_homeUnitState unit_env - home_unit = ue_homeUnit unit_env mkQualName :: Outputable info => GlobalRdrEnvX info -> QueryQualifyName mkQualName env = qual_name where @@ -215,10 +215,12 @@ Side note (int-index): -- | Creates a function for formatting modules based on two heuristics: -- (1) if the module is the current module, don't qualify, and (2) if there -- is only one exposed package which exports this module, don't qualify. -mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule -mkQualModule unit_state mhome_unit mod - | Just home_unit <- mhome_unit - , isHomeModule home_unit mod = False +mkQualModule :: UnitState -> UnitEnv -> QueryQualifyModule +mkQualModule unit_state unitEnv mod + -- Check whether the unit of the module is in the HomeUnitGraph. + -- If it is, then we consider this 'mod' to be "local" and don't + -- want to qualify it. + | HUG.memberHugUnit (moduleUnit mod) (ue_home_unit_graph unitEnv) = False | [(_, pkgconfig)] <- lookup, mkUnit pkgconfig == moduleUnit mod ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -241,7 +241,7 @@ isUnitEnvInstalledModule ue m = maybe False (`isHomeInstalledModule` m) hu -- ------------------------------------------------------- ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv -ue_findHomeUnitEnv uid e = case HUG.lookupHugUnit uid (ue_home_unit_graph e) of +ue_findHomeUnitEnv uid e = case HUG.lookupHugUnitId uid (ue_home_unit_graph e) of Nothing -> pprPanic "Unit unknown to the internal unit environment" $ text "unit (" <> ppr uid <> text ")" $$ ppr (HUG.allUnits (ue_home_unit_graph e)) @@ -311,7 +311,7 @@ ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit ue_unitHomeUnit_maybe uid ue_env = - HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnit uid (ue_home_unit_graph ue_env) + HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env) -- ------------------------------------------------------- -- Query and modify the currently active unit @@ -319,7 +319,7 @@ ue_unitHomeUnit_maybe uid ue_env = ue_currentHomeUnitEnv :: HasDebugCallStack => UnitEnv -> HomeUnitEnv ue_currentHomeUnitEnv e = - case HUG.lookupHugUnit (ue_currentUnit e) (ue_home_unit_graph e) of + case HUG.lookupHugUnitId (ue_currentUnit e) (ue_home_unit_graph e) of Just unitEnv -> unitEnv Nothing -> pprPanic "packageNotFound" $ (ppr $ ue_currentUnit e) $$ ppr (HUG.allUnits (ue_home_unit_graph e)) @@ -389,7 +389,7 @@ ue_transitiveHomeDeps uid e = -- FIXME: Shouldn't this be a proper assertion only used in debug mode? assertUnitEnvInvariant :: HasDebugCallStack => UnitEnv -> UnitEnv assertUnitEnvInvariant u = - case HUG.lookupHugUnit (ue_current_unit u) (ue_home_unit_graph u) of + case HUG.lookupHugUnitId (ue_current_unit u) (ue_home_unit_graph u) of Just _ -> u Nothing -> pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (HUG.allUnits (ue_home_unit_graph u))) ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -34,7 +34,10 @@ module GHC.Unit.Home.Graph , lookupHug , lookupHugByModule , lookupHugUnit - + , lookupHugUnitId + , lookupAllHug + , memberHugUnit + , memberHugUnitId -- ** Reachability , transitiveHomeDeps @@ -62,6 +65,8 @@ module GHC.Unit.Home.Graph , unitEnv_insert , unitEnv_new , unitEnv_lookup + , unitEnv_traverseWithKey + , unitEnv_assocs ) where import GHC.Prelude @@ -73,6 +78,7 @@ import GHC.Unit.Home.PackageTable import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Unit.State +import GHC.Utils.Monad (mapMaybeM) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -222,7 +228,7 @@ updateUnitFlags uid f = unitEnv_adjust update uid -- | Compute the transitive closure of a unit in the 'HomeUnitGraph'. -- If the argument unit is not present in the graph returns Nothing. transitiveHomeDeps :: UnitId -> HomeUnitGraph -> Maybe [UnitId] -transitiveHomeDeps uid hug = case lookupHugUnit uid hug of +transitiveHomeDeps uid hug = case lookupHugUnitId uid hug of Nothing -> Nothing Just hue -> Just $ Set.toList (loop (Set.singleton uid) (homeUnitDepends (homeUnitEnv_units hue))) @@ -234,7 +240,7 @@ transitiveHomeDeps uid hug = case lookupHugUnit uid hug of let hue = homeUnitDepends . homeUnitEnv_units . expectJust - $ lookupHugUnit uid hug + $ lookupHugUnitId uid hug in loop (Set.insert uid acc) (hue ++ uids) -------------------------------------------------------------------------------- @@ -246,21 +252,47 @@ transitiveHomeDeps uid hug = case lookupHugUnit uid hug of lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> IO (Maybe HomeModInfo) lookupHug hug uid mod = do case unitEnv_lookup_maybe uid hug of - -- Really, here we want "lookup HPT" rather than unitEnvLookup Nothing -> pure Nothing Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod -- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit) lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo) -lookupHugByModule mod hug - | otherwise = do - case unitEnv_lookup_maybe (toUnitId $ moduleUnit mod) hug of - Nothing -> pure Nothing - Just env -> lookupHptByModule (homeUnitEnv_hpt env) mod +lookupHugByModule mod hug = + case lookupHugUnit (moduleUnit mod) hug of + Nothing -> pure Nothing + Just env -> lookupHptByModule (homeUnitEnv_hpt env) mod + +-- | Lookup all 'HomeModInfo' that have the same 'ModuleName' as the given 'ModuleName'. +-- 'ModuleName's are not unique in the case of multiple home units, so there can be +-- more than one possible 'HomeModInfo'. +-- +-- You should always prefer 'lookupHug' and 'lookupHugByModule' when possible. +lookupAllHug :: HomeUnitGraph -> ModuleName -> IO [HomeModInfo] +lookupAllHug hug mod = mapMaybeM (\uid -> lookupHug hug uid mod) (Set.toList $ unitEnv_keys hug) -- | Lookup a 'HomeUnitEnv' by 'UnitId' in a 'HomeUnitGraph' -lookupHugUnit :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv -lookupHugUnit = unitEnv_lookup_maybe +lookupHugUnitId :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv +lookupHugUnitId = unitEnv_lookup_maybe + +-- | Check whether the 'UnitId' is present in the 'HomeUnitGraph' +memberHugUnitId :: UnitId -> HomeUnitGraph -> Bool +memberHugUnitId u = isJust . lookupHugUnitId u + +-- | Lookup up the 'HomeUnitEnv' by the 'Unit' in the 'HomeUnitGraph'. +-- If the 'Unit' can be turned into a 'UnitId', we behave identical to 'lookupHugUnitId'. +-- +-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's +lookupHugUnit :: Unit -> HomeUnitGraph -> Maybe HomeUnitEnv +lookupHugUnit unit hug = + if isHoleUnit unit + then Nothing + else lookupHugUnitId (toUnitId unit) hug + +-- | Check whether the 'Unit' is present in the 'HomeUnitGraph' +-- +-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's +memberHugUnit :: Unit -> HomeUnitGraph -> Bool +memberHugUnit u = isJust . lookupHugUnit u -------------------------------------------------------------------------------- -- * Internal representation map @@ -313,6 +345,13 @@ unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v unitEnv_lookup u env = expectJust $ unitEnv_lookup_maybe u env +unitEnv_traverseWithKey :: Applicative f => (UnitEnvGraphKey -> a -> f b) -> UnitEnvGraph a -> f (UnitEnvGraph b) +unitEnv_traverseWithKey f unitEnv = + UnitEnvGraph <$> Map.traverseWithKey f (unitEnv_graph unitEnv) + +unitEnv_assocs :: UnitEnvGraph a -> [(UnitEnvGraphKey, a)] +unitEnv_assocs (UnitEnvGraph x) = Map.assocs x + -------------------------------------------------------------------------------- -- * Utilities -------------------------------------------------------------------------------- ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -63,12 +63,16 @@ module GHC.Unit.Types , mainUnitId , thisGhcUnitId , interactiveUnitId + , interactiveGhciUnitId + , interactiveSessionUnitId , ghcInternalUnit , rtsUnit , mainUnit , thisGhcUnit , interactiveUnit + , interactiveGhciUnit + , interactiveSessionUnit , isInteractiveModule , wiredInUnitIds @@ -588,20 +592,24 @@ Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. -} ghcInternalUnitId, rtsUnitId, - mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId + mainUnitId, thisGhcUnitId, interactiveUnitId, interactiveGhciUnitId, interactiveSessionUnitId :: UnitId ghcInternalUnit, rtsUnit, - mainUnit, thisGhcUnit, interactiveUnit :: Unit + mainUnit, thisGhcUnit, interactiveUnit, interactiveGhciUnit, interactiveSessionUnit :: Unit ghcInternalUnitId = UnitId (fsLit "ghc-internal") rtsUnitId = UnitId (fsLit "rts") thisGhcUnitId = UnitId (fsLit cProjectUnitId) -- See Note [GHC's Unit Id] interactiveUnitId = UnitId (fsLit "interactive") +interactiveGhciUnitId = UnitId (fsLit "interactive-ghci") +interactiveSessionUnitId = UnitId (fsLit "interactive-session") ghcInternalUnit = RealUnit (Definite ghcInternalUnitId) rtsUnit = RealUnit (Definite rtsUnitId) thisGhcUnit = RealUnit (Definite thisGhcUnitId) interactiveUnit = RealUnit (Definite interactiveUnitId) +interactiveGhciUnit = RealUnit (Definite interactiveGhciUnitId) +interactiveSessionUnit = RealUnit (Definite interactiveSessionUnitId) -- | This is the package Id for the current program. It is the default -- package Id if you don't specify a package name. We don't add this prefix ===================================== docs/users_guide/ghci.rst ===================================== @@ -251,8 +251,8 @@ We can compile ``D``, then load the whole program, like this: .. code-block:: none - ghci> :! ghc -c -dynamic D.hs - ghci> :load A + ghci> :! ghc -c -this-unit-id interactive-session -dynamic D.hs + ghci> :load A B C D Compiling B ( B.hs, interpreted ) Compiling C ( C.hs, interpreted ) Compiling A ( A.hs, interpreted ) @@ -268,6 +268,10 @@ Note the :ghc-flag:`-dynamic` flag to GHC: GHCi uses dynamically-linked object code (if you are on a platform that supports it), and so in order to use compiled code with GHCi it must be compiled for dynamic linking. +Also, note the :ghc-flag:`-this-unit-id` `interactive-session` to GHC: GHCi +can only use the object code of a module loaded via :ghci-cmd:`:load`, +if the object code has been compiled for the `interactive-session`. + At any time you can use the command :ghci-cmd:`:show modules` to get a list of the modules currently loaded into GHCi: @@ -301,8 +305,8 @@ So let's try compiling one of the other modules: .. code-block:: none - *ghci> :! ghc -c C.hs - *ghci> :load A + *ghci> :! ghc -c -this-unit-id interactive-session -dynamic C.hs + *ghci> :load A B C D Compiling D ( D.hs, interpreted ) Compiling B ( B.hs, interpreted ) Compiling C ( C.hs, interpreted ) @@ -316,7 +320,7 @@ rejected ``C``\'s object file. Ok, so let's also compile ``D``: .. code-block:: none - *ghci> :! ghc -c D.hs + *ghci> :! ghc -c -this-unit-id interactive-session -dynamic D.hs *ghci> :reload Ok, modules loaded: A, B, C, D. @@ -325,7 +329,7 @@ picked up by :ghci-cmd:`:reload`, only :ghci-cmd:`:load`: .. code-block:: none - *ghci> :load A + *ghci> :load A B C D Compiling B ( B.hs, interpreted ) Compiling A ( A.hs, interpreted ) Ok, modules loaded: A, B, C (C.o), D (D.o). ===================================== ghc/GHCi/UI.hs ===================================== @@ -113,6 +113,7 @@ import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt import qualified GHC.Data.Strict as Strict import GHC.Types.Error +import qualified GHC.Unit.Home.Graph as HUG -- Haskell Libraries import System.Console.Haskeline as Haskeline @@ -129,6 +130,7 @@ import Data.Array import qualified Data.ByteString.Char8 as BS import Data.Char import Data.Function +import qualified Data.Foldable as Foldable import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( find, intercalate, intersperse, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) @@ -204,31 +206,31 @@ ghciCommands = map mkCmd [ -- Hugs users are accustomed to :e, so make sure it doesn't overlap ("?", keepGoing help, noCompletion), ("add", keepGoingPaths addModule, completeFilename), - ("abandon", keepGoing abandonCmd, noCompletion), - ("break", keepGoing breakCmd, completeBreakpoint), - ("back", keepGoing backCmd, noCompletion), + ("abandon", keepGoing abandonCmd, noCompletion), + ("break", keepGoing breakCmd, completeBreakpoint), + ("back", keepGoing backCmd, noCompletion), ("browse", keepGoing' (browseCmd False), completeModule), ("browse!", keepGoing' (browseCmd True), completeModule), - ("cd", keepGoingMulti' changeDirectory, completeFilename), - ("continue", keepGoing continueCmd, noCompletion), + ("cd", keepGoing' changeDirectory, completeFilename), + ("continue", keepGoing' continueCmd, noCompletion), ("cmd", keepGoing cmdCmd, completeExpression), ("def", keepGoing (defineMacro False), completeExpression), ("def!", keepGoing (defineMacro True), completeExpression), ("delete", keepGoing deleteCmd, noCompletion), ("disable", keepGoing disableCmd, noCompletion), ("doc", keepGoing' docCmd, completeIdentifier), - ("edit", keepGoingMulti' editFile, completeFilename), + ("edit", keepGoing' editFile, completeFilename), ("enable", keepGoing enableCmd, noCompletion), ("force", keepGoing forceCmd, completeExpression), ("forward", keepGoing forwardCmd, noCompletion), - ("help", keepGoingMulti help, noCompletion), - ("history", keepGoingMulti historyCmd, noCompletion), - ("info", keepGoingMulti' (info False), completeIdentifier), - ("info!", keepGoingMulti' (info True), completeIdentifier), + ("help", keepGoing help, noCompletion), + ("history", keepGoing historyCmd, noCompletion), + ("info", keepGoing' (info False), completeIdentifier), + ("info!", keepGoing' (info True), completeIdentifier), ("issafe", keepGoing' isSafeCmd, completeModule), ("ignore", keepGoing ignoreCmd, noCompletion), - ("kind", keepGoingMulti' (kindOfType False), completeIdentifier), - ("kind!", keepGoingMulti' (kindOfType True), completeIdentifier), + ("kind", keepGoing' (kindOfType False), completeIdentifier), + ("kind!", keepGoing' (kindOfType True), completeIdentifier), ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile), ("list", keepGoing' listCmd, noCompletion), @@ -236,19 +238,19 @@ ghciCommands = map mkCmd [ ("main", keepGoing runMain, completeFilename), ("print", keepGoing printCmd, completeExpression), ("quit", quit, noCompletion), - ("reload", keepGoingMulti' reloadModule, noCompletion), - ("reload!", keepGoingMulti' reloadModuleDefer, noCompletion), - ("run", keepGoing runRun, completeFilename), + ("reload", keepGoing' reloadModule, noCompletion), + ("reload!", keepGoing' reloadModuleDefer, noCompletion), + ("run", keepGoing' runRun, completeFilename), ("script", keepGoing' scriptCmd, completeFilename), - ("set", keepGoingMulti setCmd, completeSetOptions), - ("seti", keepGoingMulti setiCmd, completeSeti), - ("show", keepGoingMulti' showCmd, completeShowOptions), - ("showi", keepGoing showiCmd, completeShowiOptions), + ("set", keepGoing setCmd, completeSetOptions), + ("seti", keepGoing setiCmd, completeSeti), + ("show", keepGoing' showCmd, completeShowOptions), + ("showi", keepGoing showiCmd, completeShowiOptions), ("sprint", keepGoing sprintCmd, completeExpression), ("step", keepGoing stepCmd, completeIdentifier), ("steplocal", keepGoing stepLocalCmd, completeIdentifier), ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), - ("type", keepGoingMulti' typeOfExpr, completeExpression), + ("type", keepGoing' typeOfExpr, completeExpression), ("trace", keepGoing traceCmd, completeExpression), ("unadd", keepGoingPaths unAddModule, completeFilename), ("undef", keepGoing undefineMacro, completeMacro), @@ -316,24 +318,11 @@ showSDocForUserQualify doc = do keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome) keepGoing a str = keepGoing' (lift . a) str -keepGoingMulti :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome) -keepGoingMulti a str = keepGoingMulti' (lift . a) str - keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome keepGoing' a str = do - in_multi <- inMultiMode - if in_multi - then reportError GhciCommandNotSupportedInMultiMode - else a str + a str return CmdSuccess --- For commands which are actually support in multi-mode, initially just :reload -keepGoingMulti' :: GhciMonad m => (String -> m ()) -> String -> m CmdExecOutcome -keepGoingMulti' a str = a str >> return CmdSuccess - -inMultiMode :: GhciMonad m => m Bool -inMultiMode = multiMode <$> getGHCiState - keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome) keepGoingPaths a str = do case toArgsNoLoc str of @@ -489,9 +478,6 @@ default_args = [] interactiveUI :: GhciSettings -> [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> Ghc () interactiveUI config srcs maybe_exprs = do - -- This is a HACK to make sure dynflags are not overwritten when setting - -- options. When GHCi is made properly multi component it should be removed. - modifySession (\env -> hscSetActiveUnitId (hscActiveUnitId env) env) -- HACK! If we happen to get into an infinite loop (eg the user -- types 'let x=x in x' at the prompt), then the thread will block -- on a blackhole, and become unreachable during GC. The GC will @@ -507,21 +493,7 @@ interactiveUI config srcs maybe_exprs = do -- Initialise buffering for the *interpreted* I/O system (nobuffering, flush) <- runInternal initInterpBuffering - -- The initial set of DynFlags used for interactive evaluation is the same - -- as the global DynFlags, plus -XExtendedDefaultRules and - -- -XNoMonomorphismRestriction. - -- See Note [Changing language extensions for interactive evaluation] #10857 - dflags <- getDynFlags - let dflags' = (xopt_set_unlessExplSpec - LangExt.ExtendedDefaultRules xopt_set) - . (xopt_set_unlessExplSpec - LangExt.MonomorphismRestriction xopt_unset) - $ dflags - GHC.setInteractiveDynFlags dflags' - _ <- GHC.setProgramDynFlags - -- Set Opt_KeepGoing so that :reload loads as much as - -- possible - (gopt_set dflags Opt_KeepGoing) + installInteractiveHomeUnits -- Update the LogAction. Ensure we don't override the user's log action lest -- we break -ddump-json (#14078) @@ -553,9 +525,6 @@ interactiveUI config srcs maybe_exprs = do case simpleImportDecl preludeModuleName of -- Set to True because Prelude is implicitly imported. impDecl@ImportDecl{ideclExt=ext} -> impDecl{ideclExt = ext{ideclImplicit=True}} - hsc_env <- GHC.getSession - let !in_multi = length (hsc_all_home_unit_ids hsc_env) > 1 - -- We force this to make sure we don't retain the hsc_env when reloading empty_cache <- liftIO newIfaceCache startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = default_progname, @@ -566,7 +535,6 @@ interactiveUI config srcs maybe_exprs = do stop = default_stop, editor = default_editor, options = [], - multiMode = in_multi, localConfig = SourceLocalConfig, -- We initialize line number as 0, not 1, because we use -- current line number while reporting errors which is @@ -595,6 +563,236 @@ interactiveUI config srcs maybe_exprs = do return () +{- +Note [Multiple Home Units aware GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHCi supports multiple home units natively and as a first class citizen. +All GHCi sessions use a multiple home unit session and have at least three +home units: + +1. A home unit for the ghci session prompt +2. A home unit for scripts (i.e., modules that are ':load'ed or ':add'ed.) +3. The home unit specified by the user. +3+. If the users themselves provides more than one home unit. + +The first home unit is the "interactive-ghci" unit, called the 'interactiveGhciUnit'. +It contains the same 'DynFlags' that are used by the 'InteractiveContext' for +interactive evaluation of expressions. +This 'HomeUnitEnv' is only used on the prompt of GHCi, so we may refer to it as +"interactive-prompt" unit. +See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId'] +for discussing its role. + +The second home unit is the "interactive-session", called 'interactiveSessionUnit' +which is used for loading Scripts into GHCi that are not 'Target's of any home unit, +via `:load` or `:add`. +This home unit is necessary, as we can't guess to which home unit the 'Target' should +be added. + +Both of these "interactive" home units depend on all other 'HomeUnitEnv's that +are passed as arguments on the cli. +Additionally, the "interactive-ghci" unit depends on "interactive-session". + +We always evaluate expressions in the context of the +"interactive-ghci" session. +Since "interactive-ghci" depends on all home units, we can import any 'Module' +from the other home units with ease. + +As we have a clear 'HomeUnitGraph' hierarchy, we can set 'interactiveGhciUnitId' +as the active home unit for the full duration of the GHCi session. +In GHCi, we always set 'interactiveGhciUnitId' to be the currently active home unit. + +=== Single Home Unit Case Diagram + + Example: ghci -this-unit-id main ... + Equivalent to: ghci -unit @unitA + + ┌───────────────────┐ ┌─────────────────────┐ + │ Interactive Prompt│ │ Interactive Session │ + │ │───────►│ │ + │ interactive-ghci │ │ interactive-session │ + └────────┬──────────┘ └──────────┬──────────┘ + │ │ + └───────────────┬──────────────┘ + │ + │ + ┌────▼───┐ + │ Unit A │ + │ main │ + └────────┘ + + +=== Multi Home Unit Case Diagram + + Example: ghci -unit @unitA -unit @unitB -unit @unitC + + ┌───────────────────┐ ┌─────────────────────┐ + │ Interactive Prompt│ │ Interactive Session │ + │ │───────►│ │ + │ interactive-ghci │ │ interactive-session │ + └────────┬──────────┘ └──────────┬──────────┘ + │ │ + └───────────────┬──────────────┘ + │ + ┌─────────────┼─────────────┐ + ┌────▼───┐ ┌────▼───┐ ┌────▼───┐ + │ Unit A │ │ Unit B │ │ Unit C │ + │ a-0.0 │ │ b-0.0 │ │ c-0.0 │ + └────────┘ └────────┘ └────────┘ + +As we can see, this design scales to an arbitrary number of Home Units. + +=== 'interactiveGhciUnit' Home Unit + +The 'interactiveGhciUnit' home unit is used for storing the 'DynFlags' of +the interactive context. +There is considerable overlap with the 'InteractiveContext, +see Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId'] +for details. + +The 'DynFlags' of the 'interactiveGhciUnit' can be modified by using `:seti` +commands in the GHCi session. + +=== 'interactiveSessionUnit' Home Unit + +The 'interactiveSessionUnit' home unit is used as a kitchen sink for Modules that +are not part of a home unit already. +When the user types ":load", it is not trivial to figure to which home unit the module +should be added to. +Especially, when there is more than home unit. Thus, we always ":load"ed modules +to this home unit. + +The 'DynFlags' of the 'interactiveSessionUnit' can be modified via the ':set' +commands in the GHCi session. +-} + +-- | Set up the multiple home unit session. +-- Installs a 'HomeUnitEnv' for the ghci-prompt and one for the ghci-session in the +-- current 'HscEnv'. +-- +-- Installs the two home units 'interactiveGhciUnit' and 'interactiveSessionUnit', which +-- both depend on any other 'HomeUnitEnv' that is already present in the current +-- 'HomeUnitGraph'. +-- +-- In other words, in each GHCi session, there are always at least three 'HomeUnitEnv's: +-- +-- * 'interactiveGhciUnit' +-- * 'interactiveSessionUnit' +-- * 'mainUnit' (by default) +-- +-- The 'interactiveGhciUnit' is the currently active unit, i.e. @hscActiveUnit hsc_env == 'interactiveGhciUnitId'@, +-- and it stays as the active unit for the entire duration of GHCi. +-- Within GHCi, you can rely on this property. +-- +-- For motivation and design, see Note [Multiple Home Units aware GHCi] +installInteractiveHomeUnits :: GHC.GhcMonad m => m () +installInteractiveHomeUnits = do + logger <- getLogger + hsc_env <- GHC.getSession + -- The initial set of DynFlags used for interactive evaluation is the same + -- as the global DynFlags, plus: + -- * -XExtendedDefaultRules and + -- * -XNoMonomorphismRestriction. + -- See Note [Changing language extensions for interactive evaluation] #10857 + dflags <- getDynFlags + let + dflags0' = + (xopt_set_unlessExplSpec LangExt.ExtendedDefaultRules xopt_set) . + (xopt_set_unlessExplSpec LangExt.MonomorphismRestriction xopt_unset) $ + dflags + -- Disable warnings about unused packages + -- It doesn't matter for the interactive session. + -- See Note [No unused package warnings for the interactive session] + dflags0 = wopt_unset dflags0' Opt_WarnUnusedPackages + + -- Trivial '-package-id <uid>' flag + homeUnitPkgFlag uid = + ExposePackage + (unitIdString uid) + (UnitIdArg $ RealUnit (Definite uid)) + (ModRenaming False []) + + sessionUnitExposedFlag = + homeUnitPkgFlag interactiveSessionUnitId + + -- Explicitly depends on all home units and 'sessionUnitExposedFlag'. + -- Normalise the 'dflagsPrompt', as they will be used for 'ic_dflags' + -- of the 'InteractiveContext'. + -- See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId'] + -- Additionally, we remove all 'importPaths', to avoid accidentally adding + -- any 'Target's to this 'Unit'. + dflagsPrompt <- GHC.normaliseInteractiveDynFlags logger $ + setHomeUnitId interactiveGhciUnitId $ dflags0 + { packageFlags = + [ sessionUnitExposedFlag ] ++ + [ homeUnitPkgFlag uid + | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env + , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv] + , let uid = homeUnitId homeUnit + ] ++ + (packageFlags dflags0) + , importPaths = [] + } + + let + -- Explicitly depends on all current home units. + -- Additionally, we remove all 'importPaths', to avoid accidentally adding + -- any 'Target's to this 'Unit' that are not ':load'ed. + dflagsSession = + setHomeUnitId interactiveSessionUnitId $ dflags + { packageFlags = + [ homeUnitPkgFlag uid + | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env + , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv] + , let uid = homeUnitId homeUnit + ] ++ + (packageFlags dflags) + , importPaths = [] + } + + let + cached_unit_dbs = + concat + . catMaybes + . fmap homeUnitEnv_unit_dbs + $ Foldable.toList + $ hsc_HUG hsc_env + + all_unit_ids = + S.insert interactiveGhciUnitId $ + S.insert interactiveSessionUnitId $ + hsc_all_home_unit_ids hsc_env + + ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt all_unit_ids cached_unit_dbs + ghciSessionUnit <- setupHomeUnitFor logger dflagsSession all_unit_ids cached_unit_dbs + let + -- Setup up the HUG, install the interactive home units + withInteractiveUnits = + HUG.unitEnv_insert interactiveGhciUnitId ghciPromptUnit + . HUG.unitEnv_insert interactiveSessionUnitId ghciSessionUnit + + -- Finish up the setup, install the new HUG and make the 'interactiveGhciUnitId' + -- the active unit. + modifySessionM (\env -> do + -- Set the new HUG + let newEnv0 = hscUpdateHUG withInteractiveUnits env + -- Make sure the 'interactiveGhciUnitId' is active and 'hsc_dflags' + -- are populated correctly. + -- The 'interactiveGhciUnitId' will stay as the active unit within GHCi. + let newEnv1 = hscSetActiveUnitId interactiveGhciUnitId newEnv0 + -- Use the 'DynFlags' of the 'interactiveGhciUnitId' for the 'InteractiveContext'. + GHC.initialiseInteractiveDynFlags dflagsPrompt newEnv1 + ) + + pure () + where + setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> [UnitDatabase UnitId] -> m HomeUnitEnv + setupHomeUnitFor logger dflags all_home_units cached_unit_dbs = do + (dbs,unit_state,home_unit,_mconstants) <- + liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units + hpt <- liftIO emptyHomePackageTable + pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit)) + reportError :: GhciMonad m => GhciCommandMessage -> m () reportError err = do printError err @@ -933,7 +1131,7 @@ getInfoForPrompt = do | otherwise = unLoc (ideclName d) modules_names = - ['*':(moduleNameString m) | IIModule m <- rev_imports] ++ + ['*':(moduleNameString (moduleName m)) | IIModule m <- rev_imports] ++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports] line = 1 + line_number st @@ -1971,13 +2169,27 @@ wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a wrapDeferTypeErrors load = MC.bracket (do - -- Force originalFlags to avoid leaking the associated HscEnv - !originalFlags <- getDynFlags - void $ GHC.setProgramDynFlags $ - setGeneralFlag' Opt_DeferTypeErrors originalFlags - return originalFlags) - (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags) + -- Force originalHUG to avoid leaking the associated HscEnv + !originalHUG <- hsc_HUG <$> GHC.getSession + _ <- GHC.setProgramHUG (fmap deferTypeErrors originalHUG) + return originalHUG) + (\originalHUG -> + -- Restore the old 'DynFlags' for each home unit. + -- This makes sure that '-fdefer-type-errors' is unset again, iff it wasn't set before. + modifySession (hscUpdateHUG (restoreOriginalDynFlags originalHUG))) (\_ -> load) + where + deferTypeErrors home_unit_env = + home_unit_env + { homeUnitEnv_dflags = + setGeneralFlag' Opt_DeferTypeErrors (homeUnitEnv_dflags home_unit_env) + } + + restoreOriginalDynFlags (HUG.UnitEnvGraph old) (HUG.UnitEnvGraph new) = HUG.UnitEnvGraph $ + M.unionWith (\b a -> + a { homeUnitEnv_dflags = homeUnitEnv_dflags b + }) + old new loadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag loadModule fs = do @@ -1986,7 +2198,7 @@ loadModule fs = do -- | @:load@ command loadModule_ :: GhciMonad m => [FilePath] -> m () -loadModule_ fs = void $ loadModule (zip3 fs (repeat Nothing) (repeat Nothing)) +loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnitId)) (repeat Nothing)) loadModuleDefer :: GhciMonad m => [FilePath] -> m () loadModuleDefer = wrapDeferTypeErrors . loadModule_ @@ -2030,7 +2242,8 @@ addModule :: GhciMonad m => [FilePath] -> m () addModule files = do revertCAFs -- always revert CAFs on load/add. files' <- mapM expandPath files - targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files' + -- New targets are always added to the 'interactiveSessionUnitId' 'HomeUnitEnv'. + targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files' targets' <- filterM checkTarget targets -- remove old targets with the same id; e.g. for :add *M mapM_ GHC.removeTarget [ tid | Target { targetId = tid } <- targets' ] @@ -2063,7 +2276,8 @@ addModule files = do unAddModule :: GhciMonad m => [FilePath] -> m () unAddModule files = do files' <- mapM expandPath files - targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files' + -- New targets are always added to the 'interactiveSessionUnitId' 'HomeUnitEnv'. + targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files' let removals = [ tid | Target { targetId = tid } <- targets ] mapM_ GHC.removeTarget removals _ <- doLoadAndCollectInfo (Unadd $ length removals) LoadAllTargets @@ -2102,10 +2316,7 @@ doLoadAndCollectInfo load_type howmuch = do doLoad load_type howmuch >>= \case Succeeded | doCollectInfo -> do mod_summaries <- GHC.mgModSummaries <$> getModuleGraph - -- MP: :set +c code path only works in single package mode atm, hence - -- this call to isLoaded is ok. collectInfo needs to be modified further to - -- work with :set +c so I have punted on that for now. - loaded <- filterM GHC.isLoaded (map ms_mod_name mod_summaries) + loaded <- filterM GHC.isLoadedHomeModule (map ms_mod mod_summaries) v <- mod_infos <$> getGHCiState !newInfos <- collectInfo v loaded modifyGHCiState (\st -> st { mod_infos = newInfos }) @@ -2187,7 +2398,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do -- We import the module with a * iff -- - it is interpreted, and -- - -XSafe is off (it doesn't allow *-imports) - let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)] + let new_ctx | star_ok = [mkIIModule m] | otherwise = [mkIIDecl (GHC.moduleName m)] setContextKeepingPackageModules keep_ctxt new_ctx @@ -2222,9 +2433,10 @@ keepPackageImports = filterM is_pkg_import is_pkg_import (IIDecl d) = do pkgqual <- GHC.renameRawPkgQualM mod_name (ideclPkgQual d) e <- MC.try $ GHC.findQualifiedModule pkgqual mod_name + hug <- hsc_HUG <$> GHC.getSession case e :: Either SomeException Module of Left _ -> return False - Right m -> return (not (isMainUnitModule m)) + Right m -> return $ not (HUG.memberHugUnit (moduleUnit m) hug) where mod_name = unLoc (ideclName d) @@ -2607,7 +2819,7 @@ guessCurrentModule cmd = do imports <- GHC.getContext case imports of [] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module") - IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m + IIModule m : _ -> pure m IIDecl d : _ -> do pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d) GHC.findQualifiedModule pkgqual (unLoc (ideclName d)) @@ -2628,7 +2840,7 @@ browseModule bang modl exports_only = do then pure $ GHC.modInfoExports mod_info else do hsc_env <- GHC.getSession - mmod_env <- liftIO $ mkTopLevEnv hsc_env (moduleName modl) + mmod_env <- liftIO $ mkTopLevEnv hsc_env modl case mmod_env of Left err -> throwGhcException (CmdLineError (GHC.moduleNameString (GHC.moduleName modl) ++ " " ++ err)) Right mod_env -> pure $ map greName . globalRdrEnvElts $ mod_env @@ -2737,8 +2949,9 @@ addModulesToContext starred unstarred = restoreContextOnFailure $ do addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m () addModulesToContext_ starred unstarred = do - mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred) - setGHCContextFromGHCiState + starredModules <- traverse lookupModuleName starred + mapM_ addII (map mkIIModule starredModules ++ map mkIIDecl unstarred) + setGHCContextFromGHCiState remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m () remModulesFromContext starred unstarred = do @@ -2804,14 +3017,14 @@ checkAdd ii = do dflags <- getDynFlags let safe = safeLanguageOn dflags case ii of - IIModule modname + IIModule mod | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell" - | otherwise -> wantInterpretedModuleName modname >> return () + | otherwise -> checkInterpretedModule mod >> return () IIDecl d -> do let modname = unLoc (ideclName d) pkgqual <- GHC.renameRawPkgQualM modname (ideclPkgQual d) - m <- GHC.lookupQualifiedModule pkgqual modname + m <- lookupQualifiedModuleName pkgqual modname when safe $ do t <- GHC.isModuleTrusted m unless t $ throwGhcException $ ProgramError $ "" @@ -2874,13 +3087,13 @@ getImplicitPreludeImports iidecls = do -- ----------------------------------------------------------------------------- -- Utils on InteractiveImport -mkIIModule :: ModuleName -> InteractiveImport +mkIIModule :: Module -> InteractiveImport mkIIModule = IIModule mkIIDecl :: ModuleName -> InteractiveImport mkIIDecl = IIDecl . simpleImportDecl -iiModules :: [InteractiveImport] -> [ModuleName] +iiModules :: [InteractiveImport] -> [Module] iiModules is = [m | IIModule m <- is] isIIModule :: InteractiveImport -> Bool @@ -2888,7 +3101,7 @@ isIIModule (IIModule _) = True isIIModule _ = False iiModuleName :: InteractiveImport -> ModuleName -iiModuleName (IIModule m) = m +iiModuleName (IIModule m) = moduleName m iiModuleName (IIDecl d) = unLoc (ideclName d) preludeModuleName :: ModuleName @@ -2990,8 +3203,23 @@ showOptions show_all then text "none." else hsep (map (\o -> char '+' <> text (optToStr o)) opts) )) - liftIO $ showDynFlags show_all dflags - + mapNonInteractiveHomeUnitsM (liftIO . showDynFlags show_all) + +mapNonInteractiveHomeUnitsM :: GHC.GhcMonad m => (DynFlags -> m ()) -> m () +mapNonInteractiveHomeUnitsM printer = do + hug <- hsc_HUG <$> GHC.getSession + singleOrMultipleHomeUnits + $ map (\(uid, homeUnit) -> (uid, homeUnitEnv_dflags homeUnit)) + $ filter (\(uid, _) -> uid /= interactiveSessionUnitId + && uid /= interactiveGhciUnitId) + $ HUG.unitEnv_assocs hug + where + singleOrMultipleHomeUnits [] = + liftIO $ putStrLn "GHCi: internal error - no home unit configured" + singleOrMultipleHomeUnits [(_, dflags)] = printer dflags + singleOrMultipleHomeUnits xs = mapM_ (\(uid, dflags) -> do + liftIO $ putStrLn (showSDoc dflags (text "Unit ID:" <+> ppr uid)) + printer dflags) xs showDynFlags :: Bool -> DynFlags -> IO () showDynFlags show_all dflags = do @@ -3117,69 +3345,206 @@ setOptions wds = -- then, dynamic flags when (not (null minus_opts)) $ newDynFlags False minus_opts --- | newDynFlags will *not* read package environment files, therefore we --- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This --- function is called very often and results in repeatedly loading --- environment files (see #19650) +-- Note [No unused package warnings for the interactive session] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The interactive session (also called "interactive-prompt" occassionally) should not +-- report unused packages, as it will essentially always report packages +-- as unused. +-- The "interactive-prompt" doesn't contain any 'Module's, so most packages +-- are unused. +-- As this would flood the user with warnings they can't do anything about, +-- we decide to unconditionally turn off the warning 'Opt_WarnUnusedPackages'. +-- +-- Unused packages in GHCi are still reported via the 'interactive-session' unit. +-- See Note [Multiple Home Units aware GHCi] for an explanation about the +-- "interactive-prompt" and 'interactive-session' unit. + +-- | 'newDynFlags' adds the given user options to the session. +-- +-- If 'True' is passed, we add the options only to the interactive 'DynFlags'. +-- Otherwise, the options are added to each 'HomeUnitEnv' in the current session. +-- +-- This function will check whether we need to re-initialise the 'UnitState', +-- for example when the user writes ':set -package containers'. +-- +-- Any warnings during parsing, or validation of the new 'DynFlags' will be +-- directly reported to the user. newDynFlags :: GhciMonad m => Bool -> [String] -> m () newDynFlags interactive_only minus_opts = do - let lopts = map noLoc minus_opts + let lopts = map noLoc minus_opts - logger <- getLogger - idflags0 <- GHC.getInteractiveDynFlags - (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger idflags0 lopts + case interactive_only of + True -> addToInteractiveDynFlags lopts + False -> addToProgramDynFlags lopts - liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns) + idflags <- hsc_dflags <$> GHC.getSession + installInteractivePrint (interactivePrint idflags) False + +-- | Add the given options to the interactive 'DynFlags'. +-- This function will normalise and validate the 'DynFlags' and report warnings +-- directly to the user. +-- +-- Updates both the 'hsc_dflags' of 'HscEnv', and the 'ic_dflags' of the 'InteractiveContext'. +-- +-- 'addToInteractiveDynFlags' will *not* read package environment files, therefore we +-- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This +-- function is called very often and results in repeatedly loading +-- environment files (see #19650) +addToInteractiveDynFlags :: GhciMonad m => [Located String] -> m () +addToInteractiveDynFlags lopts = do + logger <- getLogger + env <- GHC.getSession + let idflags0 = hsc_dflags env + (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger idflags0 lopts + + liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns) + when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers) + + when (packageFlagsChanged idflags1 idflags0) $ do + liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set" + + idflags_norm <- GHC.normaliseInteractiveDynFlags logger idflags1 + -- Strictly speaking, 'setProgramHUG' performs more work than necessary, + -- as we know the majority of flags haven't changed. + _ <- GHC.setProgramHUG (hsc_HUG $ hscSetFlags idflags_norm env) + -- Initialise the Interactive DynFlags. + -- Sets the 'ic_dflags' and initialises the 'ic_plugins'. + -- See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId'] + idflags <- hsc_dflags <$> GHC.getSession + modifySessionM (GHC.initialiseInteractiveDynFlags idflags) + +-- | Add the given options to all 'DynFlags' in the 'HomeUnitGraph'. +-- This function will validate the 'DynFlags' and report warnings directly to the user. +-- +-- We additionally normalise the 'DynFlags' for the 'interactiveGhciUnitId' for use +-- in the 'InteractiveContext'. +-- +-- 'addToProgramDynFlags' will *not* read package environment files, therefore we +-- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This +-- function is called very often and results in repeatedly loading +-- environment files (see #19650) +addToProgramDynFlags :: GhciMonad m => [Located String] -> m () +addToProgramDynFlags lopts = do + logger <- getLogger + initial_hug <- hsc_HUG <$> GHC.getSession + -- Update the 'DynFlags' of each 'HomeUnitEnv'. + -- Parse the new 'DynFlags', and report potential issues once. + -- Arguably, we may want to report issues for each non-builtin 'HomeUnitEnv' + -- individually. + updates <- HUG.unitEnv_traverseWithKey (\uid homeUnitEnv -> do + let oldFlags = HUG.homeUnitEnv_dflags homeUnitEnv + (newFlags, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger oldFlags lopts + -- We only want to report inconsistencies and warnings once. + -- Thus, we do it only once for the 'interactiveGhciUnitId' + when (uid == interactiveGhciUnitId) $ do + liftIO $ printOrThrowDiagnostics logger (initPrintConfig newFlags) (initDiagOpts newFlags) (GhcDriverMessage <$> warns) when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers) - when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do - liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set" - GHC.setInteractiveDynFlags idflags1 - installInteractivePrint (interactivePrint idflags1) False - - dflags0 <- getDynFlags - - when (not interactive_only) $ do - (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine logger dflags0 lopts - must_reload <- GHC.setProgramDynFlags dflags1 - - -- if the package flags changed, reset the context and link - -- the new packages. - hsc_env <- GHC.getSession - let dflags2 = hsc_dflags hsc_env - let interp = hscInterp hsc_env - when (packageFlagsChanged dflags2 dflags0) $ do - when (verbosity dflags2 > 0) $ - liftIO . putStrLn $ - "package flags have changed, resetting and loading new packages..." - -- Clear caches and eventually defined breakpoints. (#1620) - clearCaches - when must_reload $ do - let units = preloadUnits (hsc_units hsc_env) - liftIO $ Loader.loadPackages interp hsc_env units - -- package flags changed, we can't re-use any of the old context - setContextAfterLoad False Nothing - -- and copy the package flags to the interactive DynFlags - idflags <- GHC.getInteractiveDynFlags - GHC.setInteractiveDynFlags - idflags{ packageFlags = packageFlags dflags2 } - - let ld0length = length $ ldInputs dflags0 - fmrk0length = length $ cmdlineFrameworks dflags0 - - newLdInputs = drop ld0length (ldInputs dflags2) - newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2) - - dflags' = dflags2 { ldInputs = newLdInputs - , cmdlineFrameworks = newCLFrameworks - } - hsc_env' = hscSetFlags dflags' hsc_env - - when (not (null newLdInputs && null newCLFrameworks)) $ - liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env' - - return () + -- Special Logic! + -- Currently, the interactive 'DynFlags' have additional restrictions, + -- for example modifying package flags is not supported! + -- The interactive 'DynFlags' get normalised to uphold this restriction. + -- As a special precaution, we also don't want to report unusued packages warnings + -- for the interactive session. + -- See Note [No unused package warnings for the interactive session] + -- + -- See Note [Multiple Home Units aware GHCi] for details about how + -- the interactive session is structured. + newFlags' <- + if uid == interactiveGhciUnitId + then do + -- See Note [No unused package warnings for the interactive session] + let icdflags1 = wopt_unset newFlags Opt_WarnUnusedPackages + GHC.normaliseInteractiveDynFlags logger icdflags1 + else + pure newFlags + pure (homeUnitEnv { homeUnitEnv_dflags = newFlags' }) + ) + initial_hug + -- Update the HUG! + -- This might force us to reload the 'UnitState' of each 'HomeUnitEnv' + -- if package flags were changed. + must_reload <- GHC.setProgramHUG updates + + -- Initialise the Interactive DynFlags. + -- Sets the 'ic_dflags' and initialises the 'ic_plugins'. + -- See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId'] + icdflags <- hsc_dflags <$> GHC.getSession + modifySessionM (GHC.initialiseInteractiveDynFlags icdflags) + + -- if the package flags changed, reset the context and link + -- the new packages. + hsc_env <- GHC.getSession + let dflags2 = hsc_dflags hsc_env + when must_reload $ do + when (verbosity dflags2 > 0) $ + liftIO . putStrLn $ + "package flags have changed, resetting and loading new packages..." + + -- Clear caches and eventually defined breakpoints. (#1620) + clearCaches + reloadPackages hsc_env + + reloadLinkerOptions hsc_env initial_hug + +reloadPackages :: GhciMonad m => HscEnv -> m () +reloadPackages hsc_env = do + let + units = + concatMap (preloadUnits . HUG.homeUnitEnv_units) + (Foldable.toList $ hsc_HUG hsc_env) + liftIO $ Loader.loadPackages (hscInterp hsc_env) hsc_env units + -- package flags changed, we can't re-use any of the old context + setContextAfterLoad False Nothing + +-- | Reload the linker options. +-- +-- Synopsis: @'reloadLinkerOptions' hsc_env old_hug@ +-- +-- After the HUG is modified, the linker may need to be reloaded. +-- The linker is reloaded via 'loadCmdLineLibs', if the library inputs +-- have changed. +-- To determine whether the library inputs have changed, we need the +-- old HUG, which is passed as the argument 'old_hug'. +-- +-- This function will crash, if the 'old_hug' doesn't have exactly +-- the same keys has the given 'hsc_env'. I.e. +-- +-- @ +-- HUG.unitEnv_keys old_hug == HUG.unitEnv_keys (hsc_HUG hsc_env) +-- @ +reloadLinkerOptions :: MonadIO m => HscEnv -> HomeUnitGraph -> m () +reloadLinkerOptions hsc_env old_hug = do + let + new_hug = hsc_HUG hsc_env + let + (needs_updates, updated_hug) = HUG.unitEnv_traverseWithKey (\key unitEnv -> + let + old_flags = homeUnitEnv_dflags (HUG.unitEnv_lookup key old_hug) + new_flags = homeUnitEnv_dflags unitEnv + ld0length = length $ ldInputs old_flags + fmrk0length = length $ cmdlineFrameworks old_flags + + newLdInputs = drop ld0length (ldInputs new_flags) + newCLFrameworks = drop fmrk0length (cmdlineFrameworks new_flags) + + dflags' = new_flags { ldInputs = newLdInputs + , cmdlineFrameworks = newCLFrameworks + } + in + (S.Any (not (null newLdInputs && null newCLFrameworks)), + unitEnv { homeUnitEnv_dflags = dflags' }) + ) new_hug + + hsc_env' = + hscSetActiveUnitId (hscActiveUnitId hsc_env) + $ hscUpdateHUG (const updated_hug) + $ hsc_env + + when (S.getAny needs_updates) $ + liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env' unknownFlagsErr :: GhciMonad m => [String] -> m () unknownFlagsErr fs = mapM_ (\f -> reportError (GhciUnknownFlag f (suggestions f))) fs @@ -3261,7 +3626,6 @@ showCmd "" = showOptions False showCmd "-a" = showOptions True showCmd str = do st <- getGHCiState - dflags <- getDynFlags hsc_env <- GHC.getSession let lookupCmd :: String -> Maybe (m ()) @@ -3299,8 +3663,10 @@ showCmd str = do case words str of [w] | Just action <- lookupCmd w -> action - _ -> let helpCmds = [ text name | (True, name, _) <- cmds ] - in throwGhcException $ CmdLineError $ showSDoc dflags + _ -> do + let helpCmds = [ text name | (True, name, _) <- cmds ] + dflags <- getDynFlags + throwGhcException $ CmdLineError $ showSDoc dflags $ hang (text "syntax:") 4 $ hang (text ":show") 6 $ brackets (fsep $ punctuate (text " |") helpCmds) @@ -3321,7 +3687,7 @@ showImports = do trans_ctx = transient_ctx st show_one (IIModule star_m) - = ":module +*" ++ moduleNameString star_m + = ":module +*" ++ moduleNameString (moduleName star_m) show_one (IIDecl imp) = showPpr dflags imp prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx) @@ -3427,16 +3793,14 @@ pprStopped res = mb_mod_name = moduleName <$> ibi_tick_mod <$> GHC.resumeBreakpointId res showUnits :: GHC.GhcMonad m => m () -showUnits = do - dflags <- getDynFlags +showUnits = mapNonInteractiveHomeUnitsM $ \dflags -> do let pkg_flags = packageFlags dflags liftIO $ putStrLn $ showSDoc dflags $ text ("active package flags:"++if null pkg_flags then " none" else "") $$ nest 2 (vcat (map pprFlag pkg_flags)) showPaths :: GHC.GhcMonad m => m () -showPaths = do - dflags <- getDynFlags +showPaths = mapNonInteractiveHomeUnitsM $ \dflags -> do liftIO $ do cwd <- getCurrentDirectory putStrLn $ showSDoc dflags $ @@ -3448,7 +3812,7 @@ showPaths = do nest 2 (vcat (map text ipaths)) showLanguages :: GHC.GhcMonad m => m () -showLanguages = getDynFlags >>= liftIO . showLanguages' False +showLanguages = mapNonInteractiveHomeUnitsM $ liftIO . showLanguages' False showiLanguages :: GHC.GhcMonad m => m () showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False @@ -3627,11 +3991,11 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 filterM GHC.moduleIsInterpreted hmods -- Return all possible bids for a given Module - bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String] + bidsByModule :: GhciMonad m => [Module] -> Module -> m [String] bidsByModule nonquals mod = do (_, decls) <- getModBreak mod let bids = nub $ declPath <$> elems decls - pure $ case (moduleName mod) `elem` nonquals of + pure $ case mod `elem` nonquals of True -> bids False -> (combineModIdent (showModule mod)) <$> bids @@ -4036,8 +4400,7 @@ breakSwitch (arg1:rest) | all isDigit arg1 = do imports <- GHC.getContext case iiModules imports of - (mn : _) -> do - md <- lookupModuleName mn + (md : _) -> do breakByModuleLine md (read arg1) rest [] -> do liftIO $ putStrLn "No modules are loaded with debugging support." @@ -4169,8 +4532,7 @@ list2 [arg] | all isDigit arg = do case iiModules imports of [] -> liftIO $ putStrLn "No module to list" (mn : _) -> do - md <- lookupModuleName mn - listModuleLine md (read arg) + listModuleLine mn (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do md <- wantInterpretedModule arg1 listModuleLine md (read arg2) @@ -4426,10 +4788,20 @@ lookupModule :: GHC.GhcMonad m => String -> m Module lookupModule mName = lookupModuleName (GHC.mkModuleName mName) lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module -lookupModuleName mName = GHC.lookupQualifiedModule NoPkgQual mName - -isMainUnitModule :: Module -> Bool -isMainUnitModule m = GHC.moduleUnit m == mainUnit +lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName + +lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module +lookupQualifiedModuleName qual modl = do + GHC.lookupAllQualifiedModuleNames qual modl >>= \case + [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found.")) + [m] -> pure m + ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms)) + where + str = moduleNameString modl + errorMsg ms = intercalate "\n" + [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m) + | m <- ms + ] showModule :: Module -> String showModule = moduleNameString . moduleName @@ -4476,15 +4848,19 @@ wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str) wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module wantInterpretedModuleName modname = do - modl <- lookupModuleName modname - let str = moduleNameString modname - home_unit <- hsc_home_unit <$> GHC.getSession - unless (isHomeModule home_unit modl) $ - throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) - is_interpreted <- GHC.moduleIsInterpreted modl - when (not is_interpreted) $ - throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) - return modl + modl <- lookupModuleName modname + checkInterpretedModule modl + +checkInterpretedModule :: GHC.GhcMonad m => Module -> m Module +checkInterpretedModule modl = do + let str = moduleNameString $ moduleName modl + hug <- hsc_HUG <$> GHC.getSession + unless (HUG.memberHugUnit (moduleUnit modl) hug) $ + throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) + is_interpreted <- GHC.moduleIsInterpreted modl + when (not is_interpreted) $ + throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) + return modl wantNameFromInterpretedModule :: GHC.GhcMonad m => (Name -> SDoc -> m ()) ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -465,7 +465,7 @@ instance DiagnosticCodeNameSpace GHCi where type GhciDiagnosticCode :: Symbol -> Nat type family GhciDiagnosticCode c = n | n -> c where - GhciDiagnosticCode "GhciCommandNotSupportedInMultiMode" = 83514 + GhciDiagnosticCode "GhciCommandNotSupportedInMultiMode" = Outdated 83514 GhciDiagnosticCode "GhciInvalidArgumentString" = 68894 GhciDiagnosticCode "GhciCommandSyntaxError" = 72682 GhciDiagnosticCode "GhciInvalidPromptString" = 50882 ===================================== ghc/GHCi/UI/Info.hs ===================================== @@ -113,7 +113,7 @@ srcSpanFilePath = unpackFS . srcSpanFile -- | Try to find the location of the given identifier at the given -- position in the module. findLoc :: GhcMonad m - => Map ModuleName ModInfo + => Map Module ModInfo -> RealSrcSpan -> String -> ExceptT GhciModuleError m (ModInfo,Name,SrcSpan) @@ -133,7 +133,7 @@ findLoc infos span0 string = do -- | Find any uses of the given identifier in the codebase. findNameUses :: (GhcMonad m) - => Map ModuleName ModInfo + => Map Module ModInfo -> RealSrcSpan -> String -> ExceptT GhciModuleError m [SrcSpan] @@ -160,7 +160,7 @@ stripSurrounding xs = filter (not . isRedundant) xs -- | Try to resolve the name located at the given position, or -- otherwise resolve based on the current module's scope. findName :: GhcMonad m - => Map ModuleName ModInfo + => Map Module ModInfo -> RealSrcSpan -> ModInfo -> String @@ -186,11 +186,11 @@ findName infos span0 mi string = -- | Try to resolve the name from another (loaded) module's exports. resolveNameFromModule :: GhcMonad m - => Map ModuleName ModInfo + => Map Module ModInfo -> Name -> ExceptT GhciModuleError m Name resolveNameFromModule infos name = do - info <- maybe (throwE $ GhciNoModuleForName name) pure (nameModule_maybe name >>= \modL -> M.lookup (moduleName modL) infos) + info <- maybe (throwE $ GhciNoModuleForName name) pure (nameModule_maybe name >>= \modL -> M.lookup modL infos) let all_names = modInfo_rdrs info maybe (throwE GhciNoMatchingModuleExport) pure $ find (matchName name) all_names @@ -206,7 +206,7 @@ resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $ -- | Try to find the type of the given span. findType :: GhcMonad m - => Map ModuleName ModInfo + => Map Module ModInfo -> RealSrcSpan -> String -> ExceptT GhciModuleError m (ModInfo, Type) @@ -228,34 +228,36 @@ findType infos span0 string = do -- | Guess a module name from a file path. guessModule :: GhcMonad m - => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName + => Map Module ModInfo -> FilePath -> MaybeT m Module guessModule infos fp = do - target <- lift $ guessTarget fp Nothing Nothing - case targetId target of - TargetModule mn -> return mn + target <- lift $ guessTargetId fp + case target of + TargetModule mn -> MaybeT $ pure $ findModByModuleName mn TargetFile fp' _ -> guessModule' fp' where - guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName + guessModule' :: GhcMonad m => FilePath -> MaybeT m Module guessModule' fp' = case findModByFp fp' of Just mn -> return mn Nothing -> do fp'' <- liftIO (makeRelativeToCurrentDirectory fp') - target' <- lift $ guessTarget fp'' Nothing Nothing - case targetId target' of - TargetModule mn -> return mn + target' <- lift $ guessTargetId fp'' + case target' of + TargetModule mn -> MaybeT . pure $ findModByModuleName mn _ -> MaybeT . pure $ findModByFp fp'' - findModByFp :: FilePath -> Maybe ModuleName + findModByFp :: FilePath -> Maybe Module findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos) where - mifp :: (ModuleName, ModInfo) -> Maybe FilePath + mifp :: (Module, ModInfo) -> Maybe FilePath mifp = ml_hs_file . ms_location . modinfoSummary . snd + findModByModuleName :: ModuleName -> Maybe Module + findModByModuleName mn = find ((== mn) . moduleName) (M.keys infos) -- | Collect type info data for the loaded modules. -collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName] - -> m (Map ModuleName ModInfo) +collectInfo :: (GhcMonad m) => Map Module ModInfo -> [Module] + -> m (Map Module ModInfo) collectInfo ms loaded = do df <- getDynFlags unit_state <- hsc_units <$> getSession @@ -299,17 +301,17 @@ srcFilePath modSum = fromMaybe obj_fp src_fp ms_loc = ms_location modSum -- | Get info about the module: summary, types, etc. -getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo -getModInfo name = do - m <- getModSummary name - p <- parseModule m +getModInfo :: (GhcMonad m) => Module -> m ModInfo +getModInfo m = do + mod_summary <- getModSummary m + p <- parseModule mod_summary typechecked <- typecheckModule p let allTypes = processAllTypeCheckedModule typechecked let !rdr_env = tcg_rdr_env (fst $ tm_internals_ typechecked) - ts <- liftIO $ getModificationTime $ srcFilePath m + ts <- liftIO $ getModificationTime $ srcFilePath mod_summary return $ ModInfo - { modinfoSummary = m + { modinfoSummary = mod_summary , modinfoSpans = allTypes , modinfoRdrEnv = forceGlobalRdrEnv rdr_env , modinfoLastUpdate = ts ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -91,7 +91,6 @@ data GHCiState = GHCiState prompt_cont :: PromptFunction, editor :: String, stop :: String, - multiMode :: Bool, localConfig :: LocalConfigBehaviour, options :: [GHCiOption], line_number :: !Int, -- ^ input line @@ -155,7 +154,7 @@ data GHCiState = GHCiState long_help :: String, lastErrorLocations :: IORef [(FastString, Int)], - mod_infos :: !(Map ModuleName ModInfo), + mod_infos :: !(Map Module ModInfo), flushStdHandles :: ForeignHValue, -- ^ @hFlush stdout; hFlush stderr@ in the interpreter ===================================== ghc/Main.hs ===================================== @@ -302,7 +302,8 @@ ghciUI units srcs maybe_expr = do [] -> return [] _ -> do s <- initMake srcs - return $ map (uncurry (,Nothing,)) s + dflags <- getDynFlags + return $ map (uncurry (,Just $ homeUnitId_ dflags,)) s interactiveUI defaultGhciSettings hs_srcs maybe_expr #endif ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -6,33 +6,33 @@ ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2556:55: Note [Plan (AFTE ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2985:13: Note [Case binder next] ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4345:8: Note [Lambda-bound unfoldings] ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1387:37: Note [Gentle mode] -ref compiler/GHC/Core/Opt/Specialise.hs:1761:29: Note [Arity decrease] +ref compiler/GHC/Core/Opt/Specialise.hs:1758:29: Note [Arity decrease] ref compiler/GHC/Core/TyCo/Rep.hs:1783:31: Note [What prevents a constraint from floating] -ref compiler/GHC/Driver/DynFlags.hs:1218:52: Note [Eta-reduction in -O0] -ref compiler/GHC/Driver/Main.hs:1901:34: Note [simpleTidyPgm - mkBootModDetailsTc] +ref compiler/GHC/Driver/DynFlags.hs:1217:52: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/Main.hs:1886:34: Note [simpleTidyPgm - mkBootModDetailsTc] ref compiler/GHC/Hs/Expr.hs:189:63: Note [Pending Splices] -ref compiler/GHC/Hs/Expr.hs:2194:87: Note [Lifecycle of a splice] -ref compiler/GHC/Hs/Expr.hs:2230:7: Note [Pending Splices] -ref compiler/GHC/Hs/Extension.hs:148:5: Note [Strict argument type constraints] +ref compiler/GHC/Hs/Expr.hs:2208:87: Note [Lifecycle of a splice] +ref compiler/GHC/Hs/Expr.hs:2244:7: Note [Pending Splices] +ref compiler/GHC/Hs/Extension.hs:151:5: Note [Strict argument type constraints] ref compiler/GHC/Hs/Pat.hs:151:74: Note [Lifecycle of a splice] ref compiler/GHC/HsToCore/Pmc/Solver.hs:860:20: Note [COMPLETE sets on data families] ref compiler/GHC/HsToCore/Quote.hs:1533:7: Note [How brackets and nested splices are handled] ref compiler/GHC/Stg/Unarise.hs:457:32: Note [Renaming during unarisation] ref compiler/GHC/Tc/Gen/HsType.hs:563:56: Note [Skolem escape prevention] -ref compiler/GHC/Tc/Gen/HsType.hs:2717:7: Note [Matching a kind signature with a declaration] +ref compiler/GHC/Tc/Gen/HsType.hs:2718:7: Note [Matching a kind signature with a declaration] ref compiler/GHC/Tc/Gen/Pat.hs:284:20: Note [Typing patterns in pattern bindings] -ref compiler/GHC/Tc/Gen/Pat.hs:1378:7: Note [Matching polytyped patterns] +ref compiler/GHC/Tc/Gen/Pat.hs:1380:7: Note [Matching polytyped patterns] ref compiler/GHC/Tc/Gen/Sig.hs:91:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:368:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:543:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:670:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:367:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:542:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:669:7: Note [How brackets and nested splices are handled] ref compiler/GHC/Tc/Gen/Splice.hs:909:11: Note [How brackets and nested splices are handled] ref compiler/GHC/Tc/Instance/Family.hs:458:35: Note [Constrained family instances] -ref compiler/GHC/Tc/Solver/Rewrite.hs:1015:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1322:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/Solver/Rewrite.hs:1020:7: Note [Stability of rewriting] +ref compiler/GHC/Tc/TyCl.hs:1662:6: Note [Unification variables need fresh Names] ref compiler/GHC/Tc/Types/Constraint.hs:209:9: Note [NonCanonical Semantics] ref compiler/GHC/Types/Demand.hs:304:25: Note [Preserving Boxity of results is rarely a win] -ref compiler/GHC/Unit/Module/Deps.hs:86:13: Note [Structure of dep_boot_mods] +ref compiler/GHC/Unit/Module/Deps.hs:97:13: Note [Structure of dep_boot_mods] ref compiler/GHC/Utils/Monad.hs:415:34: Note [multiShotIO] ref compiler/Language/Haskell/Syntax/Binds.hs:206:31: Note [fun_id in Match] ref configure.ac:205:10: Note [Linking ghc-bin against threaded stage0 RTS] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9449adfd9d8a777f16cc5b6b4d50b0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9449adfd9d8a777f16cc5b6b4d50b0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] Buglet in continuation duplication
by Simon Peyton Jones (＠simonpj) 26 May '25

26 May '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: 1dd04c7f by Simon Peyton Jones at 2025-05-26T17:33:30+01:00 Buglet in continuation duplication Need to account for strict demand; makes a difference to T19695 - - - - - 1 changed file: - compiler/GHC/Core/Opt/Simplify/Iteration.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -3923,9 +3923,12 @@ mkDupableContWithDmds env df dmds -- it, then postInlineUnconditionally will just inline it again, perhaps -- taking an extra Simplifier iteration (e.g. in test T21839c). So make -- a `let` only if `couldBeSmallEnoughToInline` says that it is big enough + -- NB: postInlineUnconditionally does not fire on strict demands, + -- so account for that too ; let uf_opts = seUnfoldingOpts env ; (let_floats2, arg'') - <- if couldBeSmallEnoughToInline uf_opts (unfoldingUseThreshold uf_opts) arg' + <- if not (isStrUsedDmd dmd) && + couldBeSmallEnoughToInline uf_opts (unfoldingUseThreshold uf_opts) arg' then return (emptyLetFloats, arg') else makeTrivial env NotTopLevel dmd (fsLit "karg") arg' View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd04c7f8e4272389c0fab21eeea1a0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd04c7f8e4272389c0fab21eeea1a0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] 2 commits: remove special case for HsExpanded in Ticks
by Apoorv Ingle (＠ani) 26 May '25

26 May '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 3c4db9cf by Apoorv Ingle at 2025-05-26T11:18:53-05:00 remove special case for HsExpanded in Ticks - - - - - 655c636b by Apoorv Ingle at 2025-05-26T11:19:29-05:00 check the right origin for record selector incomplete warnings - - - - - 2 changed files: - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Instance/Class.hs Changes: ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -583,7 +583,11 @@ addTickHsExpr (HsProc x pat cmdtop) = addTickHsExpr (XExpr (WrapExpr w e)) = liftM (XExpr . WrapExpr w) $ (addTickHsExpr e) -- Explicitly no tick on inside -addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e +addTickHsExpr (XExpr (ExpandedThingTc o e)) = + liftM (XExpr . ExpandedThingTc o) $ + (addTickHsExpr e) -- Explicitly no tick on inside + + -- addTickHsExpanded o e addTickHsExpr e@(XExpr (ConLikeTc {})) = return e @@ -607,24 +611,24 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts)) ListComp -> Just $ BinBox QualBinBox _ -> Nothing -addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of - -- We always want statements to get a tick, so we can step over each one. - -- To avoid duplicates we blacklist SrcSpans we already inserted here. - OrigStmt (L pos _) _ -> do_tick_black pos - _ -> skip - where - skip = addTickHsExpr e - do_tick_black pos = do - d <- getDensity - case d of - TickForCoverage -> tick_it_black pos - TickForBreakPoints -> tick_it_black pos - _ -> skip - tick_it_black pos = - unLoc <$> allocTickBox (ExpBox False) False False (locA pos) - (withBlackListed (locA pos) $ - addTickHsExpr e) +-- addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc) +-- addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of +-- -- We always want statements to get a tick, so we can step over each one. +-- -- To avoid duplicates we blacklist SrcSpans we already inserted here. +-- OrigStmt (L pos _) _ -> do_tick_black pos +-- _ -> skip +-- where +-- skip = addTickHsExpr e +-- do_tick_black pos = do +-- d <- getDensity +-- case d of +-- TickForCoverage -> tick_it_black pos +-- TickForBreakPoints -> tick_it_black pos +-- _ -> skip +-- tick_it_black pos = +-- unLoc <$> allocTickBox (ExpBox False) False False (locA pos) +-- (withBlackListed (locA pos) $ +-- addTickHsExpr e) addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(OccurrenceOf) ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst, FamInstEnvs ) import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) @@ -1327,7 +1327,7 @@ warnIncompleteRecSel dflags sel_id ct_loc -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, -- despite the expansion to (getField @"x" r) - isGetFieldOrigin (GetFieldOrigin {}) = True + isGetFieldOrigin (OccurrenceOf f) = f `hasKey` getFieldClassOpKey isGetFieldOrigin _ = False lookupHasFieldLabel View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3a7db680e0e4c4928e08191bed8030… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3a7db680e0e4c4928e08191bed8030… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/andreask/spec-float-again
by Andreas Klebinger (＠AndreasK) 26 May '25

26 May '25

Andreas Klebinger pushed new branch wip/andreask/spec-float-again at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/spec-float-again You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25992] 18 commits: Don't fail when ghcversion.h can't be found (#26018)
by Simon Peyton Jones (＠simonpj) 26 May '25

26 May '25

Simon Peyton Jones pushed to branch wip/T25992 at Glasgow Haskell Compiler / GHC Commits: 6d058a69 by Andrea Bedini at 2025-05-21T16:00:51-04:00 Don't fail when ghcversion.h can't be found (#26018) If ghcversion.h can't be found, don't try to include it. This happens when there is no rts package in the package db and when -ghcversion-file argument isn't passed. Co-authored-by: Syvlain Henry <sylvain(a)haskus.fr> - - - - - b1212fbf by Vladislav Zavialov at 2025-05-21T16:01:33-04:00 Implement -Wpattern-namespace-specifier (#25900) In accordance with GHC Proposal #581 "Namespace-specified imports", section 2.3 "Deprecate use of pattern in import/export lists", the `pattern` namespace specifier is now deprecated. Test cases: T25900 T25900_noext - - - - - e650ec3e by Ben Gamari at 2025-05-23T03:42:46-04:00 base: Forward port changelog language from 9.12 - - - - - 94cd9ca4 by Ben Gamari at 2025-05-23T03:42:46-04:00 base: Fix RestructuredText-isms in changelog - - - - - 7722232c by Ben Gamari at 2025-05-23T03:42:46-04:00 base: Note strictness changes made in 4.16.0.0 Addresses #25886. - - - - - 3f4b823c by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker: Factor out ProddableBlocks machinery - - - - - 6e23fef2 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker: Improve efficiency of proddable blocks structure Previously the linker's "proddable blocks" check relied on a simple linked list of spans. This resulted in extremely poor complexity while linking objects with lots of small sections (e.g. objects built with split sections). Rework the mechanism to instead use a simple interval set implemented via binary search. Fixes #26009. - - - - - ea74860c by Ben Gamari at 2025-05-23T03:43:28-04:00 testsuite: Add simple functional test for ProddableBlockSet - - - - - 74c4db46 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Drop check for LOAD_LIBRARY_SEARCH_*_DIRS The `LOAD_LIBRARY_SEARCH_USER_DIRS` and `LOAD_LIBRARY_SEARCH_DEFAULT_DIRS` were introduced in Windows Vista and have been available every since. As we no longer support Windows XP we can drop this check. Addresses #26009. - - - - - 972d81d6 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Clean up code style - - - - - 8a1073a5 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/Hash: Factor out hashBuffer This is a useful helper which can be used for non-strings as well. - - - - - 44f509f2 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Fix incorrect use of break in nested for Previously the happy path of PEi386 used `break` in a double-`for` loop resulting in redundant calls to `LoadLibraryEx`. Fixes #26052. - - - - - bfb12783 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts: Correctly mark const arguments - - - - - 08469ff8 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Don't repeatedly load DLLs Previously every DLL-imported symbol would result in a call to `LoadLibraryEx`. This ended up constituting over 40% of the runtime of `ghc --interactive -e 42` on Windows. Avoid this by maintaining a hash-set of loaded DLL names, skipping the call if we have already loaded the requested DLL. Addresses #26009. - - - - - 823d1ccf by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker: Expand comment describing ProddableBlockSet - - - - - e9de9e0b by Sylvain Henry at 2025-05-23T15:12:34-04:00 Remove emptyModBreaks Remove emptyModBreaks and track the absence of ModBreaks with `Maybe ModBreaks`. It avoids testing for null pointers... - - - - - 17db44c5 by Ben Gamari at 2025-05-23T15:13:16-04:00 base: Expose Backtraces constructor and fields This was specified in the proposal (CLC #199) yet somehow didn't make it into the implementation. Fixes #26049. - - - - - bf4ae871 by Simon Peyton Jones at 2025-05-26T12:14:22+01: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 - - - - - 104 changed files: - compiler/GHC.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/SysTools/Cpp.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/9.14.1-notes.rst - docs/users_guide/using-warnings.rst - ghc/GHCi/UI.hs - hadrian/src/Flavour.hs - libraries/base/changelog.md - libraries/base/src/Control/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Type/Reflection.hs - libraries/ghc-internal/src/GHC/Internal/TypeLits.hs - libraries/ghc-internal/src/GHC/Internal/TypeNats.hs - rts/Hash.c - rts/Hash.h - rts/Linker.c - rts/LinkerInternals.h - rts/PathUtils.c - rts/PathUtils.h - rts/linker/Elf.c - rts/linker/MachO.c - rts/linker/PEi386.c - rts/linker/PEi386.h - + rts/linker/ProddableBlocks.c - + rts/linker/ProddableBlocks.h - rts/rts.cabal - testsuite/tests/callarity/unittest/CallArity1.hs - testsuite/tests/dependent/should_fail/T13135_simple.stderr - testsuite/tests/driver/Makefile - testsuite/tests/driver/all.T - testsuite/tests/ghci/scripts/ghci024.stdout - testsuite/tests/ghci/scripts/ghci024.stdout-mingw32 - 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/parser/should_compile/T25900.hs - + testsuite/tests/parser/should_compile/T25900.stderr - + testsuite/tests/parser/should_compile/T25900_noext.hs - + testsuite/tests/parser/should_compile/T25900_noext.stderr - testsuite/tests/parser/should_compile/all.T - testsuite/tests/patsyn/should_compile/ImpExp_Exp.hs - testsuite/tests/patsyn/should_compile/T11959.hs - testsuite/tests/patsyn/should_compile/T11959.stderr - testsuite/tests/patsyn/should_compile/T11959Lib.hs - testsuite/tests/patsyn/should_compile/T13350/boolean/Boolean.hs - testsuite/tests/patsyn/should_compile/T22521.hs - testsuite/tests/patsyn/should_compile/T9857.hs - testsuite/tests/patsyn/should_compile/export.hs - testsuite/tests/pmcheck/complete_sigs/T25115a.hs - testsuite/tests/pmcheck/should_compile/T11822.hs - testsuite/tests/polykinds/T14270.hs - testsuite/tests/rename/should_compile/T12548.hs - testsuite/tests/rename/should_fail/T25056.stderr - testsuite/tests/rename/should_fail/T25056a.hs - + testsuite/tests/rts/TestProddableBlockSet.c - testsuite/tests/rts/all.T - testsuite/tests/simplCore/should_compile/T15186.hs - testsuite/tests/simplCore/should_compile/T15186A.hs - + testsuite/tests/typecheck/should_compile/T25992.hs - + testsuite/tests/typecheck/should_compile/T25992.stderr - testsuite/tests/typecheck/should_compile/TypeRepCon.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/tcfail097.stderr - testsuite/tests/warnings/should_compile/DataToTagWarnings.hs - testsuite/tests/warnings/should_compile/T14794a.hs - testsuite/tests/warnings/should_compile/T14794a.stderr - testsuite/tests/warnings/should_compile/T14794b.hs - testsuite/tests/warnings/should_compile/T14794b.stderr - testsuite/tests/warnings/should_compile/T14794c.hs - testsuite/tests/warnings/should_compile/T14794c.stderr - testsuite/tests/warnings/should_compile/T14794d.hs - testsuite/tests/warnings/should_compile/T14794d.stderr - testsuite/tests/warnings/should_compile/T14794e.hs - testsuite/tests/warnings/should_compile/T14794e.stderr - testsuite/tests/warnings/should_compile/T14794f.hs - testsuite/tests/warnings/should_compile/T14794f.stderr - testsuite/tests/wcompat-warnings/Template.hs - + testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4cb8b60a22f1a3b7227f5f5153e00f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4cb8b60a22f1a3b7227f5f5153e00f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] 3 commits: Revert "Always try rules and inlining before simplifying args"
by Simon Peyton Jones (＠simonpj) 26 May '25

26 May '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: acc7c29d by Simon Peyton Jones at 2025-05-26T10:21:37+01:00 Revert "Always try rules and inlining before simplifying args" This reverts commit 29117fad96e827f1768ca0ac2ba811929ace76f4. - - - - - 2da3fb2c by Simon Peyton Jones at 2025-05-26T10:21:55+01:00 Revert "Try inlining after simplifying the arguments" This reverts commit fb2d5dee8f50052bb3cc0bcaec37de7884d631eb. - - - - - 4d2a8804 by Simon Peyton Jones at 2025-05-26T11:23:49+01:00 Inline top-level used-one things ... until final phase. This makes a difference in LargeRecord, where we can inline lots of dictionaries Just before FinalPhase we do a float-out with floatConsts=True, so we don't want to undo it by inlining them again. - - - - - 5 changed files: - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Driver/Config/Core/Opt/Simplify.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify.hs ===================================== @@ -156,7 +156,7 @@ simplifyPgm logger unit_env name_ppr_ctx opts && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ logDumpMsg logger "Simplifier statistics for following pass" - (vcat [text termination_msg <+> text "after" <+> ppr (it_count-1) + (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", blankLine, pprSimplCount counts_out]) @@ -240,8 +240,7 @@ simplifyPgm logger unit_env name_ppr_ctx opts ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) - ; iter_mode = mode { sm_first_iter = iteration_no ==1 } - ; simpl_env = mkSimplEnv iter_mode fam_envs } ; + ; simpl_env = mkSimplEnv mode fam_envs } ; -- Simplify the program ((binds1, rules1), counts1) <- ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -272,35 +272,32 @@ seUnfoldingOpts env = sm_uf_opts (seMode env) -- See Note [The environments of the Simplify pass] data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad - { sm_phase :: !CompilerPhase - , sm_names :: ![String] -- ^ Name(s) of the phase - , sm_first_iter :: !Bool -- ^ True <=> first iteration - -- False <=> second or subsequent iteration - , sm_rules :: !Bool -- ^ Whether RULES are enabled - , sm_inline :: !Bool -- ^ Whether inlining is enabled - , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled - , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? - , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options - , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled - , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled - , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out + { sm_phase :: !CompilerPhase + , sm_names :: ![String] -- ^ Name(s) of the phase + , sm_rules :: !Bool -- ^ Whether RULES are enabled + , sm_inline :: !Bool -- ^ Whether inlining is enabled + , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled + , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? + , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options + , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled + , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out , sm_do_eta_reduction :: !Bool - , sm_arity_opts :: !ArityOpts - , sm_rule_opts :: !RuleOpts - , sm_case_folding :: !Bool - , sm_case_merge :: !Bool - , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options + , sm_arity_opts :: !ArityOpts + , sm_rule_opts :: !RuleOpts + , sm_case_folding :: !Bool + , sm_case_merge :: !Bool + , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options } instance Outputable SimplMode where ppr (SimplMode { sm_phase = p , sm_names = ss - , sm_first_iter = fi, sm_rules = r, sm_inline = i + , sm_rules = r, sm_inline = i , sm_cast_swizzle = cs , sm_eta_expand = eta, sm_case_case = cc }) = text "SimplMode" <+> braces ( sep [ text "Phase =" <+> ppr p <+> brackets (text (concat $ intersperse "," ss)) <> comma - , pp_flag fi (text "first-iter") <> comma , pp_flag i (text "inline") <> comma , pp_flag r (text "rules") <> comma , pp_flag eta (text "eta-expand") <> comma ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2342,21 +2342,10 @@ simplOutId env fun cont -- Normal case for (f e1 .. en) simplOutId env fun cont - = do { rule_base <- getSimplRules + = -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules] + do { rule_base <- getSimplRules ; let rules_for_me = getRules rule_base fun - arg_info = mkArgInfo env fun rules_for_me cont out_args = contOutArgs env cont :: [OutExpr] - - -- If we are not in the first iteration, we have already tried rules and inlining - -- at the end of the previous iteration; no need to repeat that --- ; if not (sm_first_iter (seMode env)) --- then rebuildCall env arg_info cont --- else --- Do this BEFORE so that we can take advantage of single-occ inlines --- Example: T21839c which takes an extra Simplifier iteration after w/w --- if you don't do this - - -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules] ; mb_match <- if not (null rules_for_me) && (isClassOpId fun || activeUnfolding (seMode env) fun) then tryRules env rules_for_me fun out_args @@ -2368,14 +2357,16 @@ simplOutId env fun cont -- Try inlining do { logger <- getLogger - ; mb_inline <- tryInlining env logger fun (contArgs cont) + ; mb_inline <- tryInlining env logger fun cont ; case mb_inline of{ - Just expr -> simplExprF env expr cont ; + Just expr -> do { checkedTick (UnfoldingDone fun) + ; simplExprF env expr cont } ; Nothing -> -- Neither worked, so just rebuild - rebuildCall env arg_info cont - } } } } + do { let arg_info = mkArgInfo env fun rules_for_me cont + ; rebuildCall env arg_info cont + } } } } } --------------------------------------------------------- -- Dealing with a call site @@ -2447,39 +2438,28 @@ rebuildCall env fun_info ---------- No further useful info, revert to generic rebuild ------------ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont + | null rules + = rebuild env (argInfoExpr fun rev_args) cont + | otherwise -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules] = do { let args = reverse rev_args - - -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules] - ; mb_match <- if null rules - then return Nothing - else tryRules env rules fun (map argSpecArg args) - ; case mb_match of { + ; mb_match <- tryRules env rules fun (map argSpecArg args) + ; case mb_match of Just (rule_arity, rhs) -> simplExprF env rhs $ - pushSimplifiedArgs env (drop rule_arity args) cont ; - Nothing -> - - do { logger <- getLogger - ; mb_inline <- tryInlining env logger fun (null args, argSummaries env args, cont) - ; case mb_inline of - Just body -> simplExprF env body $ - pushSimplifiedArgs env args cont - Nothing -> rebuild env (argInfoExpr fun rev_args) cont - } } } + pushSimplifiedArgs env (drop rule_arity args) cont + Nothing -> rebuild env (argInfoExpr fun rev_args) cont } ----------------------------------- -tryInlining :: SimplEnv -> Logger -> OutId - -> (Bool, [ArgSummary], SimplCont) - -> SimplM (Maybe OutExpr) -tryInlining env logger fun (lone_variable, arg_infos, call_cont) - | Just expr <- callSiteInline env logger fun lone_variable arg_infos interesting_cont - = do { dump_inline expr call_cont - ; checkedTick (UnfoldingDone fun) +tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr) +tryInlining env logger var cont + | Just expr <- callSiteInline env logger var lone_variable arg_infos interesting_cont + = do { dump_inline expr cont ; return (Just expr) } | otherwise = return Nothing where + (lone_variable, arg_infos, call_cont) = contArgs cont interesting_cont = interestingCallContext env call_cont log_inlining doc @@ -2490,12 +2470,12 @@ tryInlining env logger fun (lone_variable, arg_infos, call_cont) dump_inline unfolding cont | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () | not (logHasDumpFlag logger Opt_D_verbose_core2core) - = when (isExternalName (idName fun)) $ + = when (isExternalName (idName var)) $ log_inlining $ - sep [text "Inlining done:", nest 4 (ppr fun)] + sep [text "Inlining done:", nest 4 (ppr var)] | otherwise = log_inlining $ - sep [text "Inlining done: " <> ppr fun, + sep [text "Inlining done: " <> ppr var, nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont])] ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -24,7 +24,7 @@ module GHC.Core.Opt.Simplify.Utils ( SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv, isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, - contIsTrivial, contArgs, contIsRhs, argSummaries, + contIsTrivial, contArgs, contIsRhs, countArgs, contOutArgs, dropContArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, @@ -537,11 +537,15 @@ contArgs cont lone _ = True go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) - = go (argSummary se arg : args) k + = go (is_interesting arg se : args) k go args (ApplyToTy { sc_cont = k }) = go args k go args (CastIt { sc_cont = k }) = go args k go args k = (False, reverse args, k) + is_interesting arg se = interestingArg se arg + -- Do *not* use short-cutting substitution here + -- because we want to get as much IdInfo as possible + contOutArgs :: SimplEnv -> SimplCont -> [OutExpr] -- Get the leading arguments from the `SimplCont`, as /OutExprs/ contOutArgs env cont @@ -883,15 +887,6 @@ strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) -- Why NonRecursive? Becuase it's a bit like -- let a = g x in f a -argSummaries :: SimplEnv -> [ArgSpec] -> [ArgSummary] -argSummaries env args - = go args - where - env' = zapSubstEnv env -- The args are simplified already - go [] = [] - go (TyArg {} : args) = go args - go (ValArg { as_arg = arg } : args) = argSummary env' arg : go args - interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt -- See Note [Interesting call context] interestingCallContext env cont @@ -995,9 +990,9 @@ rule for (*) (df d) can fire. To do this b) we say that a con-like argument (eg (df d)) is interesting -} -argSummary :: SimplEnv -> CoreExpr -> ArgSummary +interestingArg :: SimplEnv -> CoreExpr -> ArgSummary -- See Note [Interesting arguments] -argSummary env e = go env 0 e +interestingArg env e = go env 0 e where -- n is # value args to which the expression is applied go env n (Var v) @@ -1005,8 +1000,6 @@ argSummary env e = go env 0 e DoneId v' -> go_var n v' DoneEx e _ -> go (zapSubstEnv env) n e ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e - -- NB: substId looks up in the InScopeSet: - -- we want to get as much IdInfo as possible go _ _ (Lit l) | isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035 @@ -1469,11 +1462,18 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env one_occ IAmDead = True -- Happens in ((\x.1) v) one_occ OneOcc{ occ_n_br = 1 - , occ_in_lam = NotInsideLam - , occ_int_cxt = int_cxt } - = isNotTopLevel top_lvl -- Get rid of allocation - || (int_cxt==IsInteresting && idArity bndr > 0) -- Function is applied - -- || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase + , occ_in_lam = NotInsideLam } + = isNotTopLevel top_lvl || sePhase env /= FinalPhase + -- Inline even top level things if not inside lambda + -- Can reduce simplifier iterations, when something is later + -- inlining and becomes dead + -- + -- But not in FinalPhase because that's just after we have + -- carefully floated out constants to top level + + -- = isNotTopLevel top_lvl -- Get rid of allocation + -- || (int_cxt==IsInteresting && idArity bndr > 0) -- Function is applied + -- OLD || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase one_occ OneOcc{ occ_n_br = 1 , occ_in_lam = IsInsideLam , occ_int_cxt = IsInteresting } ===================================== compiler/GHC/Driver/Config/Core/Opt/Simplify.hs ===================================== @@ -60,7 +60,6 @@ initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode initSimplMode dflags phase name = SimplMode { sm_names = [name] , sm_phase = phase - , sm_first_iter = True , sm_rules = gopt Opt_EnableRewriteRules dflags , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags , sm_cast_swizzle = True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/29117fad96e827f1768ca0ac2ba811… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/29117fad96e827f1768ca0ac2ba811… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] Require # against left margin for all GHC_CPP directives
by Alan Zimmerman (＠alanz) 25 May '25

25 May '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: 32bc5dfb by Alan Zimmerman at 2025-05-25T18:27:52+01:00 Require # against left margin for all GHC_CPP directives - - - - - 3 changed files: - compiler/GHC/Parser/Lexer.x - testsuite/tests/ghc-cpp/GhcCpp01.hs - testsuite/tests/ghc-cpp/GhcCpp01.stderr Changes: ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -328,7 +328,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error } <bol> { \n ; -- Ghc CPP symbols, see https://timsong-cpp.github.io/cppwp/n4140/cpp#1 - ^\ * \# \ * @cppkeyword .* \n / { ifExtensionGhcCppNotComment } { cppToken cpp_prag } + ^\# \ * @cppkeyword .* \n / { ifExtensionGhcCppNotComment } { cppToken cpp_prag } ^\# line { begin line_prag1 } ^\# / { followedByDigit } { begin line_prag1 } @@ -350,7 +350,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error } -- GhcCppBit is set. <skipping> { -- Ghc CPP symbols - ^\ * \# \ * @cppkeyword .* \n { cppToken cpp_prag } + ^\# \ * @cppkeyword .* \n { cppToken cpp_prag } ^.*\n { cppSkip } } @@ -361,7 +361,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error } \{ / { notFollowedBy '-' } { hopefully_open_brace } -- we might encounter {-# here, but {- has been handled already \n ; - ^\ * \# \ * @cppkeyword .* \n / { ifExtension GhcCppBit } { cppToken cpp_prag } + ^\# \ * @cppkeyword .* \n / { ifExtension GhcCppBit } { cppToken cpp_prag } ^\# (line)? { begin line_prag1 } ^\#.*\n / { ifExtension GhcCppBit } { cppSkip } @@ -436,7 +436,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error } -- This one does not check for GhcCpp being set, we use it to -- terminate normal pragma processing - ^\ * \# \ * @cppkeyword .* \n { cppToken cpp_prag } + ^\# \ * @cppkeyword .* \n { cppToken cpp_prag } -- ^\# .*\n { cppSkip } } ===================================== testsuite/tests/ghc-cpp/GhcCpp01.hs ===================================== @@ -3,7 +3,7 @@ module GhcCpp01 where -- Check leading whitespace on a directive - # define FOO(A,B) A + B +# define FOO(A,B) A + B #define FOO(A,B,C) A + B + C #if FOO(1,FOO(3,4)) == 8 ===================================== testsuite/tests/ghc-cpp/GhcCpp01.stderr ===================================== @@ -202,7 +202,7 @@ |module GhcCpp01 where - |-- Check leading whitespace on a directive -- | # define FOO(A,B) A + B +- |# define FOO(A,B) A + B - |#define FOO(A,B,C) A + B + C - |#if FOO(1,FOO(3,4)) == 8 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32bc5dfbbd32bcf249ffebe01ac7e74… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32bc5dfbbd32bcf249ffebe01ac7e74… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] 2 commits: Tweak testing
by Alan Zimmerman (＠alanz) 25 May '25

25 May '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: e14f9dfc by Alan Zimmerman at 2025-05-25T18:15:19+01:00 Tweak testing - - - - - 3e7ac77b by Alan Zimmerman at 2025-05-25T18:15:35+01:00 Only allow unknown cpp pragmas with # in left margin - - - - - 2 changed files: - compiler/GHC/Parser/Lexer.x - utils/check-cpp/Main.hs Changes: ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -333,7 +333,7 @@ $unigraphic / { isSmartQuote } { smart_quote_error } ^\# line { begin line_prag1 } ^\# / { followedByDigit } { begin line_prag1 } - ^\ *\# \ * $idchar+ .*\n / { ifExtensionGhcCppNotComment } { cppSkip } + ^\# \ * $idchar+ .*\n / { ifExtensionGhcCppNotComment } { cppSkip } -- No leading space, otherwise clashes with OverloadedLabels ^\# pragma .* \n / { ifExtensionGhcCppNotComment } { cppSkip } -- GCC 3.3 CPP generated, apparently ^\# \! .* \n / { ifExtensionGhcCppNotComment } { cppSkip } -- #!, for scripts -- gcc ===================================== utils/check-cpp/Main.hs ===================================== @@ -147,8 +147,8 @@ getPState dflags includes popts filename str = pstate , pp_defines = predefinedMacros dflags , pp_scope = (PpScope True PpNoGroup) :| [] } - -- pstate = Lexer.initParserState initState popts buf loc - pstate = Lexer.initPragState initState popts buf loc + pstate = Lexer.initParserState initState popts buf loc + -- pstate = Lexer.initPragState initState popts buf loc loc = mkRealSrcLoc (mkFastString filename) 1 1 buf = stringToStringBuffer str @@ -598,7 +598,7 @@ t20 :: IO () t20 = do dump [ "{-# LANGUAGE CPP #-}" - , "#if __GLASGOW_HASKELL__ >= 913" + , "#if __GLASGOW_HASKELL__ > 913" , "{-# LANGUAGE GHC_CPP #-}" , "#endif" , "" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c5ad6c90dc6932f48b8316e3637a66… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c5ad6c90dc6932f48b8316e3637a66… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] 136 commits: base: Forward port changelog language from 9.12
by Alan Zimmerman (＠alanz) 25 May '25

25 May '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: e650ec3e by Ben Gamari at 2025-05-23T03:42:46-04:00 base: Forward port changelog language from 9.12 - - - - - 94cd9ca4 by Ben Gamari at 2025-05-23T03:42:46-04:00 base: Fix RestructuredText-isms in changelog - - - - - 7722232c by Ben Gamari at 2025-05-23T03:42:46-04:00 base: Note strictness changes made in 4.16.0.0 Addresses #25886. - - - - - 3f4b823c by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker: Factor out ProddableBlocks machinery - - - - - 6e23fef2 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker: Improve efficiency of proddable blocks structure Previously the linker's "proddable blocks" check relied on a simple linked list of spans. This resulted in extremely poor complexity while linking objects with lots of small sections (e.g. objects built with split sections). Rework the mechanism to instead use a simple interval set implemented via binary search. Fixes #26009. - - - - - ea74860c by Ben Gamari at 2025-05-23T03:43:28-04:00 testsuite: Add simple functional test for ProddableBlockSet - - - - - 74c4db46 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Drop check for LOAD_LIBRARY_SEARCH_*_DIRS The `LOAD_LIBRARY_SEARCH_USER_DIRS` and `LOAD_LIBRARY_SEARCH_DEFAULT_DIRS` were introduced in Windows Vista and have been available every since. As we no longer support Windows XP we can drop this check. Addresses #26009. - - - - - 972d81d6 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Clean up code style - - - - - 8a1073a5 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/Hash: Factor out hashBuffer This is a useful helper which can be used for non-strings as well. - - - - - 44f509f2 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Fix incorrect use of break in nested for Previously the happy path of PEi386 used `break` in a double-`for` loop resulting in redundant calls to `LoadLibraryEx`. Fixes #26052. - - - - - bfb12783 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts: Correctly mark const arguments - - - - - 08469ff8 by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker/PEi386: Don't repeatedly load DLLs Previously every DLL-imported symbol would result in a call to `LoadLibraryEx`. This ended up constituting over 40% of the runtime of `ghc --interactive -e 42` on Windows. Avoid this by maintaining a hash-set of loaded DLL names, skipping the call if we have already loaded the requested DLL. Addresses #26009. - - - - - 823d1ccf by Ben Gamari at 2025-05-23T03:43:28-04:00 rts/linker: Expand comment describing ProddableBlockSet - - - - - e9de9e0b by Sylvain Henry at 2025-05-23T15:12:34-04:00 Remove emptyModBreaks Remove emptyModBreaks and track the absence of ModBreaks with `Maybe ModBreaks`. It avoids testing for null pointers... - - - - - 17db44c5 by Ben Gamari at 2025-05-23T15:13:16-04:00 base: Expose Backtraces constructor and fields This was specified in the proposal (CLC #199) yet somehow didn't make it into the implementation. Fixes #26049. - - - - - b331155d by Alan Zimmerman at 2025-05-24T10:56:53+01:00 GHC-CPP: first rough proof of concept Processes #define FOO #ifdef FOO x = 1 #endif Into [ITcppIgnored [L loc ITcppDefine] ,ITcppIgnored [L loc ITcppIfdef] ,ITvarid "x" ,ITequal ,ITinteger (IL {il_text = SourceText "1", il_neg = False, il_value = 1}) ,ITcppIgnored [L loc ITcppEndif] ,ITeof] In time, ITcppIgnored will be pushed into a comment - - - - - 6a6f8336 by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Tidy up before re-visiting the continuation mechanic - - - - - 43993211 by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Switch preprocessor to continuation passing style Proof of concept, needs tidying up - - - - - 825a7b84 by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Small cleanup - - - - - 76c63619 by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Get rid of some cruft - - - - - 1d9960a6 by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Starting to integrate. Need to get the pragma recognised and set - - - - - ae452cba by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Make cppTokens extend to end of line, and process CPP comments - - - - - 3b8658cc by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Remove unused ITcppDefined - - - - - 27e0296e by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Allow spaces between # and keyword for preprocessor directive - - - - - 46b6623c by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Process CPP continuation lines They are emited as separate ITcppContinue tokens. Perhaps the processing should be more like a comment, and keep on going to the end. BUT, the last line needs to be slurped as a whole. - - - - - 55001b63 by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Accumulate CPP continuations, process when ready Can be simplified further, we only need one CPP token - - - - - 75cd6f5f by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Simplify Lexer interface. Only ITcpp We transfer directive lines through it, then parse them from scratch in the preprocessor. - - - - - 308129ed by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Deal with directive on last line, with no trailing \n - - - - - 4fbe856b by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Start parsing and processing the directives - - - - - 1a263713 by Alan Zimmerman at 2025-05-24T10:56:53+01:00 Prepare for processing include files - - - - - d731efe8 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Move PpState into PreProcess And initParserState, initPragState too - - - - - 0c39f394 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Process nested include files Also move PpState out of Lexer.x, so it is easy to evolve it in a ghci session, loading utils/check-cpp/Main.hs - - - - - c07b44f4 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Split into separate files - - - - - 45218048 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Starting on expression parser. But it hangs. Time for Text.Parsec.Expr - - - - - b59adfd0 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Start integrating the ghc-cpp work From https://github.com/alanz/ghc-cpp - - - - - 06a7c0ed by Alan Zimmerman at 2025-05-24T10:56:54+01:00 WIP - - - - - 7002db58 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Fixup after rebase - - - - - 4900171e by Alan Zimmerman at 2025-05-24T10:56:54+01:00 WIP - - - - - 49bf7922 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Fixup after rebase, including all tests pass - - - - - cbab1612 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Change pragma usage to GHC_CPP from GhcCPP - - - - - e7d9a03a by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Some comments - - - - - 9adedee8 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Reformat - - - - - 42579ec6 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Delete unused file - - - - - 3b764ee0 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Rename module Parse to ParsePP - - - - - 4dd44437 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Clarify naming in the parser - - - - - d85d3140 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 WIP. Switching to alex/happy to be able to work in-tree Since Parsec is not available - - - - - a5b5d735 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Layering is now correct - GHC lexer, emits CPP tokens - accumulated in Preprocessor state - Lexed by CPP lexer, CPP command extracted, tokens concated with spaces (to get rid of token pasting via comments) - if directive lexed and parsed by CPP lexer/parser, and evaluated - - - - - da4102a3 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 First example working Loading Example1.hs into ghci, getting the right results ``` {-# LANGUAGE GHC_CPP #-} module Example1 where y = 3 x = "hello" "bye now" foo = putStrLn x ``` - - - - - 8fe65619 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Rebase, and all tests pass except whitespace for generated parser - - - - - 60387f1b by Alan Zimmerman at 2025-05-24T10:56:54+01:00 More plumbing. Ready for testing tomorrow. - - - - - d4b509eb by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Proress. Renamed module State from Types And at first blush it seems to handle preprocessor scopes properly. - - - - - f0e80e26 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Insert basic GHC version macros into parser __GLASGOW_HASKELL__ __GLASGOW_HASKELL_FULL_VERSION__ __GLASGOW_HASKELL_PATCHLEVEL1__ __GLASGOW_HASKELL_PATCHLEVEL2__ - - - - - f141eed9 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Re-sync check-cpp for easy ghci work - - - - - a0477115 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Get rid of warnings - - - - - 9422b43b by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Rework macro processing, in check-cpp Macros kept at the top level, looked up via name, multiple arity versions per name can be stored - - - - - 5062fe5b by Alan Zimmerman at 2025-05-24T10:56:54+01:00 WIP. Can crack arguments for #define Next step it to crack out args in an expansion - - - - - 1843a281 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 WIP on arg parsing. - - - - - 865dde13 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Progress. Still screwing up nested parens. - - - - - a5d3e335 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Seems to work, but has redundant code - - - - - e6addc9d by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Remove redundant code - - - - - 26c1d4ea by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Reformat - - - - - 2de9249e by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Expand args, single pass Still need to repeat until fixpoint - - - - - 980b9fa8 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Fixed point expansion - - - - - 56571b26 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Sync the playground to compiler - - - - - 5274439e by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Working on dumping the GHC_CPP result But We need to keep the BufSpan in a comment - - - - - d689071b by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Keep BufSpan in queued comments in GHC.Parser.Lexer - - - - - ed06be80 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Getting close to being able to print the combined tokens showing what is in and what is out - - - - - 930e3c73 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 First implementation of dumpGhcCpp. Example output First dumps all macros in the state, then the source, showing which lines are in and which are out ------------------------------ - |#define FOO(A,B) A + B - |#define FOO(A,B,C) A + B + C - |#if FOO(1,FOO(3,4)) == 8 - |-- a comment |x = 1 - |#else - |x = 5 - |#endif - - - - - 43ce53a7 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Clean up a bit - - - - - 4c7fdd44 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Add -ddump-ghc-cpp option and a test based on it - - - - - ba0882cd by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Restore Lexer.x rules, we need them for continuation lines - - - - - 2dcbdc28 by Alan Zimmerman at 2025-05-24T10:56:54+01:00 Lexer.x: trying to sort out the span for continuations - We need to match on \n at the end of the line - We cannot simply back up for it - - - - - 3ab324c9 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Inserts predefined macros. But does not dump properly Because the cpp tokens have a trailing newline - - - - - 6c8d9a66 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Remove unnecessary LExer rules We *need* the ones that explicitly match to the end of the line. - - - - - f01db2c7 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Generate correct span for ITcpp Dump now works, except we do not render trailing `\` for continuation lines. This is good enough for use in test output. - - - - - aae100a5 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Reduce duplication in lexer - - - - - 36ecf1de by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Tweaks - - - - - e21f91eb by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Insert min_version predefined macros into state The mechanism now works. Still need to flesh out the full set. - - - - - b9ff7298 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Trying my alternative pragma syntax. It works, but dumpGhcCpp is broken, I suspect from the ITcpp token span update. - - - - - 7806b47c by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Pragma extraction now works, with both CPP and GHC_CPP For the following {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 913 {-# LANGUAGE GHC_CPP #-} #endif We will enable GHC_CPP only - - - - - 0cb5848e by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Remove some tracing - - - - - 4d9ce4da by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Fix test exes for changes - - - - - 4c1a8aa6 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 For GHC_CPP tests, normalise config-time-based macros - - - - - 2dd91346 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 WIP - - - - - d5dc2164 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 WIP again. What is wrong? - - - - - 54f7ef01 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Revert to dynflags for normal not pragma lexing - - - - - efde6b0b by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Working on getting check-exact to work properly - - - - - 0584ec31 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Passes CppCommentPlacement test - - - - - 26bdd707 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Starting on exact printing with GHC_CPP While overriding normal CPP - - - - - 51dbf90c by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Correctly store CPP ignored tokens as comments By populating the lexeme string in it, based on the bufpos - - - - - 576d82b9 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 WIP - - - - - e2eb9351 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Simplifying - - - - - cfa6c9ee by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Update the active state logic - - - - - e7b67c4c by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Work the new logic into the mainline code - - - - - f4897a8a by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Process `defined` operator - - - - - 20d71b45 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Manage lexer state while skipping tokens There is very intricate layout-related state used when lexing. If a CPP directive blanks out some tokens, store this state when the blanking starts, and restore it when they are no longer being blanked. - - - - - f660cc0f by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Track the last token buffer index, for ITCppIgnored We need to attach the source being skipped in an ITCppIgnored token. We cannot simply use its BufSpan as an index into the underlying StringBuffer as it counts unicode chars, not bytes. So we update the lexer state to store the starting StringBuffer location for the last token, and use the already-stored length to extract the correct portion of the StringBuffer being parsed. - - - - - dff1b130 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Process the ! operator in GHC_CPP expressions - - - - - 0b1a1c8e by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Predefine a constant when GHC_CPP is being used. - - - - - 1b864cbb by Alan Zimmerman at 2025-05-24T10:56:55+01:00 WIP - - - - - a122870f by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Skip lines directly in the lexer when required - - - - - c08e5cfe by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Properly manage location when accepting tokens again - - - - - 5bcb5eaa by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Seems to be working now, for Example9 - - - - - af10cd3a by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Remove tracing - - - - - 7eba8335 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Fix parsing '*' in block comments Instead of replacing them with '-' - - - - - c120861f by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Keep the trailing backslash in a ITcpp token - - - - - aaf6403f by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Deal with only enabling one section of a group. A group is an instance of a conditional introduced by #if/#ifdef/#ifndef, and ending at the final #endif, including intermediate #elsif sections - - - - - 4cbc14ce by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Replace remaining identifiers with 0 when evaluating As per the spec - - - - - f2efe0a0 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Snapshot before rebase - - - - - 23a08af3 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Skip non-processed lines starting with # - - - - - 070a73ba by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Export generateMacros so we can use it in ghc-exactprint - - - - - 5961854c by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Fix rebase - - - - - 45d09b97 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Expose initParserStateWithMacrosString - - - - - f68f285b by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Fix buggy lexer cppSkip It was skipping all lines, not just ones prefixed by # - - - - - b675bbdc by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Fix evaluation of && to use the correct operator - - - - - 0590858e by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Deal with closing #-} at the start of a line - - - - - 81d303bb by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Add the MIN_VERSION_GLASGOW_HASKELL predefined macro - - - - - cac17074 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Include MIN_VERSION_GLASGOW_HASKELL in GhcCpp01.stderr - - - - - 99c5d435 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Use a strict map for macro defines - - - - - 09cd7fb3 by Alan Zimmerman at 2025-05-24T10:56:55+01:00 Process TIdentifierLParen Which only matters at the start of #define - - - - - 9fd72f0b by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Do not provide TIdentifierLParen paren twice - - - - - 6ec0fa43 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Handle whitespace between identifier and '(' for directive only - - - - - 167fb4a8 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Expose some Lexer bitmap manipulation helpers - - - - - 40d267e3 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Deal with line pragmas as tokens Blows up for dumpGhcCpp though - - - - - e6d4be32 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Allow strings delimited by a single quote too - - - - - 50f024fd by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Allow leading whitespace on cpp directives As per https://timsong-cpp.github.io/cppwp/n4140/cpp#1 - - - - - 55406057 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Implement GHC_CPP undef - - - - - 669e08f4 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Sort out expansion of no-arg macros, in a context with args And make the expansion bottom out, in the case of recursion - - - - - 24e61f12 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Fix GhcCpp01 test The LINE pragma stuff works in ghc-exactprint when specifically setting flag to emit ITline_pragma tokens - - - - - a8ebae85 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Process comments in CPP directives - - - - - 06888106 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Correctly lex pragmas with finel #-} on a newline - - - - - 85554b54 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Do not process CPP-style comments - - - - - e23844a0 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Allow cpp-style comments when GHC_CPP enabled - - - - - 1754f279 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Return other pragmas as cpp ignored when GHC_CPP active - - - - - f10714b5 by Alan Zimmerman at 2025-05-24T10:56:56+01:00 Fix exactprinting default decl - - - - - c5ad6c90 by Alan Zimmerman at 2025-05-25T15:29:59+01:00 Reorganise getOptionsFromFile for use in ghc-exactprint We want to be able to inject predefined macro definitions into the parser preprocessor state for when we do a hackage roundtrip. - - - - - 107 changed files: - compiler/GHC.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/Parser/Monad.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Config/Parser.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Parser.hs-boot - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - + compiler/GHC/Parser/PreProcess.hs - + compiler/GHC/Parser/PreProcess/Eval.hs - + compiler/GHC/Parser/PreProcess/Lexer.x - + compiler/GHC/Parser/PreProcess/Macro.hs - + compiler/GHC/Parser/PreProcess/ParsePP.hs - + compiler/GHC/Parser/PreProcess/Parser.y - + compiler/GHC/Parser/PreProcess/ParserM.hs - + compiler/GHC/Parser/PreProcess/State.hs - compiler/GHC/Parser/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/SysTools/Cpp.hs - compiler/ghc.cabal.in - docs/users_guide/debugging.rst - ghc/GHCi/UI.hs - hadrian/src/Rules/SourceDist.hs - hadrian/stack.yaml.lock - libraries/base/changelog.md - libraries/base/src/Control/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - rts/Hash.c - rts/Hash.h - rts/Linker.c - rts/LinkerInternals.h - rts/PathUtils.c - rts/PathUtils.h - rts/linker/Elf.c - rts/linker/MachO.c - rts/linker/PEi386.c - rts/linker/PEi386.h - + rts/linker/ProddableBlocks.c - + rts/linker/ProddableBlocks.h - rts/rts.cabal - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/driver/T4437.hs - testsuite/tests/ghc-api/T11579.hs - + testsuite/tests/ghc-cpp/GhcCpp01.hs - + testsuite/tests/ghc-cpp/GhcCpp01.stderr - + testsuite/tests/ghc-cpp/all.T - 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/interface-stability/template-haskell-exports.stdout - + testsuite/tests/printer/CppCommentPlacement.hs - + testsuite/tests/rts/TestProddableBlockSet.c - testsuite/tests/rts/all.T - + utils/check-cpp/.ghci - + utils/check-cpp/.gitignore - + utils/check-cpp/Eval.hs - + utils/check-cpp/Example1.hs - + utils/check-cpp/Example10.hs - + utils/check-cpp/Example11.hs - + utils/check-cpp/Example12.hs - + utils/check-cpp/Example13.hs - + utils/check-cpp/Example2.hs - + utils/check-cpp/Example3.hs - + utils/check-cpp/Example4.hs - + utils/check-cpp/Example5.hs - + utils/check-cpp/Example6.hs - + utils/check-cpp/Example7.hs - + utils/check-cpp/Example8.hs - + utils/check-cpp/Example9.hs - + utils/check-cpp/Lexer.x - + utils/check-cpp/Macro.hs - + utils/check-cpp/Main.hs - + utils/check-cpp/ParsePP.hs - + utils/check-cpp/ParseSimulate.hs - + utils/check-cpp/Parser.y - + utils/check-cpp/ParserM.hs - + utils/check-cpp/PreProcess.hs - + utils/check-cpp/README.md - + utils/check-cpp/State.hs - + utils/check-cpp/run.sh - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Preprocess.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Parser.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2eb0e2d66956ecf1531bbab902d5b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2eb0e2d66956ecf1531bbab902d5b… You're receiving this email because of your account on gitlab.haskell.org.

1 0