Hannes Siebenhandl pushed to branch wip/fendor/dep-json-link-nodes at Glasgow Haskell Compiler / GHC

Commits:

19 changed files:

Changes:

  • compiler/GHC/Driver/MakeFile.hs
    ... ... @@ -216,6 +216,18 @@ data Dep
    216 216 
         { dep_path :: OsPath
    217 217 
         }
    218 218
    219 
    +data DepLink
    220 
    +  = DepLink
    221 
    +    { link_output :: !UnitId
    222 
    +    , link_nodes :: ![DepLinkNode]
    223 
    +    }
    224 
    +
    225 
    +data DepLinkNode
    226 
    +  = DepLink_Unit !UnitId
    227 
    +  | DepLink_Module !ModuleNameWithIsBoot !UnitId
    228 
    +  | DepLink_HomeUnit {-# UNPACK #-} !UnitId
    229 
    +  | DepLink_ExtUnit {-# UNPACK #-} !UnitId
    230 
    +
    219 231 
     data DependencyWriter = DependencyWriter
    220 232 
       { dw_beginWriter :: IO DepSink
    221 233 
       , dw_endWriter :: IO ()
    ... ... @@ -223,6 +235,7 @@ data DependencyWriter = DependencyWriter
    223 235
    224 236 
     data DepSink = DepSink
    225 237 
       { ds_writeDependency :: DepNode -> [Dep] -> IO ()
    238 
    +  , ds_writeLinkDependency :: DepLink -> IO ()
    226 239 
       }
    227 240
    228 241 
     -----------------------------------------------------------------
    ... ... @@ -261,7 +274,21 @@ processDeps hsc_env _ _ (AcyclicSCC (InstantiationNode _uid node))
    261 274 
           mkPlainErrorMsgEnvelope noSrcSpan $
    262 275 
           GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node
    263 276
    264 
    -processDeps _ _ _ (AcyclicSCC (LinkNode {})) = return ()
    277 
    +processDeps _ _ sinks (AcyclicSCC (LinkNode keys unitId)) = do
    278 
    +  let
    279 
    +    toLinkNodeDep = \ case
    280 
    +      NodeKey_Unit iu -> DepLink_Unit $ virtualUnitId iu
    281 
    +      NodeKey_Module node -> DepLink_Module (mnkModuleName node) (mnkUnitId node)
    282 
    +      NodeKey_Link uid -> DepLink_HomeUnit uid
    283 
    +      NodeKey_ExternalUnit uid -> DepLink_ExtUnit uid
    284 
    +
    285 
    +    linkNode = DepLink
    286 
    +      { link_nodes = map toLinkNodeDep keys
    287 
    +      , link_output = unitId
    288 
    +      }
    289 
    +
    290 
    +  traverse_ (\ sink -> ds_writeLinkDependency sink linkNode) sinks
    291 
    +
    265 292 
     processDeps _ _ _ (AcyclicSCC (UnitNode {})) = return ()
    266 293 
     processDeps _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {})))
    267 294 
       -- No dependencies needed for fixed modules (already compiled)
    ... ... @@ -385,8 +412,13 @@ initFileDepWriter logger root tmpfs dflags makefile = do
    385 412 
       files <- beginMkDependHS logger tmpfs dflags makefile
    386 413 
       pure DependencyWriter
    387 414 
         { dw_beginWriter = do
    388 
    -        pure $ DepSink $ \ node deps -> do
    389 
    -          writeDependencies root (mkd_tmp_hdl files) suffixes node deps
    415 
    +        pure DepSink
    416 
    +          { ds_writeDependency = \ node deps -> do
    417 
    +              writeDependencies root (mkd_tmp_hdl files) suffixes node deps
    418 
    +          , ds_writeLinkDependency = \ _linkNode -> do
    419 
    +              -- Link nodes are not supported
    420 
    +              pure ()
    421 
    +          }
    390 422 
         , dw_endWriter = endMkDependHS logger files
    391 423 
         }
    392 424 
       where
    ... ... @@ -559,8 +591,13 @@ initJsonDepWriter logger tmpfs dflags output = do
    559 591 
       json_var <- mkJsonOutput logger tmpfs dflags output initDepJson
    560 592 
       pure DependencyWriter
    561 593 
         { dw_beginWriter =
    562 
    -        pure $ DepSink $ \ node deps ->
    563 
    -          writeHomeUnitDeps json_var node deps
    594 
    +        pure DepSink
    595 
    +          { ds_writeDependency = \ node deps ->
    596 
    +              writeHomeUnitDeps json_var node deps
    597 
    +          , ds_writeLinkDependency = \ link ->
    598 
    +              -- Link nodes are not supported
    599 
    +              writeLinkNode json_var link
    600 
    +          }
    564 601 
         , dw_endWriter = do
    565 602 
             writeJsonOutput logger json_var
    566 603 
         }
    ... ... @@ -629,8 +666,12 @@ writeJsonOutput logger JsonOutput {json_path, json_tmp_file, json_tmp_hdl} = do
    629 666 
     -- Output helpers
    630 667
    631 668 
     writeJsonl :: ToJson a => JsonOutput -> a -> IO ()
    632 
    -writeJsonl  JsonOutput {json_tmp_hdl} output = do
    633 
    -  hPutStrLn json_tmp_hdl (showSDocUnsafe $ renderJSON $ json output)
    669 
    +writeJsonl deps_json output = do
    670 
    +  writeJsonl' deps_json (json output)
    671 
    +
    672 
    +writeJsonl' :: JsonOutput -> JsonDoc -> IO ()
    673 
    +writeJsonl'  JsonOutput {json_tmp_hdl} output = do
    674 
    +  hPutStrLn json_tmp_hdl (showSDocUnsafe $ renderJSON output)
    634 675
    635 676 
     --------------------------------------------------------------------------------
    636 677 
     -- Payload for -dep-json
    ... ... @@ -835,6 +876,47 @@ writeHomeUnitDeps deps_json DepNode {..} deps = do
    835 876 
           DepCpp {dep_path} ->
    836 877 
             (extDeps, addCpp dep_path node_data)
    837 878
    879 
    +writeLinkNode :: JsonOutput -> DepLink -> IO ()
    880 
    +writeLinkNode dep_json (DepLink uid deps) = do
    881 
    +  writeJsonl' dep_json $
    882 
    +    JSObject
    883 
    +      [ ("unit-id", JSString $ unitIdString uid)
    884 
    +      , ("deps", JSArray $ concat
    885 
    +        [ map renderMods (Map.toList allMods)
    886 
    +        , map (JSString . unitIdString) (Set.toList units)
    887 
    +        , map (JSString . unitIdString) (Set.toList homeUids)
    888 
    +        , map (JSString . unitIdString) (Set.toList extUids)
    889 
    +        ])
    890 
    +      ]
    891 
    +  where
    892 
    +    (extUids, homeUids, units, allMods) = foldl' go (Set.empty, Set.empty, Set.empty, Map.empty) deps
    893 
    +
    894 
    +    renderMods (u, ms) =
    895 
    +      JSObject
    896 
    +        [ ("unit-id", JSString $ unitIdString u)
    897 
    +        , ("modules", JSArray $ map (JSString . moduleKey) (Set.toList ms))
    898 
    +        ]
    899 
    +
    900 
    +
    901 
    +    go (ext, homeUid, unit, mods) = \ case
    902 
    +      DepLink_Module modName u ->
    903 
    +        let
    904 
    +          newMods = Map.insertWith (Set.union) u (Set.singleton modName) mods
    905 
    +        in
    906 
    +          (ext, homeUid, unit, newMods)
    907 
    +      DepLink_Unit uid ->
    908 
    +        (ext, homeUid, Set.insert uid unit, mods)
    909 
    +      DepLink_HomeUnit uid ->
    910 
    +        (ext, Set.insert uid homeUid, unit, mods)
    911 
    +      DepLink_ExtUnit uid ->
    912 
    +        (Set.insert uid ext, homeUid, unit, mods)
    913 
    +
    914 
    +    moduleKey :: ModuleNameWithIsBoot -> String
    915 
    +    moduleKey t = moduleNameString (gwib_mod t) ++ case (gwib_isBoot t) of
    916 
    +      IsBoot -> "[boot]"
    917 
    +      NotBoot -> ""
    918 
    +
    919 
    +
    838 920 
     -----------------------------------------------------------------
    839 921 
     --              Module cycles
    840 922 
     -----------------------------------------------------------------

  • testsuite/tests/driver/mkdepend/all.T
    ... ... @@ -30,6 +30,13 @@ test('mkdepend_mhu03',
    30 30 
          , when(opsys('mingw32'), skip) # shell script preprocessor
    31 31 
          ],
    32 32 
          make_depend_multiunit, [['mhu03/unitA'], ''])
    33 
    +# Link nodes
    34 
    +test('mkdepend_mhu04',
    35 
    +     [ extra_files(['mhu04/']), dep_makefile, dep_json ],
    36 
    +     make_depend_multiunit, [['mhu04/unitLib', 'mhu04/unitApp'], ''])
    37 
    +test('mkdepend_mhu05',
    38 
    +     [ extra_files(['mhu05/']), dep_makefile, dep_json ],
    39 
    +     make_depend_multiunit, [['mhu05/unitLib', 'mhu05/unitApp', 'mhu05/unitTest'], ''])
    33 40
    34 41 
     # Honour -F
    35 42 
     test('mkdepend01',

  • testsuite/tests/driver/mkdepend/mhu04/app/Main.hs
    1 
    +module Main (main) where
    2 
    +
    3 
    +import Lib (greeting)
    4 
    +import Utils (shout)
    5 
    +
    6 
    +main :: IO ()
    7 
    +main = putStrLn (shout greeting)

  • testsuite/tests/driver/mkdepend/mhu04/app/Utils.hs
    1 
    +module Utils (shout) where
    2 
    +
    3 
    +import Data.Char (toUpper)
    4 
    +
    5 
    +shout :: String -> String
    6 
    +shout = map toUpper

  • testsuite/tests/driver/mkdepend/mhu04/lib/Lib.hs
    1 
    +module Lib (greeting) where
    2 
    +
    3 
    +import Lib.Internal (name)
    4 
    +
    5 
    +greeting :: String
    6 
    +greeting = "Hello, " ++ name

  • testsuite/tests/driver/mkdepend/mhu04/lib/Lib/Internal.hs
    1 
    +module Lib.Internal (name) where
    2 
    +
    3 
    +name :: String
    4 
    +name = "world"

  • testsuite/tests/driver/mkdepend/mhu04/unitApp
    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
    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
    1 
    +module Main (main) where
    2 
    +
    3 
    +import Lib (greeting)
    4 
    +
    5 
    +main :: IO ()
    6 
    +main = putStrLn greeting

  • testsuite/tests/driver/mkdepend/mhu05/lib/Lib.hs
    1 
    +module Lib (greeting) where
    2 
    +
    3 
    +import Lib.Internal (name)
    4 
    +
    5 
    +greeting :: String
    6 
    +greeting = "Hello, " ++ name

  • testsuite/tests/driver/mkdepend/mhu05/lib/Lib/Internal.hs
    1 
    +module Lib.Internal (name) where
    2 
    +
    3 
    +name :: String
    4 
    +name = "world"

  • testsuite/tests/driver/mkdepend/mhu05/test/Spec.hs
    1 
    +module Spec (main) where
    2 
    +
    3 
    +import Lib (greeting)
    4 
    +import Lib.Internal (name)
    5 
    +
    6 
    +main :: IO ()
    7 
    +main
    8 
    +  | greeting == "Hello, " ++ name = putStrLn "OK"
    9 
    +  | otherwise = error "unexpected greeting"

  • testsuite/tests/driver/mkdepend/mhu05/unitApp
    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
    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
    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
    1 
    +{
    2 
    +  "imports": {},
    3 
    +  "includes": [],
    4 
    +  "module": "Lib.Internal",
    5 
    +  "package-name": "lib",
    6 
    +  "source": "mhu04/lib/Lib/Internal.hs",
    7 
    +  "unit-id": "lib"
    8 
    +}
    9 
    +{
    10 
    +  "imports": {
    11 
    +    "lib": [
    12 
    +      "Lib.Internal"
    13 
    +    ]
    14 
    +  },
    15 
    +  "includes": [],
    16 
    +  "module": "Lib",
    17 
    +  "package-name": "lib",
    18 
    +  "source": "mhu04/lib/Lib.hs",
    19 
    +  "unit-id": "lib"
    20 
    +}
    21 
    +{
    22 
    +  "imports": {},
    23 
    +  "includes": [],
    24 
    +  "module": "Utils",
    25 
    +  "package-name": "app",
    26 
    +  "source": "mhu04/app/Utils.hs",
    27 
    +  "unit-id": "app"
    28 
    +}
    29 
    +{
    30 
    +  "imports": {
    31 
    +    "app": [
    32 
    +      "Utils"
    33 
    +    ],
    34 
    +    "lib": [
    35 
    +      "Lib"
    36 
    +    ]
    37 
    +  },
    38 
    +  "includes": [],
    39 
    +  "module": "Main",
    40 
    +  "package-name": "app",
    41 
    +  "source": "mhu04/app/Main.hs",
    42 
    +  "unit-id": "app"
    43 
    +}
    44 
    +{
    45 
    +  "deps": [
    46 
    +    {
    47 
    +      "modules": [
    48 
    +        "Main",
    49 
    +        "Utils"
    50 
    +      ],
    51 
    +      "unit-id": "app"
    52 
    +    }
    53 
    +  ],
    54 
    +  "unit-id": "app"
    55 
    +}

  • testsuite/tests/driver/mkdepend/mkdepend_mhu04.dep-makefile
    1 
    +# DO NOT DELETE: Beginning of Haskell dependencies
    2 
    +mhu04/lib/Lib/Internal.o : mhu04/lib/Lib/Internal.hs
    3 
    +mhu04/lib/Lib.o : mhu04/lib/Lib.hs
    4 
    +mhu04/lib/Lib.o : mhu04/lib/Lib/Internal.hi
    5 
    +mhu04/app/Utils.o : mhu04/app/Utils.hs
    6 
    +mhu04/app/Main.o : mhu04/app/Main.hs
    7 
    +mhu04/app/Main.o : mhu04/app/Utils.hi
    8 
    +mhu04/app/Main.o : mhu04/lib/Lib.hi
    9 
    +# DO NOT DELETE: End of Haskell dependencies

  • testsuite/tests/driver/mkdepend/mkdepend_mhu05.dep-json
    1 
    +{
    2 
    +  "imports": {},
    3 
    +  "includes": [],
    4 
    +  "module": "Lib.Internal",
    5 
    +  "package-name": "lib",
    6 
    +  "source": "mhu05/lib/Lib/Internal.hs",
    7 
    +  "unit-id": "lib"
    8 
    +}
    9 
    +{
    10 
    +  "imports": {
    11 
    +    "lib": [
    12 
    +      "Lib.Internal"
    13 
    +    ]
    14 
    +  },
    15 
    +  "includes": [],
    16 
    +  "module": "Lib",
    17 
    +  "package-name": "lib",
    18 
    +  "source": "mhu05/lib/Lib.hs",
    19 
    +  "unit-id": "lib"
    20 
    +}
    21 
    +{
    22 
    +  "deps": [
    23 
    +    {
    24 
    +      "modules": [
    25 
    +        "Lib",
    26 
    +        "Lib.Internal"
    27 
    +      ],
    28 
    +      "unit-id": "lib"
    29 
    +    }
    30 
    +  ],
    31 
    +  "unit-id": "lib"
    32 
    +}
    33 
    +{
    34 
    +  "imports": {
    35 
    +    "lib": [
    36 
    +      "Lib"
    37 
    +    ]
    38 
    +  },
    39 
    +  "includes": [],
    40 
    +  "module": "Main",
    41 
    +  "package-name": "app",
    42 
    +  "source": "mhu05/app/Main.hs",
    43 
    +  "unit-id": "app"
    44 
    +}
    45 
    +{
    46 
    +  "deps": [
    47 
    +    {
    48 
    +      "modules": [
    49 
    +        "Main"
    50 
    +      ],
    51 
    +      "unit-id": "app"
    52 
    +    }
    53 
    +  ],
    54 
    +  "unit-id": "app"
    55 
    +}
    56 
    +{
    57 
    +  "imports": {
    58 
    +    "lib": [
    59 
    +      "Lib",
    60 
    +      "Lib.Internal"
    61 
    +    ]
    62 
    +  },
    63 
    +  "includes": [],
    64 
    +  "module": "Spec",
    65 
    +  "package-name": "test",
    66 
    +  "source": "mhu05/test/Spec.hs",
    67 
    +  "unit-id": "test"
    68 
    +}
    69 
    +{
    70 
    +  "deps": [
    71 
    +    {
    72 
    +      "modules": [
    73 
    +        "Spec"
    74 
    +      ],
    75 
    +      "unit-id": "test"
    76 
    +    }
    77 
    +  ],
    78 
    +  "unit-id": "test"
    79 
    +}

  • testsuite/tests/driver/mkdepend/mkdepend_mhu05.dep-makefile
    1 
    +# DO NOT DELETE: Beginning of Haskell dependencies
    2 
    +mhu05/lib/Lib/Internal.o : mhu05/lib/Lib/Internal.hs
    3 
    +mhu05/lib/Lib.o : mhu05/lib/Lib.hs
    4 
    +mhu05/lib/Lib.o : mhu05/lib/Lib/Internal.hi
    5 
    +mhu05/app/Main.o : mhu05/app/Main.hs
    6 
    +mhu05/app/Main.o : mhu05/lib/Lib.hi
    7 
    +mhu05/test/Spec.o : mhu05/test/Spec.hs
    8 
    +mhu05/test/Spec.o : mhu05/lib/Lib/Internal.hi
    9 
    +mhu05/test/Spec.o : mhu05/lib/Lib.hi
    10 
    +# DO NOT DELETE: End of Haskell dependencies

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/411a916737c3509cbc53f29cec5c25f1ff97d25e at 1792064940