Hannes Siebenhandl pushed to branch wip/fendor/dep-json at Glasgow Haskell Compiler / GHC Commits: 776eb729 by fendor at 2026-09-24T14:54:13+02:00 Refactor Makefile to use phases appropriately Prepare refactoring to allow json and Makefile implementation - - - - - ba42becc by fendor at 2026-09-24T14:54:15+02:00 Abstract dependency processing from Makefile generation Allows multiple consumers - - - - - 020bc06b by fendor at 2026-09-24T14:54:15+02:00 Add json output format - - - - - 10 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/Phases.hs - compiler/GHC/Driver/Session.hs - docs/users_guide/separate_compilation.rst - testsuite/tests/driver/T24384/Makefile - + testsuite/tests/driver/T24384/T24384b.stdout - testsuite/tests/driver/T24384/all.T Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -351,6 +351,7 @@ data DynFlags = DynFlags { -- For ghc -M depMakefile :: FilePath, + depJson :: Maybe FilePath, depIncludePkgDeps :: Bool, depIncludeCppDeps :: Bool, depExcludeMods :: [ModuleName], @@ -694,6 +695,7 @@ defaultDynFlags mySettings = -- ghc -M values depMakefile = "Makefile", + depJson = Nothing, depIncludePkgDeps = False, depIncludeCppDeps = False, depExcludeMods = [], ===================================== compiler/GHC/Driver/MakeFile.hs ===================================== @@ -7,6 +7,8 @@ -- (c) The University of Glasgow 2005 -- ----------------------------------------------------------------------------- +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RecordWildCards #-} module GHC.Driver.MakeFile ( doMkDependHS @@ -16,47 +18,68 @@ where import GHC.Prelude -import qualified GHC -import GHC.Driver.Make -import GHC.Driver.Monad +import GHC qualified + +import GHC.Data.Bag (listToBag) +import GHC.Data.FastString (lexicalCompareFS, unpackFS) +import GHC.Data.Graph.Directed (SCC (..)) +import GHC.Data.OsPath + import GHC.Driver.DynFlags -import GHC.Utils.Misc import GHC.Driver.Env import GHC.Driver.Errors.Types -import GHC.Types.UnresolvedImport -import qualified GHC.SysTools as SysTools -import GHC.Data.Graph.Directed ( SCC(..) ) -import GHC.Data.OsPath (unsafeDecodeUtf) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Types.SourceError -import GHC.Types.SrcLoc -import GHC.Types.PkgQual -import Data.List (partition) -import GHC.Utils.TmpFs +import GHC.Driver.Make +import GHC.Driver.Monad +import GHC.Driver.Phases +import GHC.Driver.Pipeline +import GHC.Driver.Pipeline.Monad +import GHC.Driver.Session +import GHC.Iface.Errors.Types import GHC.Iface.Load (cannotFindModule) +import GHC.SysTools qualified as SysTools +import GHC.Types.PkgQual +import GHC.Types.SourceError +import GHC.Types.SrcLoc +import GHC.Types.Unique.Set (UniqSet) +import GHC.Types.Unique.Set qualified as UniqSet +import GHC.Types.UnresolvedImport + +import GHC.Unit.Finder +import GHC.Unit.Info import GHC.Unit.Module -import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph -import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary +import GHC.Unit.State (lookupUnitId) -import GHC.Utils.Exception import GHC.Utils.Error +import GHC.Utils.Exception +import GHC.Utils.Json import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.TmpFs +import Control.Monad (when) +import Data.Either +import Data.Foldable (traverse_) +import Data.IORef +import Data.List (partition) +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust, isNothing) +import Data.Semigroup qualified as Semigroup +import Data.Set qualified as Set +import GHC.Generics (Generic, Generically (..)) import System.Directory -import System.FilePath +import qualified System.Directory as Directory +import System.OsPath as OsPath import System.IO -import System.IO.Error ( isEOFError ) -import Control.Monad ( when, forM_ ) -import Data.Maybe ( isJust ) -import Data.IORef -import qualified Data.Set as Set -import GHC.Iface.Errors.Types -import Data.Either -import GHC.Data.Bag (listToBag) +import System.IO.Error (isEOFError) +import qualified System.OsString as OsString +import qualified Data.Monoid as Monoid +import qualified System.FilePath as FilePath ----------------------------------------------------------------- -- @@ -98,27 +121,47 @@ doMkDependHS srcs = do doMkDependModuleGraph :: GhcMonad m => DynFlags -> ModuleGraph -> m () doMkDependModuleGraph dflags module_graph = do + hsc_env <- getSession logger <- getLogger - tmpfs <- hsc_tmpfs <$> getSession - let excl_mods = depExcludeMods dflags + let + tmpfs = hsc_tmpfs hsc_env + excl_mods = depExcludeMods dflags - files <- liftIO $ beginMkDependHS logger tmpfs dflags - let sorted = GHC.topSortModuleGraph False module_graph Nothing + root_ <- liftIO getCurrentDirectory + root <- encodeUtf root_ + let + backends = concat + [ [ initFileDepWriter logger root tmpfs dflags + ] + , [ initJsonDepWriter json_output dflags + | Just json_output <- [depJson dflags] + ] + ] + + + let sorted = GHC.topSortModuleGraph False module_graph Nothing -- Print out the dependencies if wanted liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted) - -- Process them one by one, dumping results into makefile - -- and complaining about cycles - hsc_env <- getSession - root <- liftIO getCurrentDirectory - mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted + liftIO $ do + + -- Setup the writers + writers <- sequenceA backends + sinks <- traverse dw_beginWriter writers - -- If -ddump-mod-cycles, show cycles in the module graph - liftIO $ dumpModCycles logger module_graph + -- Do the actual work + do + -- Process them one by one, dumping results and complaining about cycles + mapM_ (processDeps dflags hsc_env (UniqSet.mkUniqSet excl_mods) sinks) sorted + + -- If -ddump-mod-cycles, show cycles in the module graph + liftIO $ dumpModCycles logger module_graph + + -- Tidy up + do + traverse_ dw_endWriter writers - -- 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 @@ -127,6 +170,200 @@ doMkDependModuleGraph dflags module_graph = do --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) +-------------------------------------------------------------------------------- +-- Types abstracting over the output +-------------------------------------------------------------------------------- + +data DepNode = + DepNode + { dn_mod :: Module + , dn_src :: OsPath + , dn_obj :: OsPath + , dn_hi :: OsPath + , dn_boot :: IsBootInterface + , dn_preprocessing :: PreprocessingNode + } + +data PreprocessingNode = PreprocessingNode + { pn_preprocessor :: Maybe String + , pn_options :: [String] + } + +data Dep + = DepHi + { dep_mod :: Module + , dep_path :: OsPath + , dep_unit :: Maybe UnitInfo + , dep_local :: Bool + , dep_boot :: IsBootInterface + } + | DepCpp + { dep_path :: OsPath + } + +data DependencyWriter = DependencyWriter + { dw_beginWriter :: IO DepSink + , dw_endWriter :: IO () + } + +data DepSink = DepSink + { ds_writeDependency :: DepNode -> [Dep] -> IO () + } + +----------------------------------------------------------------- +-- +-- processDeps +-- +----------------------------------------------------------------- + +processDeps :: DynFlags + -> HscEnv + -> UniqSet ModuleName -- ^ Excludes + -> [DepSink] + -> SCC ModuleGraphNode + -> IO () +-- Write suitable dependencies to handle +-- Always: +-- this.o : this.hs +-- +-- If the dependency is on something other than a .hi file: +-- this.o this.p_o ... : dep +-- otherwise +-- this.o ... : dep.hi +-- this.p_o ... : dep.p_hi +-- ... +-- (where .o is $osuf, and the other suffixes come from +-- the cmdline -s options). +-- +-- For {-# SOURCE #-} imports the "hi" will be "hi-boot". + +processDeps _ hsc_env _ _ (CyclicSCC nodes) + = -- There shouldn't be any cycles; report them + throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $ cyclicModuleErr nodes + +processDeps _ hsc_env _ _ (AcyclicSCC (InstantiationNode _uid node)) + = -- There shouldn't be any backpack instantiations; report them as well + throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $ + mkPlainErrorMsgEnvelope noSrcSpan $ + GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node + +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 sinks (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do + pp <- preprocessor + let + dep_node = mkDepNode pp + find_deps imps = do + cpp_deps <- find_cpp_deps + import_deps <- find_import_deps imps + pure $ map Right cpp_deps ++ import_deps + (missing_dep_errs, deps) <- partitionEithers <$> find_deps (ms_imps node) + + if null missing_dep_errs + then do + traverse_ (\ sink -> ds_writeDependency sink dep_node deps) sinks + else do + let sec = initSourceErrorContext (hsc_dflags hsc_env) + throwErrors sec (mkMessages (listToBag missing_dep_errs)) + where + src_file = msHsFileOsPath node + mkDepNode preproc = + DepNode + { dn_mod = ms_mod node + , dn_src = src_file + , dn_obj = msObjFileOsPath node + , dn_hi = msHiFileOsPath node + , dn_boot = isBootSummary node + , dn_preprocessing = preproc + } + + preprocessor :: IO PreprocessingNode + preprocessor + | Just src <- ml_hs_file (ms_location node) + = runPipeline (hsc_hooks hsc_env) $ do + let + (_, suffix) = FilePath.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, opts, _, _) <- use (T_FileArgs (hsc_logger hsc_env) (ms_hspp_opts node) unlit_fn) + let pp = pgm_F dflags1 + pure PreprocessingNode + { pn_preprocessor = if null pp then global_preprocessor else Just pp + , pn_options = opts + } + | otherwise + = pure PreprocessingNode + { pn_preprocessor = global_preprocessor + , pn_options = [] + } + + global_preprocessor :: Maybe String + 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). + find_cpp_deps :: IO [Dep] + find_cpp_deps = + if depIncludeCppDeps dflags + then do + session <- Session <$> newIORef hsc_env + parsedMod <- reflectGhc (GHC.parseModule node) session + pure (DepCpp . unsafeEncodeUtf <$> GHC.pm_extra_src_files parsedMod) + else + pure [] + + -- Emit a dependency for each import + find_import_deps :: [UnresolvedImport PkgQual] -> IO [Either (MsgEnvelope GhcMessage) Dep] + find_import_deps idecls = + sequence + [ findDependency hsc_env decl + | decl <- idecls + , let L _loc mod = ui_mod_name decl + , not $ mod `UniqSet.elementOfUniqSet` excl_mods + ] + +findDependency :: HscEnv + -> UnresolvedImport PkgQual -- The import to find + -> IO (Either (MsgEnvelope GhcMessage) Dep) -- Interface file +findDependency hsc_env imp = do + -- Find the module; this will be fast because + -- we've done it once during downsweep. + r <- resolveImport hsc_env imp + case r of + Found loc dep_mod -> + pure $ Right + DepHi + { dep_mod = dep_mod + , dep_path = ml_hi_file_ospath loc + , dep_unit = lookupUnitId (hsc_units hsc_env) (moduleUnitId dep_mod) + , dep_local = isJust (ml_hs_file loc) + , dep_boot = is_boot + } + + fail -> + return $ + Left $ + mkPlainErrorMsgEnvelope srcloc $ + GhcDriverMessage $ DriverInterfaceError $ + (Can'tFindInterface (cannotFindModule hsc_env mod_name fail) (LookingForModule mod_name is_boot)) + where + L srcloc mod_name = ui_mod_name imp + is_boot = ui_boot imp + ----------------------------------------------------------------- -- -- beginMkDependHs @@ -136,6 +373,18 @@ doMkDependModuleGraph dflags module_graph = do -- ----------------------------------------------------------------- +initFileDepWriter :: Logger -> OsPath -> TmpFs -> DynFlags -> IO DependencyWriter +initFileDepWriter logger root tmpfs dflags = do + files <- beginMkDependHS logger tmpfs dflags + pure DependencyWriter + { dw_beginWriter = do + pure $ DepSink $ \ node deps -> do + writeDependencies (depIncludePkgDeps dflags) root (mkd_tmp_hdl files) suffixes node deps + , dw_endWriter = endMkDependHS logger files + } + where + suffixes = map unsafeEncodeUtf (depSuffixes dflags) + data MkDepFiles = MkDep { mkd_make_file :: FilePath, -- Name of the makefile mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile @@ -151,7 +400,7 @@ beginMkDependHS logger tmpfs dflags = do -- open the makefile let makefile = depMakefile dflags - exists <- doesFileExist makefile + exists <- Directory.doesFileExist makefile mb_make_hdl <- if not exists then return Nothing @@ -188,141 +437,55 @@ beginMkDependHS logger tmpfs dflags = do return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) +writeDependencies :: + Bool -> + OsPath -> + Handle -> + [OsString] -> + -- ^ Suffixes + 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 (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_unit} + | isNothing dep_unit || include_pkgs + -> [([obj], hi) | (obj, hi) <- zip obj_files (suffixed dep_path)] ------------------------------------------------------------------ --- --- processDeps --- ------------------------------------------------------------------ - -processDeps :: DynFlags - -> HscEnv - -> [ModuleName] - -> FilePath - -> Handle -- Write dependencies to here - -> SCC ModuleGraphNode - -> IO () --- Write suitable dependencies to handle --- Always: --- this.o : this.hs --- --- If the dependency is on something other than a .hi file: --- this.o this.p_o ... : dep --- otherwise --- this.o ... : dep.hi --- this.p_o ... : dep.p_hi --- ... --- (where .o is $osuf, and the other suffixes come from --- the cmdline -s options). --- --- For {-# SOURCE #-} imports the "hi" will be "hi-boot". - -processDeps _ hsc_env _ _ _ (CyclicSCC nodes) - = -- There shouldn't be any cycles; report them - throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $ cyclicModuleErr nodes - -processDeps _ hsc_env _ _ _ (AcyclicSCC (InstantiationNode _uid node)) - = -- There shouldn't be any backpack instantiations; report them as well - throwOneError (initSourceErrorContext (hsc_dflags hsc_env)) $ - mkPlainErrorMsgEnvelope noSrcSpan $ - GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node - -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 - - - - -- 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 find_deps imps = sequence - [ findDependency hsc_env imp include_pkg_deps - | imp <- imps - , unLoc (ui_mod_name imp) `notElem` excl_mods - ] - - do_imp 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) + | otherwise + -> [] - ; (missing_dep_errs, deps) <- partitionEithers <$> find_deps (ms_imps node) + DepCpp {dep_path} -> [(obj_files, dep_path)] - ; if null missing_dep_errs - then mapM_ (mapM_ do_imp) deps - else do - let sec = initSourceErrorContext (hsc_dflags hsc_env) - throwErrors sec (mkMessages (listToBag missing_dep_errs)) - } + write (from, to) = writeDependency root hdl from to -findDependency :: HscEnv - -> UnresolvedImport PkgQual -- The import to find - -> Bool -- Record dependency on package modules - -> IO (Either (MsgEnvelope GhcMessage) (Maybe FilePath)) -- Interface file -findDependency hsc_env imp include_pkg_deps = do - -- Find the module; this will be fast because - -- we've done it once during downsweep. - r <- resolveImport hsc_env imp - 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 (Right (Just (ml_hi_file loc))) + obj_files = suffixed dn_obj - -- Not in this package: we don't need a dependency - | otherwise - -> return (Right Nothing) + suffixed f = insertSuffixes f suffixes - fail -> - return $ - Left $ - mkPlainErrorMsgEnvelope srcloc $ - GhcDriverMessage $ DriverInterfaceError $ - (Can'tFindInterface (cannotFindModule hsc_env mod_name fail) (LookingForModule mod_name is_boot)) - where - L srcloc mod_name = ui_mod_name imp - is_boot = ui_boot imp + DepNode {dn_src, dn_obj, dn_hi, dn_boot} = node ----------------------------- -writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () +writeDependency :: OsPath -> Handle -> [OsPath] -> OsPath -> IO () -- (writeDependency r h [t1,t2] dep) writes to handle h the dependency -- t1 t2 : dep writeDependency root hdl targets dep @@ -330,33 +493,30 @@ writeDependency root hdl targets dep -- c:/foo/... -- on Windows as make gets confused by the : -- Making relative deps avoids some instances of this. - dep' = makeRelative root dep - forOutput = escapeSpaces . reslash Forwards . normalise + dep' = OsPath.makeRelative root dep + forOutput = escapeSpaces . reslash Forwards . unsafeDecodeUtf . OsPath.normalise output = unwords (map forOutput targets) ++ " : " ++ forOutput dep' hPutStrLn hdl output ----------------------------- insertSuffixes - :: FilePath -- Original filename; e.g. "foo.o" - -> [String] -- Suffix prefixes e.g. ["x_", "y_"] - -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] + :: OsPath -- Original filename; e.g. "foo.o" + -> [OsString] -- Suffix prefixes e.g. ["x_", "y_"] + -> [OsPath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] -- Note that the extra bit gets inserted *before* the old suffix -- We assume the old suffix contains no dots, so we know where to -- split it insertSuffixes file_name extras - = [ basename <.> (extra ++ suffix) | extra <- extras ] + = [ basename <.> (extra Monoid.<> suffix) | extra <- extras ] where - (basename, suffix) = case splitExtension file_name of + (basename, suffix) = case OsPath.splitExtension file_name of -- Drop the "." from the extension - (b, s) -> (b, drop 1 s) + (b, s) -> (b, OsString.drop 1 s) ----------------------------------------------------------------- --- --- endMkDependHs --- Complete the makefile, close the tmp file etc --- ------------------------------------------------------------------ +-- endMkDependHs +-- Complete the makefile, close the tmp file etc endMkDependHS :: Logger -> MkDepFiles -> IO () @@ -385,6 +545,186 @@ endMkDependHS logger showPass logger "Installing new makefile" SysTools.copyFile tmp_file makefile +----------------------------------------------------------------- +-- +-- JSON MkDepends output +-- +----------------------------------------------------------------- + +initJsonDepWriter :: FilePath -> DynFlags -> IO DependencyWriter +initJsonDepWriter output dflags = do + json_var <- mkJsonOutput output initDepJson + pure DependencyWriter + { dw_beginWriter = + pure $ DepSink $ \ node deps -> + updateJson json_var (updateDepJson (depIncludePkgDeps dflags) node deps) + , dw_endWriter = + writeJsonOutput json_var + } + +-------------------------------------------------------------------------------- +-- 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 + } + +-- | TODO: @fendor +mkJsonOutput :: + FilePath -> + IO (IORef a) -> + IO (JsonOutput a) +mkJsonOutput json_path mk_ref = 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 :: JsonOutput a -> (a -> a) -> IO () +updateJson JsonOutput {json_ref} f = modifyIORef' json_ref f + +-- | Write a json object to the flag-dependent file if the output target is +-- present. +writeJsonOutput :: + ToJson a => + JsonOutput a -> + IO () +writeJsonOutput JsonOutput {json_ref, json_path} = do + payload <- readIORef json_ref + writeJsonFile payload json_path + +-------------------------------------------------------------------------------- +-- Output helpers + +writeJsonFile :: ToJson a => a -> FilePath -> IO () +writeJsonFile doc p = do + withAtomicRename p + $ \tmp -> writeFile tmp $ showSDocUnsafe $ renderJSON $ json doc + +-------------------------------------------------------------------------------- +-- Payload for -dep-json + +newtype PackageDeps + = PackageDeps (Map.Map (String, UnitId, DPackageId) (Set.Set ModuleName)) + deriving newtype (Monoid) + +newtype DPackageId = DPackageId PackageId + deriving newtype (Eq) + +instance Ord DPackageId where + DPackageId (PackageId d1) `compare` DPackageId (PackageId d2) = d1 `lexicalCompareFS` d2 + +instance Semigroup PackageDeps where + PackageDeps l <> PackageDeps r = PackageDeps (Map.unionWith (Semigroup.<>) l r) + +data Deps + = Deps + { sources :: Set.Set OsPath + , modules :: (Set.Set ModuleName, Set.Set ModuleName) + , packages :: PackageDeps + , cpp :: Set.Set OsPath + , options :: [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 (showOsPath . normalise)), + ("modules", array (fst modules) moduleNameString), + ("modules-boot", array (snd modules) moduleNameString), + ("packages", + JSArray + [ package name unit_id package_id mods + | ((name, unit_id, dpkd_id), mods) <- Map.toList packages + , let DPackageId package_id = dpkd_id + ] + ), + ("cpp", array cpp showOsPath), + ("options", JSArray $ map JSString options), + ("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)) + + showOsPath = unsafeDecodeUtf + +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 -> DepNode -> [Dep] -> DepJson -> DepJson +updateDepJson include_pkgs DepNode {..} deps = + insertDepJson [moduleName dn_mod] payload + where + payload = node_data Semigroup.<> foldMap dep deps + + node_data = + mempty { + sources = Set.singleton dn_src, + preprocessor = pn_preprocessor dn_preprocessing, + options = pn_options dn_preprocessing + } + + 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, DPackageId $ unitPackageId unit) + -> mempty {packages = PackageDeps (Map.singleton key (Set.singleton $ moduleName dep_mod))} + + | otherwise + -> mempty + + DepCpp {dep_path} -> + mempty {cpp = Set.singleton dep_path} + ----------------------------------------------------------------- -- Module cycles ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -820,13 +820,13 @@ preprocessPipeline pipe_env hsc_env input_fn = do use (T_Unlit pipe_env hsc_env input_fn) - (dflags1, p_warns1, warns1) <- use (T_FileArgs hsc_env unlit_fn) + (dflags1, _, p_warns1, warns1) <- use (fileArgsPhase hsc_env unlit_fn) let hsc_env1 = hscSetFlags dflags1 hsc_env (cpp_fn, hsc_env2) <- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn) - (dflags2, _, _) <- use (T_FileArgs hsc_env1 cpp_fn) + (dflags2, _, _, _) <- use (fileArgsPhase hsc_env1 cpp_fn) let hsc_env2 = hscSetFlags dflags2 hsc_env1 return (cpp_fn, hsc_env2) @@ -841,7 +841,8 @@ preprocessPipeline pipe_env hsc_env input_fn = do then return (dflags1, p_warns1, warns1) else do -- Reparse with original hsc_env so that we don't get duplicated options - use (T_FileArgs hsc_env pp_fn) + (dflagsPP, _, p_warns3, warns3) <- use (fileArgsPhase hsc_env pp_fn) + pure (dflagsPP, p_warns3, warns3) let print_config = initPrintConfig dflags3 liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3)) @@ -865,6 +866,9 @@ preprocessPipeline pipe_env hsc_env input_fn = do runAfter phase def $ phaseIfFlag hsc_env flag def action + fileArgsPhase env fn = + T_FileArgs (hsc_logger env) (hsc_dflags env) fn + -- | The complete compilation pipeline, from start to finish fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, RecompLinkables) fullPipeline pipe_env hsc_env pp_fn src_flavour = do ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -104,7 +104,7 @@ runPhase :: TPhase out -> IO out runPhase (T_Unlit pipe_env hsc_env inp_path) = do out_path <- phaseOutputFilenameNew (Cpp HsSrcFile) pipe_env hsc_env Nothing runUnlitPhase hsc_env inp_path out_path -runPhase (T_FileArgs hsc_env inp_path) = getFileArgs hsc_env inp_path +runPhase (T_FileArgs logger dflags inp_path) = getFileArgsNoHsc logger dflags inp_path runPhase (T_Cpp pipe_env hsc_env inp_path) = do out_path <- phaseOutputFilenameNew (HsPp HsSrcFile) pipe_env hsc_env Nothing runCppPhase hsc_env inp_path out_path @@ -620,17 +620,21 @@ runUnlitPhase hsc_env input_fn output_fn = do return output_fn -getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, Messages DriverMessage)) +getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, [String], Messages PsMessage, Messages DriverMessage)) getFileArgs hsc_env input_fn = do let dflags0 = hsc_dflags hsc_env logger = hsc_logger hsc_env - parser_opts = initParserOpts dflags0 + getFileArgsNoHsc logger dflags0 input_fn + +getFileArgsNoHsc :: Logger -> DynFlags -> FilePath -> IO ((DynFlags, [String], Messages PsMessage, Messages DriverMessage)) +getFileArgsNoHsc logger dflags0 input_fn = do + let parser_opts = initParserOpts dflags0 sec = initSourceErrorContext dflags0 (warns0, src_opts) <- getOptionsFromFile parser_opts sec (supportedLanguagePragmas dflags0) input_fn (dflags1, unhandled_flags, warns) <- parseDynamicFilePragma logger dflags0 src_opts checkProcessArgsResult dflags0 unhandled_flags - return (dflags1, warns0, warns) + return (dflags1, map unLoc src_opts, warns0, warns) runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath runCppPhase hsc_env input_fn output_fn = do ===================================== compiler/GHC/Driver/Pipeline/Phases.hs ===================================== @@ -13,6 +13,7 @@ import GHC.Driver.Errors.Types import GHC.Fingerprint.Type import GHC.Unit.Module.Location ( ModLocation ) import GHC.Unit.Module.ModIface +import GHC.Utils.Logger import GHC.Driver.Phases import Language.Haskell.Syntax.Module.Name ( ModuleName ) @@ -25,7 +26,7 @@ import GHC.Unit.Home.ModInfo -- phase if the inputs have been modified. data TPhase res where T_Unlit :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath - T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, Messages DriverMessage) + T_FileArgs :: Logger -> DynFlags -> FilePath -> TPhase ((DynFlags, [String], Messages PsMessage, Messages DriverMessage)) T_Cpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_HsPp :: PipeEnv -> HscEnv -> FilePath -> FilePath -> TPhase FilePath T_HscRecomp :: PipeEnv -> HscEnv -> FilePath -> HscSource -> TPhase (HscEnv, ModSummary, HscRecompStatus) ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -791,6 +791,12 @@ addOptCmmP f = alterToolSettings $ \s -> s setDepMakefile :: FilePath -> DynFlags -> DynFlags setDepMakefile f d = d { depMakefile = f } +setDepJson :: FilePath -> DynFlags -> DynFlags +setDepJson f d = d { depJson = Just f } + +unsetDepJson :: DynFlags -> DynFlags +unsetDepJson d = d { depJson = Nothing } + setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } @@ -1261,6 +1267,8 @@ dynamic_flags_deps = [ -------- ghc -M ----------------------------------------------------- , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) + , make_ord_flag defGhcFlag "dep-json" (hasArg setDepJson) + , make_ord_flag defGhcFlag "no-dep-json" (noArg unsetDepJson) , make_ord_flag defGhcFlag "include-cpp-deps" (noArg (setDepIncludeCppDeps True)) , make_ord_flag defGhcFlag "include-pkg-deps" ===================================== docs/users_guide/separate_compilation.rst ===================================== @@ -1503,6 +1503,23 @@ generation are: ``.depend`` and then ``include`` the file ``.depend`` into ``Makefile``. +.. ghc-flag:: -dep-json ⟨file⟩ + :shortdesc: Also emit ⟨file⟩ as a JSON file containing dependencies + :type: dynamic + :reverse: -no-dep-json + :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"``. + .. ghc-flag:: -dep-suffix ⟨suffix⟩ :shortdesc: Make dependencies that declare that files with suffix ``.⟨suf⟩⟨osuf⟩`` depend on interface files with suffix ``.⟨suf⟩hi`` ===================================== testsuite/tests/driver/T24384/Makefile ===================================== @@ -38,3 +38,11 @@ T24384a: T24384_prep A.hs lib/B.hs C.hs D.hs E.hs cat T24384a.Makefile + +T24384b: T24384_prep + '$(TEST_HC)' -M -dep-json dep.json -include-pkg-deps -include-cpp-deps \ + -hide-all-packages -package base -package containers -package template-haskell \ + -package-db ./$(PKGCONF_LOCAL) -package-id dep-1-XXX -package-id dep-public-1-XXX \ + A.hs lib/B.hs C.hs D.hs E.hs + + cat dep.json | jq --sort-keys ===================================== testsuite/tests/driver/T24384/T24384b.stdout ===================================== @@ -0,0 +1,157 @@ +{ + "A": { + "cpp": [], + "modules": [], + "modules-boot": [ + "C" + ], + "options": [ + "-XStrict", + "-fexpose-all-unfoldings" + ], + "packages": [ + { + "id": "base-4.23.0.0-inplace", + "modules": [ + "GHC.Essentials", + "Prelude" + ], + "name": "base", + "package-id": "base-4.23.0.0" + } + ], + "preprocessor": null, + "sources": [ + "A.hs" + ] + }, + "B": { + "cpp": [], + "modules": [ + "A" + ], + "modules-boot": [], + "options": [ + "-F", + "-pgmF", + "./preproc.sh" + ], + "packages": [ + { + "id": "base-4.23.0.0-inplace", + "modules": [ + "GHC.Essentials", + "Prelude" + ], + "name": "base", + "package-id": "base-4.23.0.0" + } + ], + "preprocessor": "./preproc.sh", + "sources": [ + "lib/B.hs" + ] + }, + "C": { + "cpp": [], + "modules": [ + "A", + "E" + ], + "modules-boot": [], + "options": [], + "packages": [ + { + "id": "base-4.23.0.0-inplace", + "modules": [ + "GHC.Essentials", + "Prelude" + ], + "name": "base", + "package-id": "base-4.23.0.0" + }, + { + "id": "containers-0.8-inplace", + "modules": [ + "Data.Set" + ], + "name": "containers", + "package-id": "containers-0.8" + } + ], + "preprocessor": null, + "sources": [ + "C.hs", + "C.hs-boot" + ] + }, + "D": { + "cpp": [], + "modules": [ + "B", + "C" + ], + "modules-boot": [], + "options": [], + "packages": [ + { + "id": "base-4.23.0.0-inplace", + "modules": [ + "GHC.Essentials", + "Prelude" + ], + "name": "base", + "package-id": "base-4.23.0.0" + } + ], + "preprocessor": null, + "sources": [ + "D.hs" + ] + }, + "E": { + "cpp": [], + "modules": [], + "modules-boot": [], + "options": [], + "packages": [ + { + "id": "base-4.23.0.0-inplace", + "modules": [ + "GHC.Essentials", + "Prelude" + ], + "name": "base", + "package-id": "base-4.23.0.0" + }, + { + "id": "dep-1-XXX", + "modules": [ + "Dep" + ], + "name": "dep", + "package-id": "dep-1" + }, + { + "id": "dep-public-1-XXX", + "modules": [ + "DepPublic" + ], + "name": "dep-public", + "package-id": "dep-public-1" + }, + { + "id": "template-haskell-2.25.0.0-inplace", + "modules": [ + "Language.Haskell.TH.Syntax" + ], + "name": "template-haskell", + "package-id": "template-haskell-2.25.0.0" + } + ], + "preprocessor": null, + "sources": [ + "E.hs" + ] + } +} ===================================== testsuite/tests/driver/T24384/all.T ===================================== @@ -5,3 +5,4 @@ test_extras = extra_files( ]) test('T24384a', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep') ], makefile_test, []) +test('T24384b', [ test_extras, pre_cmd('$MAKE -s --no-print-directory T24384_prep') ], makefile_test, []) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a20c20326d9f7672efb0114b0359e37... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a20c20326d9f7672efb0114b0359e37... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help