Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-mwb at Glasgow Haskell Compiler / GHC

Commits:

27 changed files:

Changes:

  • compiler/GHC.hs
    ... ... @@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
    341 341
     import GHC.Data.StringBuffer
    
    342 342
     import GHC.Data.FastString
    
    343 343
     import qualified GHC.LanguageExtensions as LangExt
    
    344
    -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
    
    344
    +import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
    
    345 345
     
    
    346 346
     import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
    
    347 347
     import GHC.Tc.Types
    
    ... ... @@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do
    625 625
     
    
    626 626
       let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
    
    627 627
       let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
    
    628
    -  (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
    
    628
    +  index <- hscUnitIndex <$> getSession
    
    629
    +  (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
    
    629 630
       updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
    
    630 631
     
    
    631 632
       let upd hue =
    
    ... ... @@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
    760 761
         then do
    
    761 762
             -- additionally, set checked dflags so we don't lose fixes
    
    762 763
             old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
    
    764
    +        ue_index <- hscUnitIndex <$> getSession
    
    763 765
     
    
    764 766
             home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
    
    765 767
               let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
    
    ... ... @@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
    767 769
                   old_hpt = homeUnitEnv_hpt homeUnitEnv
    
    768 770
                   home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
    
    769 771
     
    
    770
    -          (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
    
    772
    +          (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
    
    771 773
     
    
    772 774
               updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
    
    773 775
               pure HomeUnitEnv
    
    ... ... @@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
    785 787
                   , ue_home_unit_graph = home_unit_graph
    
    786 788
                   , ue_current_unit    = ue_currentUnit old_unit_env
    
    787 789
                   , ue_eps             = ue_eps old_unit_env
    
    790
    +              , ue_index
    
    788 791
                   }
    
    789 792
             modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
    
    790 793
         else modifySession (hscSetFlags dflags0)
    
    ... ... @@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env ->
    1379 1382
     
    
    1380 1383
     getNamePprCtx :: GhcMonad m => m NamePprCtx
    
    1381 1384
     getNamePprCtx = withSession $ \hsc_env -> do
    
    1382
    -  return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
    
    1385
    +  query <- liftIO $ hscUnitIndexQuery hsc_env
    
    1386
    +  return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
    
    1383 1387
     
    
    1384 1388
     -- | Container for information about a 'Module'.
    
    1385 1389
     data ModuleInfo = ModuleInfo {
    
    ... ... @@ -1474,7 +1478,8 @@ mkNamePprCtxForModule ::
    1474 1478
       ModuleInfo ->
    
    1475 1479
       m NamePprCtx
    
    1476 1480
     mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
    
    1477
    -  let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
    
    1481
    +  query <- liftIO $ hscUnitIndexQuery hsc_env
    
    1482
    +  let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
    
    1478 1483
           ptc = initPromotionTickContext (hsc_dflags hsc_env)
    
    1479 1484
       return name_ppr_ctx
    
    1480 1485
     
    
    ... ... @@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
    1711 1716
        parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
    
    1712 1717
     
    
    1713 1718
     renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
    
    1714
    -renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
    
    1719
    +renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
    
    1715 1720
     
    
    1716 1721
     renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
    
    1717
    -renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
    
    1722
    +renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
    
    1718 1723
     
    
    1719 1724
     -- | Like 'findModule', but differs slightly when the module refers to
    
    1720 1725
     -- a source file, and the file has not been loaded via 'load'.  In
    
    ... ... @@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
    1738 1743
           let units  = hsc_units hsc_env
    
    1739 1744
           let dflags = hsc_dflags hsc_env
    
    1740 1745
           let fopts  = initFinderOpts dflags
    
    1741
    -      res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
    
    1746
    +      query <- hscUnitIndexQuery hsc_env
    
    1747
    +      res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
    
    1742 1748
           case res of
    
    1743 1749
             Found _ m -> return m
    
    1744 1750
             err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
    

  • compiler/GHC/Core/Opt/Pipeline.hs
    ... ... @@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
    78 78
                                     , mg_rdr_env = rdr_env })
    
    79 79
       = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
    
    80 80
                  uniq_tag = 's'
    
    81
    +       ; query <- hscUnitIndexQuery hsc_env
    
    82
    +       ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
    
    81 83
     
    
    82 84
            ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
    
    83 85
                                         name_ppr_ctx loc $
    
    ... ... @@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
    100 102
         home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
    
    101 103
                                                                    , gwib_isBoot = NotBoot })
    
    102 104
         hpt_rule_base  = mkRuleBase home_pkg_rules
    
    103
    -    name_ppr_ctx   = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
    
    104 105
         ptc            = initPromotionTickContext dflags
    
    105 106
         -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
    
    106 107
         -- This is very convienent for the users of the monad (e.g. plugins do not have to
    
    ... ... @@ -459,6 +460,7 @@ doCorePass pass guts = do
    459 460
       dflags    <- getDynFlags
    
    460 461
       us        <- getUniqueSupplyM
    
    461 462
       p_fam_env <- getPackageFamInstEnv
    
    463
    +  query <- liftIO $ hscUnitIndexQuery hsc_env
    
    462 464
       let platform = targetPlatform dflags
    
    463 465
       let fam_envs = (p_fam_env, mg_fam_inst_env guts)
    
    464 466
       let updateBinds  f = return $ guts { mg_binds = f (mg_binds guts) }
    
    ... ... @@ -471,6 +473,7 @@ doCorePass pass guts = do
    471 473
             mkNamePprCtx
    
    472 474
               (initPromotionTickContext dflags)
    
    473 475
               (hsc_unit_env hsc_env)
    
    476
    +          query
    
    474 477
               rdr_env
    
    475 478
     
    
    476 479
     
    

  • compiler/GHC/Data/OsPath.hs
    1
    +module GHC.Data.OsPath
    
    2
    +  (
    
    3
    +  -- * OsPath initialisation and transformation
    
    4
    +    OsPath
    
    5
    +  , OsString
    
    6
    +  , encodeUtf
    
    7
    +  , decodeUtf
    
    8
    +  , unsafeDecodeUtf
    
    9
    +  , unsafeEncodeUtf
    
    10
    +  , os
    
    11
    +  -- * Common utility functions
    
    12
    +  , (</>)
    
    13
    +  , (<.>)
    
    14
    +  , splitSearchPath
    
    15
    +  , isRelative
    
    16
    +  , dropTrailingPathSeparator
    
    17
    +  , takeDirectory
    
    18
    +  , isSuffixOf
    
    19
    +  , doesDirectoryExist
    
    20
    +  , doesFileExist
    
    21
    +  , getDirectoryContents
    
    22
    +  , createDirectoryIfMissing
    
    23
    +  , pprOsPath
    
    24
    +  )
    
    25
    +  where
    
    26
    +
    
    27
    +import GHC.Prelude
    
    28
    +
    
    29
    +import GHC.Utils.Misc (HasCallStack)
    
    30
    +import GHC.Utils.Outputable qualified as Outputable
    
    31
    +import GHC.Utils.Panic (panic)
    
    32
    +
    
    33
    +import System.OsPath
    
    34
    +import System.OsString (isSuffixOf)
    
    35
    +import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing)
    
    36
    +import System.Directory.Internal (os)
    
    37
    +
    
    38
    +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
    
    39
    +-- Prefer 'decodeUtf' and gracious error handling.
    
    40
    +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath
    
    41
    +unsafeDecodeUtf p =
    
    42
    +  either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p)
    
    43
    +
    
    44
    +pprOsPath :: HasCallStack => OsPath -> Outputable.SDoc
    
    45
    +pprOsPath = Outputable.text . unsafeDecodeUtf

  • compiler/GHC/Driver/Backpack.hs
    ... ... @@ -76,6 +76,7 @@ import qualified GHC.LanguageExtensions as LangExt
    76 76
     import GHC.Data.Maybe
    
    77 77
     import GHC.Data.StringBuffer
    
    78 78
     import GHC.Data.FastString
    
    79
    +import qualified GHC.Data.OsPath as OsPath
    
    79 80
     import qualified GHC.Data.EnumSet as EnumSet
    
    80 81
     import qualified GHC.Data.ShortText as ST
    
    81 82
     
    
    ... ... @@ -429,15 +430,16 @@ addUnit u = do
    429 430
         logger <- getLogger
    
    430 431
         let dflags0 = hsc_dflags hsc_env
    
    431 432
         let old_unit_env = hsc_unit_env hsc_env
    
    433
    +        ue_index = hscUnitIndex hsc_env
    
    432 434
         newdbs <- case ue_unit_dbs old_unit_env of
    
    433 435
             Nothing  -> panic "addUnit: called too early"
    
    434 436
             Just dbs ->
    
    435 437
              let newdb = UnitDatabase
    
    436
    -               { unitDatabasePath  = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
    
    438
    +               { unitDatabasePath  = OsPath.unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
    
    437 439
                    , unitDatabaseUnits = [u]
    
    438 440
                    }
    
    439 441
              in return (dbs ++ [newdb]) -- added at the end because ordering matters
    
    440
    -    (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
    
    442
    +    (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
    
    441 443
     
    
    442 444
         -- update platform constants
    
    443 445
         dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
    
    ... ... @@ -452,6 +454,7 @@ addUnit u = do
    452 454
                         (homeUnitId home_unit)
    
    453 455
                         (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
    
    454 456
               , ue_eps       = ue_eps old_unit_env
    
    457
    +          , ue_index
    
    455 458
               }
    
    456 459
         setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
    
    457 460
     
    
    ... ... @@ -870,6 +873,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
    870 873
         hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
    
    871 874
         hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
    
    872 875
     
    
    876
    +    query <- liftIO $ hscUnitIndexQuery hsc_env
    
    877
    +
    
    873 878
         -- Also copied from 'getImports'
    
    874 879
         let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
    
    875 880
     
    
    ... ... @@ -882,7 +887,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
    882 887
             implicit_imports = mkPrelImports modname loc
    
    883 888
                                              implicit_prelude imps
    
    884 889
     
    
    885
    -        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
    
    890
    +        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
    
    886 891
             convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
    
    887 892
     
    
    888 893
         extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
    

  • compiler/GHC/Driver/DynFlags.hs
    ... ... @@ -96,6 +96,7 @@ import GHC.Core.Unfold
    96 96
     import GHC.Data.Bool
    
    97 97
     import GHC.Data.EnumSet (EnumSet)
    
    98 98
     import GHC.Data.Maybe
    
    99
    +import GHC.Data.OsPath (OsPath)
    
    99 100
     import GHC.Builtin.Names ( mAIN_NAME )
    
    100 101
     import GHC.Driver.Backend
    
    101 102
     import GHC.Driver.Flags
    
    ... ... @@ -948,7 +949,7 @@ setDynamicNow dflags0 =
    948 949
     data PkgDbRef
    
    949 950
       = GlobalPkgDb
    
    950 951
       | UserPkgDb
    
    951
    -  | PkgDbPath FilePath
    
    952
    +  | PkgDbPath OsPath
    
    952 953
       deriving Eq
    
    953 954
     
    
    954 955
     -- | Used to differentiate the scope an include needs to apply to.
    

  • compiler/GHC/Driver/Env.hs
    ... ... @@ -7,6 +7,8 @@ module GHC.Driver.Env
    7 7
        , hsc_home_unit
    
    8 8
        , hsc_home_unit_maybe
    
    9 9
        , hsc_units
    
    10
    +   , hscUnitIndex
    
    11
    +   , hscUnitIndexQuery
    
    10 12
        , hsc_HPT
    
    11 13
        , hsc_HUE
    
    12 14
        , hsc_HUG
    
    ... ... @@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
    118 120
     hsc_units :: HasDebugCallStack => HscEnv -> UnitState
    
    119 121
     hsc_units = ue_units . hsc_unit_env
    
    120 122
     
    
    123
    +hscUnitIndex :: HscEnv -> UnitIndex
    
    124
    +hscUnitIndex = ue_index . hsc_unit_env
    
    125
    +
    
    126
    +hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
    
    127
    +hscUnitIndexQuery hsc_env =
    
    128
    +  unitIndexQuery (hscUnitIndex hsc_env) (hscActiveUnitId hsc_env)
    
    129
    +
    
    121 130
     hsc_HPT :: HscEnv -> HomePackageTable
    
    122 131
     hsc_HPT = ue_hpt . hsc_unit_env
    
    123 132
     
    

  • compiler/GHC/Driver/Main.hs
    ... ... @@ -1009,11 +1009,6 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = do
    1009 1009
             types_var <- newIORef (md_types details)
    
    1010 1010
             let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
    
    1011 1011
             let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
    
    1012
    -        core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
    
    1013
    -        -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
    
    1014
    -        -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
    
    1015
    -        -- reports a bug.
    
    1016
    -        let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
    
    1017 1012
             -- The bytecode generation itself is lazy because otherwise even when doing
    
    1018 1013
             -- recompilation checking the bytecode will be generated (which slows things down a lot)
    
    1019 1014
             -- the laziness is OK because generateByteCode just depends on things already loaded
    
    ... ... @@ -2578,9 +2573,10 @@ hscTidy hsc_env guts = do
    2578 2573
         $! {-# SCC "CoreTidy" #-} tidyProgram opts guts
    
    2579 2574
     
    
    2580 2575
       -- post tidy pretty-printing and linting...
    
    2576
    +  query <- hscUnitIndexQuery hsc_env
    
    2581 2577
       let tidy_rules     = md_rules details
    
    2582 2578
       let all_tidy_binds = cg_binds cgguts
    
    2583
    -  let name_ppr_ctx   = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
    
    2579
    +  let name_ppr_ctx   = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
    
    2584 2580
           ptc            = initPromotionTickContext (hsc_dflags hsc_env)
    
    2585 2581
     
    
    2586 2582
       endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
    

  • compiler/GHC/Driver/Make.hs
    ... ... @@ -187,12 +187,13 @@ depanalE excluded_mods allow_dup_roots = do
    187 187
         if isEmptyMessages errs
    
    188 188
           then do
    
    189 189
             hsc_env <- getSession
    
    190
    +        query <- liftIO $ hscUnitIndexQuery hsc_env
    
    190 191
             let one_unit_messages get_mod_errs k hue = do
    
    191 192
                   errs <- get_mod_errs
    
    192 193
                   unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
    
    193 194
     
    
    194 195
                   let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
    
    195
    -                  unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
    
    196
    +                  unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
    
    196 197
     
    
    197 198
     
    
    198 199
                   return $ errs `unionMessages` unused_home_mod_err
    
    ... ... @@ -510,15 +511,15 @@ loadWithCache cache diag_wrapper how_much = do
    510 511
     -- actually loaded packages. All the packages, specified on command line,
    
    511 512
     -- but never loaded, are probably unused dependencies.
    
    512 513
     
    
    513
    -warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
    
    514
    -warnUnusedPackages us dflags mod_graph =
    
    514
    +warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
    
    515
    +warnUnusedPackages us query dflags mod_graph =
    
    515 516
         let diag_opts = initDiagOpts dflags
    
    516 517
     
    
    517 518
             home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
    
    518 519
     
    
    519 520
         -- Only need non-source imports here because SOURCE imports are always HPT
    
    520 521
             loadedPackages = concat $
    
    521
    -          mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
    
    522
    +          mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
    
    522 523
                 $ concatMap ms_imps home_mod_sum
    
    523 524
     
    
    524 525
             any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
    
    ... ... @@ -2384,7 +2385,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
    2384 2385
               mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
    
    2385 2386
               let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
    
    2386 2387
               pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
    
    2387
    -  let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
    
    2388
    +  query <- liftIO $ hscUnitIndexQuery hsc_env
    
    2389
    +  let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
    
    2388 2390
       let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
    
    2389 2391
       let pi_srcimps = rn_imps pi_srcimps'
    
    2390 2392
       let pi_theimps = rn_imps pi_theimps'
    

  • compiler/GHC/Driver/Pipeline/Execute.hs
    ... ... @@ -696,9 +696,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
    696 696
       -- gather the imports and module name
    
    697 697
       (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
    
    698 698
         buf <- hGetStringBuffer input_fn
    
    699
    +    query <- hscUnitIndexQuery hsc_env
    
    699 700
         let imp_prelude = xopt LangExt.ImplicitPrelude dflags
    
    700 701
             popts = initParserOpts dflags
    
    701
    -        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
    
    702
    +        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
    
    702 703
             rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
    
    703 704
         eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
    
    704 705
         case eimps of
    

  • compiler/GHC/Driver/Session.hs
    ... ... @@ -255,6 +255,7 @@ import GHC.Types.SrcLoc
    255 255
     import GHC.Types.SafeHaskell
    
    256 256
     import GHC.Types.Basic ( treatZeroAsInf )
    
    257 257
     import GHC.Data.FastString
    
    258
    +import qualified GHC.Data.OsPath as OsPath
    
    258 259
     import GHC.Utils.TmpFs
    
    259 260
     import GHC.Utils.Fingerprint
    
    260 261
     import GHC.Utils.Outputable
    
    ... ... @@ -1962,7 +1963,7 @@ package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]
    1962 1963
     package_flags_deps = [
    
    1963 1964
             ------- Packages ----------------------------------------------------
    
    1964 1965
         make_ord_flag defFlag "package-db"
    
    1965
    -      (HasArg (addPkgDbRef . PkgDbPath))
    
    1966
    +      (HasArg (addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf))
    
    1966 1967
       , make_ord_flag defFlag "clear-package-db"      (NoArg clearPkgDb)
    
    1967 1968
       , make_ord_flag defFlag "no-global-package-db"  (NoArg removeGlobalPkgDb)
    
    1968 1969
       , make_ord_flag defFlag "no-user-package-db"    (NoArg removeUserPkgDb)
    
    ... ... @@ -1972,7 +1973,7 @@ package_flags_deps = [
    1972 1973
           (NoArg (addPkgDbRef UserPkgDb))
    
    1973 1974
         -- backwards compat with GHC<=7.4 :
    
    1974 1975
       , make_dep_flag defFlag "package-conf"
    
    1975
    -      (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"
    
    1976
    +      (HasArg $ addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf) "Use -package-db instead"
    
    1976 1977
       , make_dep_flag defFlag "no-user-package-conf"
    
    1977 1978
           (NoArg removeUserPkgDb)              "Use -no-user-package-db instead"
    
    1978 1979
       , make_ord_flag defGhcFlag "package-name"       (HasArg $ \name ->
    
    ... ... @@ -3377,7 +3378,7 @@ parseEnvFile :: FilePath -> String -> DynP ()
    3377 3378
     parseEnvFile envfile = mapM_ parseEntry . lines
    
    3378 3379
       where
    
    3379 3380
         parseEntry str = case words str of
    
    3380
    -      ("package-db": _)     -> addPkgDbRef (PkgDbPath (envdir </> db))
    
    3381
    +      ("package-db": _)     -> addPkgDbRef (PkgDbPath (OsPath.unsafeEncodeUtf (envdir </> db)))
    
    3381 3382
             -- relative package dbs are interpreted relative to the env file
    
    3382 3383
             where envdir = takeDirectory envfile
    
    3383 3384
                   db     = drop 11 str
    

  • compiler/GHC/HsToCore.hs
    ... ... @@ -149,7 +149,8 @@ deSugar hsc_env
    149 149
       = do { let dflags = hsc_dflags hsc_env
    
    150 150
                  logger = hsc_logger hsc_env
    
    151 151
                  ptc = initPromotionTickContext (hsc_dflags hsc_env)
    
    152
    -             name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
    
    152
    +        ; query <- hscUnitIndexQuery hsc_env
    
    153
    +        ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
    
    153 154
             ; withTiming logger
    
    154 155
                          (text "Desugar"<+>brackets (ppr mod))
    
    155 156
                          (const ()) $
    

  • compiler/GHC/HsToCore/Monad.hs
    ... ... @@ -89,6 +89,7 @@ import GHC.Data.FastString
    89 89
     
    
    90 90
     import GHC.Unit.Env
    
    91 91
     import GHC.Unit.External
    
    92
    +import GHC.Unit.State (UnitIndexQuery)
    
    92 93
     import GHC.Unit.Module
    
    93 94
     import GHC.Unit.Module.ModGuts
    
    94 95
     
    
    ... ... @@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
    264 265
                                     ++ eps_complete_matches eps     -- from imports
    
    265 266
                  -- re-use existing next_wrapper_num to ensure uniqueness
    
    266 267
                  next_wrapper_num_var = tcg_next_wrapper_num tcg_env
    
    267
    -       ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
    
    268
    +       ; query <- liftIO $ hscUnitIndexQuery hsc_env
    
    269
    +       ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
    
    268 270
                                msg_var cc_st_var next_wrapper_num_var complete_matches
    
    269 271
            }
    
    270 272
     
    
    ... ... @@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
    292 294
            ; next_wrapper_num <- newIORef emptyModuleEnv
    
    293 295
            ; msg_var <- newIORef emptyMessages
    
    294 296
            ; eps <- liftIO $ hscEPS hsc_env
    
    297
    +       ; query <- liftIO $ hscUnitIndexQuery hsc_env
    
    295 298
            ; let unit_env = hsc_unit_env hsc_env
    
    296 299
                  type_env = typeEnvFromEntities ids tycons patsyns fam_insts
    
    297 300
                  ptc = initPromotionTickContext (hsc_dflags hsc_env)
    
    ... ... @@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
    303 306
                  bindsToIds (Rec    binds) = map fst binds
    
    304 307
                  ids = concatMap bindsToIds binds
    
    305 308
     
    
    306
    -             envs  = mkDsEnvs unit_env this_mod rdr_env type_env
    
    309
    +             envs  = mkDsEnvs unit_env query this_mod rdr_env type_env
    
    307 310
                                   fam_inst_env ptc msg_var cc_st_var
    
    308 311
                                   next_wrapper_num complete_matches
    
    309 312
            ; runDs hsc_env envs thing_inside
    
    ... ... @@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
    342 345
                Just ret -> pure ret
    
    343 346
                Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
    
    344 347
     
    
    345
    -mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
    
    348
    +mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
    
    346 349
              -> PromotionTickContext
    
    347 350
              -> IORef (Messages DsMessage) -> IORef CostCentreState
    
    348 351
              -> IORef (ModuleEnv Int) -> CompleteMatches
    
    349 352
              -> (DsGblEnv, DsLclEnv)
    
    350
    -mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
    
    353
    +mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
    
    351 354
              next_wrapper_num complete_matches
    
    352 355
       = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs"
    
    353 356
       -- Failing tests here are `ghci` and `T11985` if you get this wrong.
    
    ... ... @@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
    364 367
                                , ds_fam_inst_env = fam_inst_env
    
    365 368
                                , ds_gbl_rdr_env  = rdr_env
    
    366 369
                                , ds_if_env  = (if_genv, if_lenv)
    
    367
    -                           , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
    
    370
    +                           , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
    
    368 371
                                , ds_msgs    = msg_var
    
    369 372
                                , ds_complete_matches = complete_matches
    
    370 373
                                , ds_cc_st   = cc_st_var
    

  • compiler/GHC/Iface/Recomp.hs
    ... ... @@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
    588 588
     checkDependencies hsc_env summary iface
    
    589 589
      = do
    
    590 590
         res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
    
    591
    -    res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
    
    591
    +    query <- liftIO $ hscUnitIndexQuery hsc_env
    
    592
    +    res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
    
    592 593
         case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
    
    593 594
           Left recomp -> return $ NeedsRecompile recomp
    
    594 595
           Right es -> do
    

  • compiler/GHC/Linker/Deps.hs
    ... ... @@ -53,8 +53,6 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
    53 53
     import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
    
    54 54
     
    
    55 55
     import qualified Data.Set as Set
    
    56
    -import qualified Data.Map as M
    
    57
    -import Data.List (isSuffixOf)
    
    58 56
     
    
    59 57
     import System.FilePath
    
    60 58
     import System.Directory
    

  • compiler/GHC/Rename/Names.hs
    ... ... @@ -27,6 +27,7 @@ module GHC.Rename.Names (
    27 27
             getMinimalImports,
    
    28 28
             printMinimalImports,
    
    29 29
             renamePkgQual, renameRawPkgQual,
    
    30
    +        hscRenamePkgQual, hscRenameRawPkgQual,
    
    30 31
             classifyGREs,
    
    31 32
             ImportDeclUsage,
    
    32 33
         ) where
    
    ... ... @@ -337,7 +338,8 @@ rnImportDecl this_mod
    337 338
     
    
    338 339
         hsc_env <- getTopEnv
    
    339 340
         unit_env <- hsc_unit_env <$> getTopEnv
    
    340
    -    let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
    
    341
    +    query <- liftIO $ hscUnitIndexQuery hsc_env
    
    342
    +    let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
    
    341 343
     
    
    342 344
         -- Check for self-import, which confuses the typechecker (#9032)
    
    343 345
         -- ghc --make rejects self-import cycles already, but batch-mode may not
    
    ... ... @@ -447,14 +449,14 @@ rnImportDecl this_mod
    447 449
     
    
    448 450
     
    
    449 451
     -- | Rename raw package imports
    
    450
    -renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
    
    451
    -renameRawPkgQual unit_env mn = \case
    
    452
    +renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
    
    453
    +renameRawPkgQual unit_env query mn = \case
    
    452 454
       NoRawPkgQual -> NoPkgQual
    
    453
    -  RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
    
    455
    +  RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
    
    454 456
     
    
    455 457
     -- | Rename raw package imports
    
    456
    -renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
    
    457
    -renamePkgQual unit_env mn mb_pkg = case mb_pkg of
    
    458
    +renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
    
    459
    +renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
    
    458 460
       Nothing -> NoPkgQual
    
    459 461
       Just pkg_fs
    
    460 462
         | Just uid <- homeUnitId <$> ue_homeUnit unit_env
    
    ... ... @@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
    464 466
         | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
    
    465 467
         -> ThisPkg uid
    
    466 468
     
    
    467
    -    | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
    
    469
    +    | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
    
    468 470
         -> OtherPkg uid
    
    469 471
     
    
    470 472
         | otherwise
    
    ... ... @@ -479,6 +481,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
    479 481
         hpt_deps :: [UnitId]
    
    480 482
         hpt_deps  = homeUnitDepends units
    
    481 483
     
    
    484
    +hscRenameRawPkgQual ::
    
    485
    +  MonadIO m =>
    
    486
    +  HscEnv ->
    
    487
    +  ModuleName ->
    
    488
    +  RawPkgQual ->
    
    489
    +  m PkgQual
    
    490
    +hscRenameRawPkgQual hsc_env name raw = do
    
    491
    +  query <- liftIO $ hscUnitIndexQuery hsc_env
    
    492
    +  pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
    
    493
    +
    
    494
    +hscRenamePkgQual ::
    
    495
    +  MonadIO m =>
    
    496
    +  HscEnv ->
    
    497
    +  ModuleName ->
    
    498
    +  Maybe FastString ->
    
    499
    +  m PkgQual
    
    500
    +hscRenamePkgQual hsc_env name package = do
    
    501
    +  query <- liftIO $ hscUnitIndexQuery hsc_env
    
    502
    +  pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
    
    482 503
     
    
    483 504
     -- | Calculate the 'ImportAvails' induced by an import of a particular
    
    484 505
     -- interface, but without 'imp_mods'.
    

  • compiler/GHC/Runtime/Context.hs
    ... ... @@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
    26 26
     
    
    27 27
     import GHC.Unit
    
    28 28
     import GHC.Unit.Env
    
    29
    +import GHC.Unit.State (UnitIndexQuery)
    
    29 30
     
    
    30 31
     import GHC.Core.FamInstEnv
    
    31 32
     import GHC.Core.InstEnv
    
    ... ... @@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
    351 352
             ]
    
    352 353
     
    
    353 354
     -- | Get the NamePprCtx function based on the flags and this InteractiveContext
    
    354
    -icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
    
    355
    -icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
    
    355
    +icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
    
    356
    +icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
    
    356 357
       where ptc = initPromotionTickContext (ic_dflags ictxt)
    
    357 358
     
    
    358 359
     -- | extendInteractiveContext is called with new TyThings recently defined to update the
    

  • compiler/GHC/Runtime/Loader.hs
    ... ... @@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
    348 348
         let unit_state = ue_units unit_env
    
    349 349
         let mhome_unit = hsc_home_unit_maybe hsc_env
    
    350 350
         -- First find the unit the module resides in by searching exposed units and home modules
    
    351
    -    found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
    
    351
    +    query <- hscUnitIndexQuery hsc_env
    
    352
    +    found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
    
    352 353
         case found_module of
    
    353 354
             Found _ mod -> do
    
    354 355
                 -- Find the exports of the module
    

  • compiler/GHC/Tc/Module.hs
    ... ... @@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum
    266 266
             ; when (notNull prel_imports) $ do
    
    267 267
                 addDiagnostic TcRnImplicitImportOfPrelude
    
    268 268
     
    
    269
    +        ; query <- liftIO $ hscUnitIndexQuery hsc_env
    
    270
    +
    
    269 271
             ; -- TODO This is a little skeevy; maybe handle a bit more directly
    
    270 272
               let { simplifyImport (L _ idecl) =
    
    271
    -                  ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
    
    273
    +                  ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
    
    272 274
                       , reLoc $ ideclName idecl)
    
    273 275
                   }
    
    274 276
             ; raw_sig_imports <- liftIO
    
    ... ... @@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside
    1996 1998
                                      (loadSrcInterface (text "runTcInteractive") m
    
    1997 1999
                                                        NotBoot mb_pkg)
    
    1998 2000
     
    
    2001
    +
    
    1999 2002
            ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
    
    2000 2003
                 case i of                   -- force above: see #15111
    
    2001 2004
                     IIModule n -> getOrphans n NoPkgQual
    
    2002
    -                IIDecl i   -> getOrphans (unLoc (ideclName i))
    
    2003
    -                                         (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
    
    2005
    +                IIDecl i -> do
    
    2006
    +                  qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
    
    2007
    +                  getOrphans (unLoc (ideclName i)) qual
    
    2004 2008
     
    
    2005 2009
            ; let imports = emptyImportAvails { imp_orphs = orphs }
    
    2006 2010
     
    

  • compiler/GHC/Tc/Utils/Monad.hs
    ... ... @@ -869,7 +869,8 @@ getNamePprCtx
    869 869
       = do { ptc <- initPromotionTickContext <$> getDynFlags
    
    870 870
            ; rdr_env <- getGlobalRdrEnv
    
    871 871
            ; hsc_env <- getTopEnv
    
    872
    -       ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
    
    872
    +       ; query <- liftIO $ hscUnitIndexQuery hsc_env
    
    873
    +       ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
    
    873 874
     
    
    874 875
     -- | Like logInfoTcRn, but for user consumption
    
    875 876
     printForUserTcRn :: SDoc -> TcRn ()
    

  • compiler/GHC/Types/Name/Ppr.hs
    ... ... @@ -68,11 +68,11 @@ with some holes, we should try to give the user some more useful information.
    68 68
     
    
    69 69
     -- | Creates some functions that work out the best ways to format
    
    70 70
     -- names for the user according to a set of heuristics.
    
    71
    -mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
    
    72
    -mkNamePprCtx ptc unit_env env
    
    71
    +mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
    
    72
    +mkNamePprCtx ptc unit_env index env
    
    73 73
      = QueryQualify
    
    74 74
           (mkQualName env)
    
    75
    -      (mkQualModule unit_state home_unit)
    
    75
    +      (mkQualModule unit_state index home_unit)
    
    76 76
           (mkQualPackage unit_state)
    
    77 77
           (mkPromTick ptc env)
    
    78 78
       where
    
    ... ... @@ -206,8 +206,8 @@ Side note (int-index):
    206 206
     -- | Creates a function for formatting modules based on two heuristics:
    
    207 207
     -- (1) if the module is the current module, don't qualify, and (2) if there
    
    208 208
     -- is only one exposed package which exports this module, don't qualify.
    
    209
    -mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
    
    210
    -mkQualModule unit_state mhome_unit mod
    
    209
    +mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
    
    210
    +mkQualModule unit_state index mhome_unit mod
    
    211 211
          | Just home_unit <- mhome_unit
    
    212 212
          , isHomeModule home_unit mod = False
    
    213 213
     
    
    ... ... @@ -218,7 +218,7 @@ mkQualModule unit_state mhome_unit mod
    218 218
          = False
    
    219 219
     
    
    220 220
          | otherwise = True
    
    221
    -     where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
    
    221
    +     where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
    
    222 222
     
    
    223 223
     -- | Creates a function for formatting packages based on two heuristics:
    
    224 224
     -- (1) don't qualify if the package in question is "main", and (2) only qualify
    

  • compiler/GHC/Unit/Env.hs
    ... ... @@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
    100 100
     
    
    101 101
         , ue_namever   :: !GhcNameVersion
    
    102 102
             -- ^ GHC name/version (used for dynamic library suffix)
    
    103
    +
    
    104
    +    , ue_index :: !UnitIndex
    
    103 105
         }
    
    104 106
     
    
    105 107
     ueEPS :: UnitEnv -> IO ExternalPackageState
    
    ... ... @@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
    108 110
     initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
    
    109 111
     initUnitEnv cur_unit hug namever platform = do
    
    110 112
       eps <- initExternalUnitCache
    
    113
    +  ue_index <- newUnitIndex
    
    111 114
       return $ UnitEnv
    
    112 115
         { ue_eps             = eps
    
    113 116
         , ue_home_unit_graph = hug
    
    114 117
         , ue_current_unit    = cur_unit
    
    115 118
         , ue_platform        = platform
    
    116 119
         , ue_namever         = namever
    
    120
    +    , ue_index
    
    117 121
         }
    
    118 122
     
    
    119 123
     -- | Get home-unit
    

  • compiler/GHC/Unit/Finder.hs
    ... ... @@ -67,7 +67,7 @@ import Control.Monad
    67 67
     import Data.Time
    
    68 68
     import qualified Data.Map as M
    
    69 69
     import GHC.Driver.Env
    
    70
    -    ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
    
    70
    +    ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery )
    
    71 71
     import GHC.Driver.Config.Finder
    
    72 72
     import qualified Data.Set as Set
    
    73 73
     
    
    ... ... @@ -161,17 +161,19 @@ findImportedModule hsc_env mod pkg_qual =
    161 161
           dflags    = hsc_dflags hsc_env
    
    162 162
           fopts     = initFinderOpts dflags
    
    163 163
       in do
    
    164
    -    findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
    
    164
    +    query <- hscUnitIndexQuery hsc_env
    
    165
    +    findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
    
    165 166
     
    
    166 167
     findImportedModuleNoHsc
    
    167 168
       :: FinderCache
    
    168 169
       -> FinderOpts
    
    169 170
       -> UnitEnv
    
    171
    +  -> UnitIndexQuery
    
    170 172
       -> Maybe HomeUnit
    
    171 173
       -> ModuleName
    
    172 174
       -> PkgQual
    
    173 175
       -> IO FindResult
    
    174
    -findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
    
    176
    +findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
    
    175 177
       case mb_pkg of
    
    176 178
         NoPkgQual  -> unqual_import
    
    177 179
         ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
    
    ... ... @@ -193,7 +195,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
    193 195
           -- If the module is reexported, then look for it as if it was from the perspective
    
    194 196
           -- of that package which reexports it.
    
    195 197
           | mod_name `Set.member` finder_reexportedModules opts =
    
    196
    -        findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
    
    198
    +        findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
    
    197 199
           | mod_name `Set.member` finder_hiddenModules opts =
    
    198 200
             return (mkHomeHidden uid)
    
    199 201
           | otherwise =
    
    ... ... @@ -204,11 +206,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
    204 206
         -- first before looking at the packages in order.
    
    205 207
         any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
    
    206 208
     
    
    207
    -    pkg_import    = findExposedPackageModule fc fopts units  mod_name mb_pkg
    
    209
    +    pkg_import    = findExposedPackageModule fc fopts units query mod_name mb_pkg
    
    208 210
     
    
    209 211
         unqual_import = any_home_import
    
    210 212
                         `orIfNotFound`
    
    211
    -                    findExposedPackageModule fc fopts units mod_name NoPkgQual
    
    213
    +                    findExposedPackageModule fc fopts units query mod_name NoPkgQual
    
    212 214
     
    
    213 215
         units     = case mhome_unit of
    
    214 216
                       Nothing -> ue_units ue
    
    ... ... @@ -221,13 +223,13 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
    221 223
     -- plugin.  This consults the same set of exposed packages as
    
    222 224
     -- 'findImportedModule', unless @-hide-all-plugin-packages@ or
    
    223 225
     -- @-plugin-package@ are specified.
    
    224
    -findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
    
    225
    -findPluginModule fc fopts units (Just home_unit) mod_name =
    
    226
    +findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
    
    227
    +findPluginModule fc fopts units query (Just home_unit) mod_name =
    
    226 228
       findHomeModule fc fopts home_unit mod_name
    
    227 229
       `orIfNotFound`
    
    228
    -  findExposedPluginPackageModule fc fopts units mod_name
    
    229
    -findPluginModule fc fopts units Nothing mod_name =
    
    230
    -  findExposedPluginPackageModule fc fopts units mod_name
    
    230
    +  findExposedPluginPackageModule fc fopts units query mod_name
    
    231
    +findPluginModule fc fopts units query Nothing mod_name =
    
    232
    +  findExposedPluginPackageModule fc fopts units query mod_name
    
    231 233
     
    
    232 234
     -- | Locate a specific 'Module'.  The purpose of this function is to
    
    233 235
     -- create a 'ModLocation' for a given 'Module', that is to find out
    
    ... ... @@ -283,15 +285,15 @@ homeSearchCache fc home_unit mod_name do_this = do
    283 285
       let mod = mkModule home_unit mod_name
    
    284 286
       modLocationCache fc mod do_this
    
    285 287
     
    
    286
    -findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
    
    287
    -findExposedPackageModule fc fopts units mod_name mb_pkg =
    
    288
    +findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
    
    289
    +findExposedPackageModule fc fopts units query mod_name mb_pkg =
    
    288 290
       findLookupResult fc fopts
    
    289
    -    $ lookupModuleWithSuggestions units mod_name mb_pkg
    
    291
    +    $ lookupModuleWithSuggestions units query mod_name mb_pkg
    
    290 292
     
    
    291
    -findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
    
    292
    -findExposedPluginPackageModule fc fopts units mod_name =
    
    293
    +findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
    
    294
    +findExposedPluginPackageModule fc fopts units query mod_name =
    
    293 295
       findLookupResult fc fopts
    
    294
    -    $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
    
    296
    +    $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
    
    295 297
     
    
    296 298
     findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
    
    297 299
     findLookupResult fc fopts r = case r of
    

  • compiler/GHC/Unit/State.hs
    1 1
     -- (c) The University of Glasgow, 2006
    
    2 2
     
    
    3
    -{-# LANGUAGE LambdaCase #-}
    
    3
    +{-# LANGUAGE LambdaCase, RecordWildCards #-}
    
    4 4
     
    
    5 5
     -- | Unit manipulation
    
    6 6
     module GHC.Unit.State (
    
    ... ... @@ -49,6 +49,14 @@ module GHC.Unit.State (
    49 49
             closeUnitDeps',
    
    50 50
             mayThrowUnitErr,
    
    51 51
     
    
    52
    +        UnitConfig (..),
    
    53
    +        UnitIndex (..),
    
    54
    +        UnitIndexQuery (..),
    
    55
    +        UnitVisibility (..),
    
    56
    +        VisibilityMap,
    
    57
    +        ModuleNameProvidersMap,
    
    58
    +        newUnitIndex,
    
    59
    +
    
    52 60
             -- * Module hole substitution
    
    53 61
             ShHoleSubst,
    
    54 62
             renameHoleUnit,
    
    ... ... @@ -103,6 +111,8 @@ import GHC.Data.Maybe
    103 111
     import System.Environment ( getEnv )
    
    104 112
     import GHC.Data.FastString
    
    105 113
     import qualified GHC.Data.ShortText as ST
    
    114
    +import GHC.Data.OsPath (OsPath)
    
    115
    +import qualified GHC.Data.OsPath as OsPath
    
    106 116
     import GHC.Utils.Logger
    
    107 117
     import GHC.Utils.Error
    
    108 118
     import GHC.Utils.Exception
    
    ... ... @@ -112,7 +122,7 @@ import System.FilePath as FilePath
    112 122
     import Control.Monad
    
    113 123
     import Data.Graph (stronglyConnComp, SCC(..))
    
    114 124
     import Data.Char ( toUpper )
    
    115
    -import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn )
    
    125
    +import Data.List ( intersperse, partition, sortBy, sortOn )
    
    116 126
     import Data.Set (Set)
    
    117 127
     import Data.Monoid (First(..))
    
    118 128
     import qualified Data.Semigroup as Semigroup
    
    ... ... @@ -216,7 +226,7 @@ instance Outputable ModuleOrigin where
    216 226
             (if null rhs
    
    217 227
                 then []
    
    218 228
                 else [text "hidden reexport by" <+>
    
    219
    -                    sep (map (ppr . mkUnit) res)]) ++
    
    229
    +                    sep (map (ppr . mkUnit) rhs)]) ++
    
    220 230
             (if f then [text "package flag"] else [])
    
    221 231
             ))
    
    222 232
     
    
    ... ... @@ -405,7 +415,7 @@ initUnitConfig dflags cached_dbs home_units =
    405 415
     
    
    406 416
       where
    
    407 417
         offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag
    
    408
    -    offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset </> p))
    
    418
    +    offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p))
    
    409 419
         offsetPackageDb _ p = p
    
    410 420
     
    
    411 421
     
    
    ... ... @@ -500,12 +510,12 @@ emptyUnitState = UnitState {
    500 510
     
    
    501 511
     -- | Unit database
    
    502 512
     data UnitDatabase unit = UnitDatabase
    
    503
    -   { unitDatabasePath  :: FilePath
    
    513
    +   { unitDatabasePath  :: OsPath
    
    504 514
        , unitDatabaseUnits :: [GenUnitInfo unit]
    
    505 515
        }
    
    506 516
     
    
    507 517
     instance Outputable u => Outputable (UnitDatabase u) where
    
    508
    -  ppr (UnitDatabase fp _u) = text "DB:" <+> text fp
    
    518
    +  ppr (UnitDatabase fp _u) = text "DB:" <+> OsPath.pprOsPath fp
    
    509 519
     
    
    510 520
     type UnitInfoMap = UniqMap UnitId UnitInfo
    
    511 521
     
    
    ... ... @@ -575,10 +585,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
    575 585
     -- | Find the UnitId which an import qualified by a package import comes from.
    
    576 586
     -- Compared to 'lookupPackageName', this function correctly accounts for visibility,
    
    577 587
     -- renaming and thinning.
    
    578
    -resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
    
    579
    -resolvePackageImport unit_st mn pn = do
    
    588
    +resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
    
    589
    +resolvePackageImport unit_st query mn pn = do
    
    580 590
       -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
    
    581
    -  providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
    
    591
    +  providers <- filterUniqMap originVisible <$> findOrigin query unit_st mn False
    
    582 592
       -- 2. Get the UnitIds of the candidates
    
    583 593
       let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
    
    584 594
       -- 3. Get the package names of the candidates
    
    ... ... @@ -636,14 +646,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
    636 646
     -- 'initUnits' can be called again subsequently after updating the
    
    637 647
     -- 'packageFlags' field of the 'DynFlags', and it will update the
    
    638 648
     -- 'unitState' in 'DynFlags'.
    
    639
    -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
    
    640
    -initUnits logger dflags cached_dbs home_units = do
    
    649
    +initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
    
    650
    +initUnits logger dflags index cached_dbs home_units = do
    
    641 651
     
    
    642 652
       let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
    
    643 653
     
    
    644 654
       (unit_state,dbs) <- withTiming logger (text "initializing unit database")
    
    645 655
                        forceUnitInfoMap
    
    646
    -                 $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
    
    656
    +                 $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
    
    647 657
     
    
    648 658
       putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
    
    649 659
         FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
    
    ... ... @@ -720,9 +730,9 @@ getUnitDbRefs cfg = do
    720 730
             Left _ -> system_conf_refs
    
    721 731
             Right path
    
    722 732
              | Just (xs, x) <- snocView path, isSearchPathSeparator x
    
    723
    -         -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs
    
    733
    +         -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs
    
    724 734
              | otherwise
    
    725
    -         -> map PkgDbPath (splitSearchPath path)
    
    735
    +         -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path))
    
    726 736
     
    
    727 737
       -- Apply the package DB-related flags from the command line to get the
    
    728 738
       -- final list of package DBs.
    
    ... ... @@ -751,24 +761,24 @@ getUnitDbRefs cfg = do
    751 761
     -- NB: This logic is reimplemented in Cabal, so if you change it,
    
    752 762
     -- make sure you update Cabal. (Or, better yet, dump it in the
    
    753 763
     -- compiler info so Cabal can use the info.)
    
    754
    -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath)
    
    755
    -resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg)
    
    764
    +resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath)
    
    765
    +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg
    
    756 766
     resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
    
    757 767
       dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg)
    
    758 768
       let pkgconf = dir </> unitConfigDBName cfg
    
    759 769
       exist <- tryMaybeT $ doesDirectoryExist pkgconf
    
    760
    -  if exist then return pkgconf else mzero
    
    770
    +  if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
    
    761 771
     resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
    
    762 772
     
    
    763
    -readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
    
    773
    +readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId)
    
    764 774
     readUnitDatabase logger cfg conf_file = do
    
    765
    -  isdir <- doesDirectoryExist conf_file
    
    775
    +  isdir <- OsPath.doesDirectoryExist conf_file
    
    766 776
     
    
    767 777
       proto_pkg_configs <-
    
    768 778
         if isdir
    
    769 779
            then readDirStyleUnitInfo conf_file
    
    770 780
            else do
    
    771
    -            isfile <- doesFileExist conf_file
    
    781
    +            isfile <- OsPath.doesFileExist conf_file
    
    772 782
                 if isfile
    
    773 783
                    then do
    
    774 784
                      mpkgs <- tryReadOldFileStyleUnitInfo
    
    ... ... @@ -776,48 +786,49 @@ readUnitDatabase logger cfg conf_file = do
    776 786
                        Just pkgs -> return pkgs
    
    777 787
                        Nothing   -> throwGhcExceptionIO $ InstallationError $
    
    778 788
                           "ghc no longer supports single-file style package " ++
    
    779
    -                      "databases (" ++ conf_file ++
    
    789
    +                      "databases (" ++ show conf_file ++
    
    780 790
                           ") use 'ghc-pkg init' to create the database with " ++
    
    781 791
                           "the correct format."
    
    782 792
                    else throwGhcExceptionIO $ InstallationError $
    
    783
    -                      "can't find a package database at " ++ conf_file
    
    793
    +                      "can't find a package database at " ++ show conf_file
    
    784 794
     
    
    785 795
       let
    
    786 796
           -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
    
    787
    -      conf_file' = dropTrailingPathSeparator conf_file
    
    788
    -      top_dir = unitConfigGHCDir cfg
    
    789
    -      pkgroot = takeDirectory conf_file'
    
    797
    +      conf_file' = OsPath.dropTrailingPathSeparator conf_file
    
    798
    +      top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) -- TODO: hm.
    
    799
    +      pkgroot = OsPath.takeDirectory conf_file'
    
    790 800
           pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
    
    791 801
                              proto_pkg_configs
    
    792 802
       --
    
    793 803
       return $ UnitDatabase conf_file' pkg_configs1
    
    794 804
       where
    
    805
    +    readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
    
    795 806
         readDirStyleUnitInfo conf_dir = do
    
    796
    -      let filename = conf_dir </> "package.cache"
    
    797
    -      cache_exists <- doesFileExist filename
    
    807
    +      let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache")
    
    808
    +      cache_exists <- OsPath.doesFileExist filename
    
    798 809
           if cache_exists
    
    799 810
             then do
    
    800
    -          debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename
    
    801
    -          readPackageDbForGhc filename
    
    811
    +          debugTraceMsg logger 2 $ text "Using binary package database:" <+> OsPath.pprOsPath filename
    
    812
    +          readPackageDbForGhc (OsPath.unsafeDecodeUtf filename) -- TODO: Can we help it with this one? it comes from the ghc-boot package
    
    802 813
             else do
    
    803 814
               -- If there is no package.cache file, we check if the database is not
    
    804 815
               -- empty by inspecting if the directory contains any .conf file. If it
    
    805 816
               -- does, something is wrong and we fail. Otherwise we assume that the
    
    806 817
               -- database is empty.
    
    807 818
               debugTraceMsg logger 2 $ text "There is no package.cache in"
    
    808
    -                      <+> text conf_dir
    
    819
    +                      <+> OsPath.pprOsPath conf_dir
    
    809 820
                            <> text ", checking if the database is empty"
    
    810
    -          db_empty <- all (not . isSuffixOf ".conf")
    
    811
    -                   <$> getDirectoryContents conf_dir
    
    821
    +          db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf"))
    
    822
    +                   <$> OsPath.getDirectoryContents conf_dir
    
    812 823
               if db_empty
    
    813 824
                 then do
    
    814 825
                   debugTraceMsg logger 3 $ text "There are no .conf files in"
    
    815
    -                          <+> text conf_dir <> text ", treating"
    
    826
    +                          <+> OsPath.pprOsPath conf_dir <> text ", treating"
    
    816 827
                               <+> text "package database as empty"
    
    817 828
                   return []
    
    818 829
                 else
    
    819 830
                   throwGhcExceptionIO $ InstallationError $
    
    820
    -                "there is no package.cache in " ++ conf_dir ++
    
    831
    +                "there is no package.cache in " ++ show conf_dir ++
    
    821 832
                     " even though package database is not empty"
    
    822 833
     
    
    823 834
     
    
    ... ... @@ -830,13 +841,13 @@ readUnitDatabase logger cfg conf_file = do
    830 841
         -- assumes it's a file and tries to overwrite with 'writeFile'.
    
    831 842
         -- ghc-pkg also cooperates with this workaround.
    
    832 843
         tryReadOldFileStyleUnitInfo = do
    
    833
    -      content <- readFile conf_file `catchIO` \_ -> return ""
    
    844
    +      content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return ""
    
    834 845
           if take 2 content == "[]"
    
    835 846
             then do
    
    836
    -          let conf_dir = conf_file <.> "d"
    
    837
    -          direxists <- doesDirectoryExist conf_dir
    
    847
    +          let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d"
    
    848
    +          direxists <- OsPath.doesDirectoryExist conf_dir
    
    838 849
               if direxists
    
    839
    -             then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
    
    850
    +             then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> OsPath.pprOsPath conf_dir)
    
    840 851
                          liftM Just (readDirStyleUnitInfo conf_dir)
    
    841 852
                  else return (Just []) -- ghc-pkg will create it when it's updated
    
    842 853
             else return Nothing
    
    ... ... @@ -846,11 +857,12 @@ distrustAllUnits pkgs = map distrust pkgs
    846 857
       where
    
    847 858
         distrust pkg = pkg{ unitIsTrusted = False }
    
    848 859
     
    
    849
    -mungeUnitInfo :: FilePath -> FilePath
    
    860
    +-- TODO: Can we help it with this one? it comes from the ghc-boot package
    
    861
    +mungeUnitInfo :: OsPath -> OsPath
    
    850 862
                        -> UnitInfo -> UnitInfo
    
    851 863
     mungeUnitInfo top_dir pkgroot =
    
    852 864
         mungeDynLibFields
    
    853
    -  . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot)
    
    865
    +  . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot))
    
    854 866
     
    
    855 867
     mungeDynLibFields :: UnitInfo -> UnitInfo
    
    856 868
     mungeDynLibFields pkg =
    
    ... ... @@ -1388,7 +1400,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..]
    1388 1400
       where
    
    1389 1401
         merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
    
    1390 1402
           debugTraceMsg logger 2 $
    
    1391
    -          text "loading package database" <+> text db_path
    
    1403
    +          text "loading package database" <+> OsPath.pprOsPath db_path
    
    1392 1404
           forM_ (Set.toList override_set) $ \pkg ->
    
    1393 1405
               debugTraceMsg logger 2 $
    
    1394 1406
                   text "package" <+> ppr pkg <+>
    
    ... ... @@ -1480,9 +1492,11 @@ validateDatabase cfg pkg_map1 =
    1480 1492
     
    
    1481 1493
     mkUnitState
    
    1482 1494
         :: Logger
    
    1495
    +    -> UnitId
    
    1483 1496
         -> UnitConfig
    
    1497
    +    -> UnitIndex
    
    1484 1498
         -> IO (UnitState,[UnitDatabase UnitId])
    
    1485
    -mkUnitState logger cfg = do
    
    1499
    +mkUnitState logger unit cfg index = do
    
    1486 1500
     {-
    
    1487 1501
        Plan.
    
    1488 1502
     
    
    ... ... @@ -1538,15 +1552,9 @@ mkUnitState logger cfg = do
    1538 1552
     
    
    1539 1553
       -- if databases have not been provided, read the database flags
    
    1540 1554
       raw_dbs <- case unitConfigDBCache cfg of
    
    1541
    -               Nothing  -> readUnitDatabases logger cfg
    
    1555
    +               Nothing  -> readDatabases index logger unit cfg
    
    1542 1556
                    Just dbs -> return dbs
    
    1543 1557
     
    
    1544
    -  -- distrust all units if the flag is set
    
    1545
    -  let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
    
    1546
    -      dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
    
    1547
    -          | otherwise                 = raw_dbs
    
    1548
    -
    
    1549
    -
    
    1550 1558
       -- This, and the other reverse's that you will see, are due to the fact that
    
    1551 1559
       -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
    
    1552 1560
       -- than they are on the command line.
    
    ... ... @@ -1558,15 +1566,20 @@ mkUnitState logger cfg = do
    1558 1566
       let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
    
    1559 1567
     
    
    1560 1568
       -- Merge databases together, without checking validity
    
    1561
    -  (pkg_map1, prec_map) <- mergeDatabases logger dbs
    
    1569
    +  (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
    
    1562 1570
     
    
    1563 1571
       -- Now that we've merged everything together, prune out unusable
    
    1564 1572
       -- packages.
    
    1565
    -  let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
    
    1573
    +  let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
    
    1566 1574
     
    
    1567 1575
       reportCycles   logger sccs
    
    1568 1576
       reportUnusable logger unusable
    
    1569 1577
     
    
    1578
    +  -- distrust all units if the flag is set
    
    1579
    +  let distrust_all info = info {unitIsTrusted = False}
    
    1580
    +      pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
    
    1581
    +               | otherwise                 = initial_dbs
    
    1582
    +
    
    1570 1583
       -- Apply trust flags (these flags apply regardless of whether
    
    1571 1584
       -- or not packages are visible or not)
    
    1572 1585
       pkgs1 <- mayThrowUnitErr
    
    ... ... @@ -1671,6 +1684,9 @@ mkUnitState logger cfg = do
    1671 1684
                     -- likely to actually happen.
    
    1672 1685
                     return (updateVisibilityMap wired_map plugin_vis_map2)
    
    1673 1686
     
    
    1687
    +  (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
    
    1688
    +    computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable)
    
    1689
    +
    
    1674 1690
       let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
    
    1675 1691
                                   | p <- pkgs2
    
    1676 1692
                                   ]
    
    ... ... @@ -1683,8 +1699,6 @@ mkUnitState logger cfg = do
    1683 1699
           req_ctx = mapUniqMap (Set.toList)
    
    1684 1700
                   $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
    
    1685 1701
     
    
    1686
    -
    
    1687
    -  --
    
    1688 1702
       -- Here we build up a set of the packages mentioned in -package
    
    1689 1703
       -- flags on the command line; these are called the "preload"
    
    1690 1704
       -- packages.  we link these packages in eagerly.  The preload set
    
    ... ... @@ -1707,10 +1721,6 @@ mkUnitState logger cfg = do
    1707 1721
                         $ closeUnitDeps pkg_db
    
    1708 1722
                         $ zip (map toUnitId preload3) (repeat Nothing)
    
    1709 1723
     
    
    1710
    -  let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
    
    1711
    -      mod_map2 = mkUnusableModuleNameProvidersMap unusable
    
    1712
    -      mod_map = mod_map2 `plusUniqMap` mod_map1
    
    1713
    -
    
    1714 1724
       -- Force the result to avoid leaking input parameters
    
    1715 1725
       let !state = UnitState
    
    1716 1726
              { preloadUnits                 = dep_preload
    
    ... ... @@ -1718,8 +1728,8 @@ mkUnitState logger cfg = do
    1718 1728
              , homeUnitDepends              = Set.toList home_unit_deps
    
    1719 1729
              , unitInfoMap                  = pkg_db
    
    1720 1730
              , preloadClosure               = emptyUniqSet
    
    1721
    -         , moduleNameProvidersMap       = mod_map
    
    1722
    -         , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
    
    1731
    +         , moduleNameProvidersMap
    
    1732
    +         , pluginModuleNameProvidersMap
    
    1723 1733
              , packageNameMap               = pkgname_map
    
    1724 1734
              , wireMap                      = wired_map
    
    1725 1735
              , unwireMap                    = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
    
    ... ... @@ -1892,6 +1902,76 @@ addListTo = foldl' merge
    1892 1902
     mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
    
    1893 1903
     mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
    
    1894 1904
     
    
    1905
    +-- -----------------------------------------------------------------------------
    
    1906
    +-- Index
    
    1907
    +
    
    1908
    +data UnitIndexQuery =
    
    1909
    +  UnitIndexQuery {
    
    1910
    +    findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
    
    1911
    +    moduleProviders :: UnitState -> ModuleNameProvidersMap
    
    1912
    +  }
    
    1913
    +
    
    1914
    +data UnitIndex =
    
    1915
    +  UnitIndex {
    
    1916
    +    unitIndexQuery :: UnitId -> IO UnitIndexQuery,
    
    1917
    +    readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
    
    1918
    +    computeProviders ::
    
    1919
    +      Logger ->
    
    1920
    +      UnitId ->
    
    1921
    +      UnitConfig ->
    
    1922
    +      VisibilityMap ->
    
    1923
    +      VisibilityMap ->
    
    1924
    +      UnitInfoMap ->
    
    1925
    +      UnitInfoMap ->
    
    1926
    +      ModuleNameProvidersMap ->
    
    1927
    +      IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
    
    1928
    +  }
    
    1929
    +
    
    1930
    +queryFindOriginDefault ::
    
    1931
    +  UnitState ->
    
    1932
    +  ModuleName ->
    
    1933
    +  Bool ->
    
    1934
    +  Maybe (UniqMap Module ModuleOrigin)
    
    1935
    +queryFindOriginDefault UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
    
    1936
    +  lookupUniqMap source name
    
    1937
    +  where
    
    1938
    +    source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
    
    1939
    +
    
    1940
    +newUnitIndexQuery :: UnitId -> IO UnitIndexQuery
    
    1941
    +newUnitIndexQuery _ =
    
    1942
    +  pure UnitIndexQuery {
    
    1943
    +    findOrigin = queryFindOriginDefault,
    
    1944
    +    moduleProviders = moduleNameProvidersMap
    
    1945
    +  }
    
    1946
    +
    
    1947
    +readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
    
    1948
    +readDatabasesDefault logger _ cfg =
    
    1949
    +  readUnitDatabases logger cfg
    
    1950
    +
    
    1951
    +computeProvidersDefault ::
    
    1952
    +  Logger ->
    
    1953
    +  UnitId ->
    
    1954
    +  UnitConfig ->
    
    1955
    +  VisibilityMap ->
    
    1956
    +  VisibilityMap ->
    
    1957
    +  UnitInfoMap ->
    
    1958
    +  UnitInfoMap ->
    
    1959
    +  ModuleNameProvidersMap ->
    
    1960
    +  IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
    
    1961
    +computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
    
    1962
    +  pure (mod_map, plugin_mod_map)
    
    1963
    +  where
    
    1964
    +    mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
    
    1965
    +    mod_map = unusable `plusUniqMap` mod_map1
    
    1966
    +    plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
    
    1967
    +
    
    1968
    +newUnitIndex :: IO UnitIndex
    
    1969
    +newUnitIndex =
    
    1970
    +  pure UnitIndex {
    
    1971
    +    unitIndexQuery = newUnitIndexQuery,
    
    1972
    +    readDatabases = readDatabasesDefault,
    
    1973
    +    computeProviders = computeProvidersDefault
    
    1974
    +  }
    
    1895 1975
     
    
    1896 1976
     -- -----------------------------------------------------------------------------
    
    1897 1977
     -- Package Utils
    
    ... ... @@ -1899,10 +1979,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
    1899 1979
     -- | Takes a 'ModuleName', and if the module is in any package returns
    
    1900 1980
     -- list of modules which take that name.
    
    1901 1981
     lookupModuleInAllUnits :: UnitState
    
    1982
    +                          -> UnitIndexQuery
    
    1902 1983
                               -> ModuleName
    
    1903 1984
                               -> [(Module, UnitInfo)]
    
    1904
    -lookupModuleInAllUnits pkgs m
    
    1905
    -  = case lookupModuleWithSuggestions pkgs m NoPkgQual of
    
    1985
    +lookupModuleInAllUnits pkgs query m
    
    1986
    +  = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
    
    1906 1987
           LookupFound a b -> [(a,fst b)]
    
    1907 1988
           LookupMultiple rs -> map f rs
    
    1908 1989
             where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
    
    ... ... @@ -1929,18 +2010,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
    1929 2010
                           | SuggestHidden ModuleName Module ModuleOrigin
    
    1930 2011
     
    
    1931 2012
     lookupModuleWithSuggestions :: UnitState
    
    2013
    +                            -> UnitIndexQuery
    
    1932 2014
                                 -> ModuleName
    
    1933 2015
                                 -> PkgQual
    
    1934 2016
                                 -> LookupResult
    
    1935
    -lookupModuleWithSuggestions pkgs
    
    1936
    -  = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
    
    2017
    +lookupModuleWithSuggestions pkgs query name
    
    2018
    +  = lookupModuleWithSuggestions' pkgs query name False
    
    1937 2019
     
    
    1938 2020
     -- | The package which the module **appears** to come from, this could be
    
    1939 2021
     -- the one which reexports the module from it's original package. This function
    
    1940 2022
     -- is currently only used for -Wunused-packages
    
    1941
    -lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
    
    1942
    -lookupModulePackage pkgs mn mfs =
    
    1943
    -    case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
    
    2023
    +lookupModulePackage ::
    
    2024
    +  UnitState ->
    
    2025
    +  UnitIndexQuery ->
    
    2026
    +  ModuleName ->
    
    2027
    +  PkgQual ->
    
    2028
    +  Maybe [UnitInfo]
    
    2029
    +lookupModulePackage pkgs query mn mfs =
    
    2030
    +    case lookupModuleWithSuggestions' pkgs query mn False mfs of
    
    1944 2031
           LookupFound _ (orig_unit, origin) ->
    
    1945 2032
             case origin of
    
    1946 2033
               ModOrigin {fromOrigUnit, fromExposedReexport} ->
    
    ... ... @@ -1956,19 +2043,21 @@ lookupModulePackage pkgs mn mfs =
    1956 2043
           _ -> Nothing
    
    1957 2044
     
    
    1958 2045
     lookupPluginModuleWithSuggestions :: UnitState
    
    2046
    +                                  -> UnitIndexQuery
    
    1959 2047
                                       -> ModuleName
    
    1960 2048
                                       -> PkgQual
    
    1961 2049
                                       -> LookupResult
    
    1962
    -lookupPluginModuleWithSuggestions pkgs
    
    1963
    -  = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
    
    2050
    +lookupPluginModuleWithSuggestions pkgs query name
    
    2051
    +  = lookupModuleWithSuggestions' pkgs query name True
    
    1964 2052
     
    
    1965 2053
     lookupModuleWithSuggestions' :: UnitState
    
    1966
    -                            -> ModuleNameProvidersMap
    
    2054
    +                            -> UnitIndexQuery
    
    1967 2055
                                 -> ModuleName
    
    2056
    +                            -> Bool
    
    1968 2057
                                 -> PkgQual
    
    1969 2058
                                 -> LookupResult
    
    1970
    -lookupModuleWithSuggestions' pkgs mod_map m mb_pn
    
    1971
    -  = case lookupUniqMap mod_map m of
    
    2059
    +lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
    
    2060
    +  = case findOrigin query pkgs m onlyPlugins of
    
    1972 2061
             Nothing -> LookupNotFound suggestions
    
    1973 2062
             Just xs ->
    
    1974 2063
               case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
    
    ... ... @@ -2029,16 +2118,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
    2029 2118
         all_mods :: [(String, ModuleSuggestion)]     -- All modules
    
    2030 2119
         all_mods = sortBy (comparing fst) $
    
    2031 2120
             [ (moduleNameString m, suggestion)
    
    2032
    -        | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
    
    2121
    +        | (m, e) <- nonDetUniqMapToList (moduleProviders query pkgs)
    
    2033 2122
             , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
    
    2034 2123
             ]
    
    2035 2124
         getSuggestion name (mod, origin) =
    
    2036 2125
             (if originVisible origin then SuggestVisible else SuggestHidden)
    
    2037 2126
                 name mod origin
    
    2038 2127
     
    
    2039
    -listVisibleModuleNames :: UnitState -> [ModuleName]
    
    2040
    -listVisibleModuleNames state =
    
    2041
    -    map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
    
    2128
    +listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
    
    2129
    +listVisibleModuleNames unit_state query =
    
    2130
    +    map fst (filter visible (nonDetUniqMapToList (moduleProviders query unit_state)))
    
    2042 2131
       where visible (_, ms) = anyUniqMap originVisible ms
    
    2043 2132
     
    
    2044 2133
     -- | Takes a list of UnitIds (and their "parent" dependency, used for error
    

  • compiler/ghc.cabal.in
    ... ... @@ -115,6 +115,7 @@ Library
    115 115
                        containers >= 0.6.2.1 && < 0.8,
    
    116 116
                        array      >= 0.1 && < 0.6,
    
    117 117
                        filepath   >= 1   && < 1.6,
    
    118
    +                   os-string  >= 2.0.1 && < 2.1,
    
    118 119
                        template-haskell == 2.22.*,
    
    119 120
                        hpc        >= 0.6 && < 0.8,
    
    120 121
                        transformers >= 0.5 && < 0.7,
    
    ... ... @@ -430,6 +431,7 @@ Library
    430 431
             GHC.Data.List.SetOps
    
    431 432
             GHC.Data.Maybe
    
    432 433
             GHC.Data.OrdList
    
    434
    +        GHC.Data.OsPath
    
    433 435
             GHC.Data.Pair
    
    434 436
             GHC.Data.SmallArray
    
    435 437
             GHC.Data.Stream
    

  • ghc/GHCi/UI.hs
    ... ... @@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
    3695 3695
     
    
    3696 3696
     completeModule = wrapIdentCompleterMod $ \w -> do
    
    3697 3697
       hsc_env <- GHC.getSession
    
    3698
    -  let pkg_mods = allVisibleModules (hsc_units hsc_env)
    
    3698
    +  query <- liftIO $ hscUnitIndexQuery hsc_env
    
    3699
    +  let pkg_mods = allVisibleModules (hsc_units hsc_env) query
    
    3699 3700
       loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
    
    3700 3701
       return $ filter (w `isPrefixOf`)
    
    3701 3702
             $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
    
    3702 3703
     
    
    3703 3704
     completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
    
    3704 3705
       hsc_env <- GHC.getSession
    
    3706
    +  query <- liftIO $ hscUnitIndexQuery hsc_env
    
    3705 3707
       modules <- case m of
    
    3706 3708
         Just '-' -> do
    
    3707 3709
           imports <- GHC.getContext
    
    3708 3710
           return $ map iiModuleName imports
    
    3709 3711
         _ -> do
    
    3710
    -      let pkg_mods = allVisibleModules (hsc_units hsc_env)
    
    3712
    +      let pkg_mods = allVisibleModules (hsc_units hsc_env) query
    
    3711 3713
           loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
    
    3712 3714
           return $ loaded_mods ++ pkg_mods
    
    3713 3715
       return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
    
    ... ... @@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
    3775 3777
     
    
    3776 3778
     -- | Return a list of visible module names for autocompletion.
    
    3777 3779
     -- (NB: exposed != visible)
    
    3778
    -allVisibleModules :: UnitState -> [ModuleName]
    
    3779
    -allVisibleModules unit_state = listVisibleModuleNames unit_state
    
    3780
    +allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
    
    3781
    +allVisibleModules us query = listVisibleModuleNames us query
    
    3780 3782
     
    
    3781 3783
     completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
    
    3782 3784
                             completeIdentifier
    

  • ghc/GHCi/UI/Monad.hs
    ... ... @@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
    374 374
         where
    
    375 375
           mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
    
    376 376
           mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
    
    377
    -        withSession $ \ hsc_env ->
    
    377
    +        withSession $ \ hsc_env -> do
    
    378
    +        query <- liftIO $ hscUnitIndexQuery hsc_env
    
    378 379
             let unit_env = hsc_unit_env hsc_env
    
    379 380
                 ptc = initPromotionTickContext dflags
    
    380
    -        in  return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
    
    381
    +        return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
    
    381 382
     
    
    382 383
     printForUser :: GhcMonad m => SDoc -> m ()
    
    383 384
     printForUser doc = do
    

  • ghc/Main.hs
    ... ... @@ -839,12 +839,13 @@ initMulti unitArgsFiles = do
    839 839
     
    
    840 840
       let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
    
    841 841
           home_units = unitEnv_keys initial_home_graph
    
    842
    +      ue_index = hscUnitIndex hsc_env
    
    842 843
     
    
    843 844
       home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
    
    844 845
         let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
    
    845 846
             hue_flags = homeUnitEnv_dflags homeUnitEnv
    
    846 847
             dflags = homeUnitEnv_dflags homeUnitEnv
    
    847
    -    (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
    
    848
    +    (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_index cached_unit_dbs home_units
    
    848 849
     
    
    849 850
         updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
    
    850 851
         pure $ HomeUnitEnv
    
    ... ... @@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
    859 860
     
    
    860 861
       let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
    
    861 862
       unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
    
    862
    -  let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
    
    863
    +  let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index} }
    
    863 864
     
    
    864 865
       GHC.setSession final_hsc_env
    
    865 866