... |
... |
@@ -13,6 +13,7 @@ module GHC.Driver.Downsweep |
13
|
13
|
, downsweepThunk
|
14
|
14
|
, downsweepInstalledModules
|
15
|
15
|
, downsweepFromRootNodes
|
|
16
|
+ , downsweepInteractiveImports
|
16
|
17
|
, DownsweepMode(..)
|
17
|
18
|
-- * Summary functions
|
18
|
19
|
, summariseModule
|
... |
... |
@@ -49,6 +50,9 @@ import GHC.Iface.Load |
49
|
50
|
import GHC.Parser.Header
|
50
|
51
|
import GHC.Rename.Names
|
51
|
52
|
import GHC.Tc.Utils.Backpack
|
|
53
|
+import GHC.Runtime.Context
|
|
54
|
+
|
|
55
|
+import Language.Haskell.Syntax.ImpExp
|
52
|
56
|
|
53
|
57
|
import GHC.Data.Graph.Directed
|
54
|
58
|
import GHC.Data.FastString
|
... |
... |
@@ -76,6 +80,8 @@ import GHC.Types.SourceError |
76
|
80
|
import GHC.Types.SrcLoc
|
77
|
81
|
import GHC.Types.Unique.Map
|
78
|
82
|
import GHC.Types.PkgQual
|
|
83
|
+import GHC.Types.Basic
|
|
84
|
+
|
79
|
85
|
|
80
|
86
|
import GHC.Unit
|
81
|
87
|
import GHC.Unit.Env
|
... |
... |
@@ -236,6 +242,46 @@ downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do |
236
|
242
|
(GhcDriverMessage <$> unionManyMessages errs)
|
237
|
243
|
return (mkModuleGraph mg)
|
238
|
244
|
|
|
245
|
+-- | Construct a module graph starting from the interactive context.
|
|
246
|
+-- Produces, a thunk, which when forced will perform the downsweep.
|
|
247
|
+-- This graph contains the current interactive module, and its dependencies.
|
|
248
|
+
|
|
249
|
+-- This is a first approximation for this function.
|
|
250
|
+downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph
|
|
251
|
+downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
|
|
252
|
+ let imps = ic_imports (hsc_IC hsc_env)
|
|
253
|
+
|
|
254
|
+ let mn = icInteractiveModule ic
|
|
255
|
+ let ml = pprPanic "withInteractiveModuleNode" (ppr mn <+> ppr imps)
|
|
256
|
+ let key = moduleToMnk mn NotBoot
|
|
257
|
+ let node_type = ModuleNodeFixed key ml
|
|
258
|
+
|
|
259
|
+ let edges = map mkEdge imps
|
|
260
|
+ let env = DownsweepEnv hsc_env DownsweepUseCompile mempty []
|
|
261
|
+ (module_edges, graph, _) <- runDownsweepM env $ loopImports edges M.empty Map.empty
|
|
262
|
+ let node = ModuleNode module_edges node_type
|
|
263
|
+
|
|
264
|
+ let all_nodes = M.elems graph
|
|
265
|
+ let graph = mkModuleGraph (node : all_nodes)
|
|
266
|
+
|
|
267
|
+ return graph
|
|
268
|
+
|
|
269
|
+ where
|
|
270
|
+ --
|
|
271
|
+ mkEdge :: InteractiveImport -> (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))
|
|
272
|
+ -- A simple edge to a module from the same home unit
|
|
273
|
+ mkEdge (IIModule n) =
|
|
274
|
+ let unitId = homeUnitId $ hsc_home_unit hsc_env
|
|
275
|
+ in (unitId, NormalLevel, NoPkgQual, GWIB (noLoc n) NotBoot)
|
|
276
|
+ -- A complete import statement
|
|
277
|
+ mkEdge (IIDecl i) =
|
|
278
|
+ let lvl = convImportLevel (ideclLevelSpec i)
|
|
279
|
+ wanted_mod = unLoc (ideclName i)
|
|
280
|
+ is_boot = ideclSource i
|
|
281
|
+ mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)
|
|
282
|
+ unitId = homeUnitId $ hsc_home_unit hsc_env
|
|
283
|
+ in (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot)
|
|
284
|
+
|
239
|
285
|
-- | Create a module graph from a list of installed modules.
|
240
|
286
|
-- This is used by the loader when we need to load modules but there
|
241
|
287
|
-- isn't already an existing module graph. For example, when loading plugins
|
... |
... |
@@ -298,13 +344,16 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root |
298
|
344
|
= do
|
299
|
345
|
let root_map = mkRootMap root_nodes
|
300
|
346
|
checkDuplicates root_map
|
301
|
|
- (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)
|
302
|
|
- let all_deps = loopUnit hsc_env module_deps root_uids
|
|
347
|
+ let env = DownsweepEnv hsc_env mode old_summaries excl_mods
|
|
348
|
+ (deps', map0) <- runDownsweepM env $ do
|
|
349
|
+ (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)
|
|
350
|
+ let all_deps = loopUnit hsc_env module_deps root_uids
|
|
351
|
+ let all_instantiations = getHomeUnitInstantiations hsc_env
|
|
352
|
+ deps' <- loopInstantiations all_instantiations all_deps
|
|
353
|
+ return (deps', map0)
|
303
|
354
|
|
304
|
|
- let all_instantiations = getHomeUnitInstantiations hsc_env
|
305
|
|
- let deps' = loopInstantiations all_instantiations all_deps
|
306
|
355
|
|
307
|
|
- downsweep_errs = lefts $ concat $ M.elems map0
|
|
356
|
+ let downsweep_errs = lefts $ concat $ M.elems map0
|
308
|
357
|
downsweep_nodes = M.elems deps'
|
309
|
358
|
|
310
|
359
|
return (downsweep_errs, downsweep_nodes)
|
... |
... |
@@ -312,14 +361,6 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root |
312
|
361
|
getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]
|
313
|
362
|
getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env)
|
314
|
363
|
|
315
|
|
-
|
316
|
|
- calcDeps ms =
|
317
|
|
- -- Add a dependency on the HsBoot file if it exists
|
318
|
|
- -- This gets passed to the loopImports function which just ignores it if it
|
319
|
|
- -- can't be found.
|
320
|
|
- [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
|
321
|
|
- [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ]
|
322
|
|
-
|
323
|
364
|
-- In a root module, the filename is allowed to diverge from the module
|
324
|
365
|
-- name, so we have to check that there aren't multiple root files
|
325
|
366
|
-- defining the same module (otherwise the duplicates will be silently
|
... |
... |
@@ -335,208 +376,231 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root |
335
|
376
|
dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2
|
336
|
377
|
dup_roots = filterOut isSingleton $ map rights (M.elems root_map)
|
337
|
378
|
|
338
|
|
- loopInstantiations :: [(UnitId, InstantiatedUnit)]
|
339
|
|
- -> M.Map NodeKey ModuleGraphNode
|
340
|
|
- -> M.Map NodeKey ModuleGraphNode
|
341
|
|
- loopInstantiations [] done = done
|
342
|
|
- loopInstantiations ((home_uid, iud) :xs) done =
|
343
|
|
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
|
344
|
|
- done' = loopUnit hsc_env' done [instUnitInstanceOf iud]
|
345
|
|
- payload = InstantiationNode home_uid iud
|
346
|
|
- in loopInstantiations xs (M.insert (mkNodeKey payload) payload done')
|
347
|
|
-
|
348
|
|
- where
|
349
|
|
- home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
|
350
|
|
-
|
351
|
|
-
|
352
|
|
- -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
|
353
|
|
- loopSummaries :: [ModSummary]
|
354
|
|
- -> (M.Map NodeKey ModuleGraphNode,
|
355
|
|
- DownsweepCache)
|
356
|
|
- -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
|
357
|
|
- loopSummaries [] done = return done
|
358
|
|
- loopSummaries (ms:next) (done, summarised)
|
359
|
|
- | Just {} <- M.lookup k done
|
360
|
|
- = loopSummaries next (done, summarised)
|
361
|
|
- -- Didn't work out what the imports mean yet, now do that.
|
362
|
|
- | otherwise = do
|
363
|
|
- (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
|
364
|
|
- -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
|
365
|
|
- (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
|
366
|
|
- loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
|
367
|
|
- where
|
368
|
|
- k = NodeKey_Module (msKey ms)
|
369
|
|
-
|
370
|
|
- hs_file_for_boot
|
371
|
|
- | HsBootFile <- ms_hsc_src ms
|
372
|
|
- = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
|
373
|
|
- | otherwise
|
374
|
|
- = Nothing
|
375
|
|
-
|
376
|
|
- loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache)
|
377
|
|
- loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is
|
378
|
|
-
|
379
|
|
- loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache)
|
380
|
|
- loopModuleNodeInfo mod_node_info (done, summarised) = do
|
381
|
|
- case mod_node_info of
|
382
|
|
- ModuleNodeCompile ms -> do
|
383
|
|
- loopSummaries [ms] (done, summarised)
|
384
|
|
- ModuleNodeFixed mod ml -> do
|
385
|
|
- done' <- loopFixedModule mod ml done
|
386
|
|
- return (done', summarised)
|
387
|
|
-
|
388
|
|
- -- NB: loopFixedModule does not take a downsweep cache, because if you
|
389
|
|
- -- ever reach a Fixed node, everything under that also must be fixed.
|
390
|
|
- loopFixedModule :: ModNodeKeyWithUid -> ModLocation
|
391
|
|
- -> M.Map NodeKey ModuleGraphNode
|
392
|
|
- -> IO (M.Map NodeKey ModuleGraphNode)
|
393
|
|
- loopFixedModule key loc done = do
|
394
|
|
- let nk = NodeKey_Module key
|
395
|
|
- case M.lookup nk done of
|
396
|
|
- Just {} -> return done
|
397
|
|
- Nothing -> do
|
398
|
|
- -- MP: TODO, we should just read the dependency info from the interface rather than either
|
399
|
|
- -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
|
400
|
|
- -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
|
401
|
|
- read_result <-
|
402
|
|
- -- 1. Check if the interface is already loaded into the EPS by some other
|
403
|
|
- -- part of the compiler.
|
404
|
|
- lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
|
405
|
|
- Just iface -> return (M.Succeeded iface)
|
406
|
|
- Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
|
407
|
|
- case read_result of
|
408
|
|
- M.Succeeded iface -> do
|
409
|
|
- -- Computer information about this node
|
410
|
|
- let node_deps = ifaceDeps (mi_deps iface)
|
411
|
|
- edges = map mkFixedEdge node_deps
|
412
|
|
- node = ModuleNode edges (ModuleNodeFixed key loc)
|
413
|
|
- foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)
|
414
|
|
- -- Ignore any failure, we might try to read a .hi-boot file for
|
415
|
|
- -- example, even if there is not one.
|
416
|
|
- M.Failed {} ->
|
417
|
|
- return done
|
418
|
|
-
|
419
|
|
- loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> IO (M.Map NodeKey ModuleGraphNode)
|
420
|
|
- loopFixedNodeKey _ done (Left key) = do
|
421
|
|
- loopFixedImports [key] done
|
422
|
|
- loopFixedNodeKey home_uid done (Right uid) = do
|
423
|
|
- -- Set active unit so that looking loopUnit finds the correct
|
424
|
|
- -- -package flags in the unit state.
|
425
|
|
- let hsc_env' = hscSetActiveUnitId home_uid hsc_env
|
426
|
|
- return $ loopUnit hsc_env' done [uid]
|
427
|
|
-
|
428
|
|
- mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
|
429
|
|
- mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
|
430
|
|
- mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
|
431
|
|
-
|
432
|
|
- ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
|
433
|
|
- ifaceDeps deps =
|
434
|
|
- [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
|
435
|
|
- | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
|
436
|
|
- ] ++
|
437
|
|
- [ Right (tcImportLevel lvl, uid)
|
438
|
|
- | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
|
439
|
|
- ]
|
440
|
|
-
|
441
|
|
- -- Like loopImports, but we already know exactly which module we are looking for.
|
442
|
|
- loopFixedImports :: [ModNodeKeyWithUid]
|
443
|
|
- -> M.Map NodeKey ModuleGraphNode
|
444
|
|
- -> IO (M.Map NodeKey ModuleGraphNode)
|
445
|
|
- loopFixedImports [] done = pure done
|
446
|
|
- loopFixedImports (key:keys) done = do
|
447
|
|
- let nk = NodeKey_Module key
|
448
|
|
- case M.lookup nk done of
|
449
|
|
- Just {} -> loopFixedImports keys done
|
450
|
|
- Nothing -> do
|
451
|
|
- read_result <- findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
|
452
|
|
- case read_result of
|
453
|
|
- InstalledFound loc -> do
|
454
|
|
- done' <- loopFixedModule key loc done
|
455
|
|
- loopFixedImports keys done'
|
456
|
|
- _otherwise ->
|
457
|
|
- -- If the finder fails, just keep going, there will be another
|
458
|
|
- -- error later.
|
459
|
|
- loopFixedImports keys done
|
460
|
|
-
|
461
|
|
- downsweepSummarise :: HscEnv
|
462
|
|
- -> HomeUnit
|
463
|
|
- -> M.Map (UnitId, FilePath) ModSummary
|
464
|
|
- -> IsBootInterface
|
465
|
|
- -> Located ModuleName
|
466
|
|
- -> PkgQual
|
467
|
|
- -> Maybe (StringBuffer, UTCTime)
|
468
|
|
- -> [ModuleName]
|
469
|
|
- -> IO SummariseResult
|
470
|
|
- downsweepSummarise hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods =
|
471
|
|
- case mode of
|
472
|
|
- DownsweepUseCompile -> summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods
|
473
|
|
- DownsweepUseFixed -> summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods
|
474
|
|
-
|
475
|
|
-
|
476
|
|
- -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
|
477
|
|
- -- a new module by doing this.
|
478
|
|
- loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
|
479
|
|
- -- Work list: process these modules
|
480
|
|
- -> M.Map NodeKey ModuleGraphNode
|
481
|
|
- -> DownsweepCache
|
482
|
|
- -- Visited set; the range is a list because
|
483
|
|
- -- the roots can have the same module names
|
484
|
|
- -- if allow_dup_roots is True
|
485
|
|
- -> IO ([ModuleNodeEdge],
|
486
|
|
- M.Map NodeKey ModuleGraphNode, DownsweepCache)
|
487
|
|
- -- The result is the completed NodeMap
|
488
|
|
- loopImports [] done summarised = return ([], done, summarised)
|
489
|
|
- loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised
|
490
|
|
- | Just summs <- M.lookup cache_key summarised
|
491
|
|
- = case summs of
|
492
|
|
- [Right ms] -> do
|
493
|
|
- let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))
|
494
|
|
- (rest, summarised', done') <- loopImports ss done summarised
|
495
|
|
- return (nk: rest, summarised', done')
|
496
|
|
- [Left _err] ->
|
497
|
|
- loopImports ss done summarised
|
498
|
|
- _errs -> do
|
499
|
|
- loopImports ss done summarised
|
500
|
|
- | otherwise
|
501
|
|
- = do
|
502
|
|
- mb_s <- downsweepSummarise hsc_env home_unit old_summaries
|
503
|
|
- is_boot wanted_mod mb_pkg
|
504
|
|
- Nothing excl_mods
|
505
|
|
- case mb_s of
|
506
|
|
- NotThere -> loopImports ss done summarised
|
507
|
|
- External uid -> do
|
508
|
|
- -- Pass an updated hsc_env to loopUnit, as each unit might
|
509
|
|
- -- have a different visible package database.
|
510
|
|
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
|
511
|
|
- let done' = loopUnit hsc_env' done [uid]
|
512
|
|
- (other_deps, done'', summarised') <- loopImports ss done' summarised
|
513
|
|
- return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')
|
514
|
|
- FoundInstantiation iud -> do
|
515
|
|
- (other_deps, done', summarised') <- loopImports ss done summarised
|
516
|
|
- return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')
|
517
|
|
- FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
|
518
|
|
- FoundHome s -> do
|
519
|
|
- (done', summarised') <-
|
520
|
|
- loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)
|
521
|
|
- (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
|
522
|
|
-
|
523
|
|
- -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
|
524
|
|
- return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)
|
525
|
|
- where
|
526
|
|
- cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
|
527
|
|
- home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
|
528
|
|
- GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
|
529
|
|
- wanted_mod = L loc mod
|
530
|
|
-
|
531
|
|
- loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
|
532
|
|
- loopUnit _ cache [] = cache
|
533
|
|
- loopUnit lcl_hsc_env cache (u:uxs) = do
|
534
|
|
- let nk = (NodeKey_ExternalUnit u)
|
535
|
|
- case Map.lookup nk cache of
|
536
|
|
- Just {} -> loopUnit lcl_hsc_env cache uxs
|
537
|
|
- Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of
|
538
|
|
- Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs
|
539
|
|
- Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)
|
|
379
|
+
|
|
380
|
+calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
|
|
381
|
+calcDeps ms =
|
|
382
|
+ -- Add a dependency on the HsBoot file if it exists
|
|
383
|
+ -- This gets passed to the loopImports function which just ignores it if it
|
|
384
|
+ -- can't be found.
|
|
385
|
+ [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
|
|
386
|
+ [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ]
|
|
387
|
+
|
|
388
|
+
|
|
389
|
+type DownsweepM a = ReaderT DownsweepEnv IO a
|
|
390
|
+data DownsweepEnv = DownsweepEnv {
|
|
391
|
+ downsweep_hsc_env :: HscEnv
|
|
392
|
+ , _downsweep_mode :: DownsweepMode
|
|
393
|
+ , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary
|
|
394
|
+ , _downsweep_excl_mods :: [ModuleName]
|
|
395
|
+}
|
|
396
|
+
|
|
397
|
+runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
|
|
398
|
+runDownsweepM env act = runReaderT act env
|
|
399
|
+
|
|
400
|
+
|
|
401
|
+loopInstantiations :: [(UnitId, InstantiatedUnit)]
|
|
402
|
+ -> M.Map NodeKey ModuleGraphNode
|
|
403
|
+ -> DownsweepM (M.Map NodeKey ModuleGraphNode)
|
|
404
|
+loopInstantiations [] done = pure done
|
|
405
|
+loopInstantiations ((home_uid, iud) :xs) done = do
|
|
406
|
+ hsc_env <- asks downsweep_hsc_env
|
|
407
|
+ let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
|
|
408
|
+ let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
|
|
409
|
+ done' = loopUnit hsc_env' done [instUnitInstanceOf iud]
|
|
410
|
+ payload = InstantiationNode home_uid iud
|
|
411
|
+ loopInstantiations xs (M.insert (mkNodeKey payload) payload done')
|
|
412
|
+
|
|
413
|
+
|
|
414
|
+-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
|
|
415
|
+loopSummaries :: [ModSummary]
|
|
416
|
+ -> (M.Map NodeKey ModuleGraphNode,
|
|
417
|
+ DownsweepCache)
|
|
418
|
+ -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
|
|
419
|
+loopSummaries [] done = pure done
|
|
420
|
+loopSummaries (ms:next) (done, summarised)
|
|
421
|
+ | Just {} <- M.lookup k done
|
|
422
|
+ = loopSummaries next (done, summarised)
|
|
423
|
+ -- Didn't work out what the imports mean yet, now do that.
|
|
424
|
+ | otherwise = do
|
|
425
|
+ (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
|
|
426
|
+ -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
|
|
427
|
+ (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
|
|
428
|
+ loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
|
|
429
|
+ where
|
|
430
|
+ k = NodeKey_Module (msKey ms)
|
|
431
|
+
|
|
432
|
+ hs_file_for_boot
|
|
433
|
+ | HsBootFile <- ms_hsc_src ms
|
|
434
|
+ = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
|
|
435
|
+ | otherwise
|
|
436
|
+ = Nothing
|
|
437
|
+
|
|
438
|
+loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
|
|
439
|
+loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is
|
|
440
|
+
|
|
441
|
+loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
|
|
442
|
+loopModuleNodeInfo mod_node_info (done, summarised) = do
|
|
443
|
+ case mod_node_info of
|
|
444
|
+ ModuleNodeCompile ms -> do
|
|
445
|
+ loopSummaries [ms] (done, summarised)
|
|
446
|
+ ModuleNodeFixed mod ml -> do
|
|
447
|
+ done' <- loopFixedModule mod ml done
|
|
448
|
+ return (done', summarised)
|
|
449
|
+
|
|
450
|
+-- NB: loopFixedModule does not take a downsweep cache, because if you
|
|
451
|
+-- ever reach a Fixed node, everything under that also must be fixed.
|
|
452
|
+loopFixedModule :: ModNodeKeyWithUid -> ModLocation
|
|
453
|
+ -> M.Map NodeKey ModuleGraphNode
|
|
454
|
+ -> DownsweepM (M.Map NodeKey ModuleGraphNode)
|
|
455
|
+loopFixedModule key loc done = do
|
|
456
|
+ let nk = NodeKey_Module key
|
|
457
|
+ hsc_env <- asks downsweep_hsc_env
|
|
458
|
+ case M.lookup nk done of
|
|
459
|
+ Just {} -> return done
|
|
460
|
+ Nothing -> do
|
|
461
|
+ -- MP: TODO, we should just read the dependency info from the interface rather than either
|
|
462
|
+ -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
|
|
463
|
+ -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
|
|
464
|
+ read_result <- liftIO $
|
|
465
|
+ -- 1. Check if the interface is already loaded into the EPS by some other
|
|
466
|
+ -- part of the compiler.
|
|
467
|
+ lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
|
|
468
|
+ Just iface -> return (M.Succeeded iface)
|
|
469
|
+ Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
|
|
470
|
+ case read_result of
|
|
471
|
+ M.Succeeded iface -> do
|
|
472
|
+ -- Computer information about this node
|
|
473
|
+ let node_deps = ifaceDeps (mi_deps iface)
|
|
474
|
+ edges = map mkFixedEdge node_deps
|
|
475
|
+ node = ModuleNode edges (ModuleNodeFixed key loc)
|
|
476
|
+ foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)
|
|
477
|
+ -- Ignore any failure, we might try to read a .hi-boot file for
|
|
478
|
+ -- example, even if there is not one.
|
|
479
|
+ M.Failed {} ->
|
|
480
|
+ return done
|
|
481
|
+
|
|
482
|
+loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM (M.Map NodeKey ModuleGraphNode)
|
|
483
|
+loopFixedNodeKey _ done (Left key) = do
|
|
484
|
+ loopFixedImports [key] done
|
|
485
|
+loopFixedNodeKey home_uid done (Right uid) = do
|
|
486
|
+ -- Set active unit so that looking loopUnit finds the correct
|
|
487
|
+ -- -package flags in the unit state.
|
|
488
|
+ hsc_env <- asks downsweep_hsc_env
|
|
489
|
+ let hsc_env' = hscSetActiveUnitId home_uid hsc_env
|
|
490
|
+ return $ loopUnit hsc_env' done [uid]
|
|
491
|
+
|
|
492
|
+mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
|
|
493
|
+mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
|
|
494
|
+mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
|
|
495
|
+
|
|
496
|
+ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
|
|
497
|
+ifaceDeps deps =
|
|
498
|
+ [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
|
|
499
|
+ | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
|
|
500
|
+ ] ++
|
|
501
|
+ [ Right (tcImportLevel lvl, uid)
|
|
502
|
+ | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
|
|
503
|
+ ]
|
|
504
|
+
|
|
505
|
+-- Like loopImports, but we already know exactly which module we are looking for.
|
|
506
|
+loopFixedImports :: [ModNodeKeyWithUid]
|
|
507
|
+ -> M.Map NodeKey ModuleGraphNode
|
|
508
|
+ -> DownsweepM (M.Map NodeKey ModuleGraphNode)
|
|
509
|
+loopFixedImports [] done = pure done
|
|
510
|
+loopFixedImports (key:keys) done = do
|
|
511
|
+ let nk = NodeKey_Module key
|
|
512
|
+ hsc_env <- asks downsweep_hsc_env
|
|
513
|
+ case M.lookup nk done of
|
|
514
|
+ Just {} -> loopFixedImports keys done
|
|
515
|
+ Nothing -> do
|
|
516
|
+ read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
|
|
517
|
+ case read_result of
|
|
518
|
+ InstalledFound loc -> do
|
|
519
|
+ done' <- loopFixedModule key loc done
|
|
520
|
+ loopFixedImports keys done'
|
|
521
|
+ _otherwise ->
|
|
522
|
+ -- If the finder fails, just keep going, there will be another
|
|
523
|
+ -- error later.
|
|
524
|
+ loopFixedImports keys done
|
|
525
|
+
|
|
526
|
+downsweepSummarise :: HomeUnit
|
|
527
|
+ -> IsBootInterface
|
|
528
|
+ -> Located ModuleName
|
|
529
|
+ -> PkgQual
|
|
530
|
+ -> Maybe (StringBuffer, UTCTime)
|
|
531
|
+ -> DownsweepM SummariseResult
|
|
532
|
+downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do
|
|
533
|
+ DownsweepEnv hsc_env mode old_summaries excl_mods <- ask
|
|
534
|
+ case mode of
|
|
535
|
+ DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods
|
|
536
|
+ DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods
|
|
537
|
+
|
|
538
|
+
|
|
539
|
+-- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
|
|
540
|
+-- a new module by doing this.
|
|
541
|
+loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
|
|
542
|
+ -- Work list: process these modules
|
|
543
|
+ -> M.Map NodeKey ModuleGraphNode
|
|
544
|
+ -> DownsweepCache
|
|
545
|
+ -- Visited set; the range is a list because
|
|
546
|
+ -- the roots can have the same module names
|
|
547
|
+ -- if allow_dup_roots is True
|
|
548
|
+ -> DownsweepM ([ModuleNodeEdge],
|
|
549
|
+ M.Map NodeKey ModuleGraphNode, DownsweepCache)
|
|
550
|
+ -- The result is the completed NodeMap
|
|
551
|
+loopImports [] done summarised = return ([], done, summarised)
|
|
552
|
+loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised
|
|
553
|
+ | Just summs <- M.lookup cache_key summarised
|
|
554
|
+ = case summs of
|
|
555
|
+ [Right ms] -> do
|
|
556
|
+ let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))
|
|
557
|
+ (rest, summarised', done') <- loopImports ss done summarised
|
|
558
|
+ return (nk: rest, summarised', done')
|
|
559
|
+ [Left _err] ->
|
|
560
|
+ loopImports ss done summarised
|
|
561
|
+ _errs -> do
|
|
562
|
+ loopImports ss done summarised
|
|
563
|
+ | otherwise
|
|
564
|
+ = do
|
|
565
|
+ hsc_env <- asks downsweep_hsc_env
|
|
566
|
+ let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
|
|
567
|
+ mb_s <- downsweepSummarise home_unit
|
|
568
|
+ is_boot wanted_mod mb_pkg
|
|
569
|
+ Nothing
|
|
570
|
+ case mb_s of
|
|
571
|
+ NotThere -> loopImports ss done summarised
|
|
572
|
+ External uid -> do
|
|
573
|
+ -- Pass an updated hsc_env to loopUnit, as each unit might
|
|
574
|
+ -- have a different visible package database.
|
|
575
|
+ let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
|
|
576
|
+ let done' = loopUnit hsc_env' done [uid]
|
|
577
|
+ (other_deps, done'', summarised') <- loopImports ss done' summarised
|
|
578
|
+ return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')
|
|
579
|
+ FoundInstantiation iud -> do
|
|
580
|
+ (other_deps, done', summarised') <- loopImports ss done summarised
|
|
581
|
+ return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')
|
|
582
|
+ FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
|
|
583
|
+ FoundHome s -> do
|
|
584
|
+ (done', summarised') <-
|
|
585
|
+ loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)
|
|
586
|
+ (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
|
|
587
|
+
|
|
588
|
+ -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
|
|
589
|
+ return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)
|
|
590
|
+ where
|
|
591
|
+ cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
|
|
592
|
+ GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
|
|
593
|
+ wanted_mod = L loc mod
|
|
594
|
+
|
|
595
|
+loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
|
|
596
|
+loopUnit _ cache [] = cache
|
|
597
|
+loopUnit lcl_hsc_env cache (u:uxs) = do
|
|
598
|
+ let nk = (NodeKey_ExternalUnit u)
|
|
599
|
+ case Map.lookup nk cache of
|
|
600
|
+ Just {} -> loopUnit lcl_hsc_env cache uxs
|
|
601
|
+ Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of
|
|
602
|
+ Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs
|
|
603
|
+ Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)
|
540
|
604
|
|
541
|
605
|
multiRootsErr :: [ModuleNodeInfo] -> IO ()
|
542
|
606
|
multiRootsErr [] = panic "multiRootsErr"
|