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'])

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