Wolfgang Jeltsch pushed to branch wip/jeltsch/module-graph-reuse-in-downsweep at Glasgow Haskell Compiler / GHC

Commits:

16 changed files:

Changes:

  • changelog.d/module-graph-reuse-in-downsweep
    1 
    +section: compiler
    2 
    +synopsis: Allow `downsweep` to use nodes of an existing module graph
    3 
    +issues: #27054
    4 
    +mrs: !16028
    5 
    +description: {
    6 
    +    This contribution enables `downsweep` to use the nodes of a module
    7 
    +    graph obtained from a previous downsweeping round, which allows GHC
    8 
    +    API applications to build module graphs somewhat incrementally.
    9 
    +}

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -146,6 +146,10 @@ The result is having a uniform graph available for the whole compilation pipelin
    146 146 
     -- an import of this module mean.
    147 147 
     type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo]
    148 148
    149 
    +moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode
    150 
    +moduleGraphNodeMap graph
    151 
    +    = M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph]
    152 
    +
    149 153 
     -----------------------------------------------------------------------------
    150 154 
     --
    151 155 
     -- | Downsweep (dependency analysis) for --make mode
    ... ... @@ -158,6 +162,13 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv
    158 162 
     -- cache to avoid recalculating a module summary if the source is
    159 163 
     -- unchanged.
    160 164 
     --
    165 
    +-- Downsweeping can start from scratch for from a given module graph. In the
    166 
    +-- latter case, the given graph is fully included in the resulting graph, even
    167 
    +-- if parts of it are not reachable from any of the given roots. When an import
    168 
    +-- is processed, the source of the imported module is not consulted if this
    169 
    +-- module is already mentioned in the given graph. The sources of the root
    170 
    +-- modules are always consulted, though.
    171 
    +--
    161 172 
     -- The returned ModuleGraph has one node for each home-package
    162 173 
     -- module, plus one for any hs-boot files.  The imports of these nodes
    163 174 
     -- are all there, including the imports of non-home-package modules.
    ... ... @@ -172,6 +183,8 @@ downsweep :: HscEnv
    172 183 
               -> Maybe Messager
    173 184 
               -> [ModSummary]
    174 185 
               -- ^ Old summaries
    186 
    +          -> Maybe ModuleGraph
    187 
    +          -- ^ Optionally a module graph to extend
    175 188 
               -> [ModuleName]       -- Ignore dependencies on these; treat
    176 189 
                                     -- them as if they were package modules
    177 190 
               -> Bool               -- True <=> allow multiple targets to have
    ... ... @@ -181,7 +194,7 @@ downsweep :: HscEnv
    181 194 
                     -- The non-error elements of the returned list all have distinct
    182 195 
                     -- (Modules, IsBoot) identifiers, unless the Bool is true in
    183 196 
                     -- which case there can be repeats
    184 
    -downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do
    197 
    +downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allow_dup_roots = do
    185 198 
       n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
    186 199 
       (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary
    187 200 
       let closure_errs = checkHomeUnitsClosed unit_env
    ... ... @@ -191,7 +204,7 @@ downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do
    191 204
    192 205 
       case all_errs of
    193 206 
         [] -> do
    194 
    -       (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []
    207 
    +       (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map maybe_base_graph excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []
    195 208
    196 209 
            let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)
    197 210
    ... ... @@ -232,7 +245,7 @@ downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do
    232 245 
     downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph
    233 246 
     downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do
    234 247 
       debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..."
    235 
    -  ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] []
    248 
    +  ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] []
    236 249 
       let dflags = hsc_dflags hsc_env
    237 250 
       liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)
    238 251 
                                        (initPrintConfig dflags)
    ... ... @@ -360,7 +373,7 @@ downsweepInstalledModules hsc_env mods = do
    360 373 
                 _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i
    361 374
    362 375 
         nodes <- mapM process installed_mods
    363 
    -    (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids
    376 
    +    (errs, mg) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed nodes external_uids
    364 377
    365 378 
         -- Similarly here, we should really not get any errors, but print them out if we do.
    366 379 
         let dflags = hsc_dflags hsc_env
    ... ... @@ -385,19 +398,21 @@ data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed
    385 398 
     -- all the dependencies, all the way to the leaf units.
    386 399 
     downsweepFromRootNodes :: HscEnv
    387 400 
                       -> M.Map (UnitId, OsPath) ModSummary
    401 
    +                  -> Maybe ModuleGraph
    388 402 
                       -> [ModuleName]
    389 403 
                       -> Bool
    390 404 
                       -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies
    391 405 
                       -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo
    392 406 
                       -> [UnitId] -- ^ The starting units
    393 407 
                       -> IO ([DriverMessages], [ModuleGraphNode])
    394 
    -downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root_nodes root_uids
    408 
    +downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids
    395 409 
        = do
    396 410 
            let root_map = mkRootMap root_nodes
    397 411 
            checkDuplicates root_map
    398 412 
            let env = DownsweepEnv hsc_env mode old_summaries excl_mods
    399 413 
            (deps', map0) <- runDownsweepM env  $ do
    400 
    -                    (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)
    414 
    +                    let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph
    415 
    +                    (module_deps, map0) <- loopModuleNodeInfos root_nodes (base_nodes, root_map)
    401 416 
                         let all_deps = loopUnit hsc_env module_deps root_uids
    402 417 
                         let all_instantiations =  getHomeUnitInstantiations hsc_env
    403 418 
                         deps' <- loopInstantiations all_instantiations all_deps

  • compiler/GHC/Driver/Make.hs
    ... ... @@ -232,7 +232,7 @@ depanalPartial diag_wrapper msg excluded_mods allow_dup_roots = do
    232 232 
         liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
    233 233
    234 234 
         (errs, mod_graph) <- liftIO $ downsweep
    235 
    -      hsc_env diag_wrapper msg (mgModSummaries old_graph)
    235 
    +      hsc_env diag_wrapper msg (mgModSummaries old_graph) Nothing
    236 236 
           excluded_mods allow_dup_roots
    237 237 
         return (unionManyMessages errs, mod_graph)
    238 238

  • testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs
    1 
    +{-# LANGUAGE Haskell2010 #-}
    2 
    +
    3 
    +{-# OPTIONS_GHC -Wall -Werror #-}
    4 
    +
    5 
    +import Control.Monad (unless)
    6 
    +import Control.Monad.IO.Class (liftIO)
    7 
    +import Control.Arrow ((>>>))
    8 
    +import Data.List (sort)
    9 
    +import System.Environment (getArgs)
    10 
    +import System.Exit (exitFailure)
    11 
    +import System.IO (stderr)
    12 
    +import System.Directory (removeFile)
    13 
    +import Language.Haskell.Syntax.Module.Name (moduleNameString)
    14 
    +import GHC.Utils.Ppr (Mode (PageMode))
    15 
    +import GHC.Utils.Outputable (vcat, defaultSDocContext, printSDocLn, ppr)
    16 
    +import GHC.Utils.Logger (getLogger)
    17 
    +import GHC.Types.SrcLoc (noLoc)
    18 
    +import GHC.Types.Error (mkUnknownDiagnostic)
    19 
    +import GHC.Unit.Types (moduleName)
    20 
    +import GHC.Unit.Module.ModSummary (ms_mod)
    21 
    +import GHC.Unit.Module.Graph (ModuleGraph, mgModSummaries)
    22 
    +import GHC.Driver.DynFlags (defaultFatalMessager, defaultFlushOut)
    23 
    +import GHC.Driver.Monad (Ghc, getSession, getSessionDynFlags)
    24 
    +import GHC.Driver.Make (downsweep)
    25 
    +import GHC.Driver.Errors.Types (DriverMessages)
    26 
    +import GHC
    27 
    +       (
    28 
    +           defaultErrorHandler,
    29 
    +           guessTarget,
    30 
    +           setTargets,
    31 
    +           parseDynamicFlags,
    32 
    +           setSessionDynFlags,
    33 
    +           runGhc
    34 
    +       )
    35 
    +
    36 
    +sourceDirectory :: String
    37 
    +sourceDirectory = "IncrementalDownsweep.modules"
    38 
    +
    39 
    +withSimpleErrorHandler :: Ghc a -> Ghc a
    40 
    +withSimpleErrorHandler = defaultErrorHandler defaultFatalMessager
    41 
    +                                             defaultFlushOut
    42 
    +
    43 
    +handleDriverMessages :: [DriverMessages] -> IO ()
    44 
    +handleDriverMessages driverMsgs
    45 
    +    = unless (null driverMsgs) $
    46 
    +      do
    47 
    +          printSDocLn defaultSDocContext
    48 
    +                      (PageMode True)
    49 
    +                      stderr
    50 
    +                      (vcat (map ppr driverMsgs))
    51 
    +          exitFailure
    52 
    +
    53 
    +performDownsweepTurn :: Maybe ModuleGraph -> String -> Ghc ModuleGraph
    54 
    +performDownsweepTurn maybeGivenModuleGraph rootModuleName = do
    55 
    +    target <- guessTarget rootModuleName Nothing Nothing
    56 
    +    setTargets [target]
    57 
    +    session <- getSession
    58 
    +    (driverMsgs, resultingModuleGraph)
    59 
    +        <- liftIO $ downsweep session
    60 
    +                              mkUnknownDiagnostic
    61 
    +                              Nothing
    62 
    +                              []
    63 
    +                              maybeGivenModuleGraph
    64 
    +                              []
    65 
    +                              False
    66 
    +    liftIO $ handleDriverMessages driverMsgs
    67 
    +    return resultingModuleGraph
    68 
    +
    69 
    +outputModuleNamesInGraph :: ModuleGraph -> IO ()
    70 
    +outputModuleNamesInGraph = mgModSummaries                                   >>>
    71 
    +                           map (ms_mod >>> moduleName >>> moduleNameString) >>>
    72 
    +                           sort                                             >>>
    73 
    +                           print
    74 
    +
    75 
    +main :: IO ()
    76 
    +main = do
    77 
    +    libDir : otherArgs <- getArgs
    78 
    +    runGhc (Just libDir) $ withSimpleErrorHandler $ do
    79 
    +
    80 
    +        -- Setup
    81 
    +        logger <- getLogger
    82 
    +        originalDynFlags <- getSessionDynFlags
    83 
    +        (finalDynFlags, _, _)
    84 
    +            <- parseDynamicFlags logger originalDynFlags $
    85 
    +               map noLoc (["-i", "-i" ++ sourceDirectory] ++ otherArgs)
    86 
    +        _ <- setSessionDynFlags finalDynFlags
    87 
    +
    88 
    +        -- Turn 1: From scratch, using 'A' as root
    89 
    +        moduleGraph1 <- performDownsweepTurn Nothing "A"
    90 
    +        liftIO $ outputModuleNamesInGraph moduleGraph1
    91 
    +
    92 
    +        -- Turn 2: From scratch, using 'X' as root
    93 
    +        -- NOTE: 'A' is not included, because it is not reachable.
    94 
    +        moduleGraph2 <- performDownsweepTurn Nothing "X"
    95 
    +        liftIO $ outputModuleNamesInGraph moduleGraph2
    96 
    +
    97 
    +        -- Deletion of the source files used in turn 1
    98 
    +        _ <- liftIO $
    99 
    +             mapM_ (((sourceDirectory ++ "/") ++) >>> (++ ".hs") >>> removeFile)
    100 
    +                   ["A", "B", "C", "D"]
    101 
    +
    102 
    +        -- Turn 3: Based on the result of turn 1, using 'X' as root
    103 
    +        -- NOTE: 'A' is included, because the result of turn 1 contains it.
    104 
    +        moduleGraph3 <- performDownsweepTurn (Just moduleGraph1) "X"
    105 
    +        liftIO $ outputModuleNamesInGraph moduleGraph3

  • testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/A.hs
    1 
    +module A where
    2 
    +
    3 
    +import B
    4 
    +import C

  • testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/B.hs
    1 
    +module B where
    2 
    +
    3 
    +import D

  • testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/C.hs
    1 
    +module C where
    2 
    +
    3 
    +import D

  • testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/D.hs
    1 
    +module D where

  • testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/X.hs
    1 
    +module X where
    2 
    +
    3 
    +import Y
    4 
    +import Z

  • testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/Y.hs
    1 
    +module Y where
    2 
    +
    3 
    +import B

  • testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.modules/Z.hs
    1 
    +module Z where
    2 
    +
    3 
    +import C

  • testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.stdout
    1 
    +["A","B","C","D"]
    2 
    +["B","C","D","X","Y","Z"]
    3 
    +["A","B","C","D","X","Y","Z"]

  • testsuite/tests/ghc-api/downsweep/OldModLocation.hs
    ... ... @@ -48,13 +48,13 @@ main = do
    48 48
    49 49 
         liftIO $ do
    50 50
    51 
    -    _emss <- downsweep hsc_env mkUnknownDiagnostic Nothing [] [] False
    51 
    +    _emss <- downsweep hsc_env mkUnknownDiagnostic Nothing [] Nothing [] False
    52 52
    53 53 
         flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
    54 54 
         createDirectoryIfMissing False "mydir"
    55 55 
         renameFile "B.hs" "mydir/B.hs"
    56 56
    57 
    -    (_, nodes) <- downsweep hsc_env mkUnknownDiagnostic Nothing [] [] False
    57 
    +    (_, nodes) <- downsweep hsc_env mkUnknownDiagnostic Nothing [] Nothing [] False
    58 58
    59 59 
         -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with
    60 60 
         -- (ms_location old_summary) like summariseFile used to instead of

  • testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
    ... ... @@ -169,7 +169,7 @@ go label mods cnd =
    169 169 
         setTargets [tgt]
    170 170
    171 171 
         hsc_env <- getSession
    172 
    -    (_, nodes) <- liftIO $ downsweep hsc_env mkUnknownDiagnostic Nothing [] [] False
    172 
    +    (_, nodes) <- liftIO $ downsweep hsc_env mkUnknownDiagnostic Nothing [] Nothing [] False
    173 173
    174 174 
         it label $ cnd (mgModSummaries nodes)
    175 175

  • testsuite/tests/ghc-api/downsweep/all.T
    ... ... @@ -14,3 +14,10 @@ test('OldModLocation',
    14 14 
          ],
    15 15 
          compile_and_run,
    16 16 
          ['-package ghc'])
    17 
    +
    18 
    +test('IncrementalDownsweep',
    19 
    +     [ extra_files(['IncrementalDownsweep.modules/'])
    20 
    +     , extra_run_opts('"' + config.libdir + '"')
    21 
    +     ],
    22 
    +     compile_and_run,
    23 
    +     ['-package ghc'])

  • testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs
    ... ... @@ -67,7 +67,7 @@ main = do
    67 67 
               keyC = msKey msC
    68 68
    69 69 
           let mkGraph s = do
    70 
    -            ([], nodes) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed s []
    70 
    +            ([], nodes) <- downsweepFromRootNodes hsc_env mempty Nothing [] True DownsweepUseFixed s []
    71 71 
                 return $ mkModuleGraph nodes
    72 72
    73 73 
           graph <- liftIO $ mkGraph [ModuleNodeCompile msC]

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help