[Git][ghc/ghc][wip/torsten.schmits/mercury-fixed] 2 commits: driver: add -dep-json -opt-json flags to ghc -M

Torsten Schmits pushed to branch wip/torsten.schmits/mercury-fixed at Glasgow Haskell Compiler / GHC Commits: b7ef1743 by Cheng Shao at 2025-10-22T15:39:51+02:00 driver: add -dep-json -opt-json flags to ghc -M docs: document -dep-json -opt-json flags Rework protocol merge opt-json into dep-json normalize source filenames include more canonical variant of the package id choose the main library when -package matches multiple units with the same version allow specifying library deps with -package pkg:lib Backported to GHC 9.10 - - - - - dbb1df4d by Torsten Schmits at 2025-10-22T15:39:51+02:00 release - - - - - 25 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/MakeFile.hs - + compiler/GHC/Driver/MakeFile/JSON.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in - configure.ac - docs/users_guide/separate_compilation.rst - docs/users_guide/using.rst - + testsuite/tests/driver/T24384/A.hs - + testsuite/tests/driver/T24384/B.hs - + testsuite/tests/driver/T24384/C.hs - + testsuite/tests/driver/T24384/C.hs-boot - + testsuite/tests/driver/T24384/D.hs - + testsuite/tests/driver/T24384/E.hs - + testsuite/tests/driver/T24384/Makefile - + testsuite/tests/driver/T24384/T24384.stdout - + testsuite/tests/driver/T24384/all.T - + testsuite/tests/driver/T24384/preproc.sh - + testsuite/tests/driver/T24384/setup-dep.sh Changes: ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -804,6 +804,7 @@ summariseRequirement pn mod_name = do ms_hie_date = hie_timestamp, ms_srcimps = [], ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports, + ms_opts = [], ms_parsed_mod = Just (HsParsedModule { hpm_module = L loc (HsModule { hsmodExt = XModulePs { @@ -909,6 +910,7 @@ hsModuleToModSummary home_keys pn hsc_src modname -- extra imports ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports) ++ ((,) NoPkgQual . noLoc <$> implicit_sigs), + ms_opts = [], -- This is our hack to get the parse tree to the right spot ms_parsed_mod = Just (HsParsedModule { hpm_module = hsmod, ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -27,7 +27,7 @@ import GHC.Tc.Utils.Backpack import GHC.Platform.Ways import GHC.Driver.Config.Finder (initFinderOpts) -import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Parser (initParserOpts, supportedLanguagePragmas) import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Session @@ -819,6 +819,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf , nms_location = location , nms_mod = mod , nms_preimps = preimps + , nms_opts = pi_mod_opts } checkSummaryHash @@ -981,6 +982,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p , nms_location = location , nms_mod = mod , nms_preimps = preimps + , nms_opts = pi_mod_opts } -- | Convenience named arguments for 'makeNewModSummary' only used to make @@ -993,6 +995,7 @@ data MakeNewModSummary , nms_location :: ModLocation , nms_mod :: Module , nms_preimps :: PreprocessedImports + , nms_opts :: ![String] } makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary @@ -1020,6 +1023,7 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do ((,) NoPkgQual . noLoc <$> extra_sig_imports) ++ ((,) NoPkgQual . noLoc <$> implicit_sigs) ++ pi_theimps + , ms_opts = nms_opts , ms_hs_hash = nms_src_hash , ms_iface_date = hi_timestamp , ms_hie_date = hie_timestamp @@ -1036,6 +1040,7 @@ data PreprocessedImports , pi_hspp_buf :: StringBuffer , pi_mod_name_loc :: SrcSpan , pi_mod_name :: ModuleName + , pi_mod_opts :: ![String] } -- Preprocess the source file and get its imports @@ -1051,14 +1056,15 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do (pi_local_dflags, pi_hspp_fn) <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn - (pi_srcimps', pi_theimps', L pi_mod_name_loc pi_mod_name) + ((pi_srcimps', pi_theimps', L pi_mod_name_loc pi_mod_name), pi_mod_opts) <- ExceptT $ do let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags popts = initParserOpts pi_local_dflags mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn - return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps) + let mopts = map unLoc $ snd $ getOptions popts (supportedLanguagePragmas pi_local_dflags) pi_hspp_buf src_fn + pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) let pi_srcimps = rn_imps pi_srcimps' let pi_theimps = rn_imps pi_theimps' - return PreprocessedImports {..} \ No newline at end of file + return PreprocessedImports {..} ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -338,6 +338,7 @@ data DynFlags = DynFlags { depIncludeCppDeps :: Bool, depExcludeMods :: [ModuleName], depSuffixes :: [String], + depJSON :: !(Maybe FilePath), -- Package flags packageDBFlags :: [PackageDBFlag], @@ -667,6 +668,7 @@ defaultDynFlags mySettings = depIncludeCppDeps = False, depExcludeMods = [], depSuffixes = [], + depJSON = Nothing, -- end of ghc -M values ghcVersionFile = Nothing, haddockOptions = Nothing, ===================================== compiler/GHC/Driver/MakeFile.hs ===================================== @@ -1,4 +1,5 @@ - +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} ----------------------------------------------------------------------------- -- @@ -17,15 +18,21 @@ where import GHC.Prelude import qualified GHC +import GHC.Data.Maybe import GHC.Driver.Make import GHC.Driver.Monad import GHC.Driver.DynFlags +import GHC.Driver.MakeFile.JSON import GHC.Utils.Misc import GHC.Driver.Env import GHC.Driver.Errors.Types +import GHC.Driver.Pipeline (runPipeline, TPhase (T_Unlit, T_FileArgs), use, mkPipeEnv) +import GHC.Driver.Phases (StopPhase (StopPreprocess), startPhase, Phase (Unlit)) +import GHC.Driver.Pipeline.Monad (PipelineOutput (NoOutputFile)) +import GHC.Driver.Session (pgm_F) import qualified GHC.SysTools as SysTools import GHC.Data.Graph.Directed ( SCC(..) ) -import GHC.Data.OsPath (unsafeDecodeUtf) +import GHC.Data.OsPath (unsafeDecodeUtf, unsafeEncodeUtf) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SourceError @@ -35,11 +42,13 @@ import Data.List (partition) import GHC.Utils.TmpFs import GHC.Iface.Load (cannotFindModule) +import GHC.Iface.Errors.Types import GHC.Unit.Module import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph import GHC.Unit.Finder +import GHC.Unit.State (lookupUnitId) import GHC.Utils.Exception import GHC.Utils.Error @@ -49,11 +58,10 @@ import System.Directory import System.FilePath import System.IO import System.IO.Error ( isEOFError ) -import Control.Monad ( when, forM_ ) -import Data.Maybe ( isJust ) +import Control.Monad ( when ) +import Data.Foldable (traverse_) import Data.IORef import qualified Data.Set as Set -import GHC.Iface.Errors.Types import Data.Either ----------------------------------------------------------------- @@ -110,7 +118,7 @@ doMkDependModuleGraph dflags module_graph = do -- and complaining about cycles hsc_env <- getSession root <- liftIO getCurrentDirectory - mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted + mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files) (mkd_dep_json files)) sorted -- If -ddump-mod-cycles, show cycles in the module graph liftIO $ dumpModCycles logger module_graph @@ -118,13 +126,6 @@ doMkDependModuleGraph dflags module_graph = do -- Tidy up liftIO $ endMkDependHS logger files - -- Unconditional exiting is a bad idea. If an error occurs we'll get an - --exception; if that is not caught it's fine, but at least we have a - --chance to find out exactly what went wrong. Uncomment the following - --line if you disagree. - - --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) - ----------------------------------------------------------------- -- -- beginMkDependHs @@ -137,6 +138,8 @@ doMkDependModuleGraph dflags module_graph = do data MkDepFiles = MkDep { mkd_make_file :: FilePath, -- Name of the makefile mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile + -- | Output interface for the -dep-json file + mkd_dep_json :: !(Maybe (JsonOutput DepJSON)), mkd_tmp_file :: FilePath, -- Name of the temporary file mkd_tmp_hdl :: Handle } -- Handle of the open temporary file @@ -179,14 +182,15 @@ beginMkDependHS logger tmpfs dflags = do return (Just makefile_hdl) + dep_json_ref <- mkJsonOutput initDepJSON (depJSON dflags) -- write the magic marker into the tmp file hPutStrLn tmp_hdl depStartMarker return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, + mkd_dep_json = dep_json_ref, mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) - ----------------------------------------------------------------- -- -- processDeps @@ -198,6 +202,7 @@ processDeps :: DynFlags -> [ModuleName] -> FilePath -> Handle -- Write dependencies to here + -> Maybe (JsonOutput DepJSON) -> SCC ModuleGraphNode -> IO () -- Write suitable dependencies to handle @@ -215,79 +220,83 @@ processDeps :: DynFlags -- -- For {-# SOURCE #-} imports the "hi" will be "hi-boot". -processDeps _ _ _ _ _ (CyclicSCC nodes) +processDeps _ _ _ _ _ _ (CyclicSCC nodes) = -- There shouldn't be any cycles; report them throwOneError $ cyclicModuleErr nodes -processDeps _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node)) +processDeps _ _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node)) = -- There shouldn't be any backpack instantiations; report them as well throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node -processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return () -processDeps _dflags _ _ _ _ (AcyclicSCC (UnitNode {})) = return () -processDeps _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) +processDeps _dflags _ _ _ _ _ (AcyclicSCC (LinkNode {})) = return () +processDeps _dflags _ _ _ _ _ (AcyclicSCC (UnitNode {})) = return () +processDeps _ _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) -- No dependencies needed for fixed modules (already compiled) = return () -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) - = do { let extra_suffixes = depSuffixes dflags - include_pkg_deps = depIncludePkgDeps dflags - src_file = msHsFilePath node - obj_file = msObjFilePath node - obj_files = insertSuffixes obj_file extra_suffixes - - do_imp loc is_boot pkg_qual imp_mod - = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod - is_boot include_pkg_deps - ; case mb_hi of { - Nothing -> return () ; - Just hi_file -> do - { let hi_files = insertSuffixes hi_file extra_suffixes - write_dep (obj,hi) = writeDependency root hdl [obj] hi - - -- Add one dependency for each suffix; - -- e.g. A.o : B.hi - -- A.x_o : B.x_hi - ; mapM_ write_dep (obj_files `zip` hi_files) }}} - - - -- Emit std dependency of the object(s) on the source file - -- Something like A.o : A.hs - ; writeDependency root hdl obj_files src_file - - -- add dependency between objects and their corresponding .hi-boot - -- files if the module has a corresponding .hs-boot file (#14482) - ; when (isBootSummary node == IsBoot) $ do - let hi_boot = msHiFilePath node - let obj = unsafeDecodeUtf $ removeBootSuffix (msObjFileOsPath node) - forM_ extra_suffixes $ \suff -> do - let way_obj = insertSuffixes obj [suff] - let way_hi_boot = insertSuffixes hi_boot [suff] - mapM_ (writeDependency root hdl way_obj) way_hi_boot - - -- Emit a dependency for each CPP import - ; when (depIncludeCppDeps dflags) $ do - -- CPP deps are discovered in the module parsing phase by parsing - -- comment lines left by the preprocessor. - -- Note that GHC.parseModule may throw an exception if the module - -- fails to parse, which may not be desirable (see #16616). - { session <- Session <$> newIORef hsc_env - ; parsedMod <- reflectGhc (GHC.parseModule node) session - ; mapM_ (writeDependency root hdl obj_files) - (GHC.pm_extra_src_files parsedMod) - } - - -- Emit a dependency for each import - - ; let do_imps is_boot idecls = sequence_ - [ do_imp loc is_boot mb_pkg mod - | (mb_pkg, L loc mod) <- idecls, - mod `notElem` excl_mods ] - - ; do_imps IsBoot (ms_srcimps node) - ; do_imps NotBoot (ms_imps node) - } + +processDeps dflags hsc_env excl_mods root hdl m_dep_json (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do + pp <- preprocessor + deps <- fmap concat $ sequence $ + [cpp_deps | depIncludeCppDeps dflags] ++ [ + import_deps IsBoot (ms_srcimps node), + import_deps NotBoot (ms_imps node) + ] + updateJson m_dep_json (updateDepJSON include_pkg_deps pp dep_node deps) + writeDependencies include_pkg_deps root hdl extra_suffixes dep_node deps + where + extra_suffixes = depSuffixes dflags + include_pkg_deps = depIncludePkgDeps dflags + src_file = msHsFilePath node + dep_node = + DepNode { + dn_mod = ms_mod node, + dn_src = src_file, + dn_obj = msObjFilePath node, + dn_hi = msHiFilePath node, + dn_boot = isBootSummary node, + dn_options = Set.fromList (ms_opts node) + } + + preprocessor + | Just src <- ml_hs_file (ms_location node) + = runPipeline (hsc_hooks hsc_env) $ do + let (_, suffix) = splitExtension src + lit | Unlit _ <- startPhase suffix = True + | otherwise = False + pipe_env = mkPipeEnv StopPreprocess src Nothing NoOutputFile + unlit_fn <- if lit then use (T_Unlit pipe_env hsc_env src) else pure src + (dflags1, _, _) <- use (T_FileArgs hsc_env unlit_fn) + let pp = pgm_F dflags1 + pure (if null pp then global_preprocessor else Just pp) + | otherwise + = pure global_preprocessor + + global_preprocessor + | let pp = pgm_F dflags + , not (null pp) + = Just pp + | otherwise + = Nothing + + -- Emit a dependency for each CPP import + -- CPP deps are discovered in the module parsing phase by parsing + -- comment lines left by the preprocessor. + -- Note that GHC.parseModule may throw an exception if the module + -- fails to parse, which may not be desirable (see #16616). + cpp_deps = do + session <- Session <$> newIORef hsc_env + parsedMod <- reflectGhc (GHC.parseModule node) session + pure (DepCpp <$> GHC.pm_extra_src_files parsedMod) + + -- Emit a dependency for each import + import_deps is_boot idecls = + sequence [ + findDependency hsc_env loc mb_pkg mod is_boot + | (mb_pkg, L loc mod) <- idecls + , mod `notElem` excl_mods + ] findDependency :: HscEnv @@ -295,27 +304,78 @@ findDependency :: HscEnv -> PkgQual -- package qualifier, if any -> ModuleName -- Imported module -> IsBootInterface -- Source import - -> Bool -- Record dependency on package modules - -> IO (Maybe FilePath) -- Interface file -findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do + -> IO Dep +findDependency hsc_env srcloc pkg imp dep_boot = do -- Find the module; this will be fast because -- we've done it once during downsweep - r <- findImportedModuleWithIsBoot hsc_env imp is_boot pkg - case r of - Found loc _ - -- Home package: just depend on the .hi or hi-boot file - | isJust (ml_hs_file loc) || include_pkg_deps - -> return (Just (ml_hi_file loc)) - - -- Not in this package: we don't need a dependency - | otherwise - -> return Nothing + findImportedModule hsc_env imp pkg >>= \case + Found loc dep_mod -> + pure DepHi { + dep_mod, + dep_path = ml_hi_file loc, + dep_unit = lookupUnitId (hsc_units hsc_env) (moduleUnitId dep_mod), + dep_local, + dep_boot + } + where + dep_local = isJust (ml_hs_file loc) fail -> - throwOneError $ - mkPlainErrorMsgEnvelope srcloc $ - GhcDriverMessage $ DriverInterfaceError $ - (Can'tFindInterface (cannotFindModule hsc_env imp fail) (LookingForModule imp is_boot)) + throwOneError $ + mkPlainErrorMsgEnvelope srcloc $ + GhcDriverMessage $ + DriverInterfaceError $ + Can'tFindInterface (cannotFindModule hsc_env imp fail) $ + LookingForModule imp dep_boot + +writeDependencies :: + Bool -> + FilePath -> + Handle -> + [FilePath] -> + DepNode -> + [Dep] -> + IO () +writeDependencies include_pkgs root hdl suffixes node deps = + traverse_ write tasks + where + tasks = source_dep : boot_dep ++ concatMap import_dep deps + + -- Emit std dependency of the object(s) on the source file + -- Something like A.o : A.hs + source_dep = (obj_files, dn_src) + + -- add dependency between objects and their corresponding .hi-boot + -- files if the module has a corresponding .hs-boot file (#14482) + boot_dep + | IsBoot <- dn_boot + = [([obj], hi) | (obj, hi) <- zip (suffixed (viaOsPath removeBootSuffix dn_obj)) (suffixed dn_hi)] + | otherwise + = [] + + -- Add one dependency for each suffix; + -- e.g. A.o : B.hi + -- A.x_o : B.x_hi + import_dep = \case + DepHi {dep_path, dep_boot, dep_unit} + | isNothing dep_unit || include_pkgs + , let path = if dep_boot == IsBoot then viaOsPath addBootSuffix dep_path else dep_path + -> [([obj], hi) | (obj, hi) <- zip obj_files (suffixed path)] + + | otherwise + -> [] + + DepCpp {dep_path} -> [(obj_files, dep_path)] + + write (from, to) = writeDependency root hdl from to + + obj_files = suffixed dn_obj + + suffixed f = insertSuffixes f suffixes + + DepNode {dn_src, dn_obj, dn_hi, dn_boot} = node + + viaOsPath f a = unsafeDecodeUtf (f (unsafeEncodeUtf a)) ----------------------------- writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () @@ -357,8 +417,9 @@ insertSuffixes file_name extras endMkDependHS :: Logger -> MkDepFiles -> IO () endMkDependHS logger - (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, - mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) + (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, + mkd_dep_json, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) = do -- write the magic marker into the tmp file hPutStrLn tmp_hdl depEndMarker @@ -381,6 +442,10 @@ endMkDependHS logger showPass logger "Installing new makefile" SysTools.copyFile tmp_file makefile + -- Write the dependency and option data to a json file if the corresponding + -- flags were specified. + writeJsonOutput mkd_dep_json + ----------------------------------------------------------------- -- Module cycles ===================================== compiler/GHC/Driver/MakeFile/JSON.hs ===================================== @@ -0,0 +1,221 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE RecordWildCards #-} +module GHC.Driver.MakeFile.JSON + ( writeJSONFile, + JsonOutput (..), + mkJsonOutput, + updateJson, + writeJsonOutput, + DepJSON, + DepNode (..), + Dep (..), + initDepJSON, + updateDepJSON, + ) +where + +import Data.Foldable (traverse_) +import Data.IORef +import qualified Data.Map.Strict as Map +import qualified Data.Semigroup as Semigroup +import qualified Data.Set as Set +import GHC.Data.FastString (unpackFS) +import GHC.Generics (Generic, Generically (Generically)) +import GHC.Prelude +import GHC.Unit +import GHC.Utils.Json +import GHC.Utils.Misc +import GHC.Utils.Outputable +import System.FilePath (normalise) + +-------------------------------------------------------------------------------- +-- Output helpers +-------------------------------------------------------------------------------- + +writeJSONFile :: ToJson a => a -> FilePath -> IO () +writeJSONFile doc p = do + withAtomicRename p + $ \tmp -> writeFile tmp $ showSDocUnsafe $ renderJSON $ json doc + +-------------------------------------------------------------------------------- +-- Output interface for json dumps +-------------------------------------------------------------------------------- + +-- | Resources for a json dump option, used in "GHC.Driver.MakeFile". +-- The flag @-dep-json@ add an additional output target for dependency +-- diagnostics. +data JsonOutput a = + JsonOutput { + -- | This ref is updated in @processDeps@ incrementally, using a + -- flag-specific type. + json_ref :: IORef a, + + -- | The output file path specified as argument to the flag. + json_path :: FilePath + } + +-- | Allocate an 'IORef' with the given function if the 'FilePath' is 'Just', +-- indicating that the userspecified @-*-json@. +mkJsonOutput :: + IO (IORef a) -> + Maybe FilePath -> + IO (Maybe (JsonOutput a)) +mkJsonOutput mk_ref = + traverse $ \ json_path -> do + json_ref <- mk_ref + pure JsonOutput {json_ref, json_path} + +-- | Update the dump data in 'json_ref' if the output target is present. +updateJson :: Maybe (JsonOutput a) -> (a -> a) -> IO () +updateJson out f = traverse_ (\ JsonOutput {json_ref} -> modifyIORef' json_ref f) out + +-- | Write a json object to the flag-dependent file if the output target is +-- present. +writeJsonOutput :: + ToJson a => + Maybe (JsonOutput a) -> + IO () +writeJsonOutput = + traverse_ $ \ JsonOutput {json_ref, json_path} -> do + payload <- readIORef json_ref + writeJSONFile payload json_path + +-------------------------------------------------------------------------------- +-- Types abstracting over json and Makefile +-------------------------------------------------------------------------------- + +data DepNode = + DepNode { + dn_mod :: Module, + dn_src :: FilePath, + dn_obj :: FilePath, + dn_hi :: FilePath, + dn_boot :: IsBootInterface, + dn_options :: Set.Set String + } + +data Dep = + DepHi { + dep_mod :: Module, + dep_path :: FilePath, + dep_unit :: Maybe UnitInfo, + dep_local :: Bool, + dep_boot :: IsBootInterface + } + | + DepCpp { + dep_path :: FilePath + } + +-------------------------------------------------------------------------------- +-- Payload for -dep-json +-------------------------------------------------------------------------------- + +newtype PackageDeps = + PackageDeps (Map.Map (String, UnitId, PackageId) (Set.Set ModuleName)) + deriving newtype (Monoid) + +instance Semigroup PackageDeps where + PackageDeps l <> PackageDeps r = PackageDeps (Map.unionWith (Semigroup.<>) l r) + +data Deps = + Deps { + sources :: Set.Set FilePath, + modules :: (Set.Set ModuleName, Set.Set ModuleName), + packages :: PackageDeps, + cpp :: Set.Set FilePath, + options :: Set.Set String, + preprocessor :: Maybe FilePath + } + deriving stock (Generic) + deriving (Semigroup, Monoid) via (Generically Deps) + +newtype DepJSON = DepJSON (Map.Map ModuleName Deps) + +instance ToJson DepJSON where + json (DepJSON m) = + JSObject [ + (moduleNameString target, JSObject [ + ("sources", array sources normalise), + ("modules", array (fst modules) moduleNameString), + ("modules-boot", array (snd modules) moduleNameString), + ("packages", + JSArray [ + package name unit_id package_id mods | + ((name, unit_id, package_id), mods) <- Map.toList packages + ] + ), + ("cpp", array cpp id), + ("options", array options id), + ("preprocessor", maybe JSNull JSString preprocessor) + ]) + | (target, Deps {packages = PackageDeps packages, ..}) <- Map.toList m + ] + where + package name unit_id (PackageId package_id) mods = + JSObject [ + ("id", JSString (unitIdString unit_id)), + ("name", JSString name), + ("package-id", JSString (unpackFS package_id)), + ("modules", array mods moduleNameString) + ] + + array values render = JSArray (fmap (JSString . render) (Set.toList values)) + +initDepJSON :: IO (IORef DepJSON) +initDepJSON = newIORef $ DepJSON Map.empty + +insertDepJSON :: [ModuleName] -> Deps -> DepJSON -> DepJSON +insertDepJSON targets dep (DepJSON m0) = + DepJSON + $ foldl' + ( \acc target -> + Map.insertWith + (Semigroup.<>) + target + dep + acc + ) + m0 + targets + +updateDepJSON :: Bool -> Maybe FilePath -> DepNode -> [Dep] -> DepJSON -> DepJSON +updateDepJSON include_pkgs preprocessor DepNode {..} deps = + insertDepJSON [moduleName dn_mod] payload + where + payload = node_data Semigroup.<> foldMap dep deps + + node_data = + mempty { + sources = Set.singleton dn_src, + preprocessor, + options = dn_options + } + + dep = \case + DepHi {dep_mod, dep_local, dep_unit, dep_boot} + | dep_local + , let set = Set.singleton (moduleName dep_mod) + value | IsBoot <- dep_boot = (Set.empty, set) + | otherwise = (set, Set.empty) + -> mempty {modules = value} + + | include_pkgs + , Just unit <- dep_unit + , let PackageName nameFS = unitPackageName unit + name = unpackFS nameFS + withLibName (PackageName c) = name ++ ":" ++ unpackFS c + lname = maybe name withLibName (unitComponentName unit) + key = (lname, unitId unit, unitPackageId unit) + -> mempty {packages = PackageDeps (Map.singleton key (Set.singleton (moduleName dep_mod)))} + + | otherwise + -> mempty + + DepCpp {dep_path} -> + mempty {cpp = Set.singleton dep_path} ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -753,6 +753,7 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do ms_iface_date = hi_date, ms_hie_date = hie_date, ms_textual_imps = imps, + ms_opts = [], ms_srcimps = src_imps } ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -753,6 +753,9 @@ addDepExcludeMod m d addDepSuffix :: FilePath -> DynFlags -> DynFlags addDepSuffix s d = d { depSuffixes = s : depSuffixes d } +setDepJSON :: FilePath -> DynFlags -> DynFlags +setDepJSON f d = d { depJSON = Just f } + addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} addGhcVersionFile :: FilePath -> DynFlags -> DynFlags @@ -1218,6 +1221,7 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) + , make_ord_flag defGhcFlag "dep-json" (hasArg setDepJSON) -------- Linking ---------------------------------------------------- , make_ord_flag defGhcFlag "no-link" ===================================== compiler/GHC/Unit/Info.hs ===================================== @@ -117,6 +117,9 @@ instance Outputable PackageId where instance Outputable PackageName where ppr (PackageName str) = ftext str +instance Ord PackageId where + PackageId p1 `compare` PackageId p2 = p1 `lexicalCompareFS` p2 + unitPackageIdString :: GenUnitInfo u -> String unitPackageIdString pkg = unpackFS str where ===================================== compiler/GHC/Unit/Module/ModSummary.hs ===================================== @@ -83,6 +83,8 @@ data ModSummary -- ^ Source imports of the module ms_textual_imps :: [(PkgQual, Located ModuleName)], -- ^ Non-source imports of the module from the module *text* + ms_opts :: ![String], + -- ^ OPTIONS and LANGUAGE pragmas of the source file ms_parsed_mod :: Maybe HsParsedModule, -- ^ The parsed, nonrenamed source, if we have it. This is also -- used to support "inline module syntax" in Backpack files. ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -71,6 +71,7 @@ module GHC.Unit.State ( unwireUnit) where +import Data.Foldable (find) import GHC.Prelude import GHC.Driver.DynFlags @@ -903,8 +904,18 @@ applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag = ExposePackage _ arg (ModRenaming b rns) -> case findPackages prec_map pkg_map closure arg pkgs unusable of Left ps -> Failed (PackageFlagErr flag ps) - Right (p:_) -> Succeeded vm' + Right ps@(p0:_) -> Succeeded vm' where + p | PackageArg _ <- arg = fromMaybe p0 mainPackage + | otherwise = p0 + + mainPackage = find (\ u -> isNothing (unitComponentName u)) matchFirst + + matchFirst = filter (\ u -> unitPackageName u == firstName && unitPackageVersion u == firstVersion) ps + + firstName = unitPackageName p0 + firstVersion = unitPackageVersion p0 + n = fsPackageName p -- If a user says @-unit-id p[A=<A>]@, this imposes @@ -1030,6 +1041,13 @@ matchingStr :: String -> UnitInfo -> Bool matchingStr str p = str == unitPackageIdString p || str == unitPackageNameString p + || matchSublibrary + where + matchSublibrary + | Just (PackageName c) <- unitComponentName p + = str == (unitPackageNameString p ++ ":" ++ unpackFS c) + | otherwise + = False matchingId :: UnitId -> UnitInfo -> Bool matchingId uid p = uid == unitId p ===================================== compiler/ghc.cabal.in ===================================== @@ -528,6 +528,7 @@ Library GHC.Driver.Make GHC.Driver.MakeAction GHC.Driver.MakeFile + GHC.Driver.MakeFile.JSON GHC.Driver.Monad GHC.Driver.Phases GHC.Driver.Pipeline ===================================== configure.ac ===================================== @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.13], [glasgow-haskell-bugs@haskell.org], [ghc-AC_PACKAGE_VERSION]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.12.1], [glasgow-haskell-bugs@haskell.org], [ghc-AC_PACKAGE_VERSION]) # Version on master must be X.Y (not X.Y.Z) for ProjectVersionMunged variable # to be useful (cf #19058). However, the version must have three components # (X.Y.Z) on stable branches (e.g. ghc-9.2) to ensure that pre-releases are @@ -22,7 +22,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.13], [glasgow-hask AC_CONFIG_MACRO_DIRS([m4]) # Set this to YES for a released version, otherwise NO -: ${RELEASE=NO} +: ${RELEASE=YES} # The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line # above. If this is not a released version, then we will append the ===================================== docs/users_guide/separate_compilation.rst ===================================== @@ -1520,6 +1520,22 @@ generation are: is only a temporary file that GHC will always generate, it is not output as a dependency. +.. ghc-flag:: -dep-json ⟨file⟩ + :shortdesc: Also emit ⟨file⟩ as a JSON file containing dependencies + :type: dynamic + :category: redirect-output + + In addition to the makefile, also emit ⟨file⟩ as a JSON file + containing the same dependencies info, so it can be parsed by + external build systems. The JSON file contains a single object, + mapping each target to a list of dependencies. + In addition to the makefile, each module's payload will contain the + values of ``OPTIONS`` and ``LANGUAGE`` pragmas of the source + file, so it can be parsed by external build systems. Each ``LANGUAGE`` + pragma is represented as an option as well, e.g. + ``{-# LANGUAGE TemplateHaskell #-}`` is represented as + ``"-XTemplateHaskell"``. + .. _orphan-modules: Orphan modules and instance declarations ===================================== docs/users_guide/using.rst ===================================== @@ -366,7 +366,7 @@ The available mode flags are: .. ghc-flag:: -M :shortdesc: generate dependency information suitable for use in a - ``Makefile``; see :ref:`makefile-dependencies` for details. + ``Makefile`` or as JSON; see :ref:`makefile-dependencies` for details. :type: mode :category: modes ===================================== testsuite/tests/driver/T24384/A.hs ===================================== @@ -0,0 +1,5 @@ +{-# language Strict #-} +{-# options_ghc -fexpose-all-unfoldings #-} +module A where + +import {-# source #-} C ===================================== testsuite/tests/driver/T24384/B.hs ===================================== @@ -0,0 +1,2 @@ +{-# options_ghc -F -pgmF ./preproc.sh #-} +module B where ===================================== testsuite/tests/driver/T24384/C.hs ===================================== @@ -0,0 +1,6 @@ +module C where + +import A +import Data.Set + +data C = C ===================================== testsuite/tests/driver/T24384/C.hs-boot ===================================== @@ -0,0 +1,5 @@ +module C where + +import E + +data C ===================================== testsuite/tests/driver/T24384/D.hs ===================================== @@ -0,0 +1,4 @@ +module D where + +import B +import C ===================================== testsuite/tests/driver/T24384/E.hs ===================================== @@ -0,0 +1,14 @@ +module E where + +import Language.Haskell.TH.Syntax +import Dep +import DepPub + +e :: Q Exp +e = lift (5 :: Integer) + +edep :: () +edep = dep + +edepPub :: () +edepPub = depPub ===================================== testsuite/tests/driver/T24384/Makefile ===================================== @@ -0,0 +1,10 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T24384: + ./setup-dep.sh "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(CABAL_MINIMAL_BUILD)" "$(GHC_PKG)" + mkdir -p lib + mv B.hs lib/ + '$(TEST_HC)' A.hs lib/B.hs C.hs D.hs E.hs -M -dep-json dep.json -include-pkg-deps -include-cpp-deps -package-db ./db -hide-all-packages -package base -package containers -package template-haskell -package dep -package dep:pub + cat dep.json ===================================== testsuite/tests/driver/T24384/T24384.stdout ===================================== @@ -0,0 +1 @@ +{"A":{"sources":["A.hs"],"modules":[],"modules-boot":["C"],"packages":[{"id":"base","name":"base","package-id":"base-4.20.0.0","modules":["Prelude"]}],"cpp":[],"options":["-XStrict","-fexpose-all-unfoldings"],"preprocessor":null},"B":{"sources":["lib/B.hs"],"modules":["A"],"modules-boot":[],"packages":[{"id":"base","name":"base","package-id":"base-4.20.0.0","modules":["Prelude"]}],"cpp":[],"options":[],"preprocessor":"./preproc.sh"},"C":{"sources":["C.hs","C.hs-boot"],"modules":["A","E"],"modules-boot":[],"packages":[{"id":"base","name":"base","package-id":"base-4.20.0.0","modules":["Prelude"]},{"id":"containers-0.7-inplace","name":"containers","package-id":"containers-0.7","modules":["Data.Set"]}],"cpp":[],"options":[],"preprocessor":null},"D":{"sources":["D.hs"],"modules":["B","C"],"modules-boot":[],"packages":[{"id":"base","name":"base","package-id":"base-4.20.0.0","modules":["Prelude"]}],"cpp":[],"options":[],"preprocessor":null},"E":{"sources":["E.hs"],"modules":[],"modules-boot":[],"packages":[{"id":"base","name":"base","package-id":"base-4.20.0.0","modules":["Prelude"]},{"id":"dep-1-Acdff5K3xp09fO6uiTrnge","name":"dep","package-id":"dep-1","modules":["Dep"]},{"id":"dep-1-8mhA0yJkyEn42CuhdNx93G-pub","name":"dep:pub","package-id":"dep-1","modules":["DepPub"]},{"id":"template-haskell","name":"template-haskell","package-id":"template-haskell-2.22.0.0","modules":["Language.Haskell.TH.Syntax"]}],"cpp":[],"options":[],"preprocessor":null}} \ No newline at end of file ===================================== testsuite/tests/driver/T24384/all.T ===================================== @@ -0,0 +1 @@ +test('T24384', [extra_files(['A.hs', 'B.hs', 'C.hs', 'C.hs-boot', 'D.hs', 'E.hs', 'preproc.sh', 'setup-dep.sh'])], makefile_test, []) ===================================== testsuite/tests/driver/T24384/preproc.sh ===================================== @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +sed '/preproc/d' $2 > $3 +echo 'import A' >> $3 ===================================== testsuite/tests/driver/T24384/setup-dep.sh ===================================== @@ -0,0 +1,65 @@ +#!/usr/bin/env bash + +set -eu + +ghc="$1" +ghc_opts="$2" +config_options="$3" +ghc_pkg="$4" +base=$(cd $(dirname $0); pwd) + +mkdir -p dep/{int,pub} +$ghc_pkg init ./db + +cd dep/ + +cat > dep.cabal < Dep.hs < int/DepInt.hs < pub/DepPub.hs < Setup.hs <