[Git][ghc/ghc][wip/buildplan] 2 commits: driver: implement --buildplan major mode to extract BuildPlan info from dependency analysis
Cheng Shao (@TerrorJack)
gitlab at gitlab.haskell.org
Mon Mar 10 15:05:35 UTC 2025
Cheng Shao pushed to branch wip/buildplan at Glasgow Haskell Compiler / GHC
Commits:
f7eed8ac by Cheng Shao at 2025-03-10T15:05:17+00:00
driver: implement --buildplan major mode to extract BuildPlan info from dependency analysis
- - - - -
267e74e1 by Cheng Shao at 2025-03-10T15:05:22+00:00
track non-hs deps
- - - - -
4 changed files:
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Unit/Module/Graph.hs
- docs/users_guide/expected-undocumented-flags.txt
- ghc/Main.hs
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -8,6 +8,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- -----------------------------------------------------------------------------
--
@@ -20,6 +21,10 @@
module GHC.Driver.Make (
depanal, depanalE, depanalPartial, checkHomeUnitsClosed,
load, loadWithCache, load', AnyGhcDiagnostic, LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,
+ ModuleGraphNodeWithBootFile(..),
+ BuildPlan(..),
+ computeBuildPlan,
+ speculateIface,
instantiationNodes,
downsweep,
@@ -73,6 +78,7 @@ import GHC.Driver.MakeSem
import GHC.Parser.Header
import GHC.ByteCode.Types
+import GHC.Iface.Binary
import GHC.Iface.Load ( cannotFindModule )
import GHC.IfaceToCore ( typecheckIface )
import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) )
@@ -92,6 +98,7 @@ import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Fingerprint
+import GHC.Utils.Json
import GHC.Utils.TmpFs
import GHC.Types.Basic
@@ -119,6 +126,7 @@ import qualified Data.Set as Set
import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
+import Control.Exception (evaluate)
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
@@ -482,6 +490,29 @@ newIfaceCache = do
load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
load how_much = loadWithCache noIfaceCache mkUnknownDiagnostic how_much
+computeBuildPlan :: GhcMonad m => m [BuildPlan]
+computeBuildPlan = do
+ msg <- mkBatchMsg <$> getSession
+ (errs, mod_graph) <- depanalE mkUnknownDiagnostic (Just msg) [] False
+ unless (isEmptyMessages errs) $ throwErrors (fmap GhcDriverMessage errs)
+ modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
+ guessOutputFile
+
+ liftIO $ evaluate $ createBuildPlan mod_graph Nothing
+
+speculateIface :: GhcMonad m => ModSummary -> m (Maybe ModIface)
+speculateIface ms = withSession $ \hsc_env -> liftIO $ do
+ let dflags = hsc_dflags hsc_env
+ profile = targetProfile dflags
+ name_cache = hsc_NC hsc_env
+ file_path
+ | ways dflags `hasWay` WayDyn = msDynHiFilePath ms
+ | otherwise = msHiFilePath ms
+ res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path
+ pure $ case res of
+ Right iface -> Just iface
+ _ -> Nothing
+
mkBatchMsg :: HscEnv -> Messager
mkBatchMsg hsc_env =
if length (hsc_all_home_unit_ids hsc_env) > 1
@@ -571,6 +602,19 @@ instance Outputable BuildPlan where
ppr (ResolvedCycle mgn) = text "ResolvedCycle:" <+> ppr mgn
ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn
+instance ToJson BuildPlan where
+ json (SingleModule mgn) = JSObject [
+ ("type", json "single-module"),
+ ("node", json mgn)
+ ]
+ json (ResolvedCycle mgn) = JSObject [
+ ("type", json "resolved-cycle"),
+ ("nodes", JSArray $ map (either json (\(ModuleGraphNodeWithBootFile mgn _) -> json mgn)) mgn)
+ ]
+ json (UnresolvedCycle mgn) = JSObject [
+ ("type", json "unresolved-cycle"),
+ ("nodes", JSArray $ map json mgn)
+ ]
-- Just used for an assertion
countMods :: BuildPlan -> Int
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -117,9 +117,11 @@ import GHC.Types.SourceFile ( hscSourceString, isHsigFile )
import GHC.Unit.Module.ModSummary
import GHC.Unit.Types
+import GHC.Utils.Json
import GHC.Utils.Outputable
import GHC.Unit.Module.ModIface
import GHC.Utils.Misc ( partitionWith )
+import GHC.Utils.Panic
import System.FilePath
import qualified Data.Map as Map
@@ -248,6 +250,29 @@ instance Outputable ModuleGraphNode where
LinkNode uid _ -> text "LN:" <+> ppr uid
UnitNode _ uid -> text "P:" <+> ppr uid
+instance ToJson ModuleGraphNode where
+ json (InstantiationNode {}) = panic "--buildplan: backpack not supported"
+ json (ModuleNode nks ms) = JSObject [
+ ("node-kind", json "compile"),
+ ("dependencies", JSArray $ map json nks),
+ ("unit_id", JSString $ unitIdString $ ms_unitid ms),
+ ("module_name", JSString $ moduleNameString $ moduleName $ ms_mod ms),
+ ("is_boot", JSBool $ isBootSummary ms == IsBoot),
+ ("hs_path", JSString $ normalise $ msHsFilePath ms),
+ ("uses_th", JSBool $ isTemplateHaskellOrQQNonBoot ms)
+ ]
+ json (LinkNode nks uid) = JSObject [
+ ("node-kind", json "link"),
+ ("dependencies", JSArray $ map json nks),
+ ("unit_id", JSString $ unitIdString uid)
+ ]
+ json (UnitNode nks uid) = JSObject [
+ ("node-kind", json "unit"),
+ ("dependencies", JSArray $ map (JSString . unitIdString) nks),
+ ("unit_id", JSString $ unitIdString uid)
+ ]
+
+
instance Eq ModuleGraphNode where
(==) = (==) `on` mkNodeKey
@@ -480,6 +505,12 @@ instance Outputable NodeKey where
ppr (NodeKey_Link uid) = ppr uid
ppr (NodeKey_ExternalUnit uid) = ppr uid
+instance ToJson NodeKey where
+ json (NodeKey_Unit {}) = panic "--buildplan: backpack not supported"
+ json (NodeKey_Module (ModNodeKeyWithUid mnwib uid)) = JSObject $ [("unit_id", JSString $ unitIdString uid), ("module_name", JSString $ moduleNameString $ gwib_mod mnwib), ("is_boot", JSBool $ gwib_isBoot mnwib == IsBoot)]
+ json (NodeKey_Link uid) = JSObject [("unit_id", JSString $ unitIdString uid)]
+ json (NodeKey_ExternalUnit uid) = JSObject [("unit_id", JSString $ unitIdString uid)]
+
mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey = \case
InstantiationNode _ iu -> NodeKey_Unit iu
=====================================
docs/users_guide/expected-undocumented-flags.txt
=====================================
@@ -1,6 +1,7 @@
-#include
--abi-hash
--backpack
+--buildplan
--show-packages
-Onot
-Walternative-layout-rule-transitional
=====================================
ghc/Main.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
@@ -17,7 +18,7 @@ module Main (main) where
-- The official GHC API
import qualified GHC
import GHC (parseTargetFiles, Ghc, GhcMonad(..),
- LoadHowMuch(..) )
+ LoadHowMuch(..), moduleName, moduleNameString )
import GHC.Driver.Backend
import GHC.Driver.CmdLine
@@ -28,6 +29,7 @@ import GHC.Driver.Phases
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Pipeline ( oneShot, compileFile )
+import GHC.Driver.Make ( ModuleGraphNodeWithBootFile(..), BuildPlan(..), computeBuildPlan, speculateIface )
import GHC.Driver.MakeFile ( doMkDependHS )
import GHC.Driver.Backpack ( doBackpack )
import GHC.Driver.Plugins
@@ -49,11 +51,14 @@ import GHC.Unit (UnitId)
import GHC.Unit.Home.PackageTable
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Module ( ModuleName, mkModuleName )
+import GHC.Unit.Module.Deps
+import GHC.Unit.Module.Graph
import GHC.Unit.Module.ModIface
import GHC.Unit.State ( pprUnits, pprUnitsSimple, emptyUnitState )
+import GHC.Unit.Module.ModSummary
import GHC.Unit.Finder ( findImportedModule, FindResult(..) )
import qualified GHC.Unit.State as State
-import GHC.Unit.Types ( IsBootInterface(..) )
+import GHC.Unit.Types ( IsBootInterface(..), unitIdString )
import GHC.Types.Basic ( failed )
import GHC.Types.SrcLoc
@@ -68,6 +73,8 @@ import GHC.Utils.Outputable as Outputable
import GHC.Utils.Monad ( liftIO, mapMaybeM )
import GHC.Utils.Binary ( openBinMem, put_ )
import GHC.Utils.Logger
+import GHC.Utils.Json
+import qualified GHC.Utils.Ppr as Ppr
import GHC.Settings.Config
import GHC.Settings.Constants
@@ -93,6 +100,7 @@ import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (throwE, runExceptT)
import Data.Char
+import Data.Foldable
import Data.List ( isPrefixOf, partition, intercalate, (\\) )
import qualified Data.Set as Set
import Prelude
@@ -182,6 +190,7 @@ main' postLoadMode units dflags0 args flagWarnings = do
DoEval _ -> (CompManager, interpreterBackend, LinkInMemory)
DoRun -> (CompManager, interpreterBackend, LinkInMemory)
DoMake -> (CompManager, dflt_backend, LinkBinary)
+ DoBuildPlan _ -> (CompManager, dflt_backend, LinkBinary)
DoBackpack -> (CompManager, dflt_backend, LinkBinary)
DoMkDependHS -> (MkDepend, dflt_backend, LinkBinary)
DoAbiHash -> (OneShot, dflt_backend, LinkBinary)
@@ -309,6 +318,7 @@ main' postLoadMode units dflags0 args flagWarnings = do
(hsc_NC hsc_env)
f
DoMake -> doMake units srcs
+ DoBuildPlan f -> doBuildPlan f units srcs
DoMkDependHS -> doMkDependHS (map fst srcs)
StopBefore p -> liftIO (oneShot hsc_env p srcs)
DoInteractive -> ghciUI units srcs Nothing
@@ -502,6 +512,7 @@ data PostLoadMode
| StopBefore StopPhase -- ghc -E | -C | -S
-- StopBefore StopLn is the default
| DoMake -- ghc --make
+ | DoBuildPlan FilePath -- ghc --buildplan
| DoBackpack -- ghc --backpack foo.bkp
| DoInteractive -- ghc --interactive
| DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
@@ -519,6 +530,9 @@ doRunMode = mkPostLoadMode DoRun
doAbiHashMode = mkPostLoadMode DoAbiHash
showUnitsMode = mkPostLoadMode ShowPackages
+doBuildPlanMode :: FilePath -> Mode
+doBuildPlanMode f = mkPostLoadMode (DoBuildPlan f)
+
showInterfaceMode :: FilePath -> Mode
showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
@@ -584,6 +598,7 @@ isLinkMode _ = False
isCompManagerMode :: PostLoadMode -> Bool
isCompManagerMode DoRun = True
isCompManagerMode DoMake = True
+isCompManagerMode (DoBuildPlan _) = True
isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _) = True
isCompManagerMode _ = False
@@ -665,6 +680,7 @@ mode_flags =
, defFlag "S" (PassFlag (setMode (stopBeforeMode StopAs)))
, defFlag "-run" (PassFlag (setMode doRunMode))
, defFlag "-make" (PassFlag (setMode doMakeMode))
+ , defFlag "-buildplan" (HasArg (\f -> setMode (doBuildPlanMode f) "--buildplan"))
, defFlag "unit" (SepArg (\s -> addUnit s "-unit"))
, defFlag "-backpack" (PassFlag (setMode doBackpackMode))
, defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
@@ -764,6 +780,39 @@ doMake units targets = do
ok_flag <- GHC.load LoadAllTargets
when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
+doBuildPlan :: FilePath -> [String] -> [(String, Maybe Phase)] -> Ghc ()
+doBuildPlan out units targets = do
+ hs_srcs <- case NE.nonEmpty units of
+ Just ne_units -> do
+ initMulti ne_units
+ Nothing -> do
+ s <- initMake targets
+ return $ map (uncurry (,Nothing,)) s
+ build_plan <- case hs_srcs of
+ [] -> pure []
+ _ -> do
+ targets' <- mapM (\(src, uid, phase) -> GHC.guessTarget src uid phase) hs_srcs
+ GHC.setTargets targets'
+ computeBuildPlan
+ let on_usage ms (UsageFile {usg_file_path, usg_file_nonhs = True}) acc = JSObject [("unit_id", JSString $ unitIdString $ ms_unitid ms), ("module_name", JSString $ moduleNameString $ moduleName $ ms_mod ms), ("usage_file", JSString $ unpackFS usg_file_path)] : acc
+ on_usage _ _ acc = acc
+
+ on_mod_summary ms acc = do
+ maybe_iface <- speculateIface ms
+ pure $ case maybe_iface of
+ Just iface | Just usages <- mi_usages iface -> foldr (on_usage ms) acc usages
+ Nothing -> acc
+
+ on_node (ModuleNode _ ms) acc = on_mod_summary ms acc
+ on_node _ acc = pure acc
+
+ on_buildplan (SingleModule node) acc = on_node node acc
+ on_buildplan (ResolvedCycle nodes) acc = foldrM on_node acc $ map (either id (\(ModuleGraphNodeWithBootFile node _) -> node)) nodes
+ on_buildplan (UnresolvedCycle nodes) acc = foldrM on_node acc nodes
+ usage_files <- foldrM on_buildplan [] build_plan
+ liftIO $ withBinaryFile out WriteMode $ \h ->
+ printSDoc defaultSDocContext Ppr.OneLineMode h $ renderJSON $ JSObject [("build_plan", JSArray $ map json build_plan), ("usage_files", JSArray usage_files)]
+
initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)]
initMake srcs = do
let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/96fdb8a59aa502380a1a764508ebe502c66db90d...267e74e1b1106d656806d4731efbaf281eb62537
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/96fdb8a59aa502380a1a764508ebe502c66db90d...267e74e1b1106d656806d4731efbaf281eb62537
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250310/29040b95/attachment-0001.html>
More information about the ghc-commits
mailing list