Hannes Siebenhandl pushed to branch wip/fendor/dep-json-link-nodes at Glasgow Haskell Compiler / GHC Commits: 411a9167 by fendor at 2026-10-15T13:48:50+02:00 WIP: Add support for link nodes - - - - - 19 changed files: - compiler/GHC/Driver/MakeFile.hs - testsuite/tests/driver/mkdepend/all.T - + testsuite/tests/driver/mkdepend/mhu04/app/Main.hs - + testsuite/tests/driver/mkdepend/mhu04/app/Utils.hs - + testsuite/tests/driver/mkdepend/mhu04/lib/Lib.hs - + testsuite/tests/driver/mkdepend/mhu04/lib/Lib/Internal.hs - + testsuite/tests/driver/mkdepend/mhu04/unitApp - + testsuite/tests/driver/mkdepend/mhu04/unitLib - + testsuite/tests/driver/mkdepend/mhu05/app/Main.hs - + testsuite/tests/driver/mkdepend/mhu05/lib/Lib.hs - + testsuite/tests/driver/mkdepend/mhu05/lib/Lib/Internal.hs - + testsuite/tests/driver/mkdepend/mhu05/test/Spec.hs - + testsuite/tests/driver/mkdepend/mhu05/unitApp - + testsuite/tests/driver/mkdepend/mhu05/unitLib - + testsuite/tests/driver/mkdepend/mhu05/unitTest - + testsuite/tests/driver/mkdepend/mkdepend_mhu04.dep-json - + testsuite/tests/driver/mkdepend/mkdepend_mhu04.dep-makefile - + testsuite/tests/driver/mkdepend/mkdepend_mhu05.dep-json - + testsuite/tests/driver/mkdepend/mkdepend_mhu05.dep-makefile Changes: ===================================== compiler/GHC/Driver/MakeFile.hs ===================================== @@ -216,6 +216,18 @@ data Dep { dep_path :: OsPath } +data DepLink + = DepLink + { link_output :: !UnitId + , link_nodes :: ![DepLinkNode] + } + +data DepLinkNode + = DepLink_Unit !UnitId + | DepLink_Module !ModuleNameWithIsBoot !UnitId + | DepLink_HomeUnit {-# UNPACK #-} !UnitId + | DepLink_ExtUnit {-# UNPACK #-} !UnitId + data DependencyWriter = DependencyWriter { dw_beginWriter :: IO DepSink , dw_endWriter :: IO () @@ -223,6 +235,7 @@ data DependencyWriter = DependencyWriter data DepSink = DepSink { ds_writeDependency :: DepNode -> [Dep] -> IO () + , ds_writeLinkDependency :: DepLink -> IO () } ----------------------------------------------------------------- @@ -261,7 +274,21 @@ processDeps hsc_env _ _ (AcyclicSCC (InstantiationNode _uid node)) mkPlainErrorMsgEnvelope noSrcSpan $ GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node -processDeps _ _ _ (AcyclicSCC (LinkNode {})) = return () +processDeps _ _ sinks (AcyclicSCC (LinkNode keys unitId)) = do + let + toLinkNodeDep = \ case + NodeKey_Unit iu -> DepLink_Unit $ virtualUnitId iu + NodeKey_Module node -> DepLink_Module (mnkModuleName node) (mnkUnitId node) + NodeKey_Link uid -> DepLink_HomeUnit uid + NodeKey_ExternalUnit uid -> DepLink_ExtUnit uid + + linkNode = DepLink + { link_nodes = map toLinkNodeDep keys + , link_output = unitId + } + + traverse_ (\ sink -> ds_writeLinkDependency sink linkNode) sinks + processDeps _ _ _ (AcyclicSCC (UnitNode {})) = return () processDeps _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) -- No dependencies needed for fixed modules (already compiled) @@ -385,8 +412,13 @@ initFileDepWriter logger root tmpfs dflags makefile = do files <- beginMkDependHS logger tmpfs dflags makefile pure DependencyWriter { dw_beginWriter = do - pure $ DepSink $ \ node deps -> do - writeDependencies root (mkd_tmp_hdl files) suffixes node deps + pure DepSink + { ds_writeDependency = \ node deps -> do + writeDependencies root (mkd_tmp_hdl files) suffixes node deps + , ds_writeLinkDependency = \ _linkNode -> do + -- Link nodes are not supported + pure () + } , dw_endWriter = endMkDependHS logger files } where @@ -559,8 +591,13 @@ initJsonDepWriter logger tmpfs dflags output = do json_var <- mkJsonOutput logger tmpfs dflags output initDepJson pure DependencyWriter { dw_beginWriter = - pure $ DepSink $ \ node deps -> - writeHomeUnitDeps json_var node deps + pure DepSink + { ds_writeDependency = \ node deps -> + writeHomeUnitDeps json_var node deps + , ds_writeLinkDependency = \ link -> + -- Link nodes are not supported + writeLinkNode json_var link + } , dw_endWriter = do writeJsonOutput logger json_var } @@ -629,8 +666,12 @@ writeJsonOutput logger JsonOutput {json_path, json_tmp_file, json_tmp_hdl} = do -- Output helpers writeJsonl :: ToJson a => JsonOutput -> a -> IO () -writeJsonl JsonOutput {json_tmp_hdl} output = do - hPutStrLn json_tmp_hdl (showSDocUnsafe $ renderJSON $ json output) +writeJsonl deps_json output = do + writeJsonl' deps_json (json output) + +writeJsonl' :: JsonOutput -> JsonDoc -> IO () +writeJsonl' JsonOutput {json_tmp_hdl} output = do + hPutStrLn json_tmp_hdl (showSDocUnsafe $ renderJSON output) -------------------------------------------------------------------------------- -- Payload for -dep-json @@ -835,6 +876,47 @@ writeHomeUnitDeps deps_json DepNode {..} deps = do DepCpp {dep_path} -> (extDeps, addCpp dep_path node_data) +writeLinkNode :: JsonOutput -> DepLink -> IO () +writeLinkNode dep_json (DepLink uid deps) = do + writeJsonl' dep_json $ + JSObject + [ ("unit-id", JSString $ unitIdString uid) + , ("deps", JSArray $ concat + [ map renderMods (Map.toList allMods) + , map (JSString . unitIdString) (Set.toList units) + , map (JSString . unitIdString) (Set.toList homeUids) + , map (JSString . unitIdString) (Set.toList extUids) + ]) + ] + where + (extUids, homeUids, units, allMods) = foldl' go (Set.empty, Set.empty, Set.empty, Map.empty) deps + + renderMods (u, ms) = + JSObject + [ ("unit-id", JSString $ unitIdString u) + , ("modules", JSArray $ map (JSString . moduleKey) (Set.toList ms)) + ] + + + go (ext, homeUid, unit, mods) = \ case + DepLink_Module modName u -> + let + newMods = Map.insertWith (Set.union) u (Set.singleton modName) mods + in + (ext, homeUid, unit, newMods) + DepLink_Unit uid -> + (ext, homeUid, Set.insert uid unit, mods) + DepLink_HomeUnit uid -> + (ext, Set.insert uid homeUid, unit, mods) + DepLink_ExtUnit uid -> + (Set.insert uid ext, homeUid, unit, mods) + + moduleKey :: ModuleNameWithIsBoot -> String + moduleKey t = moduleNameString (gwib_mod t) ++ case (gwib_isBoot t) of + IsBoot -> "[boot]" + NotBoot -> "" + + ----------------------------------------------------------------- -- Module cycles ----------------------------------------------------------------- ===================================== testsuite/tests/driver/mkdepend/all.T ===================================== @@ -30,6 +30,13 @@ test('mkdepend_mhu03', , when(opsys('mingw32'), skip) # shell script preprocessor ], make_depend_multiunit, [['mhu03/unitA'], '']) +# Link nodes +test('mkdepend_mhu04', + [ extra_files(['mhu04/']), dep_makefile, dep_json ], + make_depend_multiunit, [['mhu04/unitLib', 'mhu04/unitApp'], '']) +test('mkdepend_mhu05', + [ extra_files(['mhu05/']), dep_makefile, dep_json ], + make_depend_multiunit, [['mhu05/unitLib', 'mhu05/unitApp', 'mhu05/unitTest'], '']) # Honour -F test('mkdepend01', ===================================== testsuite/tests/driver/mkdepend/mhu04/app/Main.hs ===================================== @@ -0,0 +1,7 @@ +module Main (main) where + +import Lib (greeting) +import Utils (shout) + +main :: IO () +main = putStrLn (shout greeting) ===================================== testsuite/tests/driver/mkdepend/mhu04/app/Utils.hs ===================================== @@ -0,0 +1,6 @@ +module Utils (shout) where + +import Data.Char (toUpper) + +shout :: String -> String +shout = map toUpper ===================================== testsuite/tests/driver/mkdepend/mhu04/lib/Lib.hs ===================================== @@ -0,0 +1,6 @@ +module Lib (greeting) where + +import Lib.Internal (name) + +greeting :: String +greeting = "Hello, " ++ name ===================================== testsuite/tests/driver/mkdepend/mhu04/lib/Lib/Internal.hs ===================================== @@ -0,0 +1,4 @@ +module Lib.Internal (name) where + +name :: String +name = "world" ===================================== testsuite/tests/driver/mkdepend/mhu04/unitApp ===================================== @@ -0,0 +1 @@ +-i -i. -working-dir=mhu04/app -this-unit-id app -this-package-name app -package-id lib -o app Main ===================================== testsuite/tests/driver/mkdepend/mhu04/unitLib ===================================== @@ -0,0 +1 @@ +-i -i. -working-dir=mhu04/lib -this-unit-id lib -this-package-name lib Lib Lib.Internal ===================================== testsuite/tests/driver/mkdepend/mhu05/app/Main.hs ===================================== @@ -0,0 +1,6 @@ +module Main (main) where + +import Lib (greeting) + +main :: IO () +main = putStrLn greeting ===================================== testsuite/tests/driver/mkdepend/mhu05/lib/Lib.hs ===================================== @@ -0,0 +1,6 @@ +module Lib (greeting) where + +import Lib.Internal (name) + +greeting :: String +greeting = "Hello, " ++ name ===================================== testsuite/tests/driver/mkdepend/mhu05/lib/Lib/Internal.hs ===================================== @@ -0,0 +1,4 @@ +module Lib.Internal (name) where + +name :: String +name = "world" ===================================== testsuite/tests/driver/mkdepend/mhu05/test/Spec.hs ===================================== @@ -0,0 +1,9 @@ +module Spec (main) where + +import Lib (greeting) +import Lib.Internal (name) + +main :: IO () +main + | greeting == "Hello, " ++ name = putStrLn "OK" + | otherwise = error "unexpected greeting" ===================================== testsuite/tests/driver/mkdepend/mhu05/unitApp ===================================== @@ -0,0 +1 @@ +-i -i. -working-dir=mhu05/app -this-unit-id app -this-package-name app -package-id lib -o app Main ===================================== testsuite/tests/driver/mkdepend/mhu05/unitLib ===================================== @@ -0,0 +1 @@ +-i -i. -working-dir=mhu05/lib -this-unit-id lib -this-package-name lib -staticlib Lib Lib.Internal ===================================== testsuite/tests/driver/mkdepend/mhu05/unitTest ===================================== @@ -0,0 +1 @@ +-i -i. -working-dir=mhu05/test -this-unit-id test -this-package-name test -package-id lib -main-is Spec -o test Spec ===================================== testsuite/tests/driver/mkdepend/mkdepend_mhu04.dep-json ===================================== @@ -0,0 +1,55 @@ +{ + "imports": {}, + "includes": [], + "module": "Lib.Internal", + "package-name": "lib", + "source": "mhu04/lib/Lib/Internal.hs", + "unit-id": "lib" +} +{ + "imports": { + "lib": [ + "Lib.Internal" + ] + }, + "includes": [], + "module": "Lib", + "package-name": "lib", + "source": "mhu04/lib/Lib.hs", + "unit-id": "lib" +} +{ + "imports": {}, + "includes": [], + "module": "Utils", + "package-name": "app", + "source": "mhu04/app/Utils.hs", + "unit-id": "app" +} +{ + "imports": { + "app": [ + "Utils" + ], + "lib": [ + "Lib" + ] + }, + "includes": [], + "module": "Main", + "package-name": "app", + "source": "mhu04/app/Main.hs", + "unit-id": "app" +} +{ + "deps": [ + { + "modules": [ + "Main", + "Utils" + ], + "unit-id": "app" + } + ], + "unit-id": "app" +} ===================================== testsuite/tests/driver/mkdepend/mkdepend_mhu04.dep-makefile ===================================== @@ -0,0 +1,9 @@ +# DO NOT DELETE: Beginning of Haskell dependencies +mhu04/lib/Lib/Internal.o : mhu04/lib/Lib/Internal.hs +mhu04/lib/Lib.o : mhu04/lib/Lib.hs +mhu04/lib/Lib.o : mhu04/lib/Lib/Internal.hi +mhu04/app/Utils.o : mhu04/app/Utils.hs +mhu04/app/Main.o : mhu04/app/Main.hs +mhu04/app/Main.o : mhu04/app/Utils.hi +mhu04/app/Main.o : mhu04/lib/Lib.hi +# DO NOT DELETE: End of Haskell dependencies ===================================== testsuite/tests/driver/mkdepend/mkdepend_mhu05.dep-json ===================================== @@ -0,0 +1,79 @@ +{ + "imports": {}, + "includes": [], + "module": "Lib.Internal", + "package-name": "lib", + "source": "mhu05/lib/Lib/Internal.hs", + "unit-id": "lib" +} +{ + "imports": { + "lib": [ + "Lib.Internal" + ] + }, + "includes": [], + "module": "Lib", + "package-name": "lib", + "source": "mhu05/lib/Lib.hs", + "unit-id": "lib" +} +{ + "deps": [ + { + "modules": [ + "Lib", + "Lib.Internal" + ], + "unit-id": "lib" + } + ], + "unit-id": "lib" +} +{ + "imports": { + "lib": [ + "Lib" + ] + }, + "includes": [], + "module": "Main", + "package-name": "app", + "source": "mhu05/app/Main.hs", + "unit-id": "app" +} +{ + "deps": [ + { + "modules": [ + "Main" + ], + "unit-id": "app" + } + ], + "unit-id": "app" +} +{ + "imports": { + "lib": [ + "Lib", + "Lib.Internal" + ] + }, + "includes": [], + "module": "Spec", + "package-name": "test", + "source": "mhu05/test/Spec.hs", + "unit-id": "test" +} +{ + "deps": [ + { + "modules": [ + "Spec" + ], + "unit-id": "test" + } + ], + "unit-id": "test" +} ===================================== testsuite/tests/driver/mkdepend/mkdepend_mhu05.dep-makefile ===================================== @@ -0,0 +1,10 @@ +# DO NOT DELETE: Beginning of Haskell dependencies +mhu05/lib/Lib/Internal.o : mhu05/lib/Lib/Internal.hs +mhu05/lib/Lib.o : mhu05/lib/Lib.hs +mhu05/lib/Lib.o : mhu05/lib/Lib/Internal.hi +mhu05/app/Main.o : mhu05/app/Main.hs +mhu05/app/Main.o : mhu05/lib/Lib.hi +mhu05/test/Spec.o : mhu05/test/Spec.hs +mhu05/test/Spec.o : mhu05/lib/Lib/Internal.hi +mhu05/test/Spec.o : mhu05/lib/Lib.hi +# DO NOT DELETE: End of Haskell dependencies View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/411a916737c3509cbc53f29cec5c25f1... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/411a916737c3509cbc53f29cec5c25f1... 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