Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC

Commits:

19 changed files:

Changes:

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -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"
    

  • compiler/GHC/Tc/Module.hs
    ... ... @@ -164,6 +164,7 @@ import GHC.Unit.Module.ModSummary
    164 164
     import GHC.Unit.Module.ModIface
    
    165 165
     import GHC.Unit.Module.ModDetails
    
    166 166
     import GHC.Unit.Module.Deps
    
    167
    +import GHC.Driver.Downsweep
    
    167 168
     
    
    168 169
     import GHC.Data.FastString
    
    169 170
     import GHC.Data.Maybe
    
    ... ... @@ -2077,12 +2078,25 @@ was added for External Core which faced a similar issue.
    2077 2078
     *********************************************************
    
    2078 2079
     -}
    
    2079 2080
     
    
    2081
    +-- This function is essentially a single-level downsweep
    
    2082
    +-- for an interactive module. There is no source file, so we create a fixed node.
    
    2083
    +withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a
    
    2084
    +withInteractiveModuleNode hsc_env thing_inside = do
    
    2085
    +  mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env)
    
    2086
    +  updTopEnv (\env -> env { hsc_mod_graph = mg }) thing_inside
    
    2087
    +
    
    2088
    +
    
    2089
    +
    
    2090
    +
    
    2091
    +
    
    2092
    +
    
    2080 2093
     runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
    
    2081 2094
     -- Initialise the tcg_inst_env with instances from all home modules.
    
    2082 2095
     -- This mimics the more selective call to hptInstances in tcRnImports
    
    2083 2096
     runTcInteractive hsc_env thing_inside
    
    2084 2097
       = initTcInteractive hsc_env $ withTcPlugins hsc_env $
    
    2085 2098
         withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $
    
    2099
    +    withInteractiveModuleNode hsc_env $
    
    2086 2100
         do { traceTc "setInteractiveContext" $
    
    2087 2101
                 vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
    
    2088 2102
                      , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts))
    

  • compiler/GHC/Unit/Module/Graph.hs
    ... ... @@ -101,6 +101,9 @@ module GHC.Unit.Module.Graph
    101 101
                                  -- time it's called.
    
    102 102
        , filterToposortToModules
    
    103 103
        , moduleGraphNodesZero
    
    104
    +   , StageSummaryNode
    
    105
    +   , stageSummaryNodeSummary
    
    106
    +   , stageSummaryNodeKey
    
    104 107
        , mkStageDeps
    
    105 108
     
    
    106 109
         -- * Keys into the 'ModuleGraph'
    
    ... ... @@ -930,6 +933,9 @@ stageSummaryNodeSummary = node_payload
    930 933
     --  * If NoImplicitStagePersistence then Quote/Splice/Normal imports offset the required stage
    
    931 934
     --  * If ImplicitStagePersistence and TemplateHaskell then imported module are needed at all stages.
    
    932 935
     --  * Otherwise, an imported module is just needed at the normal stage.
    
    936
    +--
    
    937
    +--  * A module using TemplateHaskellQuotes required at C stage is also required at R
    
    938
    +--    stage.
    
    933 939
     moduleGraphNodesStages ::
    
    934 940
          [ModuleGraphNode]
    
    935 941
       -> (Graph StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
    
    ... ... @@ -945,7 +951,7 @@ moduleGraphNodesStages summaries =
    945 951
                normal_case :: (ModuleGraphNode, ModuleStage)  -> StageSummaryNode
    
    946 952
                normal_case ((m@(ModuleNode nks ms), s)) =
    
    947 953
                       DigraphNode ((mkNodeKey m, s)) key $ out_edge_keys $
    
    948
    -                       concatMap (classifyDeps ms s) nks
    
    954
    +                       selfEdges ms s (mkNodeKey m) ++ concatMap (classifyDeps ms s) nks
    
    949 955
                normal_case (m, s) =
    
    950 956
                  DigraphNode (mkNodeKey m, s) key (out_edge_keys . map (, s) $ mgNodeDependencies False m)
    
    951 957
     
    
    ... ... @@ -955,6 +961,16 @@ moduleGraphNodesStages summaries =
    955 961
         isTemplateHaskellQuotesMS :: ModSummary -> Bool
    
    956 962
         isTemplateHaskellQuotesMS ms = xopt LangExt.TemplateHaskellQuotes (ms_hspp_opts ms)
    
    957 963
     
    
    964
    +    -- Accounting for persistence within a module.
    
    965
    +    -- If a module is required @ C and it persists an idenfifier, it's also required
    
    966
    +    -- at R.
    
    967
    +    selfEdges (ModuleNodeCompile ms) s self_key
    
    968
    +      | not (isExplicitStageMS ms)
    
    969
    +        && (isTemplateHaskellQuotesMS ms
    
    970
    +            || isTemplateHaskellOrQQNonBoot ms)
    
    971
    +        = [(self_key, s') | s' <- onlyFutureStages s]
    
    972
    +    selfEdges _ _ _ = []
    
    973
    +
    
    958 974
         -- Case 1. No implicit stage persistnce is enabled
    
    959 975
         classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge il k)
    
    960 976
           | isExplicitStageMS ms = case il of
    
    ... ... @@ -966,7 +982,7 @@ moduleGraphNodesStages summaries =
    966 982
           | not (isExplicitStageMS ms)
    
    967 983
           , not (isTemplateHaskellOrQQNonBoot ms)
    
    968 984
           , isTemplateHaskellQuotesMS ms
    
    969
    -      = [(k, s') | s' <- futureStages s]
    
    985
    +      = [(k, s') | s' <- nowAndFutureStages s]
    
    970 986
         -- Case 2b. Template haskell is enabled, with implicit stage persistence
    
    971 987
         classifyDeps (ModuleNodeCompile ms) _ (ModuleNodeEdge _ k)
    
    972 988
           | isTemplateHaskellOrQQNonBoot ms
    
    ... ... @@ -977,7 +993,7 @@ moduleGraphNodesStages summaries =
    977 993
     
    
    978 994
     
    
    979 995
         numbered_summaries :: [((ModuleGraphNode, ModuleStage), Int)]
    
    980
    -    numbered_summaries = zip (([(s, l) | s <- summaries, l <- [CompileStage, RunStage]])) [0..]
    
    996
    +    numbered_summaries = zip (([(s, l) | s <- summaries, l <- allStages])) [0..]
    
    981 997
     
    
    982 998
         lookup_node :: (NodeKey, ModuleStage) -> Maybe StageSummaryNode
    
    983 999
         lookup_node key = Map.lookup key node_map
    

  • compiler/GHC/Unit/Module/Stage.hs
    1 1
     module GHC.Unit.Module.Stage ( ModuleStage(..)
    
    2 2
                                  , allStages
    
    3
    -                             , futureStages
    
    3
    +                             , nowAndFutureStages
    
    4
    +                             , onlyFutureStages
    
    4 5
                                  , minStage
    
    5 6
                                  , maxStage
    
    6 7
                                  , zeroStage
    
    ... ... @@ -56,8 +57,12 @@ data ModuleStage = CompileStage | RunStage deriving (Eq, Ord, Enum, Bounded)
    56 57
     allStages :: [ModuleStage]
    
    57 58
     allStages = [minBound .. maxBound]
    
    58 59
     
    
    59
    -futureStages :: ModuleStage -> [ModuleStage]
    
    60
    -futureStages cur_st = [cur_st .. ]
    
    60
    +nowAndFutureStages :: ModuleStage -> [ModuleStage]
    
    61
    +nowAndFutureStages cur_st = [cur_st .. ]
    
    62
    +
    
    63
    +onlyFutureStages :: ModuleStage -> [ModuleStage]
    
    64
    +onlyFutureStages cur_st | cur_st == maxBound = []
    
    65
    +onlyFutureStages cur_st = [succ cur_st .. ]
    
    61 66
     
    
    62 67
     minStage :: ModuleStage
    
    63 68
     minStage = minBound
    

  • ghc/GHCi/UI.hs
    ... ... @@ -2928,6 +2928,7 @@ iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
    2928 2928
     iiSubsumes (IIDecl d1) (IIDecl d2)      -- A bit crude
    
    2929 2929
       =  unLoc (ideclName d1) == unLoc (ideclName d2)
    
    2930 2930
          && ideclAs d1 == ideclAs d2
    
    2931
    +     && convImportLevel (ideclLevelSpec d1) == convImportLevel (ideclLevelSpec d2)
    
    2931 2932
          && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2))
    
    2932 2933
          && (ideclImportList d1 `hidingSubsumes` ideclImportList d2)
    
    2933 2934
       where
    

  • testsuite/tests/splice-imports/SI30.stdout
    1
    +2

  • testsuite/tests/splice-imports/SI31.script
    1
    +-- Failure, since explicit level imports is on
    
    2
    +$(id [| () |])
    \ No newline at end of file

  • testsuite/tests/splice-imports/SI31.stderr
    1
    +<interactive>:2:3: error: [GHC-28914]
    
    2
    +    • Level error: ‘id’ is bound at level 0 but used at level -1
    
    3
    +      Hint: quoting [| id |] or an enclosing expression
    
    4
    +      would allow the quotation to be used at an earlier level
    
    5
    +      From imports {imported from ‘Prelude’}
    
    6
    +    • In the untyped splice: $(id [| () |])
    
    7
    +

  • testsuite/tests/splice-imports/SI32.script
    1
    +-- Success case with explicit level imports
    
    2
    +import Language.Haskell.TH
    
    3
    +import splice Data.Function (id)
    
    4
    +
    
    5
    +$(id [| () |])
    \ No newline at end of file

  • testsuite/tests/splice-imports/SI32.stdout
    1
    +()

  • testsuite/tests/splice-imports/SI33.script
    1
    +-- Test using both normal and splice level imports with Template Haskell
    
    2
    +import Language.Haskell.TH
    
    3
    +-- Using two imports here tests the iiSubsumes function
    
    4
    +import splice Data.Function (id)
    
    5
    +import Data.Function (id)
    
    6
    +
    
    7
    +-- Use the splice-level 'id' in the splice and normal-level 'on' in the quote
    
    8
    +$(id [| id () |])
    \ No newline at end of file

  • testsuite/tests/splice-imports/SI33.stdout
    1
    +()

  • testsuite/tests/splice-imports/SI34.hs
    1
    +module SI34 where
    
    2
    +
    
    3
    +-- Compiling SI34 @ R, requires SI34M2 @ R, which requires SI34M1 @ R,
    
    4
    +-- but NOT SI34M1 @ C or SI34M2 @ C due to ImplicitStagePersistence + TemplateHaskellQuotes
    
    5
    +import SI34M2
    
    6
    +
    
    7
    +-- Uses the MkT constructor indirectly through SI34M2.makeMkT
    
    8
    +foo = makeMkT 42
    
    9
    +
    
    10
    +-- Uses the wrapper type from SI34M2
    
    11
    +bar = wrapT (makeMkT 100)
    \ No newline at end of file

  • testsuite/tests/splice-imports/SI34.stderr
    1
    +[1 of 3] Compiling SI34M1           ( SI34M1.hs, nothing )
    
    2
    +[2 of 3] Compiling SI34M2           ( SI34M2.hs, nothing )
    
    3
    +[3 of 3] Compiling SI34             ( SI34.hs, nothing )

  • testsuite/tests/splice-imports/SI34M1.hs
    1
    +{-# LANGUAGE ImplicitStagePersistence #-}
    
    2
    +{-# LANGUAGE TemplateHaskellQuotes #-}
    
    3
    +
    
    4
    +module SI34M1 where
    
    5
    +
    
    6
    +import Language.Haskell.TH
    
    7
    +import Language.Haskell.TH.Syntax
    
    8
    +
    
    9
    +data T = MkT Int
    
    10
    +  deriving Show
    
    11
    +
    
    12
    +instance Lift T where
    
    13
    +  lift (MkT n) = [| MkT $(lift n) |]
    
    14
    +  liftTyped (MkT n) = [|| MkT $$(liftTyped n) ||]

  • testsuite/tests/splice-imports/SI34M2.hs
    1
    +{-# LANGUAGE ImplicitStagePersistence #-}
    
    2
    +{-# LANGUAGE TemplateHaskellQuotes #-}
    
    3
    +
    
    4
    +module SI34M2 (
    
    5
    +    makeMkT,
    
    6
    +    TWrapper(..),
    
    7
    +    wrapT
    
    8
    +) where
    
    9
    +
    
    10
    +import SI34M1
    
    11
    +import Language.Haskell.TH.Syntax
    
    12
    +
    
    13
    +-- A wrapper for T
    
    14
    +data TWrapper = WrapT T
    
    15
    +  deriving Show
    
    16
    +
    
    17
    +-- Create a MkT with the given Int
    
    18
    +makeMkT :: Int -> T
    
    19
    +makeMkT = MkT
    
    20
    +
    
    21
    +-- Wrap a T in a TWrapper
    
    22
    +wrapT :: T -> TWrapper
    
    23
    +wrapT = WrapT
    
    24
    +
    
    25
    +-- Quote functions for TWrapper
    
    26
    +instance Lift TWrapper where
    
    27
    +  lift (WrapT t) = [| WrapT $(lift t) |]
    
    28
    +  liftTyped (WrapT t) = [|| WrapT $$(liftTyped t) ||]

  • testsuite/tests/splice-imports/SI35.hs
    1
    +{-# LANGUAGE RecordWildCards #-}
    
    2
    +module Main where
    
    3
    +
    
    4
    +import GHC
    
    5
    +import GHC.Driver.Session
    
    6
    +import GHC.Driver.Monad
    
    7
    +import GHC.Driver.Make (load', summariseFile)
    
    8
    +import GHC.Unit.Module.Graph
    
    9
    +import GHC.Unit.Module.ModSummary
    
    10
    +import GHC.Unit.Types
    
    11
    +import GHC.Unit.Module.ModIface
    
    12
    +import GHC.Unit.Module
    
    13
    +import GHC.Unit.Module.ModNodeKey
    
    14
    +import GHC.Types.SourceFile
    
    15
    +import System.Environment
    
    16
    +import Control.Monad (void, when)
    
    17
    +import Data.Maybe (fromJust)
    
    18
    +import Control.Exception (ExceptionWithContext(..), SomeException)
    
    19
    +import Control.Monad.Catch (handle, throwM)
    
    20
    +import Control.Exception.Context
    
    21
    +import GHC.Utils.Outputable
    
    22
    +import GHC.Unit.Home
    
    23
    +import GHC.Driver.Env
    
    24
    +import Data.List (sort)
    
    25
    +import GHC.Driver.MakeFile
    
    26
    +import GHC.Data.Maybe
    
    27
    +import GHC.Unit.Module.Stage
    
    28
    +import GHC.Data.Graph.Directed.Reachability
    
    29
    +import GHC.Utils.Trace
    
    30
    +import GHC.Unit.Module.Graph
    
    31
    +
    
    32
    +main :: IO ()
    
    33
    +main = do
    
    34
    +    [libdir] <- getArgs
    
    35
    +    runGhc (Just libdir) $ handle (\(ExceptionWithContext c e :: ExceptionWithContext SomeException) ->
    
    36
    +      liftIO $ putStrLn (displayExceptionContext c) >> print e >> throwM e) $ do
    
    37
    +
    
    38
    +      -- Set up session
    
    39
    +      dflags <- getSessionDynFlags
    
    40
    +      setSessionDynFlags dflags
    
    41
    +      hsc_env <- getSession
    
    42
    +      setSession $ hscSetActiveUnitId mainUnitId hsc_env
    
    43
    +
    
    44
    +      -- Get ModSummary for our test module
    
    45
    +      msA <- getModSummaryFromTarget "SI35A.hs"
    
    46
    +
    
    47
    +      -- Define NodeKey
    
    48
    +      let keyA = NodeKey_Module (msKey msA)
    
    49
    +          edgeA = mkNormalEdge keyA
    
    50
    +
    
    51
    +      -- Define ModuleNodeInfo
    
    52
    +      let infoA_compile = ModuleNodeCompile msA
    
    53
    +
    
    54
    +      -- Define the complete node
    
    55
    +      let nodeA_compile = ModuleNode [] infoA_compile
    
    56
    +
    
    57
    +      -- This test checks that a module required at compile stage invokes a
    
    58
    +      -- depedency on the runstage of itself when using TemplateHaskellQuotes.
    
    59
    +
    
    60
    +      -- This is hard to test with a normal compiler invocation as GHC does not
    
    61
    +      -- not distinguish very easily these two stages.
    
    62
    +      let (ri, to_node) = mkStageDeps [nodeA_compile]
    
    63
    +      let reachable = allReachable ri (expectJust $ to_node (keyA, CompileStage))
    
    64
    +      let reachable_nodes = map stageSummaryNodeSummary reachable
    
    65
    +
    
    66
    +      if (keyA, RunStage) `elem` reachable_nodes
    
    67
    +        then return ()
    
    68
    +        else do
    
    69
    +          liftIO $ putStrLn "Test failed -- (keyA, RunStage) not reachable"
    
    70
    +          pprTraceM "reachable_nodes" (ppr reachable_nodes)
    
    71
    +          pprTraceM "reachable" (ppr (reachabilityIndexMembers ri))
    
    72
    +
    
    73
    +      where
    
    74
    +        -- Helper to get ModSummary from a target file
    
    75
    +        getModSummaryFromTarget :: FilePath -> Ghc ModSummary
    
    76
    +        getModSummaryFromTarget file = do
    
    77
    +          hsc_env <- getSession
    
    78
    +          Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing
    
    79
    +          return ms
    \ No newline at end of file

  • testsuite/tests/splice-imports/SI35A.hs
    1
    +{-# LANGUAGE TemplateHaskellQuotes #-}
    
    2
    +module SI35A where
    
    3
    +
    
    4
    +-- Define a type for use in Template Haskell
    
    5
    +data T = MkT Int
    
    6
    +
    
    7
    +-- Helper function to construct a T
    
    8
    +mkT :: Int -> T
    
    9
    +mkT = MkT
    
    10
    +
    
    11
    +-- A function that creates a quoted expression using T
    
    12
    +quotedT :: Int -> Q Exp
    
    13
    +quotedT n = [| mkT n |]
    
    14
    +
    
    15
    +-- Another quoted expression function
    
    16
    +quotedAdd :: Q Exp
    
    17
    +quotedAdd = [| \x y -> x + y :: Int |]
    
    18
    +
    
    19
    +-- Show instance
    
    20
    +instance Show T where
    
    21
    +  show (MkT n) = "MkT " ++ show n
    \ No newline at end of file

  • testsuite/tests/splice-imports/all.T
    ... ... @@ -36,3 +36,12 @@ test('SI27', normal, compile_fail, [''])
    36 36
     test('SI28', normal, compile_fail, [''])
    
    37 37
     test('SI29', normal, compile_fail, [''])
    
    38 38
     test('SI30', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports")], ghci_script, ['SI30.script'])
    
    39
    +test('SI31', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI31.script'])
    
    40
    +test('SI32', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI32.script'])
    
    41
    +test('SI33', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI33.script'])
    
    42
    +test('SI34', [extra_files(["SI34M1.hs", "SI34M2.hs"])], multimod_compile, ['SI34', '-fno-code'])
    
    43
    +test('SI35',
    
    44
    +     [extra_run_opts(f'"{config.libdir}"'),
    
    45
    +     extra_files(['SI35A.hs'])],
    
    46
    +     compile_and_run,
    
    47
    +     ['-package ghc'])