June 2025 - ghc-commits

[Git][ghc/ghc][wip/fendor/no-load] Implement `-ghci-no-load` flag
by Hannes Siebenhandl (＠fendor) 24 Jun '25

24 Jun '25

Hannes Siebenhandl pushed to branch wip/fendor/no-load at Glasgow Haskell Compiler / GHC Commits: e10b825d by fendor at 2025-06-24T15:04:00+02:00 Implement `-ghci-no-load` flag We add the new flag `-ghci-no-load` which doesn't load all `Target`s immediately but only computes the module graph for all `Target`s. The user can then decide to load modules from that module graph using the syntax: ghci> :reload <Mod> This will load everything in the module graph up to `Mod`. The user can return to the initial state by using the builtin target `none` to unload all modules. ghci> :reload none Is in principle identical to starting a new session with the `-ghci-no-load` flag. The `-ghci-no-load` flag allows for faster startup time of GHCi when a user has lots of `Target`s. We additionally extend the `:reload` command to accept multiple `ModuleName`s. For example: ghci> :reload <Mod1> <Mod2> Loads all modules up to the modules `Mod1` and `Mod2`. - - - - - 33 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Unit/Module/Graph.hs - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - + testsuite/tests/ghci/prog-mhu005/Makefile - + testsuite/tests/ghci/prog-mhu005/a/A.hs - + testsuite/tests/ghci/prog-mhu005/all.T - + testsuite/tests/ghci/prog-mhu005/b/B.hs - + testsuite/tests/ghci/prog-mhu005/prog-mhu005a.script - + testsuite/tests/ghci/prog-mhu005/prog-mhu005a.stderr - + testsuite/tests/ghci/prog-mhu005/prog-mhu005a.stdout - + testsuite/tests/ghci/prog-mhu005/unitA - + testsuite/tests/ghci/prog-mhu005/unitB - + testsuite/tests/ghci/prog021/all.T - − testsuite/tests/ghci/prog021/prog021.T - testsuite/tests/ghci/prog021/prog021.script → testsuite/tests/ghci/prog021/prog021a.script - testsuite/tests/ghci/prog021/prog021.stderr → testsuite/tests/ghci/prog021/prog021a.stderr - testsuite/tests/ghci/prog021/prog021.stdout → testsuite/tests/ghci/prog021/prog021a.stdout - + testsuite/tests/ghci/prog021/prog021b.script - + testsuite/tests/ghci/prog021/prog021b.stderr - + testsuite/tests/ghci/prog021/prog021b.stdout - + testsuite/tests/ghci/prog022/A.hs - + testsuite/tests/ghci/prog022/B.hs - + testsuite/tests/ghci/prog022/Makefile - + testsuite/tests/ghci/prog022/all.T - + testsuite/tests/ghci/prog022/ghci.prog022a.script - + testsuite/tests/ghci/prog022/ghci.prog022a.stderr - + testsuite/tests/ghci/prog022/ghci.prog022a.stdout - + testsuite/tests/ghci/prog022/ghci.prog022b.script - + testsuite/tests/ghci/prog022/ghci.prog022b.stderr - + testsuite/tests/ghci/prog022/ghci.prog022b.stdout The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e10b825df11c0e0ae347ed10b594ce5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e10b825df11c0e0ae347ed10b594ce5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/no-load] Implement `-ghci-no-load` flag
by Hannes Siebenhandl (＠fendor) 24 Jun '25

24 Jun '25

Hannes Siebenhandl pushed to branch wip/fendor/no-load at Glasgow Haskell Compiler / GHC Commits: f900502b by fendor at 2025-06-24T14:45:19+02:00 Implement `-ghci-no-load` flag We add the new flag `-ghci-no-load` which doesn't load all `Target`s immediately but only computes the module graph for all `Target`s. The user can then decide to load modules from that module graph using the syntax: ghci> :reload <Mod> This will load everything in the module graph up to `Mod`. The user can return to the initial state by using the builtin target `none` to unload all modules. ghci> :reload none Is in principle identical to starting a new session with the `-ghci-no-load` flag. The `-ghci-no-load` flag allows for faster startup time of GHCi when a user has lots of `Target`s. We additionally extend the `:reload` command to accept multiple `ModuleName`s. For example: ghci> :reload <Mod1> <Mod2> Loads all modules up to the modules `Mod1` and `Mod2`. - - - - - 33 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Unit/Module/Graph.hs - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - + testsuite/tests/ghci/prog-mhu005/Makefile - + testsuite/tests/ghci/prog-mhu005/a/A.hs - + testsuite/tests/ghci/prog-mhu005/all.T - + testsuite/tests/ghci/prog-mhu005/b/B.hs - + testsuite/tests/ghci/prog-mhu005/prog-mhu005a.script - + testsuite/tests/ghci/prog-mhu005/prog-mhu005a.stderr - + testsuite/tests/ghci/prog-mhu005/prog-mhu005a.stdout - + testsuite/tests/ghci/prog-mhu005/unitA - + testsuite/tests/ghci/prog-mhu005/unitB - + testsuite/tests/ghci/prog021/all.T - − testsuite/tests/ghci/prog021/prog021.T - testsuite/tests/ghci/prog021/prog021.script → testsuite/tests/ghci/prog021/prog021a.script - testsuite/tests/ghci/prog021/prog021.stderr → testsuite/tests/ghci/prog021/prog021a.stderr - testsuite/tests/ghci/prog021/prog021.stdout → testsuite/tests/ghci/prog021/prog021a.stdout - + testsuite/tests/ghci/prog021/prog021b.script - + testsuite/tests/ghci/prog021/prog021b.stderr - + testsuite/tests/ghci/prog021/prog021b.stdout - + testsuite/tests/ghci/prog022/A.hs - + testsuite/tests/ghci/prog022/B.hs - + testsuite/tests/ghci/prog022/Makefile - + testsuite/tests/ghci/prog022/all.T - + testsuite/tests/ghci/prog022/ghci.prog022a.script - + testsuite/tests/ghci/prog022/ghci.prog022a.stderr - + testsuite/tests/ghci/prog022/ghci.prog022a.stdout - + testsuite/tests/ghci/prog022/ghci.prog022b.script - + testsuite/tests/ghci/prog022/ghci.prog022b.stderr - + testsuite/tests/ghci/prog022/ghci.prog022b.stdout The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f900502bb70c0b91a3f4a4e561c1768… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f900502bb70c0b91a3f4a4e561c1768… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/no-load] 2 commits: Teach `:reload` about multiple home units
by Hannes Siebenhandl (＠fendor) 24 Jun '25

24 Jun '25

Hannes Siebenhandl pushed to branch wip/fendor/no-load at Glasgow Haskell Compiler / GHC Commits: 166d218b by fendor at 2025-06-24T13:25:07+02:00 Teach `:reload` about multiple home units `:reload` needs to lookup the `ModuleName` and must not assume the given `ModuleName` is in the current `HomeUnit`. We add a new utility function which allows us to find a `HomeUnitModule` instead of a `Module`. Further, we introduce the `GhciCommandError` type which can be used to abort the execution of a GHCi command. This error is caught and printed in a human readable fashion. - - - - - 830a5ea7 by fendor at 2025-06-24T13:26:14+02:00 WIP - - - - - 18 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Unit/Module/Graph.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - ghc/GHCi/UI/Print.hs - testsuite/tests/ghc-e/should_fail/T18441fail5.stderr - testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr - testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr - + testsuite/tests/ghci/prog021/A.hs - + testsuite/tests/ghci/prog021/B.hs - + testsuite/tests/ghci/prog021/Makefile - + testsuite/tests/ghci/prog021/prog021.T - + testsuite/tests/ghci/prog021/prog021.script - + testsuite/tests/ghci/prog021/prog021.stderr - + testsuite/tests/ghci/prog021/prog021.stdout - testsuite/tests/ghci/scripts/ghci021.stderr Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -422,6 +422,8 @@ data DynFlags = DynFlags { -- | GHCi scripts specified by -ghci-script, in reverse order ghciScripts :: [String], + -- | Instruct GHCi to not load the targets immediately + ghciDontLoad :: Bool, -- Output style options pprUserLength :: Int, @@ -677,6 +679,7 @@ defaultDynFlags mySettings = customWarningCategories = completeWarningCategorySet, fatalCustomWarningCategories = emptyWarningCategorySet, ghciScripts = [], + ghciDontLoad = False, language = Nothing, safeHaskell = Sf_None, safeInfer = True, ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -116,6 +116,7 @@ import qualified Control.Monad.Catch as MC import Data.IORef import Data.Maybe import Data.List (sortOn, groupBy, sortBy) +import qualified Data.List as List import System.FilePath import Control.Monad.IO.Class @@ -343,8 +344,9 @@ warnUnknownModules hsc_env dflags mod_graph = do data LoadHowMuch = LoadAllTargets -- ^ Load all targets and its dependencies. - | LoadUpTo HomeUnitModule + | LoadUpTo [HomeUnitModule] -- ^ Load only the given module and its dependencies. + -- If empty, we load none of the targets | LoadDependenciesOf HomeUnitModule -- ^ Load only the dependencies of the given module, but not the module -- itself. @@ -517,16 +519,17 @@ countMods (ResolvedCycle ns) = length ns countMods (UnresolvedCycle ns) = length ns -- See Note [Upsweep] for a high-level description. -createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan] +createBuildPlan :: ModuleGraph -> Maybe [HomeUnitModule] -> [BuildPlan] createBuildPlan mod_graph maybe_top_mod = let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles - cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + acyclic_mod_graph = topSortModuleGraph False mod_graph maybe_top_mod -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles. build_plan :: [BuildPlan] build_plan -- Fast path, if there are no boot modules just do a normal toposort - | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod + | isEmptyModuleEnv boot_modules = collapseAcyclic acyclic_mod_graph | otherwise = toBuildPlan cycle_mod_graph [] toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan] @@ -598,14 +601,17 @@ createBuildPlan mod_graph maybe_top_mod = collapseAcyclic [] = [] topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing - - in - - assertPpr (sum (map countMods build_plan) == lengthMG mod_graph) - (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMG mod_graph))]) + -- We need to use 'acyclic_mod_graph', since if 'maybe_top_mod' is 'Just', then the resulting module + -- graph is pruned, reducing the number of 'build_plan' elements. + -- We don't use the size of 'cycle_mod_graph', as it removes @.hi-boot@ modules. These are added + -- later in the processing. + assertPpr (sum (map countMods build_plan) == lengthMGWithSCC acyclic_mod_graph) + (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMGWithSCC acyclic_mod_graph))]) build_plan - + where + lengthMGWithSCC :: [SCC a] -> Int + lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0 -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally @@ -640,16 +646,20 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- check that the module given in HowMuch actually exists, otherwise -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m + let checkHowMuch (LoadUpTo ms) = checkMods ms + checkHowMuch (LoadDependenciesOf m) = checkMods [m] checkHowMuch _ = id - checkMod m and_then - | m `Set.member` all_home_mods = and_then - | otherwise = do - throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan - $ GhcDriverMessage - $ DriverModuleNotFound (moduleUnit m) (moduleName m) + checkMods ms and_then = + case List.partition (`Set.member` all_home_mods) ms of + (_, []) -> and_then + (_, not_found_mods) -> do + let + mkModuleNotFoundError m = + mkPlainErrorMsgEnvelope noSrcSpan + $ GhcDriverMessage + $ DriverModuleNotFound (moduleUnit m) (moduleName m) + throwErrors $ mkMessages $ listToBag [mkModuleNotFoundError not_found | not_found <- not_found_mods] checkHowMuch how_much $ do @@ -662,12 +672,12 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- are definitely unnecessary, then emit a warning. warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps) - let maybe_top_mod = case how_much of + let maybe_top_mods = case how_much of LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m + LoadDependenciesOf m -> Just [m] _ -> Nothing - build_plan = createBuildPlan mod_graph maybe_top_mod + build_plan = createBuildPlan mod_graph maybe_top_mods cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache @@ -1301,7 +1311,7 @@ topSortModuleGraph :: Bool -- ^ Drop hi-boot nodes? (see below) -> ModuleGraph - -> Maybe HomeUnitModule + -> Maybe [HomeUnitModule] -- ^ Root module name. If @Nothing@, use the full graph. -> [SCC ModuleGraphNode] -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes @@ -1351,7 +1361,7 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod = cmpModuleGraphNodes k1 k2 = compare (moduleGraphNodeRank k1) (moduleGraphNodeRank k2) `mappend` compare k2 k1 -topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode] +topSortModules :: Bool -> [ModuleGraphNode] -> Maybe [HomeUnitModule] -> [SCC ModuleGraphNode] topSortModules drop_hs_boot_nodes summaries mb_root_mod = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph where @@ -1360,17 +1370,20 @@ topSortModules drop_hs_boot_nodes summaries mb_root_mod initial_graph = case mb_root_mod of Nothing -> graph - Just (Module uid root_mod) -> + Just mods -> -- restrict the graph to just those modules reachable from -- the specified module. We do this by building a graph with -- the full set of nodes, and determining the reachable set from -- the specified node. - let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid - , graph `hasVertexG` node - = node - | otherwise - = throwGhcException (ProgramError "module does not exist") - in graphFromEdgedVerticesUniq (seq root (root:allReachable (graphReachability graph) root)) + let + findNodeForModule (Module uid root_mod) + | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid + , graph `hasVertexG` node + = seq node node + | otherwise + = throwGhcException (ProgramError "module does not exist") + roots = fmap findNodeForModule mods + in graphFromEdgedVerticesUniq (seq roots (roots ++ allReachableMany (graphReachability graph) roots)) newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a } deriving (Functor, Traversable, Foldable) ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -764,6 +764,9 @@ addHaddockOpts f d = d { haddockOptions = Just f} addGhciScript f d = d { ghciScripts = f : ghciScripts d} +setDontLoadGhci :: Bool -> DynP () +setDontLoadGhci f = upd $ \d -> d { ghciDontLoad = f } + setInteractivePrint f d = d { interactivePrint = Just f} ----------------------------------------------------------------------------- @@ -1344,6 +1347,8 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) + , make_ord_flag defGhciFlag "ghci-no-load" (NoArg (setDontLoadGhci True)) + , make_ord_flag defGhciFlag "ghci-load" (NoArg (setDontLoadGhci False)) , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) , make_ord_flag defGhcFlag "ticky-allocd" (NoArg (setGeneralFlag Opt_Ticky_Allocd)) ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -67,6 +67,7 @@ module GHC.Unit.Module.Graph , mapMG, mgMapM , mgModSummaries , mgLookupModule + , mgLookupModuleName , mgHasHoles , showModMsg @@ -523,6 +524,17 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss = Just ms go _ = Nothing +-- | +-- TODO @fendor: Docs +mgLookupModuleName :: ModuleGraph -> ModuleName -> [ModuleNodeInfo] +mgLookupModuleName ModuleGraph{..} m = mapMaybe go mg_mss + where + go (ModuleNode _ ms) + | NotBoot <- isBootModuleNodeInfo ms + , moduleName (moduleNodeInfoModule ms) == m + = Just ms + go _ = Nothing + mgMember :: ModuleGraph -> NodeKey -> Bool mgMember graph k = isJust $ snd (mg_graph graph) k ===================================== ghc/GHCi/UI.hs ===================================== @@ -948,7 +948,7 @@ runGHCi paths maybe_exprs = do -- immediately rather than going on to evaluate the expression. when (not (null paths)) $ do ok <- ghciHandle (\e -> do showException e; return Failed) $ - loadModule paths + initialLoadModule paths when (isJust maybe_exprs && failed ok) $ liftIO (exitWith (ExitFailure 1)) @@ -1302,7 +1302,8 @@ runOneCommand eh gCmd = do st <- getGHCiState ghciHandle (\e -> lift $ eh e >>= return . Just) $ handleSourceError printErrorAndFail $ - cmd_wrapper st $ doCommand c + handleGhciCommandError printErrorAndContinue $ + cmd_wrapper st $ doCommand c -- source error's are handled by runStmt -- is the handler necessary here? where @@ -1310,6 +1311,10 @@ runOneCommand eh gCmd = do printGhciException err return $ Just False -- Exit ghc -e, but not GHCi + printErrorAndContinue err = do + printGhciCommandException err + return $ Just False -- Exit ghc -e, but not GHCi + noSpace q = q >>= maybe (return Nothing) (\c -> case removeSpaces c of "" -> noSpace q @@ -2196,6 +2201,11 @@ loadModule fs = do (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs) either (liftIO . Exception.throwIO) return result +initialLoadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag +initialLoadModule fs = do + (_, result) <- runAndPrintStats (const Nothing) (initialLoadModule' fs) + either (liftIO . Exception.throwIO) return result + -- | @:load@ command loadModule_ :: GhciMonad m => [FilePath] -> m () loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnitId)) (repeat Nothing)) @@ -2203,6 +2213,44 @@ loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnit loadModuleDefer :: GhciMonad m => [FilePath] -> m () loadModuleDefer = wrapDeferTypeErrors . loadModule_ +initialLoadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag +initialLoadModule' files = do + let (filenames, uids, phases) = unzip3 files + exp_filenames <- mapM expandPath filenames + let files' = zip3 exp_filenames uids phases + targets <- mapM (\(file, uid, phase) -> GHC.guessTarget file uid phase) files' + + -- NOTE: we used to do the dependency anal first, so that if it + -- fails we didn't throw away the current set of modules. This would + -- require some re-working of the GHC interface, so we'll leave it + -- as a ToDo for now. + + hsc_env <- GHC.getSession + let !dflags = hsc_dflags hsc_env + + let load_module = do + -- unload first + _ <- GHC.abandonAll + clearCaches + + GHC.setTargets targets + if ghciDontLoad dflags + then + doLoadAndCollectInfo Load (LoadUpTo []) + else + doLoadAndCollectInfo Load LoadAllTargets + + if gopt Opt_GhciLeakCheck dflags + then do + -- Grab references to the currently loaded modules so that we can see if + -- they leak. + leak_indicators <- liftIO $ getLeakIndicators hsc_env + success <- load_module + liftIO $ checkLeakIndicators dflags leak_indicators + return success + else + load_module + loadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag loadModule' files = do let (filenames, uids, phases) = unzip3 files @@ -2286,13 +2334,18 @@ unAddModule files = do -- | @:reload@ command reloadModule :: GhciMonad m => String -> m () reloadModule m = do - session <- GHC.getSession - let home_unit = homeUnitId (hsc_home_unit session) - ok <- doLoadAndCollectInfo Reload (loadTargets home_unit) + let mods = words m + loadTarget <- findLoadTargets mods + ok <- doLoadAndCollectInfo Reload loadTarget when (failed ok) failIfExprEvalMode where - loadTargets hu | null m = LoadAllTargets - | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m)) + findLoadTargets modls + | null modls = + pure LoadAllTargets + | otherwise = do + mod_graph <- GHC.getModuleGraph + let mods = concatMap (fmap (fmap toUnitId . GHC.moduleNodeInfoModule) . GHC.mgLookupModuleName mod_graph) [GHC.mkModuleName modl | modl <- modls] + pure $ LoadUpTo mods reloadModuleDefer :: GhciMonad m => String -> m () reloadModuleDefer = wrapDeferTypeErrors . reloadModule @@ -4747,8 +4800,11 @@ showException se = Just other_ghc_ex -> putException (show other_ghc_ex) Nothing -> case fromException se of - Just UserInterrupt -> putException "Interrupted." - _ -> putException ("*** Exception: " ++ show se) + Just (GhciCommandError s) -> putException (show (GhciCommandError s)) + Nothing -> + case fromException se of + Just UserInterrupt -> putException "Interrupted." + _ -> putException ("*** Exception: " ++ show se) where putException = hPutStrLn stderr @@ -4798,15 +4854,22 @@ 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.")) + [] -> throwGhciCommandError (GhciModuleError $ GhciModuleNameNotFound modl) [m] -> pure m - ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms)) + ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + +lookupHomeUnitModuleName :: GHC.GhcMonad m => ModuleName -> m HomeUnitModule +lookupHomeUnitModuleName modl = do + m <- GHC.lookupLoadedHomeModuleByModuleName modl >>= \case + Nothing -> throwGhciCommandError (GhciModuleError $ GhciNoLocalModuleName modl) + Just [m] -> pure m + Just ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + + if unitIsDefinite (moduleUnit m) + then pure (fmap toUnitId m) + else throwGhcException (CmdLineError ("module '" ++ str ++ "' is not from a definite unit")) where str = moduleNameString modl - errorMsg ms = intercalate "\n" - [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m) - | m <- ms - ] showModule :: Module -> String showModule = moduleNameString . moduleName ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -5,7 +5,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} module GHCi.UI.Exception - ( GhciMessage(..) + ( GhciCommandError(..) + , throwGhciCommandError + , handleGhciCommandError + , GhciMessage(..) , GhciMessageOpts(..) , fromGhcOpts , toGhcHint @@ -29,19 +32,57 @@ import GHC.Tc.Errors.Ppr import GHC.Tc.Errors.Types import GHC.Types.Error.Codes +import GHC.Types.SrcLoc (interactiveSrcSpan) import GHC.TypeLits import GHC.Unit.State import GHC.Utils.Outputable +import GHC.Utils.Error import GHC.Generics import GHC.Types.Error import GHC.Types import qualified GHC +import Control.Exception +import Control.Monad.Catch as MC (MonadCatch, catch) +import Control.Monad.IO.Class import Data.List.NonEmpty (NonEmpty(..)) +-- | A 'GhciCommandError' are messages that caused the abortion of a GHCi command. +newtype GhciCommandError = GhciCommandError (Messages GhciMessage) + +instance Exception GhciCommandError + +instance Show GhciCommandError where + -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics + -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions. + -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. + show (GhciCommandError msgs) = + renderWithContext defaultSDocContext + . vcat + . pprMsgEnvelopeBagWithLocDefault + . getMessages + $ msgs + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleGhciCommandError :: (MonadCatch m) => + (GhciCommandError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleGhciCommandError handler act = + MC.catch act (\(e :: GhciCommandError) -> handler e) + +throwGhciCommandError :: MonadIO m => GhciCommandMessage -> m a +throwGhciCommandError errorMessage = + liftIO + . throwIO + . GhciCommandError + . singleMessage + $ mkPlainErrorMsgEnvelope interactiveSrcSpan (GhciCommandMessage errorMessage) + -- | The Options passed to 'diagnosticMessage' -- in the 'Diagnostic' instance of 'GhciMessage'. data GhciMessageOpts = GhciMessageOpts @@ -257,6 +298,9 @@ data GhciModuleError | GhciNoResolvedModules | GhciNoModuleForName GHC.Name | GhciNoMatchingModuleExport + | GhciNoLocalModuleName !GHC.ModuleName + | GhciModuleNameNotFound !GHC.ModuleName + | GhciAmbiguousModuleName !GHC.ModuleName ![GHC.Module] deriving Generic instance Diagnostic GhciModuleError where @@ -278,6 +322,16 @@ instance Diagnostic GhciModuleError where -> "No module for" <+> ppr name GhciNoMatchingModuleExport -> "No matching export in any local modules." + GhciNoLocalModuleName modl + -> "Module" <+> quotes (ppr modl) <+> "cannot be found locally" + GhciModuleNameNotFound modl + -> "module" <+> quotes (ppr modl) <+> "could not be found." + GhciAmbiguousModuleName modl candidates + -> "Module name" <+> quotes (ppr modl) <+> "is ambiguous" $+$ + vcat + [ text "-" <+> ppr (GHC.moduleName m) <> colon <> ppr (GHC.moduleUnit m) + | m <- candidates + ] diagnosticReason = \case GhciModuleNotFound{} -> @@ -294,6 +348,12 @@ instance Diagnostic GhciModuleError where ErrorWithoutFlag GhciNoMatchingModuleExport{} -> ErrorWithoutFlag + GhciNoLocalModuleName{} -> + ErrorWithoutFlag + GhciModuleNameNotFound{} -> + ErrorWithoutFlag + GhciAmbiguousModuleName{} -> + ErrorWithoutFlag diagnosticHints = \case GhciModuleNotFound{} -> @@ -310,7 +370,12 @@ instance Diagnostic GhciModuleError where [] GhciNoMatchingModuleExport{} -> [] - + GhciNoLocalModuleName{} -> + [] + GhciModuleNameNotFound{} -> + [] + GhciAmbiguousModuleName{} -> + [] diagnosticCode = constructorCode @GHCi -- | A Diagnostic emitted by GHCi while executing a command @@ -487,6 +552,9 @@ type family GhciDiagnosticCode c = n | n -> c where GhciDiagnosticCode "GhciNoModuleForName" = 21847 GhciDiagnosticCode "GhciNoMatchingModuleExport" = 59723 GhciDiagnosticCode "GhciArgumentParseError" = 35671 + GhciDiagnosticCode "GhciNoLocalModuleName" = 81235 + GhciDiagnosticCode "GhciModuleNameNotFound" = 40475 + GhciDiagnosticCode "GhciAmbiguousModuleName" = 59019 type GhciConRecursInto :: Symbol -> Maybe Type type family GhciConRecursInto con where ===================================== ghc/GHCi/UI/Print.hs ===================================== @@ -5,6 +5,7 @@ module GHCi.UI.Print , printForUserPartWay , printError , printGhciException + , printGhciCommandException ) where import qualified GHC @@ -64,7 +65,7 @@ printForUserPartWay doc = do -- | pretty-print a 'GhciCommandMessage' printError :: GhcMonad m => GhciCommandMessage -> m () printError err = - let errEnvelope = mkPlainErrorMsgEnvelope (UnhelpfulSpan UnhelpfulInteractive) err + let errEnvelope = mkPlainErrorMsgEnvelope interactiveSrcSpan err in printError' (const NoDiagnosticOpts) (singleMessage errEnvelope) -- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting @@ -72,6 +73,9 @@ printError err = printGhciException :: GhcMonad m => SourceError -> m () printGhciException err = printError' initGhciPrintConfig (GhciGhcMessage <$> (srcErrorMessages err)) +printGhciCommandException :: GhcMonad m => GhciCommandError -> m () +printGhciCommandException (GhciCommandError errs) = printError' initGhciPrintConfig errs + printError' :: (GhcMonad m, Diagnostic a) => (DynFlags -> DiagnosticOpts a) -> Messages a -> m () printError' get_config err = do dflags <- getDynFlags ===================================== testsuite/tests/ghc-e/should_fail/T18441fail5.stderr ===================================== @@ -1,4 +1,4 @@ -<no location info>: error: [GHC-82272] - module ‘Abcde’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘Abcde’ cannot be found locally 1 ===================================== testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr ===================================== @@ -1,9 +1,15 @@ -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + ===================================== testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr ===================================== @@ -1,9 +1,14 @@ -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 + +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 + +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 ===================================== testsuite/tests/ghci/prog021/A.hs ===================================== @@ -0,0 +1,5 @@ +module A (f) where + +f x = [x] + +g x = Just x ===================================== testsuite/tests/ghci/prog021/B.hs ===================================== @@ -0,0 +1,5 @@ +module B where + +import A + +h = f ===================================== testsuite/tests/ghci/prog021/Makefile ===================================== @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk ===================================== testsuite/tests/ghci/prog021/prog021.T ===================================== @@ -0,0 +1,6 @@ +test('prog021', + [req_interp, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + extra_files(['A.hs', 'B.hs', 'prog021.script']) + ], + ghci_script, ['prog021.script']) ===================================== testsuite/tests/ghci/prog021/prog021.script ===================================== @@ -0,0 +1,15 @@ +-- Loads all targets +:load A B +:m + A B +f 5 +g 5 +h 5 +-- Load only one target +:reload A +:m A +putStrLn "B is not loaded, we can't add it to the context" +:m + B +f 5 +putStrLn "`g` and `h` are not in scope" +g 5 +h 5 ===================================== testsuite/tests/ghci/prog021/prog021.stderr ===================================== @@ -0,0 +1,10 @@ +<no location info>: error: [GHC-35235] + Could not find module ‘B’. + It is not a module in the current program, or in any known package. + +<interactive>:14:1: error: [GHC-88464] + Variable not in scope: g :: t0 -> t + +<interactive>:15:1: error: [GHC-88464] + Variable not in scope: h :: t0 -> t + ===================================== testsuite/tests/ghci/prog021/prog021.stdout ===================================== @@ -0,0 +1,6 @@ +[5] +Just 5 +[5] +B is not loaded, we can't add it to the context +[5] +`g` and `h` are not in scope ===================================== testsuite/tests/ghci/scripts/ghci021.stderr ===================================== @@ -1,3 +1,3 @@ -<no location info>: error: [GHC-82272] - module ‘ThisDoesNotExist’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘ThisDoesNotExist’ cannot be found locally View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d18f16873f9c0c13ca85951c975300… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d18f16873f9c0c13ca85951c975300… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/fix-reload-targets] Teach `:reload` about multiple home units
by Hannes Siebenhandl (＠fendor) 24 Jun '25

24 Jun '25

Hannes Siebenhandl pushed to branch wip/fendor/fix-reload-targets at Glasgow Haskell Compiler / GHC Commits: 166d218b by fendor at 2025-06-24T13:25:07+02:00 Teach `:reload` about multiple home units `:reload` needs to lookup the `ModuleName` and must not assume the given `ModuleName` is in the current `HomeUnit`. We add a new utility function which allows us to find a `HomeUnitModule` instead of a `Module`. Further, we introduce the `GhciCommandError` type which can be used to abort the execution of a GHCi command. This error is caught and printed in a human readable fashion. - - - - - 15 changed files: - compiler/GHC/Driver/Make.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - ghc/GHCi/UI/Print.hs - testsuite/tests/ghc-e/should_fail/T18441fail5.stderr - testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr - testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr - + testsuite/tests/ghci/prog021/A.hs - + testsuite/tests/ghci/prog021/B.hs - + testsuite/tests/ghci/prog021/Makefile - + testsuite/tests/ghci/prog021/prog021.T - + testsuite/tests/ghci/prog021/prog021.script - + testsuite/tests/ghci/prog021/prog021.stderr - + testsuite/tests/ghci/prog021/prog021.stdout - testsuite/tests/ghci/scripts/ghci021.stderr Changes: ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -116,6 +116,7 @@ import qualified Control.Monad.Catch as MC import Data.IORef import Data.Maybe import Data.List (sortOn, groupBy, sortBy) +import qualified Data.List as List import System.FilePath import Control.Monad.IO.Class @@ -520,13 +521,14 @@ countMods (UnresolvedCycle ns) = length ns createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan] createBuildPlan mod_graph maybe_top_mod = let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles - cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + acyclic_mod_graph = topSortModuleGraph False mod_graph maybe_top_mod -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles. build_plan :: [BuildPlan] build_plan -- Fast path, if there are no boot modules just do a normal toposort - | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod + | isEmptyModuleEnv boot_modules = collapseAcyclic acyclic_mod_graph | otherwise = toBuildPlan cycle_mod_graph [] toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan] @@ -598,14 +600,17 @@ createBuildPlan mod_graph maybe_top_mod = collapseAcyclic [] = [] topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing - - in - - assertPpr (sum (map countMods build_plan) == lengthMG mod_graph) - (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMG mod_graph))]) + -- We need to use 'acyclic_mod_graph', since if 'maybe_top_mod' is 'Just', then the resulting module + -- graph is pruned, reducing the number of 'build_plan' elements. + -- We don't use the size of 'cycle_mod_graph', as it removes @.hi-boot@ modules. These are added + -- later in the processing. + assertPpr (sum (map countMods build_plan) == lengthMGWithSCC acyclic_mod_graph) + (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMGWithSCC acyclic_mod_graph))]) build_plan - + where + lengthMGWithSCC :: [SCC a] -> Int + lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0 -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally ===================================== ghc/GHCi/UI.hs ===================================== @@ -1302,7 +1302,8 @@ runOneCommand eh gCmd = do st <- getGHCiState ghciHandle (\e -> lift $ eh e >>= return . Just) $ handleSourceError printErrorAndFail $ - cmd_wrapper st $ doCommand c + handleGhciCommandError printErrorAndContinue $ + cmd_wrapper st $ doCommand c -- source error's are handled by runStmt -- is the handler necessary here? where @@ -1310,6 +1311,10 @@ runOneCommand eh gCmd = do printGhciException err return $ Just False -- Exit ghc -e, but not GHCi + printErrorAndContinue err = do + printGhciCommandException err + return $ Just False -- Exit ghc -e, but not GHCi + noSpace q = q >>= maybe (return Nothing) (\c -> case removeSpaces c of "" -> noSpace q @@ -2286,13 +2291,16 @@ unAddModule files = do -- | @:reload@ command reloadModule :: GhciMonad m => String -> m () reloadModule m = do - session <- GHC.getSession - let home_unit = homeUnitId (hsc_home_unit session) - ok <- doLoadAndCollectInfo Reload (loadTargets home_unit) + loadTarget <- findLoadTarget + ok <- doLoadAndCollectInfo Reload loadTarget when (failed ok) failIfExprEvalMode where - loadTargets hu | null m = LoadAllTargets - | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m)) + findLoadTarget + | null m = + pure LoadAllTargets + | otherwise = do + mod' <- lookupHomeUnitModuleName (GHC.mkModuleName m) + pure $ LoadUpTo mod' reloadModuleDefer :: GhciMonad m => String -> m () reloadModuleDefer = wrapDeferTypeErrors . reloadModule @@ -4747,8 +4755,11 @@ showException se = Just other_ghc_ex -> putException (show other_ghc_ex) Nothing -> case fromException se of - Just UserInterrupt -> putException "Interrupted." - _ -> putException ("*** Exception: " ++ show se) + Just (GhciCommandError s) -> putException (show (GhciCommandError s)) + Nothing -> + case fromException se of + Just UserInterrupt -> putException "Interrupted." + _ -> putException ("*** Exception: " ++ show se) where putException = hPutStrLn stderr @@ -4798,15 +4809,22 @@ 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.")) + [] -> throwGhciCommandError (GhciModuleError $ GhciModuleNameNotFound modl) [m] -> pure m - ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms)) + ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + +lookupHomeUnitModuleName :: GHC.GhcMonad m => ModuleName -> m HomeUnitModule +lookupHomeUnitModuleName modl = do + m <- GHC.lookupLoadedHomeModuleByModuleName modl >>= \case + Nothing -> throwGhciCommandError (GhciModuleError $ GhciNoLocalModuleName modl) + Just [m] -> pure m + Just ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + + if unitIsDefinite (moduleUnit m) + then pure (fmap toUnitId m) + else throwGhcException (CmdLineError ("module '" ++ str ++ "' is not from a definite unit")) where str = moduleNameString modl - errorMsg ms = intercalate "\n" - [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m) - | m <- ms - ] showModule :: Module -> String showModule = moduleNameString . moduleName ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -5,7 +5,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} module GHCi.UI.Exception - ( GhciMessage(..) + ( GhciCommandError(..) + , throwGhciCommandError + , handleGhciCommandError + , GhciMessage(..) , GhciMessageOpts(..) , fromGhcOpts , toGhcHint @@ -29,19 +32,57 @@ import GHC.Tc.Errors.Ppr import GHC.Tc.Errors.Types import GHC.Types.Error.Codes +import GHC.Types.SrcLoc (interactiveSrcSpan) import GHC.TypeLits import GHC.Unit.State import GHC.Utils.Outputable +import GHC.Utils.Error import GHC.Generics import GHC.Types.Error import GHC.Types import qualified GHC +import Control.Exception +import Control.Monad.Catch as MC (MonadCatch, catch) +import Control.Monad.IO.Class import Data.List.NonEmpty (NonEmpty(..)) +-- | A 'GhciCommandError' are messages that caused the abortion of a GHCi command. +newtype GhciCommandError = GhciCommandError (Messages GhciMessage) + +instance Exception GhciCommandError + +instance Show GhciCommandError where + -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics + -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions. + -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. + show (GhciCommandError msgs) = + renderWithContext defaultSDocContext + . vcat + . pprMsgEnvelopeBagWithLocDefault + . getMessages + $ msgs + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleGhciCommandError :: (MonadCatch m) => + (GhciCommandError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleGhciCommandError handler act = + MC.catch act (\(e :: GhciCommandError) -> handler e) + +throwGhciCommandError :: MonadIO m => GhciCommandMessage -> m a +throwGhciCommandError errorMessage = + liftIO + . throwIO + . GhciCommandError + . singleMessage + $ mkPlainErrorMsgEnvelope interactiveSrcSpan (GhciCommandMessage errorMessage) + -- | The Options passed to 'diagnosticMessage' -- in the 'Diagnostic' instance of 'GhciMessage'. data GhciMessageOpts = GhciMessageOpts @@ -257,6 +298,9 @@ data GhciModuleError | GhciNoResolvedModules | GhciNoModuleForName GHC.Name | GhciNoMatchingModuleExport + | GhciNoLocalModuleName !GHC.ModuleName + | GhciModuleNameNotFound !GHC.ModuleName + | GhciAmbiguousModuleName !GHC.ModuleName ![GHC.Module] deriving Generic instance Diagnostic GhciModuleError where @@ -278,6 +322,16 @@ instance Diagnostic GhciModuleError where -> "No module for" <+> ppr name GhciNoMatchingModuleExport -> "No matching export in any local modules." + GhciNoLocalModuleName modl + -> "Module" <+> quotes (ppr modl) <+> "cannot be found locally" + GhciModuleNameNotFound modl + -> "module" <+> quotes (ppr modl) <+> "could not be found." + GhciAmbiguousModuleName modl candidates + -> "Module name" <+> quotes (ppr modl) <+> "is ambiguous" $+$ + vcat + [ text "-" <+> ppr (GHC.moduleName m) <> colon <> ppr (GHC.moduleUnit m) + | m <- candidates + ] diagnosticReason = \case GhciModuleNotFound{} -> @@ -294,6 +348,12 @@ instance Diagnostic GhciModuleError where ErrorWithoutFlag GhciNoMatchingModuleExport{} -> ErrorWithoutFlag + GhciNoLocalModuleName{} -> + ErrorWithoutFlag + GhciModuleNameNotFound{} -> + ErrorWithoutFlag + GhciAmbiguousModuleName{} -> + ErrorWithoutFlag diagnosticHints = \case GhciModuleNotFound{} -> @@ -310,7 +370,12 @@ instance Diagnostic GhciModuleError where [] GhciNoMatchingModuleExport{} -> [] - + GhciNoLocalModuleName{} -> + [] + GhciModuleNameNotFound{} -> + [] + GhciAmbiguousModuleName{} -> + [] diagnosticCode = constructorCode @GHCi -- | A Diagnostic emitted by GHCi while executing a command @@ -487,6 +552,9 @@ type family GhciDiagnosticCode c = n | n -> c where GhciDiagnosticCode "GhciNoModuleForName" = 21847 GhciDiagnosticCode "GhciNoMatchingModuleExport" = 59723 GhciDiagnosticCode "GhciArgumentParseError" = 35671 + GhciDiagnosticCode "GhciNoLocalModuleName" = 81235 + GhciDiagnosticCode "GhciModuleNameNotFound" = 40475 + GhciDiagnosticCode "GhciAmbiguousModuleName" = 59019 type GhciConRecursInto :: Symbol -> Maybe Type type family GhciConRecursInto con where ===================================== ghc/GHCi/UI/Print.hs ===================================== @@ -5,6 +5,7 @@ module GHCi.UI.Print , printForUserPartWay , printError , printGhciException + , printGhciCommandException ) where import qualified GHC @@ -64,7 +65,7 @@ printForUserPartWay doc = do -- | pretty-print a 'GhciCommandMessage' printError :: GhcMonad m => GhciCommandMessage -> m () printError err = - let errEnvelope = mkPlainErrorMsgEnvelope (UnhelpfulSpan UnhelpfulInteractive) err + let errEnvelope = mkPlainErrorMsgEnvelope interactiveSrcSpan err in printError' (const NoDiagnosticOpts) (singleMessage errEnvelope) -- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting @@ -72,6 +73,9 @@ printError err = printGhciException :: GhcMonad m => SourceError -> m () printGhciException err = printError' initGhciPrintConfig (GhciGhcMessage <$> (srcErrorMessages err)) +printGhciCommandException :: GhcMonad m => GhciCommandError -> m () +printGhciCommandException (GhciCommandError errs) = printError' initGhciPrintConfig errs + printError' :: (GhcMonad m, Diagnostic a) => (DynFlags -> DiagnosticOpts a) -> Messages a -> m () printError' get_config err = do dflags <- getDynFlags ===================================== testsuite/tests/ghc-e/should_fail/T18441fail5.stderr ===================================== @@ -1,4 +1,4 @@ -<no location info>: error: [GHC-82272] - module ‘Abcde’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘Abcde’ cannot be found locally 1 ===================================== testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr ===================================== @@ -1,9 +1,15 @@ -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + ===================================== testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr ===================================== @@ -1,9 +1,14 @@ -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 + +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 + +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 ===================================== testsuite/tests/ghci/prog021/A.hs ===================================== @@ -0,0 +1,5 @@ +module A (f) where + +f x = [x] + +g x = Just x ===================================== testsuite/tests/ghci/prog021/B.hs ===================================== @@ -0,0 +1,5 @@ +module B where + +import A + +h = f ===================================== testsuite/tests/ghci/prog021/Makefile ===================================== @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk ===================================== testsuite/tests/ghci/prog021/prog021.T ===================================== @@ -0,0 +1,6 @@ +test('prog021', + [req_interp, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + extra_files(['A.hs', 'B.hs', 'prog021.script']) + ], + ghci_script, ['prog021.script']) ===================================== testsuite/tests/ghci/prog021/prog021.script ===================================== @@ -0,0 +1,15 @@ +-- Loads all targets +:load A B +:m + A B +f 5 +g 5 +h 5 +-- Load only one target +:reload A +:m A +putStrLn "B is not loaded, we can't add it to the context" +:m + B +f 5 +putStrLn "`g` and `h` are not in scope" +g 5 +h 5 ===================================== testsuite/tests/ghci/prog021/prog021.stderr ===================================== @@ -0,0 +1,10 @@ +<no location info>: error: [GHC-35235] + Could not find module ‘B’. + It is not a module in the current program, or in any known package. + +<interactive>:14:1: error: [GHC-88464] + Variable not in scope: g :: t0 -> t + +<interactive>:15:1: error: [GHC-88464] + Variable not in scope: h :: t0 -> t + ===================================== testsuite/tests/ghci/prog021/prog021.stdout ===================================== @@ -0,0 +1,6 @@ +[5] +Just 5 +[5] +B is not loaded, we can't add it to the context +[5] +`g` and `h` are not in scope ===================================== testsuite/tests/ghci/scripts/ghci021.stderr ===================================== @@ -1,3 +1,3 @@ -<no location info>: error: [GHC-82272] - module ‘ThisDoesNotExist’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘ThisDoesNotExist’ cannot be found locally View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/166d218bb79c1979d484c2e09073df5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/166d218bb79c1979d484c2e09073df5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26135] compiler: Export a version of `newNameCache` that is not prone to footguns.
by Zubin (＠wz1000) 24 Jun '25

24 Jun '25

Zubin pushed to branch wip/26135 at Glasgow Haskell Compiler / GHC Commits: 6997abfc by Zubin Duggal at 2025-06-24T16:32:03+05:30 compiler: Export a version of `newNameCache` that is not prone to footguns. `newNameCache` must be initialized with both a non-"reserved" unique tag, as well as a list of known key names. Failing to do so results in hard to debug unique conflicts. It is difficult for API users to tell which unique tags are safe to use. So instead of leaving this up to the user to decide, we now export a version of `newNameCache` which uses a guaranteed non-reserved unique tag. In fact, this is now the way the unique tag is initialized for all invocations of the compiler. The original version of `newNameCache` is now exported as `newNameCache'` for advanced users. We also deprecate `initNameCache` as it is also prone to footguns and is completely subsumed in functionality by `newNameCache` and `newNameCache'`. Fixes #26135 and #26055 - - - - - 3 changed files: - compiler/GHC/Driver/Main.hs - compiler/GHC/Types/Name/Cache.hs - testsuite/tests/hiefile/should_run/TestUtils.hs Changes: ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -245,7 +245,7 @@ import GHC.Types.IPE import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Name -import GHC.Types.Name.Cache ( newNameCache, knownKeysOrigNameCache ) +import GHC.Types.Name.Cache ( newNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr import GHC.Types.TyThing @@ -322,7 +322,7 @@ newHscEnv top_dir dflags = do newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do - nc_var <- newNameCache 'r' knownKeysOrigNameCache + nc_var <- newNameCache fc_var <- initFinderCache logger <- initLogger tmpfs <- initTmpFs ===================================== compiler/GHC/Types/Name/Cache.hs ===================================== @@ -4,6 +4,7 @@ module GHC.Types.Name.Cache ( NameCache (..) , newNameCache + , newNameCache' , initNameCache , takeUniqFromNameCache , updateNameCache' @@ -140,11 +141,27 @@ extendOrigNameCache nc mod occ name where combine _ occ_env = extendOccEnv occ_env occ name -newNameCache :: Char -> OrigNameCache -> IO NameCache -newNameCache c nc = NameCache c <$> newMVar nc +-- | Initialize a new name cache +newNameCache :: IO NameCache +newNameCache = newNameCache' 'r' knownKeysOrigNameCache +-- | This is a version of `newNameCache` that lets you supply your +-- own unique tag and set of known key names. This can go wrong if the tag +-- supplied is one reserved by GHC for internal purposes. See #26055 for +-- an example. +-- +-- Use `newNameCache` when possible. +newNameCache' :: Char -> OrigNameCache -> IO NameCache +newNameCache' c nc = NameCache c <$> newMVar nc + +-- | This takes a tag for uniques to be generated and the list of knownKeyNames +-- These must be initialized properly to ensure that names generated from this +-- NameCache do not conflict with known key names. +-- +-- Use `newNameCache` or `newNameCache'` instead +{-# DEPRECATED initNameCache "Use newNameCache or newNameCache' instead" #-} initNameCache :: Char -> [Name] -> IO NameCache -initNameCache c names = newNameCache c (initOrigNames names) +initNameCache c names = newNameCache' c (initOrigNames names) initOrigNames :: [Name] -> OrigNameCache initOrigNames names = foldl' extendOrigNameCache' emptyModuleEnv names ===================================== testsuite/tests/hiefile/should_run/TestUtils.hs ===================================== @@ -25,9 +25,6 @@ import GHC.Iface.Ext.Utils import GHC.Driver.Session import GHC.SysTools -makeNc :: IO NameCache -makeNc = initNameCache 'z' [] - dynFlagsForPrinting :: String -> IO DynFlags dynFlagsForPrinting libdir = do systemSettings <- initSysTools libdir @@ -37,7 +34,7 @@ readTestHie :: FilePath -> IO (DynFlags, HieFile) readTestHie fp = do libdir:_ <- getArgs df <- dynFlagsForPrinting libdir - nc <- makeNc + nc <- newNameCache hfr <- readHieFile nc fp pure (df, hie_file_result hfr) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6997abfc3ef8622eeee8d69696746bf… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6997abfc3ef8622eeee8d69696746bf… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/26114
by Zubin (＠wz1000) 24 Jun '25

24 Jun '25

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

1 0

[Git][ghc/ghc] Pushed new branch wip/26135
by Zubin (＠wz1000) 24 Jun '25

24 Jun '25

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

1 0

[Git][ghc/ghc][master] 2 commits: rts/linker/LoadArchive: Use bool
by Marge Bot (＠marge-bot) 24 Jun '25

24 Jun '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 580a3353 by Ben Gamari at 2025-06-24T05:02:51-04:00 rts/linker/LoadArchive: Use bool Improve type precision by using `bool` instead of `int` and `StgBool`. - - - - - 76d1041d by Ben Gamari at 2025-06-24T05:02:51-04:00 rts/linker/LoadArchive: Don't rely on file extensions for identification Previously archive members would be identified via their file extension, as described in #13103. We now instead use a more principled approach, relying on the magic number in the member's header. As well, we refactor treatment of archive format detection to improve code clarity and error handling. Closes #13103. - - - - - 1 changed file: - rts/linker/LoadArchive.c Changes: ===================================== rts/linker/LoadArchive.c ===================================== @@ -33,6 +33,7 @@ #define DEBUG_LOG(...) IF_DEBUG(linker, debugBelch("loadArchive: " __VA_ARGS__)) + #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) /* Read 4 bytes and convert to host byte order */ static uint32_t read4Bytes(const char buf[static 4]) @@ -40,7 +41,7 @@ static uint32_t read4Bytes(const char buf[static 4]) return ntohl(*(uint32_t*)buf); } -static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) +static bool loadFatArchive(char input[static 20], FILE* f, pathchar* path) { uint32_t nfat_arch, nfat_offset, cputype, cpusubtype; #if defined(i386_HOST_ARCH) @@ -58,8 +59,9 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) #error Unknown Darwin architecture #endif - nfat_arch = read4Bytes(tmp + 4); + nfat_arch = read4Bytes(input + 4); DEBUG_LOG("found a fat archive containing %d architectures\n", nfat_arch); + char tmp[20]; nfat_offset = 0; for (uint32_t i = 0; i < nfat_arch; i++) { /* search for the right arch */ @@ -90,6 +92,7 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) } /* Read the header */ + char tmp[20]; n = fread(tmp, 1, 8, f); if (n != 8) { errorBelch("Failed reading header from `%" PATH_FMT "'", path); @@ -107,10 +110,51 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) } #endif -static StgBool readThinArchiveMember(int n, int memberSize, pathchar* path, +enum ObjectFileFormat { + NotObject, + COFFAmd64, + COFFI386, + COFFAArch64, + ELF, + MachO32, + MachO64, +}; + +static enum ObjectFileFormat identifyObjectFile_(char* buf, size_t sz) +{ + if (sz > 2 && ((uint16_t*)buf)[0] == 0x8664) { + return COFFAmd64; + } + if (sz > 2 && ((uint16_t*)buf)[0] == 0x014c) { + return COFFI386; + } + if (sz > 2 && ((uint16_t*)buf)[0] == 0xaa64) { + return COFFAArch64; + } + if (sz > 4 && memcmp(buf, "\x7f" "ELF", 4) == 0) { + return ELF; + } + if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedface) { + return MachO32; + } + if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedfacf) { + return MachO64; + } + return NotObject; +} + +static enum ObjectFileFormat identifyObjectFile(FILE *f) +{ + char buf[32]; + ssize_t sz = fread(buf, 1, 32, f); + CHECK(fseek(f, -sz, SEEK_CUR) == 0); + return identifyObjectFile_(buf, sz); +} + +static bool readThinArchiveMember(int n, int memberSize, pathchar* path, char* fileName, char* image) { - StgBool has_succeeded = false; + bool has_succeeded = false; FILE* member = NULL; pathchar *pathCopy, *dirName, *memberPath, *objFileName; memberPath = NULL; @@ -148,10 +192,9 @@ inner_fail: return has_succeeded; } -static StgBool checkFatArchive(char magic[static 20], FILE* f, pathchar* path) +static bool checkFatArchive(char magic[static 4], FILE* f, pathchar* path) { - StgBool success; - success = false; + bool success = false; #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) /* Not a standard archive, look for a fat archive magic number: */ if (read4Bytes(magic) == FAT_MAGIC) @@ -175,7 +218,7 @@ static StgBool checkFatArchive(char magic[static 20], FILE* f, pathchar* path) * be reallocated on return; the old value is now _invalid_. * @param gnuFileIndexSize The size of the index. */ -static StgBool +static bool lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, char* gnuFileIndex, pathchar* path, size_t* thisFileNameSize, size_t* fileNameSize) @@ -241,47 +284,21 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, return true; } -HsInt loadArchive_ (pathchar *path) -{ - char *image = NULL; - HsInt retcode = 0; - int memberSize; - int memberIdx = 0; - FILE *f = NULL; - int n; - size_t thisFileNameSize = (size_t)-1; /* shut up bogus GCC warning */ - char *fileName; - size_t fileNameSize; - int isObject, isGnuIndex, isThin, isImportLib; - char tmp[20]; - char *gnuFileIndex; - int gnuFileIndexSize; - int misalignment = 0; - - DEBUG_LOG("start\n"); - DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); +enum ArchiveFormat { + StandardArchive, + ThinArchive, + FatArchive, +}; - /* Check that we haven't already loaded this archive. - Ignore requests to load multiple times */ - if (isAlreadyLoaded(path)) { - IF_DEBUG(linker, - debugBelch("ignoring repeated load of %" PATH_FMT "\n", path)); - return 1; /* success */ +static bool identifyArchiveFormat(FILE *f, pathchar *path, enum ArchiveFormat *out) +{ + char tmp[8]; + size_t n = fread(tmp, 1, 8, f); + if (n != 8) { + errorBelch("loadArchive: Failed reading header from `%" PATH_FMT "'", path); \ + return false; } - gnuFileIndex = NULL; - gnuFileIndexSize = 0; - - fileNameSize = 32; - fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)"); - - isThin = 0; - isImportLib = 0; - - f = pathopen(path, WSTR("rb")); - if (!f) - FAIL("loadObj: can't read `%" PATH_FMT "'", path); - /* Check if this is an archive by looking for the magic "!<arch>\n" * string. Usually, if this fails, we belch an error and return. On * Darwin however, we may have a fat archive, which contains archives for @@ -300,12 +317,10 @@ HsInt loadArchive_ (pathchar *path) * its magic "!<arch>\n" string and continue processing just as if * we had a single architecture archive. */ - - n = fread ( tmp, 1, 8, f ); - if (n != 8) { - FAIL("Failed reading header from `%" PATH_FMT "'", path); + if (strncmp(tmp, "!<arch>\n", 8) == 0) { + *out = StandardArchive; + return true; } - if (strncmp(tmp, "!<arch>\n", 8) == 0) {} /* Check if this is a thin archive by looking for the magic string "!<thin>\n" * * ar thin libraries have the exact same format as normal archives except they @@ -322,16 +337,59 @@ HsInt loadArchive_ (pathchar *path) * */ else if (strncmp(tmp, "!<thin>\n", 8) == 0) { - isThin = 1; + *out = ThinArchive; + return true; } else { - StgBool success = checkFatArchive(tmp, f, path); - if (!success) - goto fail; + bool success = checkFatArchive(tmp, f, path); + if (!success) { + return false; + } + *out = FatArchive; + return true; } +} + +HsInt loadArchive_ (pathchar *path) +{ + char *image = NULL; + HsInt retcode = 0; + int memberIdx = 0; + FILE *f = NULL; + size_t thisFileNameSize = (size_t) -1; /* shut up bogus GCC warning */ + int misalignment = 0; + + DEBUG_LOG("start\n"); + DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); + + /* Check that we haven't already loaded this archive. + Ignore requests to load multiple times */ + if (isAlreadyLoaded(path)) { + IF_DEBUG(linker, + debugBelch("ignoring repeated load of %" PATH_FMT "\n", path)); + return 1; /* success */ + } + + char *gnuFileIndex = NULL; + int gnuFileIndexSize = 0; + + size_t fileNameSize = 32; + char *fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)"); + + f = pathopen(path, WSTR("rb")); + if (!f) + FAIL("loadObj: can't read `%" PATH_FMT "'", path); + + enum ArchiveFormat archive_fmt; + if (!identifyArchiveFormat(f, path, &archive_fmt)) { + FAIL("failed to identify archive format of %" PATH_FMT ".", path); + } + bool isThin = archive_fmt == ThinArchive; + DEBUG_LOG("loading archive contents\n"); while (1) { + size_t n; DEBUG_LOG("reading at %ld\n", ftell(f)); n = fread ( fileName, 1, 16, f ); if (n != 16) { @@ -351,6 +409,7 @@ HsInt loadArchive_ (pathchar *path) } #endif + char tmp[32]; n = fread ( tmp, 1, 12, f ); if (n != 12) FAIL("Failed reading mod time from `%" PATH_FMT "'", path); @@ -369,9 +428,16 @@ HsInt loadArchive_ (pathchar *path) tmp[10] = '\0'; for (n = 0; isdigit(tmp[n]); n++); tmp[n] = '\0'; - memberSize = atoi(tmp); + size_t memberSize; + { + char *end; + memberSize = strtol(tmp, &end, 10); + if (tmp == end) { + FAIL("Failed to decode member size"); + } + } - DEBUG_LOG("size of this archive member is %d\n", memberSize); + DEBUG_LOG("size of this archive member is %zd\n", memberSize); n = fread ( tmp, 1, 2, f ); if (n != 2) FAIL("Failed reading magic from `%" PATH_FMT "'", path); @@ -379,7 +445,7 @@ HsInt loadArchive_ (pathchar *path) FAIL("Failed reading magic from `%" PATH_FMT "' at %ld. Got %c%c", path, ftell(f), tmp[0], tmp[1]); - isGnuIndex = 0; + bool isGnuIndex = false; /* Check for BSD-variant large filenames */ if (0 == strncmp(fileName, "#1/", 3)) { size_t n = 0; @@ -419,7 +485,7 @@ HsInt loadArchive_ (pathchar *path) else if (0 == strncmp(fileName, "//", 2)) { fileName[0] = '\0'; thisFileNameSize = 0; - isGnuIndex = 1; + isGnuIndex = true; } /* Check for a file in the GNU file index */ else if (fileName[0] == '/') { @@ -460,12 +526,8 @@ HsInt loadArchive_ (pathchar *path) DEBUG_LOG("Found member file `%s'\n", fileName); - /* TODO: Stop relying on file extensions to determine input formats. - Instead try to match file headers. See #13103. */ - isObject = (thisFileNameSize >= 2 && strncmp(fileName + thisFileNameSize - 2, ".o" , 2) == 0) - || (thisFileNameSize >= 3 && strncmp(fileName + thisFileNameSize - 3, ".lo" , 3) == 0) - || (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".p_o", 4) == 0) - || (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".obj", 4) == 0); + bool is_symbol_table = strcmp("", fileName) == 0; + enum ObjectFileFormat object_fmt = is_symbol_table ? NotObject : identifyObjectFile(f); #if defined(OBJFORMAT_PEi386) /* @@ -479,15 +541,15 @@ HsInt loadArchive_ (pathchar *path) * * Linker members (e.g. filename / are skipped since they are not needed) */ - isImportLib = thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".dll", 4) == 0; + bool isImportLib = thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".dll", 4) == 0; +#else + bool isImportLib = false; #endif // windows DEBUG_LOG("\tthisFileNameSize = %d\n", (int)thisFileNameSize); - DEBUG_LOG("\tisObject = %d\n", isObject); - - if (isObject) { - pathchar *archiveMemberName; + DEBUG_LOG("\tisObject = %d\n", object_fmt); + if ((!is_symbol_table && isThin) || object_fmt != NotObject) { DEBUG_LOG("Member is an object file...loading...\n"); #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) @@ -505,14 +567,13 @@ HsInt loadArchive_ (pathchar *path) image = stgMallocBytes(memberSize, "loadArchive(image)"); #endif if (isThin) { - if (!readThinArchiveMember(n, memberSize, path, - fileName, image)) { + if (!readThinArchiveMember(n, memberSize, path, fileName, image)) { goto fail; } } else { - n = fread ( image, 1, memberSize, f ); + size_t n = fread ( image, 1, memberSize, f ); if (n != memberSize) { FAIL("error whilst reading `%" PATH_FMT "'", path); } @@ -523,16 +584,18 @@ HsInt loadArchive_ (pathchar *path) // I don't understand why this extra +1 is needed here; pathprintf // should have given us the correct length but in practice it seems // to be one byte short on Win32. - archiveMemberName = stgMallocBytes((size+1+1) * sizeof(pathchar), "loadArchive(file)"); + pathchar *archiveMemberName = stgMallocBytes((size+1+1) * sizeof(pathchar), "loadArchive(file)"); pathprintf(archiveMemberName, size+1, WSTR("%" PATH_FMT "(#%d:%.*s)"), path, memberIdx, (int)thisFileNameSize, fileName); ObjectCode *oc = mkOc(STATIC_OBJECT, path, image, memberSize, false, archiveMemberName, misalignment); #if defined(OBJFORMAT_MACHO) + ASSERT(object_fmt == MachO32 || object_fmt == MachO64); ocInit_MachO( oc ); #endif #if defined(OBJFORMAT_ELF) + ASSERT(object_fmt == ELF); ocInit_ELF( oc ); #endif @@ -577,7 +640,7 @@ while reading filename from `%" PATH_FMT "'", path); "Skipping...\n"); n = fseek(f, memberSize, SEEK_CUR); if (n != 0) - FAIL("error whilst seeking by %d in `%" PATH_FMT "'", + FAIL("error whilst seeking by %zd in `%" PATH_FMT "'", memberSize, path); } #endif @@ -588,7 +651,7 @@ while reading filename from `%" PATH_FMT "'", path); if (!isThin || thisFileNameSize == 0) { n = fseek(f, memberSize, SEEK_CUR); if (n != 0) - FAIL("error whilst seeking by %d in `%" PATH_FMT "'", + FAIL("error whilst seeking by %zd in `%" PATH_FMT "'", memberSize, path); } } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dcf68a83980e760d95c0cb335fe774… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dcf68a83980e760d95c0cb335fe774… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 5 commits: configure: Don't force value of OTOOL, etc. if not present
by Marge Bot (＠marge-bot) 24 Jun '25

24 Jun '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 83ee7b78 by Ben Gamari at 2025-06-24T05:02:07-04:00 configure: Don't force value of OTOOL, etc. if not present Previously if `otool` and `install_name_tool` were not present they would be overridden by `fp_settings.m4`. This logic was introduced in 4ff93292243888545da452ea4d4c1987f2343591 without explanation. - - - - - 9329c9e1 by Ben Gamari at 2025-06-24T05:02:07-04:00 ghc-toolchain: Add support for otool, install_name_tool Fixes part of ghc#23675. - - - - - 25f5c998 by Ben Gamari at 2025-06-24T05:02:08-04:00 ghc-toolchain: Add support for llc, opt, llvm-as Fixes #23675. - - - - - 51d150dd by Rodrigo Mesquita at 2025-06-24T05:02:08-04:00 hadrian: Use settings-use-distro-mingw directly The type `ToolchainSetting` only made sense when we had more settings to fetch from the system config file. Even then "settings-use-distro-mingw" is arguably not a toolchain setting. With the fix for #23675, all toolchain tools were moved to the `ghc-toolchain` `Toolchain` format. Therefore, we can inline `settings-use-distro-mingw` accesses and delete `ToolchainSetting`. - - - - - dcf68a83 by Rodrigo Mesquita at 2025-06-24T05:02:08-04:00 configure: Check LlvmTarget exists for LlvmAsFlags If LlvmTarget was empty, LlvmAsFlags would be just "--target=". If it is empty now, simply keep LlvmAsFlags empty. ghc-toolchain already does this right. This fix makes the two configurations match up. - - - - - 13 changed files: - distrib/configure.ac.in - hadrian/cfg/default.host.target.in - hadrian/cfg/default.target.in - hadrian/cfg/system.config.in - hadrian/src/Builder.hs - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs - m4/fp_settings.m4 - m4/ghc_toolchain.m4 - m4/prep_target_file.m4 - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs Changes: ===================================== distrib/configure.ac.in ===================================== @@ -216,7 +216,7 @@ AC_SUBST([LlvmAsCmd]) dnl We know that `clang` supports `--target` and it is necessary to pass it dnl lest we see #25793. -if test -z "$LlvmAsFlags" ; then +if test -z "$LlvmAsFlags" && ! test -z "$LlvmTarget"; then LlvmAsFlags="--target=$LlvmTarget" fi AC_SUBST([LlvmAsFlags]) ===================================== hadrian/cfg/default.host.target.in ===================================== @@ -38,5 +38,10 @@ Target , tgtRanlib = Nothing , tgtNm = Nm {nmProgram = Program {prgPath = "", prgFlags = []}} , tgtMergeObjs = Just (MergeObjs {mergeObjsProgram = Program {prgPath = "@LD_STAGE0@", prgFlags = ["-r"]}, mergeObjsSupportsResponseFiles = False}) +, tgtLlc = Nothing +, tgtOpt = Nothing +, tgtLlvmAs = Nothing , tgtWindres = Nothing +, tgtOtool = Nothing +, tgtInstallNameTool = Nothing } ===================================== hadrian/cfg/default.target.in ===================================== @@ -38,5 +38,10 @@ Target , tgtRanlib = Just (Ranlib {ranlibProgram = Program {prgPath = "@RanlibCmd@", prgFlags = []}}) , tgtNm = Nm {nmProgram = Program {prgPath = "@NmCmd@", prgFlags = []}} , tgtMergeObjs = @MergeObjsCmdMaybe@ +, tgtLlc = @LlcCmdMaybeProg@ +, tgtOpt = @OptCmdMaybeProg@ +, tgtLlvmAs = @LlvmAsCmdMaybeProg@ , tgtWindres = @WindresCmdMaybeProg@ +, tgtOtool = @OtoolCmdMaybeProg@ +, tgtInstallNameTool = @InstallNameToolCmdMaybeProg@ } ===================================== hadrian/cfg/system.config.in ===================================== @@ -79,13 +79,6 @@ project-git-commit-id = @ProjectGitCommitId@ # generated by configure, to generated being by the build system. Many of these # might become redundant. # See Note [tooldir: How GHC finds mingw on Windows] - -settings-otool-command = @SettingsOtoolCommand@ -settings-install_name_tool-command = @SettingsInstallNameToolCommand@ -settings-llc-command = @SettingsLlcCommand@ -settings-opt-command = @SettingsOptCommand@ -settings-llvm-as-command = @SettingsLlvmAsCommand@ -settings-llvm-as-flags = @SettingsLlvmAsFlags@ settings-use-distro-mingw = @SettingsUseDistroMINGW@ target-has-libm = @TargetHasLibm@ ===================================== hadrian/src/Builder.hs ===================================== @@ -34,7 +34,6 @@ import Base import Context import Oracles.Flag import Oracles.Setting (setting, Setting(..)) -import Oracles.Setting (settingsFileSetting, ToolchainSetting(..)) import Packages import GHC.IO.Encoding (getFileSystemEncoding) @@ -240,7 +239,7 @@ instance H.Builder Builder where Ghc _ st -> do root <- buildRoot unlitPath <- builderPath Unlit - distro_mingw <- settingsFileSetting ToolchainSetting_DistroMinGW + distro_mingw <- lookupSystemConfig "settings-use-distro-mingw" libffi_adjustors <- useLibffiForAdjustors use_system_ffi <- flag UseSystemFfi ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -2,7 +2,6 @@ module Oracles.Setting ( configFile, -- * Settings Setting (..), setting, getSetting, - ToolchainSetting (..), settingsFileSetting, -- * Helpers ghcCanonVersion, cmdLineLengthLimit, targetSupportsRPaths, topDirectory, @@ -75,25 +74,6 @@ data Setting = CursesIncludeDir | BourneShell | EmsdkVersion --- TODO compute solely in Hadrian, removing these variables' definitions --- from aclocal.m4 whenever they can be calculated from other variables --- already fed into Hadrian. - --- | All 'ToolchainSetting's are computed by the ghc-toolchain utility for configuring toolchains. --- This used to be defined by 'FP_SETTINGS' in aclocal.m4. --- --- TODO: We should be able to drop this completely, after moving all the toolchain settings to ghc-toolchain --- Move to ghc-toolchain and to the Target files generated by configure and ghc-toolchain --- * First we will get rid of DistroMinGW when we fix the windows build -data ToolchainSetting - = ToolchainSetting_OtoolCommand - | ToolchainSetting_InstallNameToolCommand - | ToolchainSetting_LlcCommand - | ToolchainSetting_OptCommand - | ToolchainSetting_LlvmAsCommand - | ToolchainSetting_LlvmAsFlags - | ToolchainSetting_DistroMinGW - -- | Look up the value of a 'Setting' in @cfg/system.config@, tracking the -- result. setting :: Setting -> Action String @@ -134,20 +114,6 @@ setting key = lookupSystemConfig $ case key of BourneShell -> "bourne-shell" EmsdkVersion -> "emsdk-version" --- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the --- result. --- See Note [tooldir: How GHC finds mingw on Windows] --- ROMES:TODO: This should be queryTargetTargetConfig -settingsFileSetting :: ToolchainSetting -> Action String -settingsFileSetting key = lookupSystemConfig $ case key of - ToolchainSetting_OtoolCommand -> "settings-otool-command" - ToolchainSetting_InstallNameToolCommand -> "settings-install_name_tool-command" - ToolchainSetting_LlcCommand -> "settings-llc-command" - ToolchainSetting_OptCommand -> "settings-opt-command" - ToolchainSetting_LlvmAsCommand -> "settings-llvm-as-command" - ToolchainSetting_LlvmAsFlags -> "settings-llvm-as-flags" - ToolchainSetting_DistroMinGW -> "settings-use-distro-mingw" -- ROMES:TODO: This option doesn't seem to be in ghc-toolchain yet. It corresponds to EnableDistroToolchain - -- | An expression that looks up the value of a 'Setting' in @cfg/system.config@, -- tracking the result. getSetting :: Setting -> Expr c b String ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -424,7 +424,7 @@ bindistRules = do , interpolateSetting "LlvmMinVersion" LlvmMinVersion , interpolateVar "LlvmTarget" $ getTarget tgtLlvmTarget , interpolateSetting "ProjectVersion" ProjectVersion - , interpolateVar "SettingsUseDistroMINGW" $ settingsFileSetting ToolchainSetting_DistroMinGW + , interpolateVar "SettingsUseDistroMINGW" $ lookupSystemConfig "settings-use-distro-mingw" , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode , interpolateVar "TargetHasLibm" $ lookupSystemConfig "target-has-libm" , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple @@ -508,9 +508,9 @@ generateSettings settingsFile = do , ("ar flags", queryTarget arFlags) , ("ar supports at file", queryTarget arSupportsAtFile') , ("ar supports -L", queryTarget arSupportsDashL') - , ("ranlib command", queryTarget ranlibPath) - , ("otool command", expr $ settingsFileSetting ToolchainSetting_OtoolCommand) - , ("install_name_tool command", expr $ settingsFileSetting ToolchainSetting_InstallNameToolCommand) + , ("ranlib command", queryTarget ranlibPath) + , ("otool command", queryTarget otoolPath) + , ("install_name_tool command", queryTarget installNameToolPath) , ("windres command", queryTarget (maybe "/bin/false" prgPath . tgtWindres)) -- TODO: /bin/false is not available on many distributions by default, but we keep it as it were before the ghc-toolchain patch. Fix-me. , ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) , ("cross compiling", expr $ yesNo <$> flag CrossCompiling) @@ -525,11 +525,11 @@ generateSettings settingsFile = do , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", queryTarget (yesNo . tgtUnregisterised)) , ("LLVM target", queryTarget tgtLlvmTarget) - , ("LLVM llc command", expr $ settingsFileSetting ToolchainSetting_LlcCommand) - , ("LLVM opt command", expr $ settingsFileSetting ToolchainSetting_OptCommand) - , ("LLVM llvm-as command", expr $ settingsFileSetting ToolchainSetting_LlvmAsCommand) - , ("LLVM llvm-as flags", expr $ settingsFileSetting ToolchainSetting_LlvmAsFlags) - , ("Use inplace MinGW toolchain", expr $ settingsFileSetting ToolchainSetting_DistroMinGW) + , ("LLVM llc command", queryTarget llcPath) + , ("LLVM opt command", queryTarget optPath) + , ("LLVM llvm-as command", queryTarget llvmAsPath) + , ("LLVM llvm-as flags", queryTarget llvmAsFlags) + , ("Use inplace MinGW toolchain", expr $ lookupSystemConfig "settings-use-distro-mingw") , ("target RTS linker only supports shared libraries", expr $ yesNo <$> targetRTSLinkerOnlySupportsSharedLibs) , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) @@ -571,10 +571,16 @@ generateSettings settingsFile = do linkSupportsFilelist = yesNo . ccLinkSupportsFilelist . tgtCCompilerLink linkSupportsCompactUnwind = yesNo . ccLinkSupportsCompactUnwind . tgtCCompilerLink linkIsGnu = yesNo . ccLinkIsGnu . tgtCCompilerLink + llcPath = maybe "" prgPath . tgtLlc + optPath = maybe "" prgPath . tgtOpt + llvmAsPath = maybe "" prgPath . tgtLlvmAs + llvmAsFlags = escapeArgs . maybe [] prgFlags . tgtLlvmAs arPath = prgPath . arMkArchive . tgtAr arFlags = escapeArgs . prgFlags . arMkArchive . tgtAr arSupportsAtFile' = yesNo . arSupportsAtFile . tgtAr arSupportsDashL' = yesNo . arSupportsDashL . tgtAr + otoolPath = maybe "" prgPath . tgtOtool + installNameToolPath = maybe "" prgPath . tgtInstallNameTool ranlibPath = maybe "" (prgPath . ranlibProgram) . tgtRanlib mergeObjsSupportsResponseFiles' = maybe "NO" (yesNo . mergeObjsSupportsResponseFiles) . tgtMergeObjs ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -127,9 +127,9 @@ inTreeCompilerArgs stg = do platform <- queryTargetTarget targetPlatformTriple wordsize <- show @Int . (*8) <$> queryTargetTarget (wordSize2Bytes . tgtWordSize) - llc_cmd <- settingsFileSetting ToolchainSetting_LlcCommand - llvm_as_cmd <- settingsFileSetting ToolchainSetting_LlvmAsCommand - have_llvm <- liftIO (all isJust <$> mapM findExecutable [llc_cmd, llvm_as_cmd]) + llc_cmd <- queryTargetTarget tgtLlc + llvm_as_cmd <- queryTargetTarget tgtLlvmAs + let have_llvm = all isJust [llc_cmd, llvm_as_cmd] top <- topDirectory ===================================== m4/fp_settings.m4 ===================================== @@ -136,14 +136,7 @@ AC_DEFUN([FP_SETTINGS], fi # Mac-only tools - if test -z "$OtoolCmd"; then - OtoolCmd="otool" - fi SettingsOtoolCommand="$OtoolCmd" - - if test -z "$InstallNameToolCmd"; then - InstallNameToolCmd="install_name_tool" - fi SettingsInstallNameToolCommand="$InstallNameToolCmd" SettingsCCompilerSupportsNoPie="$CONF_GCC_SUPPORTS_NO_PIE" ===================================== m4/ghc_toolchain.m4 ===================================== @@ -107,6 +107,9 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], echo "--merge-objs=$MergeObjsCmd" >> acargs echo "--readelf=$READELF" >> acargs echo "--windres=$WindresCmd" >> acargs + echo "--llc=$LlcCmd" >> acargs + echo "--opt=$OptCmd" >> acargs + echo "--llvm-as=$LlvmAsCmd" >> acargs if test -n "$USER_LD"; then echo "--ld=$USER_LD" >> acargs ===================================== m4/prep_target_file.m4 ===================================== @@ -10,6 +10,38 @@ # This toolchain will additionally be used to validate the one generated by # ghc-toolchain. See Note [ghc-toolchain consistency checking]. +# PREP_LIST +# ============ +# +# Issue a substitution with ["list","of","args"] of [$1List] when $1 is a +# space-separated list of args +# i.e. +# "arg1 arg2 arg3" +# ==> +# ["arg1","arg2","arg3"] +# +# $1 = list variable to substitute +dnl In autoconf, '@<:@' stands for '[', and '@:>@' for ']'. +AC_DEFUN([PREP_LIST],[ + # shell array + set -- $$1 + $1List="@<:@" + if test "[$]#" -eq 0; then + # no arguments + true + else + $1List="${$1List}\"[$]1\"" + shift # drop first elem + for arg in "[$]@" + do + $1List="${$1List},\"$arg\"" + done + fi + $1List="${$1List}@:>@" + + AC_SUBST([$1List]) +]) + # PREP_MAYBE_SIMPLE_PROGRAM # ========================= # @@ -27,6 +59,25 @@ AC_DEFUN([PREP_MAYBE_SIMPLE_PROGRAM],[ AC_SUBST([$1MaybeProg]) ]) +# PREP_MAYBE_PROGRAM +# ========================= +# +# Introduce a substitution [$1MaybeProg] with +# * Nothing, if $$1 is empty +# * Just (Program {prgPath = "$$1", prgFlags = [elements of $$2]}), otherwise +# +# $1 = optional program path +# $2 = program arguments +AC_DEFUN([PREP_MAYBE_PROGRAM],[ + if test -z "$$1"; then + $1MaybeProg=Nothing + else + PREP_LIST([$2]) + $1MaybeProg="Just (Program {prgPath = \"$$1\", prgFlags = $$2List})" + fi + AC_SUBST([$1MaybeProg]) +]) + # PREP_MAYBE_STRING # ========================= # @@ -86,38 +137,6 @@ AC_DEFUN([PREP_NOT_BOOLEAN],[ AC_SUBST([Not$1Bool]) ]) -# PREP_LIST -# ============ -# -# Issue a substitution with ["list","of","args"] of [$1List] when $1 is a -# space-separated list of args -# i.e. -# "arg1 arg2 arg3" -# ==> -# ["arg1","arg2","arg3"] -# -# $1 = list variable to substitute -dnl In autoconf, '@<:@' stands for '[', and '@:>@' for ']'. -AC_DEFUN([PREP_LIST],[ - # shell array - set -- $$1 - $1List="@<:@" - if test "[$]#" -eq 0; then - # no arguments - true - else - $1List="${$1List}\"[$]1\"" - shift # drop first elem - for arg in "[$]@" - do - $1List="${$1List},\"$arg\"" - done - fi - $1List="${$1List}@:>@" - - AC_SUBST([$1List]) -]) - # Eventually: PREP_BUILD_TARGET_FILE, PREP_HOST_TARGET_FILE, PREP_TARGET_TARGET_FILE # Prepares required substitutions to generate the target file AC_DEFUN([PREP_TARGET_FILE],[ @@ -148,7 +167,12 @@ AC_DEFUN([PREP_TARGET_FILE],[ PREP_LIST([JavaScriptCPPArgs]) PREP_LIST([CmmCPPArgs]) PREP_LIST([CmmCPPArgs_STAGE0]) + PREP_MAYBE_SIMPLE_PROGRAM([LlcCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([OptCmd]) + PREP_MAYBE_PROGRAM([LlvmAsCmd], [LlvmAsFlags]) PREP_MAYBE_SIMPLE_PROGRAM([WindresCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([OtoolCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([InstallNameToolCmd]) PREP_MAYBE_STRING([TargetVendor_CPP]) PREP_MAYBE_STRING([HostVendor_CPP]) PREP_LIST([CONF_CPP_OPTS_STAGE2]) ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -52,7 +52,12 @@ data Opts = Opts , optNm :: ProgOpt , optReadelf :: ProgOpt , optMergeObjs :: ProgOpt + , optLlc :: ProgOpt + , optOpt :: ProgOpt + , optLlvmAs :: ProgOpt , optWindres :: ProgOpt + , optOtool :: ProgOpt + , optInstallNameTool :: ProgOpt -- Note we don't actually configure LD into anything but -- see #23857 and #22550 for the very unfortunate story. , optLd :: ProgOpt @@ -99,8 +104,13 @@ emptyOpts = Opts , optNm = po0 , optReadelf = po0 , optMergeObjs = po0 + , optLlc = po0 + , optOpt = po0 + , optLlvmAs = po0 , optWindres = po0 , optLd = po0 + , optOtool = po0 + , optInstallNameTool = po0 , optUnregisterised = Nothing , optTablesNextToCode = Nothing , optUseLibFFIForAdjustors = Nothing @@ -112,7 +122,8 @@ emptyOpts = Opts po0 = emptyProgOpt _optCc, _optCxx, _optCpp, _optHsCpp, _optJsCpp, _optCmmCpp, _optCcLink, _optAr, - _optRanlib, _optNm, _optReadelf, _optMergeObjs, _optWindres, _optLd + _optRanlib, _optNm, _optReadelf, _optMergeObjs, _optLlc, _optOpt, _optLlvmAs, + _optWindres, _optLd, _optOtool, _optInstallNameTool :: Lens Opts ProgOpt _optCc = Lens optCc (\x o -> o {optCc=x}) _optCxx = Lens optCxx (\x o -> o {optCxx=x}) @@ -126,8 +137,13 @@ _optRanlib = Lens optRanlib (\x o -> o {optRanlib=x}) _optNm = Lens optNm (\x o -> o {optNm=x}) _optReadelf = Lens optReadelf (\x o -> o {optReadelf=x}) _optMergeObjs = Lens optMergeObjs (\x o -> o {optMergeObjs=x}) +_optLlc = Lens optLlc (\x o -> o {optLlc=x}) +_optOpt = Lens optOpt (\x o -> o {optOpt=x}) +_optLlvmAs = Lens optLlvmAs (\x o -> o {optLlvmAs=x}) _optWindres = Lens optWindres (\x o -> o {optWindres=x}) -_optLd = Lens optLd (\x o -> o {optLd= x}) +_optLd = Lens optLd (\x o -> o {optLd=x}) +_optOtool = Lens optOtool (\x o -> o {optOtool=x}) +_optInstallNameTool = Lens optInstallNameTool (\x o -> o {optInstallNameTool=x}) _optTriple :: Lens Opts (Maybe String) _optTriple = Lens optTriple (\x o -> o {optTriple=x}) @@ -183,8 +199,13 @@ options = , progOpts "nm" "nm archiver" _optNm , progOpts "readelf" "readelf utility" _optReadelf , progOpts "merge-objs" "linker for merging objects" _optMergeObjs + , progOpts "llc" "LLVM llc utility" _optLlc + , progOpts "opt" "LLVM opt utility" _optOpt + , progOpts "llvm-as" "Assembler used for LLVM backend (typically clang)" _optLlvmAs , progOpts "windres" "windres utility" _optWindres , progOpts "ld" "linker" _optLd + , progOpts "otool" "otool utility" _optOtool + , progOpts "install-name-tool" "install-name-tool utility" _optInstallNameTool ] where progOpts :: String -> String -> Lens Opts ProgOpt -> [OptDescr (Opts -> Opts)] @@ -436,6 +457,11 @@ mkTarget opts = do when (isNothing mergeObjs && not (arSupportsDashL ar)) $ throwE "Neither a object-merging tool (e.g. ld -r) nor an ar that supports -L is available" + -- LLVM toolchain + llc <- optional $ findProgram "llc" (optLlc opts) ["llc"] + opt <- optional $ findProgram "opt" (optOpt opts) ["opt"] + llvmAs <- optional $ findProgram "llvm assembler" (optLlvmAs opts) ["clang"] + -- Windows-specific utilities windres <- case archOS_OS archOs of @@ -444,6 +470,15 @@ mkTarget opts = do return (Just windres) _ -> return Nothing + -- Darwin-specific utilities + (otool, installNameTool) <- + case archOS_OS archOs of + OSDarwin -> do + otool <- findProgram "otool" (optOtool opts) ["otool"] + installNameTool <- findProgram "install_name_tool" (optInstallNameTool opts) ["install_name_tool"] + return (Just otool, Just installNameTool) + _ -> return (Nothing, Nothing) + -- various other properties of the platform tgtWordSize <- checkWordSize cc tgtEndianness <- checkEndianness cc @@ -480,7 +515,12 @@ mkTarget opts = do , tgtRanlib = ranlib , tgtNm = nm , tgtMergeObjs = mergeObjs + , tgtLlc = llc + , tgtOpt = opt + , tgtLlvmAs = llvmAs , tgtWindres = windres + , tgtOtool = otool + , tgtInstallNameTool = installNameTool , tgtWordSize , tgtEndianness , tgtUnregisterised ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -22,15 +22,6 @@ data WordSize = WS4 | WS8 data Endianness = LittleEndian | BigEndian deriving (Show, Read, Eq, Ord) --- TODO(#23674): Move the remaining relevant `settings-xxx` to Target: --- * llc command --- * opt command --- * install_name_tool --- * otool command --- --- Those are all things that are put into GHC's settings, and that might be --- different across targets - -- | A 'Target' consists of: -- -- * a target architecture and operating system @@ -72,8 +63,18 @@ data Target = Target , tgtMergeObjs :: Maybe MergeObjs -- ^ We don't need a merge objects tool if we @Ar@ supports @-L@ + -- LLVM backend toolchain + , tgtLlc :: Maybe Program + , tgtOpt :: Maybe Program + , tgtLlvmAs :: Maybe Program + -- ^ assembler used to assemble LLVM backend output; typically @clang@ + -- Windows-specific tools , tgtWindres :: Maybe Program + + -- Darwin-specific tools + , tgtOtool :: Maybe Program + , tgtInstallNameTool :: Maybe Program } deriving (Read, Eq, Ord) @@ -121,6 +122,11 @@ instance Show Target where , ", tgtRanlib = " ++ show tgtRanlib , ", tgtNm = " ++ show tgtNm , ", tgtMergeObjs = " ++ show tgtMergeObjs + , ", tgtLlc = " ++ show tgtLlc + , ", tgtOpt = " ++ show tgtOpt + , ", tgtLlvmAs = " ++ show tgtLlvmAs , ", tgtWindres = " ++ show tgtWindres + , ", tgtOtool = " ++ show tgtOtool + , ", tgtInstallNameTool = " ++ show tgtInstallNameTool , "}" ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3bf6720eff5e86e673568e756161e6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3bf6720eff5e86e673568e756161e6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] rename HsThingRn to SrcCodeOrigin
by Apoorv Ingle (＠ani) 24 Jun '25

24 Jun '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: da6e83b0 by Apoorv Ingle at 2025-06-24T00:17:51-05:00 rename HsThingRn to SrcCodeOrigin - - - - - 7 changed files: - compiler/GHC/Hs.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Hs.hs ===================================== @@ -150,16 +150,8 @@ data HsParsedModule = HsParsedModule { -- them change (#3589) } --- All the various located syntax things that sets the user context code in TcLclEnv --- data SrcCodeOrigin = --- ExprThing (HsExpr GhcRn) --- | PatThing (LPat GhcRn) --- | StmtThing (ExprLStmt GhcRn) HsDoFlavour - --- I'm a looking at a generated thing or am I a user written thing? -data SrcCodeCtxt = UserCode | GeneratedCode HsThingRn - --- mkSrcCodeOrigin :: HsThingRn -> SrcCodeOrigin --- mkSrcCodeOrigin (OrigExpr e) = ExprThing e --- mkSrcCodeOrigin (OrigPat p) = PatThing p --- mkSrcCodeOrigin (OrigStmt s f) = StmtThing e f +-- Used in TcLclCtxt.tcl_in_gen_code to mark if the current expression +-- is a user generated code or a compiler generated expansion of some user written code +data SrcCodeCtxt + = UserCode + | GeneratedCode SrcCodeOrigin ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -672,12 +672,13 @@ type instance XXExpr GhcTc = XXExprGhcTc -- | The different source constructs that we use to instantiate the "original" field -- in an `XXExprGhcRn original expansion` -- See Note [Handling overloaded and rebindable constructs] in `GHC.Rename.Expr` -data HsThingRn = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression - | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from - | OrigPat (LPat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints +data SrcCodeOrigin + = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression + | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from + | OrigPat (LPat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints data XXExprGhcRn - = ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing to be used for error messages + = ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages , xrn_expanded :: HsExpr GhcRn -- The compiler generated expanded thing } @@ -718,7 +719,7 @@ data XXExprGhcTc | ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn] -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` - { xtc_orig :: HsThingRn -- The original user written thing + { xtc_orig :: SrcCodeOrigin -- The original user written thing , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression | ConLikeTc -- Result of typechecking a data-con @@ -752,10 +753,10 @@ mkExpandedExprTc :: HsExpr GhcRn -- ^ source expression -> HsExpr GhcTc -- ^ expanded typechecked expression -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr) +mkExpandedExprTc oExpr eExpr = mkExpandedTc (OrigExpr oExpr) eExpr mkExpandedTc - :: HsThingRn -- ^ source do statement + :: SrcCodeOrigin -- ^ source, user written do statement/expression -> HsExpr GhcTc -- ^ expanded typechecked expression -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' mkExpandedTc o e = XExpr (ExpandedThingTc o e) @@ -1020,7 +1021,7 @@ ppr_expr (XExpr x) = case ghcPass @p of GhcRn -> ppr x GhcTc -> ppr x -instance Outputable HsThingRn where +instance Outputable SrcCodeOrigin where ppr thing = case thing of OrigExpr x -> ppr_builder "<OrigExpr>:" x @@ -1087,7 +1088,7 @@ ppr_infix_expr_tc (HsTick {}) = Nothing ppr_infix_expr_tc (HsBinTick {}) = Nothing ppr_infix_expr_tc (HsRecSelTc f) = Just (pprInfixOcc f) -ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc +ppr_infix_hs_expansion :: SrcCodeOrigin -> Maybe SDoc ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e ppr_infix_hs_expansion _ = Nothing @@ -1195,7 +1196,7 @@ hsExprNeedsParens prec = go go_x_rn (PopErrCtxt a) = hsExprNeedsParens prec a go_x_rn (HsRecSelRn{}) = False - hsExpandedNeedsParens :: HsThingRn -> Bool + hsExpandedNeedsParens :: SrcCodeOrigin -> Bool hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e hsExpandedNeedsParens _ = False @@ -1248,7 +1249,7 @@ isAtomicHsExpr (XExpr x) go_x_rn (PopErrCtxt a) = isAtomicHsExpr a go_x_rn (HsRecSelRn{}) = True - isAtomicExpandedThingRn :: HsThingRn -> Bool + isAtomicExpandedThingRn :: SrcCodeOrigin -> Bool isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e isAtomicExpandedThingRn _ = False ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -591,7 +591,7 @@ deriving instance Eq (IE GhcTc) -- --------------------------------------------------------------------- -deriving instance Data HsThingRn +deriving instance Data SrcCodeOrigin deriving instance Data XXExprGhcRn deriving instance Data a => Data (WithUserRdr a) ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -611,7 +611,7 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts)) ListComp -> Just $ BinBox QualBinBox _ -> Nothing --- addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc) +-- addTickHsExpanded :: SrcCodeOrigin -> 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. ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -5306,11 +5306,9 @@ pprArising :: CtLoc -> SDoc -- We've done special processing for TypeEq, KindEq, givens pprArising ct_loc | suppress_origin = empty - | in_generated_code = pprCtOrigin orig -- TODO ANI: maybe should go way | otherwise = pprCtOrigin orig where orig = ctLocOrigin ct_loc - in_generated_code = ctLocEnvInGeneratedCode (ctLocEnv ct_loc) suppress_origin | isGivenOrigin orig = True | otherwise = case orig of ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -763,18 +763,18 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] -exprCtOrigin (XExpr (ExpandedThingRn {})) = Shouldn'tHappenOrigin "XExpr ExpandedThingRn" +exprCtOrigin (XExpr (ExpandedThingRn o _)) = srcCodeOriginCtOrigin o exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) -hsThingCtOrigin :: HsThingRn -> CtOrigin -hsThingCtOrigin (OrigExpr e) = exprCtOrigin e -hsThingCtOrigin (OrigStmt{}) = DoStmtOrigin -hsThingCtOrigin (OrigPat p) = DoPatOrigin p +srcCodeOriginCtOrigin :: SrcCodeOrigin -> CtOrigin +srcCodeOriginCtOrigin (OrigExpr e) = exprCtOrigin e +srcCodeOriginCtOrigin (OrigStmt{}) = DoStmtOrigin +srcCodeOriginCtOrigin (OrigPat p) = DoPatOrigin p srcCodeCtxtCtOrigin :: HsExpr GhcRn -> SrcCodeCtxt -> CtOrigin srcCodeCtxtCtOrigin e UserCode = exprCtOrigin e -srcCodeCtxtCtOrigin _ (GeneratedCode e) = hsThingCtOrigin e +srcCodeCtxtCtOrigin _ (GeneratedCode e) = srcCodeOriginCtOrigin e -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -990,9 +990,9 @@ getSrcCodeCtxt = getLclEnvSrcCodeCtxt <$> getLclEnv -- | Mark the inner computation as being done inside generated code. -- -- See Note [Error contexts in generated code] -setInGeneratedCode :: HsThingRn -> TcRn a -> TcRn a -setInGeneratedCode syntax_thing thing_inside = - updLclCtxt (setLclCtxtSrcCodeCtxt (GeneratedCode syntax_thing)) thing_inside +setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a +setInGeneratedCode scOrig thing_inside = + updLclCtxt (setLclCtxtSrcCodeCtxt (GeneratedCode scOrig)) thing_inside setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/da6e83b044e60a5a4bd8cf249582b21… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/da6e83b044e60a5a4bd8cf249582b21… You're receiving this email because of your account on gitlab.haskell.org.

1 0