Rodrigo Mesquita pushed to branch wip/romes/27461 at Glasgow Haskell Compiler / GHC

Commits:

1 changed file:

Changes:

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -5,6 +5,8 @@
    5 5 
     {-# LANGUAGE RecordWildCards #-}
    6 6 
     {-# LANGUAGE BlockArguments #-}
    7 7 
     {-# LANGUAGE ViewPatterns #-}
    8 
    +{-# LANGUAGE TypeFamilies #-}
    9 
    +{-# LANGUAGE FunctionalDependencies #-}
    8 10 
     module GHC.Driver.Downsweep
    9 11 
       ( downsweep
    10 12 
       , downsweepThunk
    ... ... @@ -109,6 +111,7 @@ import Control.Monad.Trans.Reader
    109 111 
     import qualified Data.Map.Strict as M
    110 112 
     import Control.Monad.Trans.Class
    111 113 
     import System.IO.Unsafe (unsafeInterleaveIO)
    114 
    +import Data.IORef
    112 115
    113 116 
     {-
    114 117 
     Note [Downsweep and the ModuleGraph]
    ... ... @@ -143,6 +146,7 @@ The result is having a uniform graph available for the whole compilation pipelin
    143 146 
     -- This caches the answer to the question, if we are in this unit, what does
    144 147 
     -- an import of this module mean.
    145 148 
     type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo]
    149 
    +-- TODO: kill this type alias and see what can be removed
    146 150
    147 151 
     moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode
    148 152 
     moduleGraphNodeMap graph
    ... ... @@ -193,8 +197,10 @@ downsweep :: HscEnv
    193 197 
                     -- (Modules, IsBoot) identifiers, unless the Bool is true in
    194 198 
                     -- which case there can be repeats
    195 199 
     downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allow_dup_roots = do
    196 
    -  n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
    197 
    -  (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary
    200 
    +  n_jobs     <- mkWorkerLimit (hsc_dflags hsc_env)
    201 
    +  summ_cache <- newIORef (mkModSummaryCache old_summaries)
    202 
    +  (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg
    203 
    +                                   (getRootSummary excl_mods summ_cache)
    198 204 
       let closure_errs = checkHomeUnitsClosed unit_env
    199 205 
           unit_env = hsc_unit_env hsc_env
    200 206
    ... ... @@ -202,7 +208,7 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
    202 208
    203 209 
       case all_errs of
    204 210 
         [] -> do
    205 
    -       (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map maybe_base_graph excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []
    211 
    +       (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []
    206 212
    207 213 
            let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)
    208 214
    ... ... @@ -220,17 +226,6 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
    220 226 
            return (all_errs, th_configured_nodes)
    221 227 
         _  -> return (all_errs, emptyMG)
    222 228 
       where
    223 
    -    summary = getRootSummary excl_mods old_summary_map
    224 
    -
    225 
    -    -- A cache from file paths to the already summarised modules. The same file
    226 
    -    -- can be used in multiple units so the map is also keyed by which unit the
    227 
    -    -- file was used in.
    228 
    -    -- Reuse these if we can because the most expensive part of downsweep is
    229 
    -    -- reading the headers.
    230 
    -    old_summary_map :: M.Map (UnitId, OsPath) ModSummary
    231 
    -    old_summary_map =
    232 
    -      M.fromList [((ms_unitid ms, msHsFileOsPath ms), ms) | ms <- old_summaries]
    233 
    -
    234 229 
         -- Dependencies arising on a unit (backpack and module linking deps)
    235 230 
         unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
    236 231 
         unitModuleNodes summaries uid hue =
    ... ... @@ -313,8 +308,9 @@ loopFromInteractive :: HscEnv
    313 308 
                         -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
    314 309 
                         -> M.Map NodeKey ModuleGraphNode
    315 310 
                         -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode)
    316 
    -loopFromInteractive _ [] cached_nodes = return ([], cached_nodes)
    317 
    -loopFromInteractive hsc_env (edge:edges) cached_nodes =
    311 
    +loopFromInteractive = error "TODO"
    312 
    +{-
    313 
    +loopFromInteractive = return ([], cached_nodes)
    318 314 
       case edge of
    319 315 
         Left edge -> do
    320 316 
             (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes
    ... ... @@ -342,7 +338,7 @@ loopFromInteractive hsc_env (edge:edges) cached_nodes =
    342 338 
               return (edge : edges, cached_nodes')
    343 339 
             -- And if it's not found.. just carry on and hope.
    344 340 
             _ -> loopFromInteractive hsc_env edges cached_nodes
    345 
    -
    341 
    +-}
    346 342
    347 343 
     -- | Create a module graph from a list of installed modules.
    348 344 
     -- This is used by the loader when we need to load modules but there
    ... ... @@ -395,7 +391,7 @@ data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed
    395 391 
     -- This function will start at the given roots, and traverse downwards to find
    396 392 
     -- all the dependencies, all the way to the leaf units.
    397 393 
     downsweepFromRootNodes :: HscEnv
    398 
    -                  -> M.Map (UnitId, OsPath) ModSummary
    394 
    +                  -> [ModSummary]
    399 395 
                       -> Maybe ModuleGraph
    400 396 
                       -> [ModuleName]
    401 397 
                       -> Bool
    ... ... @@ -407,17 +403,16 @@ downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_du
    407 403 
        = do
    408 404 
            let root_map = mkRootMap root_nodes
    409 405 
            checkDuplicates root_map
    410 
    -       let env = DownsweepEnv hsc_env mode old_summaries excl_mods
    411 
    -       (deps', map0) <- runDownsweepM env  $ do
    412 
    -                    let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph
    413 
    -                    (module_deps, map0) <- loopModuleNodeInfos root_nodes (base_nodes, root_map)
    414 
    -                    let all_deps = loopUnit hsc_env module_deps root_uids
    415 
    -                    let all_instantiations =  getHomeUnitInstantiations hsc_env
    416 
    -                    deps' <- loopInstantiations all_instantiations all_deps
    417 
    -                    return (deps', map0)
    418 
    -
    419 
    -
    420 
    -       let downsweep_errs = lefts $ concat $ M.elems map0
    406 
    +       summ_cache <- newIORef (foldr insertRoot (mkModSummaryCache old_summaries) root_nodes)
    407 
    +       let env = DownsweepEnv hsc_env mode summ_cache excl_mods
    408 
    +       deps' <- runDownsweepM env  $ do
    409 
    +          let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph
    410 
    +          module_deps <- loopModuleNodeInfos base_nodes root_nodes
    411 
    +          all_deps    <- loopUnits module_deps (hscActiveUnitId hsc_env) root_uids
    412 
    +          deps'       <- loopInstantiations all_deps (getHomeUnitInstantiations hsc_env)
    413 
    +          return deps'
    414 
    +       (m_cache, f_cache) <- readIORef summ_cache
    415 
    +       let downsweep_errs = lefts (moduleEnvElts m_cache) ++ lefts (M.elems f_cache)
    421 416 
                downsweep_nodes = M.elems deps'
    422 417
    423 418 
            return (downsweep_errs, downsweep_nodes)
    ... ... @@ -441,6 +436,8 @@ downsweepFromRootNodes hsc_env old_summaries maybe_base_graph excl_mods allow_du
    441 436 
                  dup_roots :: [[ModuleNodeInfo]]        -- Each at least of length 2
    442 437 
                  dup_roots = filterOut isSingleton $ map rights (M.elems root_map)
    443 438
    439 
    +        insertRoot (ModuleNodeCompile ms) = addModSummaryCache ms
    440 
    +        insertRoot (ModuleNodeFixed _ _)  = id
    444 441
    445 442 
     calcDeps :: ModSummary -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
    446 443 
     calcDeps ms =
    ... ... @@ -455,104 +452,186 @@ type DownsweepM a = ReaderT DownsweepEnv IO a
    455 452 
     data DownsweepEnv = DownsweepEnv {
    456 453 
           downsweep_hsc_env :: HscEnv
    457 454 
         , _downsweep_mode :: DownsweepMode
    458 
    -    , _downsweep_old_summaries :: M.Map (UnitId, OsPath) ModSummary
    455 
    +    , _downsweep_summaries_cache :: ModSummaryCache
    459 456 
         , _downsweep_excl_mods :: [ModuleName]
    460 457 
     }
    461 458
    462 
    -runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
    463 
    -runDownsweepM env act = runReaderT act env
    459 
    +type ModSummaryCache = IORef ModSummaryCacheMap
    460 
    +
    461 
    +-- | A cache both from 'Module' or file paths to the already summarised
    462 
    +-- modules. The same file can be used in multiple units so the file-path map is
    463 
    +-- actually also keyed by which unit the file was used in.
    464 
    +--
    465 
    +-- We want to reuse ModSummaries as far as possible because the most expensive
    466 
    +-- part of downsweep is reading the headers.
    467 
    +type ModSummaryCacheMap
    468 
    +      = ( ModuleEnv (Either DriverMessages ModSummary)
    469 
    +        , M.Map (UnitId, OsPath) (Either DriverMessages ModSummary) )
    464 470
    471 
    +mkModSummaryCache :: [ModSummary] -> ModSummaryCacheMap
    472 
    +mkModSummaryCache summs = foldr addModSummaryCache (emptyModuleEnv, M.empty) summs
    465 473
    466 
    -loopInstantiations :: [(UnitId, InstantiatedUnit)]
    467 
    -                   -> M.Map NodeKey ModuleGraphNode
    468 
    -                   -> DownsweepM (M.Map NodeKey ModuleGraphNode)
    469 
    -loopInstantiations [] done = pure done
    470 
    -loopInstantiations ((home_uid, iud) :xs) done = do
    471 
    -  hsc_env <- asks downsweep_hsc_env
    472 
    -  let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
    473 
    -  let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
    474 
    -      done' = loopUnit hsc_env' done [instUnitInstanceOf iud]
    475 
    -      payload = InstantiationNode home_uid iud
    476 
    -  loopInstantiations xs (M.insert (mkNodeKey payload) payload done')
    477 
    -
    478 
    -
    479 
    --- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
    480 
    -loopSummaries :: [ModSummary]
    481 
    -      -> (M.Map NodeKey ModuleGraphNode,
    482 
    -            DownsweepCache)
    483 
    -      -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
    484 
    -loopSummaries [] done = pure done
    485 
    -loopSummaries (ms:next) (done, summarised)
    486 
    -  | Just {} <- M.lookup k done
    487 
    -  = loopSummaries next (done, summarised)
    488 
    -  -- Didn't work out what the imports mean yet, now do that.
    489 
    -  | otherwise = do
    490 
    -     (final_deps, done', summarised') <- loopImports (ms_unitid ms) (calcDeps ms) done summarised
    491 
    -     -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
    492 
    -     (_, done'', summarised'') <- loopImports (ms_unitid ms) (maybeToList hs_file_for_boot) done' summarised'
    493 
    -     loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
    474 
    +addModSummaryCache :: ModSummary -> ModSummaryCacheMap -> ModSummaryCacheMap
    475 
    +addModSummaryCache ms (me, fe) = (upd_me me, upd_fe fe)
    494 476 
       where
    495 
    -    k = NodeKey_Module (msKey ms)
    477 
    +    upd_me me = extendModuleEnv me (ms_mod ms) (Right ms)
    478 
    +    upd_fe fe
    479 
    +      | Just src_fn_os <- ml_hs_file_ospath (ms_location ms)
    480 
    +      = M.insert (ms_unitid ms, src_fn_os) (Right ms) fe
    481 
    +      | otherwise = fe
    496 482
    497 
    -    hs_file_for_boot
    498 
    -      | HsBootFile <- ms_hsc_src ms
    499 
    -      = Just (NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
    500 
    -      | otherwise
    501 
    -      = Nothing
    502 
    -
    503 
    -loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
    504 
    -loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is
    505 
    -
    506 
    -loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
    507 
    -loopModuleNodeInfo mod_node_info (done, summarised) = do
    508 
    -  case mod_node_info of
    509 
    -    ModuleNodeCompile ms -> do
    510 
    -      loopSummaries [ms] (done, summarised)
    511 
    -    ModuleNodeFixed mod ml -> do
    512 
    -      done' <- loopFixedModule mod ml done
    513 
    -      return (done', summarised)
    514 
    -
    515 
    --- NB: loopFixedModule does not take a downsweep cache, because if you
    516 
    --- ever reach a Fixed node, everything under that also must be fixed.
    517 
    -loopFixedModule :: ModNodeKeyWithUid -> ModLocation
    518 
    -                -> M.Map NodeKey ModuleGraphNode
    519 
    -                -> DownsweepM (M.Map NodeKey ModuleGraphNode)
    520 
    -loopFixedModule key loc done = do
    521 
    -  let nk = NodeKey_Module key
    522 
    -  hsc_env <- asks downsweep_hsc_env
    523 
    -  case M.lookup nk done of
    524 
    -    Just {} -> return done
    525 
    -    Nothing -> do
    526 
    -      -- MP: TODO, we should just read the dependency info from the interface rather than either
    527 
    -      -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
    528 
    -      -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
    529 
    -      read_result <- liftIO $
    530 
    -        -- 1. Check if the interface is already loaded into the EPS by some other
    531 
    -        -- part of the compiler.
    532 
    -        lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
    533 
    -          Just iface -> return (M.Succeeded iface)
    534 
    -          Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
    483 
    +runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
    484 
    +runDownsweepM env act = runReaderT act env
    485 
    +
    486 
    +loopDownsweepNodes  :: M.Map NodeKey ModuleGraphNode -> [DownsweepNode]              -> DownsweepM (M.Map NodeKey ModuleGraphNode)
    487 
    +loopModuleNodeInfos :: M.Map NodeKey ModuleGraphNode -> [ModuleNodeInfo]             -> DownsweepM (M.Map NodeKey ModuleGraphNode)
    488 
    +loopUnits           :: M.Map NodeKey ModuleGraphNode -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey ModuleGraphNode)
    489 
    +loopInstantiations  :: M.Map NodeKey ModuleGraphNode -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey ModuleGraphNode)
    490 
    +loopDownsweepNodes  base_map nodes = dfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand
    491 
    +loopModuleNodeInfos base_map       = loopDownsweepNodes base_map . map DSMod
    492 
    +loopUnits           base_map homud = loopDownsweepNodes base_map . map (DSUnit homud)
    493 
    +loopInstantiations  base_map       = loopDownsweepNodes base_map . map (uncurry DSInst)
    494 
    +
    495 
    +--------------------------------------------------------------------------------
    496 
    +
    497 
    +-- | A 'DownsweepNode' is the basic block of the downsweep algorithm which
    498 
    +-- encompasses the types of nodes we can iteratively expand to construct the
    499 
    +-- full module graph. See 'loopDownsweepNodes'.
    500 
    +data DownsweepNode
    501 
    +  = DSMod  ModuleNodeInfo
    502 
    +  -- ^ A module node to expand
    503 
    +  | DSUnit
    504 
    +  { home_context_uid :: UnitId
    505 
    +  -- ^ The home unit which introduced the dependency on this 'node_uid'. This
    506 
    +  -- 'node_uid' can only be expanded in the context ('HscEnv') where
    507 
    +  -- 'home_context_uid' is the active home unit, to make sure the package flags
    508 
    +  -- are the ones attributed to the home package that introduced this node.
    509 
    +  , node_uid         :: UnitId
    510 
    +  -- ^ The unit node to expand
    511 
    +  }
    512 
    +  | DSInst
    513 
    +  { home_context_uid :: UnitId
    514 
    +  , instantiated_ud  :: InstantiatedUnit
    515 
    +  }
    516 
    +
    517 
    +-- | They key by which to cache previously visited 'DownsweepNode's
    518 
    +dsNodeInfoKey :: DownsweepNode -> NodeKey
    519 
    +dsNodeInfoKey = \case
    520 
    +  DSMod (ModuleNodeCompile ms)  -> NodeKey_Module (msKey ms)
    521 
    +  DSMod (ModuleNodeFixed mod _) -> NodeKey_Module mod
    522 
    +  DSUnit{node_uid}              -> NodeKey_ExternalUnit node_uid
    523 
    +  DSInst{instantiated_ud}       -> NodeKey_Unit instantiated_ud
    524 
    +
    525 
    +dsNodeExpand :: DownsweepNode -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))
    526 
    +dsNodeExpand = \case
    527 
    +  DSMod (ModuleNodeCompile ms)         -> expandModuleSummary ms
    528 
    +  DSMod (ModuleNodeFixed key loc)      -> expandFixedModuleNode key loc
    529 
    +  DSUnit{ node_uid, home_context_uid } -> expandUnitNode node_uid home_context_uid
    530 
    +  DSInst{ instantiated_ud
    531 
    +        , home_context_uid }           -> expandInstantiatedUnit instantiated_ud home_context_uid
    532 
    +
    533 
    +expandModuleSummary :: ModSummary -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))
    534 
    +expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do that.
    535 
    +    hsc_env <- asks downsweep_hsc_env
    536 
    +    let home_uid  = ms_unitid ms
    537 
    +        home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
    538 
    +    (final_deps, todo) <- fmap unzip $ forM (calcDeps ms) $ \(imp,mb_pkg,gwib) -> do
    539 
    +      let GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
    540 
    +          wanted_mod = L loc mod
    541 
    +      mb_s <- downsweepSummarise home_unit is_boot wanted_mod mb_pkg Nothing
    542 
    +      case mb_s of
    543 
    +        NotThere -> return
    544 
    +          ( Nothing, [] )
    545 
    +        External uid -> return
    546 
    +          ( Just $ mkModuleEdge imp (NodeKey_ExternalUnit uid)
    547 
    +          -- Specify home unit, as each unit might have a different visible package database.
    548 
    +          , [DSUnit{node_uid = uid, home_context_uid = home_uid}] )
    549 
    +        FoundInstantiation iud -> return
    550 
    +          ( Just (mkModuleEdge imp (NodeKey_Unit iud)), [] )
    551 
    +        FoundHomeWithError (_uid, _e) -> return
    552 
    +          ( Nothing, [] )
    553 
    +          -- the error @e@ is already stored in the summarisation cache,
    554 
    +          -- (the IORef in DownsweepM) and will get reported at the end.
    555 
    +        FoundHome s -> return
    556 
    +          -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
    557 
    +          ( Just $ mkModuleEdge imp (NodeKey_Module (mnKey s))
    558 
    +          , [DSMod s] )
    559 
    +          -- TODO: if this FoundHome was already in the cache, we shouldn't
    560 
    +          -- return any dependencies right? or will it all work out?
    561 
    +
    562 
    +    -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
    563 
    +    if | HsBootFile <- ms_hsc_src ms
    564 
    +       -> void $
    565 
    +          downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing
    566 
    +       | otherwise
    567 
    +       -> pure ()
    568 
    +
    569 
    +    return $ Just
    570 
    +      ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms)
    571 
    +      , concat todo )
    572 
    +
    573 
    +-- | Expand a 'ModuleNodeFixed' node
    574 
    +-- NB: If you ever reach a Fixed node, everything under that also must be fixed.
    575 
    +expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))
    576 
    +expandFixedModuleNode key loc = do
    577 
    +    hsc_env <- asks downsweep_hsc_env
    578 
    +    -- MP: TODO, we should just read the dependency info from the interface rather than either
    579 
    +    -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
    580 
    +    -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
    581 
    +    read_result <- liftIO $
    582 
    +      -- 1. Check if the interface is already loaded into the EPS by some other
    583 
    +      -- part of the compiler.
    584 
    +      lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
    585 
    +        Just iface -> return (M.Succeeded iface)
    586 
    +        Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
    587 
    +    case read_result of
    588 
    +      M.Succeeded iface -> do
    589 
    +        -- Computer information about this node
    590 
    +        let node_deps = ifaceDeps (mi_deps iface)
    591 
    +            edges = map mkFixedEdge node_deps
    592 
    +            node = ModuleNode edges (ModuleNodeFixed key loc)
    593 
    +        deps' <- catMaybes <$> mapM (mk_dep hsc_env) (bimap snd snd <$> node_deps)
    594 
    +        pure $ Just (node, deps')
    595 
    +
    596 
    +      -- Ignore any failure, we might try to read a .hi-boot file for
    597 
    +      -- example, even if there is not one.
    598 
    +      M.Failed {} ->
    599 
    +        pure Nothing
    600 
    +  where
    601 
    +    mk_dep hsc_env (Left key) = do
    602 
    +      -- Like expandImports, but we already know exactly which module we are looking for.
    603 
    +      read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
    535 604 
           case read_result of
    536 
    -        M.Succeeded iface -> do
    537 
    -          -- Computer information about this node
    538 
    -          let node_deps = ifaceDeps (mi_deps iface)
    539 
    -              edges = map mkFixedEdge node_deps
    540 
    -              node = ModuleNode edges (ModuleNodeFixed key loc)
    541 
    -          foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)
    542 
    -        -- Ignore any failure, we might try to read a .hi-boot file for
    543 
    -        -- example, even if there is not one.
    544 
    -        M.Failed {} ->
    545 
    -          return done
    546 
    -
    547 
    -loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM  (M.Map NodeKey ModuleGraphNode)
    548 
    -loopFixedNodeKey _ done (Left key) = do
    549 
    -  loopFixedImports [key] done
    550 
    -loopFixedNodeKey home_uid done (Right uid) = do
    551 
    -  -- Set active unit so that looking loopUnit finds the correct
    552 
    -  -- -package flags in the unit state.
    553 
    -  hsc_env <- asks downsweep_hsc_env
    554 
    -  let hsc_env' = hscSetActiveUnitId home_uid hsc_env
    555 
    -  return $ loopUnit hsc_env' done [uid]
    605 
    +        InstalledFound loc -> do
    606 
    +          pure $ Just $ DSMod (ModuleNodeFixed key loc)
    607 
    +        _otherwise ->
    608 
    +          -- If the finder fails, just keep going, there will be another
    609 
    +          -- error later.
    610 
    +          pure Nothing
    611 
    +    mk_dep _ (Right uid_dep) = do
    612 
    +      -- Set active unit so that looking loopUnit finds the correct
    613 
    +      -- -package flags in the unit state.
    614 
    +      let home_uid = mnkUnitId key
    615 
    +      pure (Just DSUnit{node_uid=uid_dep, home_context_uid=home_uid})
    616 
    +
    617 
    +-- | Expand a unit id under the context of a certain home unit
    618 
    +expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @node_uid@ was introduced -}
    619 
    +               -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))
    620 
    +expandUnitNode node_uid home_context_uid = do
    621 
    +    -- Set active unit so that looking loopUnit finds the correct
    622 
    +    -- -package flags in the unit state.
    623 
    +    hsc_env <- asks downsweep_hsc_env
    624 
    +    let lcl_hsc_env = hscSetActiveUnitId home_context_uid hsc_env
    625 
    +    case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) node_uid of
    626 
    +      Just us -> pure $ Just ((UnitNode us node_uid), map (\u -> DSUnit{node_uid=u, home_context_uid{-inherit-}}) us)
    627 
    +      Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr node_uid)
    628 
    +
    629 
    +expandInstantiatedUnit :: InstantiatedUnit -> UnitId {-^ Home unit -} -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))
    630 
    +expandInstantiatedUnit iud home_uid = pure $ Just
    631 
    +  ( InstantiationNode home_uid iud
    632 
    +  , [DSUnit{node_uid=instUnitInstanceOf iud, home_context_uid=home_uid}] )
    633 
    +
    634 
    +--------------------------------------------------------------------------------
    556 635
    557 636 
     mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
    558 637 
     mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
    ... ... @@ -567,27 +646,6 @@ ifaceDeps deps =
    567 646 
       | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
    568 647 
       ]
    569 648
    570 
    --- Like loopImports, but we already know exactly which module we are looking for.
    571 
    -loopFixedImports :: [ModNodeKeyWithUid]
    572 
    -                 -> M.Map NodeKey ModuleGraphNode
    573 
    -                 -> DownsweepM (M.Map NodeKey ModuleGraphNode)
    574 
    -loopFixedImports [] done = pure done
    575 
    -loopFixedImports (key:keys) done = do
    576 
    -  let nk = NodeKey_Module key
    577 
    -  hsc_env <- asks downsweep_hsc_env
    578 
    -  case M.lookup nk done of
    579 
    -    Just {} -> loopFixedImports keys done
    580 
    -    Nothing -> do
    581 
    -      read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
    582 
    -      case read_result of
    583 
    -        InstalledFound loc -> do
    584 
    -          done' <- loopFixedModule key loc done
    585 
    -          loopFixedImports keys done'
    586 
    -        _otherwise ->
    587 
    -          -- If the finder fails, just keep going, there will be another
    588 
    -          -- error later.
    589 
    -          loopFixedImports keys done
    590 
    -
    591 649 
     downsweepSummarise :: HomeUnit
    592 650 
                        -> IsBootInterface
    593 651 
                        -> Located ModuleName
    ... ... @@ -595,82 +653,11 @@ downsweepSummarise :: HomeUnit
    595 653 
                        -> Maybe (StringBuffer, UTCTime)
    596 654 
                        -> DownsweepM SummariseResult
    597 655 
     downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do
    598 
    -  DownsweepEnv hsc_env mode old_summaries excl_mods <- ask
    656 
    +  DownsweepEnv hsc_env mode summaries_cache_ref excl_mods <- ask
    599 657 
       case mode of
    600 
    -    DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods
    658 
    +    DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit summaries_cache_ref is_boot wanted_mod mb_pkg maybe_buf excl_mods
    601 659 
         DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods
    602 660
    603 
    -
    604 
    --- This loops over each import in each summary. It is mutually recursive with
    605 
    --- loopSummaries if we discover a new module by doing this.
    606 
    -loopImports
    607 
    -  :: UnitId
    608 
    -      -- ^ UnitId of home unit of summary whose imports are being processed
    609 
    -  -> [(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
    610 
    -      -- ^ Work list: process these modules
    611 
    -  -> M.Map NodeKey ModuleGraphNode
    612 
    -  -> DownsweepCache
    613 
    -      -- ^ Visited set; the range is a list because
    614 
    -      -- the roots can have the same module names
    615 
    -      -- if allow_dup_roots is True
    616 
    -  -> DownsweepM ([ModuleNodeEdge],
    617 
    -       M.Map NodeKey ModuleGraphNode, DownsweepCache)
    618 
    -      -- ^ The result is the completed NodeMap
    619 
    -loopImports _ [] done summarised = return ([], done, summarised)
    620 
    -loopImports home_uid ((imp, mb_pkg, gwib) : ss) done summarised
    621 
    -  | Just summs <- M.lookup cache_key summarised
    622 
    -  = case summs of
    623 
    -      [Right ms] -> do
    624 
    -        let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))
    625 
    -        (rest, summarised', done') <- loopImportsNext done summarised
    626 
    -        return (nk: rest, summarised', done')
    627 
    -      [Left _err] ->
    628 
    -        loopImportsNext done summarised
    629 
    -      _errs ->  do
    630 
    -        loopImportsNext done summarised
    631 
    -  | otherwise
    632 
    -  = do
    633 
    -       hsc_env <- asks downsweep_hsc_env
    634 
    -       let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
    635 
    -       mb_s <- downsweepSummarise home_unit
    636 
    -                               is_boot wanted_mod mb_pkg
    637 
    -                               Nothing
    638 
    -       case mb_s of
    639 
    -           NotThere -> loopImportsNext done summarised
    640 
    -           External uid -> do
    641 
    -            -- Pass an updated hsc_env to loopUnit, as each unit might
    642 
    -            -- have a different visible package database.
    643 
    -            let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
    644 
    -            let done' = loopUnit hsc_env' done [uid]
    645 
    -            (other_deps, done'', summarised') <- loopImportsNext done' summarised
    646 
    -            return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')
    647 
    -           FoundInstantiation iud -> do
    648 
    -            (other_deps, done', summarised') <- loopImportsNext done summarised
    649 
    -            return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')
    650 
    -           FoundHomeWithError (_uid, e) ->  loopImportsNext done (Map.insert cache_key [(Left e)] summarised)
    651 
    -           FoundHome s -> do
    652 
    -             (done', summarised') <-
    653 
    -               loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)
    654 
    -             (other_deps, final_done, final_summarised) <- loopImportsNext done' summarised'
    655 
    -
    656 
    -             -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
    657 
    -             return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)
    658 
    -  where
    659 
    -    loopImportsNext = loopImports home_uid ss
    660 
    -    cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
    661 
    -    GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
    662 
    -    wanted_mod = L loc mod
    663 
    -
    664 
    -loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
    665 
    -loopUnit _ cache [] = cache
    666 
    -loopUnit lcl_hsc_env cache (u:uxs) = do
    667 
    -   let nk = (NodeKey_ExternalUnit u)
    668 
    -   case Map.lookup nk cache of
    669 
    -     Just {} -> loopUnit lcl_hsc_env cache uxs
    670 
    -     Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of
    671 
    -                 Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs
    672 
    -                 Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)
    673 
    -
    674 661 
     multiRootsErr :: SourceErrorContext -> [ModuleNodeInfo] -> IO ()
    675 662 
     multiRootsErr _ [] = panic "multiRootsErr"
    676 663 
     multiRootsErr sec summs@(summ1:_)
    ... ... @@ -732,24 +719,24 @@ linkNodes summaries uid hue =
    732 719
    733 720 
     getRootSummary ::
    734 721 
       [ModuleName] ->
    735 
    -  M.Map (UnitId, OsPath) ModSummary ->
    722 
    +  ModSummaryCache ->
    736 723 
       HscEnv ->
    737 724 
       Target ->
    738 725 
       IO (Either DriverMessages ModSummary)
    739 
    -getRootSummary excl_mods old_summary_map hsc_env target
    726 
    +getRootSummary excl_mods summ_cache hsc_env target
    740 727 
       | TargetFile file mb_phase <- targetId
    741 728 
       = do
    742 729 
         let offset_file = augmentByWorkingDirectory dflags file
    743 730 
         exists <- liftIO $ doesFileExist offset_file
    744 731 
         if exists || isJust maybe_buf
    745 
    -    then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
    732 
    +    then summariseFile hsc_env home_unit summ_cache offset_file mb_phase
    746 733 
              maybe_buf
    747 734 
         else
    748 735 
           return $ Left $ singleMessage $
    749 736 
           mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)
    750 737 
       | TargetModule modl <- targetId
    751 738 
       = do
    752 
    -    maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot
    739 
    +    maybe_summary <- summariseModule hsc_env home_unit summ_cache NotBoot
    753 740 
                          (L rootLoc modl) (ThisPkg (homeUnitId home_unit))
    754 741 
                          maybe_buf excl_mods
    755 742 
         pure case maybe_summary of
    ... ... @@ -1178,9 +1165,7 @@ Potential TODOS:
    1178 1165 
     -}
    1179 1166
    1180 1167 
     -- | Populate the Downsweep cache with the root modules.
    1181 
    -mkRootMap
    1182 
    -  :: [ModuleNodeInfo]
    1183 
    -  -> DownsweepCache
    1168 
    +mkRootMap :: [ModuleNodeInfo] -> DownsweepCache
    1184 1169 
     mkRootMap summaries = Map.fromListWith (flip (++))
    1185 1170 
       [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ]
    1186 1171
    ... ... @@ -1200,33 +1185,32 @@ mkRootMap summaries = Map.fromListWith (flip (++))
    1200 1185 
     summariseFile
    1201 1186 
             :: HscEnv
    1202 1187 
             -> HomeUnit
    1203 
    -        -> M.Map (UnitId, OsPath) ModSummary    -- old summaries
    1188 
    +        -> ModSummaryCache
    1204 1189 
             -> FilePath                     -- source file name
    1205 1190 
             -> Maybe Phase                  -- start phase
    1206 1191 
             -> Maybe (StringBuffer,UTCTime)
    1207 1192 
             -> IO (Either DriverMessages ModSummary)
    1208 1193
    1209 
    -summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
    1210 
    -        -- we can use a cached summary if one is available and the
    1211 
    -        -- source file hasn't changed,
    1212 
    -   | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries
    1213 
    -   = do
    1214 
    -        let location = ms_location $ old_summary
    1215 
    -
    1216 
    -        src_hash <- get_src_hash
    1217 
    -                -- The file exists; we checked in getRootSummary above.
    1218 
    -                -- If it gets removed subsequently, then this
    1219 
    -                -- getFileHash may fail, but that's the right
    1220 
    -                -- behaviour.
    1221 
    -
    1222 
    -                -- return the cached summary if the source didn't change
    1223 
    -        checkSummaryHash
    1224 
    -            hsc_env (new_summary src_fn)
    1225 
    -            old_summary location src_hash
    1226 
    -
    1227 
    -   | otherwise
    1228 
    -   = do src_hash <- get_src_hash
    1229 
    -        new_summary src_fn src_hash
    1194 
    +summariseFile hsc_env' home_unit summ_cache_ref src_fn mb_phase maybe_buf
    1195 
    +   = do (_, file_summ_cache) <- readIORef summ_cache_ref
    1196 
    +        case M.lookup (homeUnitId home_unit, src_fn_os) file_summ_cache of
    1197 
    +          Just (Right old_summary) -> do
    1198 
    +            -- we can use a cached summary if one is available and the
    1199 
    +            -- source file hasn't changed,
    1200 
    +            let location = ms_location $ old_summary
    1201 
    +
    1202 
    +            src_hash <- get_src_hash
    1203 
    +                    -- The file exists; we checked in getRootSummary above.
    1204 
    +                    -- If it gets removed subsequently, then this
    1205 
    +                    -- getFileHash may fail, but that's the right
    1206 
    +                    -- behaviour.
    1207 
    +
    1208 
    +                    -- return the cached summary if the source didn't change
    1209 
    +            checkSummaryHash
    1210 
    +                hsc_env (new_summary src_fn)
    1211 
    +                old_summary location src_hash
    1212 
    +          _ -> do src_hash <- get_src_hash
    1213 
    +                  new_summary src_fn src_hash
    1230 1214 
       where
    1231 1215 
         -- change the main active unit so all operations happen relative to the given unit
    1232 1216 
         hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
    ... ... @@ -1237,7 +1221,8 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
    1237 1221 
                           Just (buf,_) -> return $ fingerprintStringBuffer buf
    1238 1222 
                           Nothing -> liftIO $ getFileHash src_fn
    1239 1223
    1240 
    -    new_summary src_fn src_hash = runExceptT $ do
    1224 
    +    new_summary src_fn src_hash = do
    1225 
    +      res <- runExceptT $ do
    1241 1226 
             preimps@PreprocessedImports {..}
    1242 1227 
                 <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
    1243 1228
    ... ... @@ -1268,6 +1253,11 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
    1268 1253 
                 , nms_mod = mod
    1269 1254 
                 , nms_preimps = preimps
    1270 1255 
                 }
    1256 
    +      case res of
    1257 
    +        Left e -> modifyIORef' summ_cache_ref
    1258 
    +          (\(me, fe) -> (me, M.insert (homeUnitId home_unit, src_fn_os) (Left e) fe))
    1259 
    +        Right ms -> modifyIORef' summ_cache_ref (addModSummaryCache ms)
    1260 
    +      return res
    1271 1261
    1272 1262 
     checkSummaryHash
    1273 1263 
         :: HscEnv
    ... ... @@ -1320,7 +1310,7 @@ data SummariseResult =
    1320 1310 
     -- --make mode.
    1321 1311 
     summariseModule :: HscEnv
    1322 1312 
                     -> HomeUnit
    1323 
    -                -> M.Map (UnitId, OsPath) ModSummary
    1313 
    +                -> ModSummaryCache
    1324 1314 
                     -> IsBootInterface
    1325 1315 
                     -> Located ModuleName
    1326 1316 
                     -> PkgQual
    ... ... @@ -1400,15 +1390,15 @@ summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg exc
    1400 1390 
     -- for it and potentially compile it.
    1401 1391 
     summariseModuleWithSource
    1402 1392 
               :: HomeUnit
    1403 
    -          -> M.Map (UnitId, OsPath) ModSummary
    1404 
    -          -- ^ Map of old summaries
    1393 
    +          -> ModSummaryCache
    1394 
    +          -- ^ Cache of constructed summaries
    1405 1395 
               -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
    1406 1396 
               -> Maybe (StringBuffer, UTCTime)
    1407 1397 
               -> HscEnv
    1408 1398 
               -> ModLocation
    1409 1399 
               -> Module
    1410 1400 
               -> IO SummariseResult
    1411 
    -summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do
    1401 
    +summariseModuleWithSource home_unit summ_cache_ref is_boot maybe_buf hsc_env location mod = do
    1412 1402 
             -- Adjust location to point to the hs-boot source file,
    1413 1403 
             -- hi file, object file, when is_boot says so
    1414 1404 
             let src_fn = expectJust (ml_hs_file location)
    ... ... @@ -1428,20 +1418,19 @@ summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env lo
    1428 1418
    1429 1419 
       where
    1430 1420 
         dflags    = hsc_dflags hsc_env
    1431 
    -    new_summary_cache_check loc mod src_fn h
    1432 
    -      | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map =
    1433 
    -
    1434 
    -         -- check the hash on the source file, and
    1435 
    -         -- return the cached summary if it hasn't changed.  If the
    1436 
    -         -- file has changed then need to resummarise.
    1437 
    -        case maybe_buf of
    1438 
    -           Just (buf,_) ->
    1439 
    -               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)
    1440 
    -           Nothing    ->
    1441 
    -               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
    1442 
    -      | otherwise = new_summary loc mod src_fn h
    1443 
    -      where
    1444 
    -        src_fn_os = unsafeEncodeUtf src_fn
    1421 
    +    new_summary_cache_check loc mod src_fn h = do
    1422 
    +      (summ_cache, _) <- readIORef summ_cache_ref
    1423 
    +      case lookupModuleEnv summ_cache mod of
    1424 
    +        Just (Right old_summary) -> do
    1425 
    +          -- check the hash on the source file, and
    1426 
    +          -- return the cached summary if it hasn't changed.  If the
    1427 
    +          -- file has changed then need to resummarise.
    1428 
    +          case maybe_buf of
    1429 
    +            Just (buf,_) ->
    1430 
    +                checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)
    1431 
    +            Nothing    ->
    1432 
    +                checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
    1433 
    +        _ -> new_summary loc mod src_fn h
    1445 1434
    1446 1435 
         new_summary :: ModLocation
    1447 1436 
                       -> Module
    ... ... @@ -1449,41 +1438,48 @@ summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env lo
    1449 1438 
                       -> Fingerprint
    1450 1439 
                       -> IO (Either DriverMessages ModSummary)
    1451 1440 
         new_summary location mod src_fn src_hash
    1452 
    -      = runExceptT $ do
    1453 
    -        preimps@PreprocessedImports {..}
    1454 
    -            -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP
    1455 
    -            -- See multiHomeUnits_cpp2 test
    1456 
    -            <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf
    1457 
    -
    1458 
    -        -- NB: Despite the fact that is_boot is a top-level parameter, we
    1459 
    -        -- don't actually know coming into this function what the HscSource
    1460 
    -        -- of the module in question is.  This is because we may be processing
    1461 
    -        -- this module because another module in the graph imported it: in this
    1462 
    -        -- case, we know if it's a boot or not because of the {-# SOURCE #-}
    1463 
    -        -- annotation, but we don't know if it's a signature or a regular
    1464 
    -        -- module until we actually look it up on the filesystem.
    1465 
    -        let hsc_src
    1466 
    -              | is_boot == IsBoot           = HsBootFile
    1467 
    -              | isHaskellSigFilename src_fn = HsigFile
    1468 
    -              | otherwise                   = HsSrcFile
    1469 
    -
    1470 
    -        when (pi_mod_name /= moduleName mod) $
    1471 
    -                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
    1472 
    -                       $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)
    1473 
    -
    1474 
    -        let instantiations = homeUnitInstantiations home_unit
    1475 
    -        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $
    1476 
    -            throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
    1477 
    -                   $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations
    1441 
    +      = pprTrace "new_summary" (ppr mod) $ do
    1442 
    +        res <- runExceptT $ do
    1443 
    +          preimps@PreprocessedImports {..}
    1444 
    +              -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP
    1445 
    +              -- See multiHomeUnits_cpp2 test
    1446 
    +              <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf
    1447 
    +
    1448 
    +          -- NB: Despite the fact that is_boot is a top-level parameter, we
    1449 
    +          -- don't actually know coming into this function what the HscSource
    1450 
    +          -- of the module in question is.  This is because we may be processing
    1451 
    +          -- this module because another module in the graph imported it: in this
    1452 
    +          -- case, we know if it's a boot or not because of the {-# SOURCE #-}
    1453 
    +          -- annotation, but we don't know if it's a signature or a regular
    1454 
    +          -- module until we actually look it up on the filesystem.
    1455 
    +          let hsc_src
    1456 
    +                | is_boot == IsBoot           = HsBootFile
    1457 
    +                | isHaskellSigFilename src_fn = HsigFile
    1458 
    +                | otherwise                   = HsSrcFile
    1459 
    +
    1460 
    +          when (pi_mod_name /= moduleName mod) $
    1461 
    +                  throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
    1462 
    +                         $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)
    1463 
    +
    1464 
    +          let instantiations = homeUnitInstantiations home_unit
    1465 
    +          when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $
    1466 
    +              throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
    1467 
    +                     $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations
    1468 
    +
    1469 
    +          liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
    1470 
    +              { nms_src_fn = src_fn
    1471 
    +              , nms_src_hash = src_hash
    1472 
    +              , nms_hsc_src = hsc_src
    1473 
    +              , nms_location = location
    1474 
    +              , nms_mod = mod
    1475 
    +              , nms_preimps = preimps
    1476 
    +              }
    1477 
    +        case res of
    1478 
    +          Left e -> modifyIORef' summ_cache_ref
    1479 
    +            (\(me, fe) -> (extendModuleEnv me mod (Left e), fe))
    1480 
    +          Right ms -> modifyIORef' summ_cache_ref (addModSummaryCache ms)
    1481 
    +        return res
    1478 1482
    1479 
    -        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
    1480 
    -            { nms_src_fn = src_fn
    1481 
    -            , nms_src_hash = src_hash
    1482 
    -            , nms_hsc_src = hsc_src
    1483 
    -            , nms_location = location
    1484 
    -            , nms_mod = mod
    1485 
    -            , nms_preimps = preimps
    1486 
    -            }
    1487 1483
    1488 1484 
     -- | Convenience named arguments for 'makeNewModSummary' only used to make
    1489 1485 
     -- code more readable, not exported.
    ... ... @@ -1563,3 +1559,37 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
    1563 1559 
       let pi_srcimps = pi_srcimps'
    1564 1560 
       let pi_theimps = rn_imps pi_theimps'
    1565 1561 
       return PreprocessedImports {..}
    1562 
    +
    1563 
    +--------------------------------------------------------------------------------
    1564 
    +
    1565 
    +-- ToDo: MiniQuickCheck me that I don't ever expand the same node twice (by key)
    1566 
    +-- ToDo: Docs
    1567 
    +-- base, roots, node to key, expand
    1568 
    +--
    1569 
    +-- @n@: a graph node, from which you can recover the key and dependencies
    1570 
    +-- @k@: a key from which you can compute the graph node (thus, transitively, the dependencies of that key too)
    1571 
    +--
    1572 
    +-- @n@ instanced by @ModuleGraphNode@
    1573 
    +-- @k@ instanced by @NodeKey@
    1574 
    +--
    1575 
    +-- Returning 'Nothing' in the @expand@ function means that node couldn't be
    1576 
    +-- expanded yet, and we should continue without failure. Do NOT cache a
    1577 
    +-- "negative" result for the 'Nothing', because we may yet discover new
    1578 
    +-- information and try to expand that node in the future again, then
    1579 
    +-- successfully.
    1580 
    +dfsBuild :: (Ord k, Monad m) => Maybe (Map.Map k v) -> [n] -> (n -> k) -> (n -> m (Maybe (v,[n]))) -> m (Map.Map k v)
    1581 
    +dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
    1582 
    +  where
    1583 
    +    go []     visited = pure visited
    1584 
    +    go (s:ss) visited
    1585 
    +      | k `Map.member` visited
    1586 
    +      = go ss visited
    1587 
    +      | otherwise
    1588 
    +      = do r <- expand s
    1589 
    +           case r of
    1590 
    +             Nothing -> go ss visited -- Skip!
    1591 
    +             Just (v,ns) ->
    1592 
    +               go (ns ++ ss {- todo: not use ++ here? -})
    1593 
    +                  (Map.insert k v visited)
    1594 
    +      where
    1595 
    +        k = key s

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