Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC

Commits:

15 changed files:

Changes:

  • compiler/GHC.hs
    ... ... @@ -671,15 +671,12 @@ setUnitDynFlagsNoCheck uid dflags1 = do
    671 671 
       logger <- getLogger
    672 672 
       hsc_env <- getSession
    673 673
    674 
    -  let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
    675 
    -  let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
    676 
    -  (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
    674 
    +  (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hsc_unit_index hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env)
    677 675 
       updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
    678 676
    679 677 
       let upd hue =
    680 678 
            hue
    681 679 
               { homeUnitEnv_units = unit_state
    682 
    -          , homeUnitEnv_unit_dbs = Just dbs
    683 680 
               , homeUnitEnv_dflags = updated_dflags
    684 681 
               , homeUnitEnv_home_unit = Just home_unit
    685 682 
               }
    ... ... @@ -759,17 +756,15 @@ setProgramDynFlags_ invalidate_needed dflags = do
    759 756 
             old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
    760 757
    761 758 
             home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
    762 
    -          let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
    763 
    -              dflags = homeUnitEnv_dflags homeUnitEnv
    759 
    +          let dflags = homeUnitEnv_dflags homeUnitEnv
    764 760 
                   old_hpt = homeUnitEnv_hpt homeUnitEnv
    765 761 
                   home_units = HUG.allUnits (ue_home_unit_graph old_unit_env)
    766 762
    767 
    -          (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
    763 
    +          (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index old_unit_env) (ue_eud old_unit_env) home_units
    768 764
    769 765 
               updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
    770 766 
               pure HomeUnitEnv
    771 767 
                 { homeUnitEnv_units = unit_state
    772 
    -            , homeUnitEnv_unit_dbs = Just dbs
    773 768 
                 , homeUnitEnv_dflags = updated_dflags
    774 769 
                 , homeUnitEnv_hpt = old_hpt
    775 770 
                 , homeUnitEnv_home_unit = Just home_unit
    ... ... @@ -783,6 +778,8 @@ setProgramDynFlags_ invalidate_needed dflags = do
    783 778 
                   , ue_current_unit    = ue_currentUnit old_unit_env
    784 779 
                   , ue_module_graph    = ue_module_graph old_unit_env
    785 780 
                   , ue_eps             = ue_eps old_unit_env
    781 
    +              , ue_eud             = ue_eud old_unit_env
    782 
    +              , ue_unit_index      = ue_unit_index old_unit_env
    786 783 
                   }
    787 784 
             modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
    788 785 
         else modifySession (hscSetFlags dflags0)
    ... ... @@ -840,6 +837,8 @@ setProgramHUG_ invalidate_needed new_hug0 = do
    840 837 
                 , ue_current_unit    = ue_currentUnit unit_env0
    841 838 
                 , ue_eps             = ue_eps unit_env0
    842 839 
                 , ue_module_graph    = ue_module_graph unit_env0
    840 
    +            , ue_eud             = ue_eud unit_env0
    841 
    +            , ue_unit_index      = ue_unit_index unit_env0
    843 842 
                 }
    844 843 
           modifySession $ \h ->
    845 844 
             -- hscSetFlags takes care of updating the logger as well.
    ... ... @@ -881,19 +880,17 @@ setProgramHUG_ invalidate_needed new_hug0 = do
    881 880
    882 881 
         updateHomeUnit :: GhcMonad m => Logger -> UnitEnv -> HomeUnitGraph -> (UnitId -> HomeUnitEnv -> m HomeUnitEnv)
    883 882 
         updateHomeUnit logger unit_env updates = \uid homeUnitEnv -> do
    884 
    -      let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
    885 
    -          dflags = case HUG.unitEnv_lookup_maybe uid updates of
    883 
    +      let dflags = case HUG.unitEnv_lookup_maybe uid updates of
    886 884 
                 Nothing -> homeUnitEnv_dflags homeUnitEnv
    887 885 
                 Just env -> homeUnitEnv_dflags env
    888 886 
               old_hpt = homeUnitEnv_hpt homeUnitEnv
    889 887 
               home_units = HUG.allUnits (ue_home_unit_graph unit_env)
    890 888
    891 
    -      (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
    889 
    +      (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index unit_env) (ue_eud unit_env) home_units
    892 890
    893 891 
           updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
    894 892 
           pure HomeUnitEnv
    895 893 
             { homeUnitEnv_units = unit_state
    896 
    -        , homeUnitEnv_unit_dbs = Just dbs
    897 894 
             , homeUnitEnv_dflags = updated_dflags
    898 895 
             , homeUnitEnv_hpt = old_hpt
    899 896 
             , homeUnitEnv_home_unit = Just home_unit

  • compiler/GHC/Driver/Backpack.hs
    ... ... @@ -92,6 +92,7 @@ import GHC.Types.Error (mkUnknownDiagnostic)
    92 92 
     import qualified GHC.Unit.Home.Graph as HUG
    93 93 
     import GHC.Unit.Home.ModInfo
    94 94 
     import GHC.Unit.Home.PackageTable
    95 
    +import GHC.Unit.External.Database (cacheExternalUnitDatabase)
    95 96
    96 97 
     -- | Entry point to compile a Backpack file.
    97 98 
     doBackpack :: [FilePath] -> Ghc ()
    ... ... @@ -174,6 +175,8 @@ withBkpSession :: UnitId
    174 175 
                    -> BkpM a
    175 176 
     withBkpSession cid insts deps session_type do_this = do
    176 177 
         dflags <- getDynFlags
    178 
    +    env <- getSession
    179 
    +    unitIndex <- liftIO $ hscUnitIndex env
    177 180 
         let cid_fs = unitFS cid
    178 181 
             is_primary = False
    179 182 
             uid_str = unpackFS (mkInstantiatedUnitHash cid insts)
    ... ... @@ -193,8 +196,8 @@ withBkpSession cid insts deps session_type do_this = do
    193 196 
                      | otherwise = sub_comp (key_base p)
    194 197
    195 198 
             mk_temp_env hsc_env =
    196 
    -          hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env
    197 
    -        mk_temp_dflags unit_state dflags = dflags
    199 
    +          hscUpdateFlags (\dflags -> mk_temp_dflags unitIndex (hsc_units hsc_env) dflags) hsc_env
    200 
    +        mk_temp_dflags unit_index unit_state dflags = dflags
    198 201 
                 { backend = case session_type of
    199 202 
                                 TcSession -> noBackend
    200 203 
                                 _         -> backend dflags
    ... ... @@ -241,7 +244,7 @@ withBkpSession cid insts deps session_type do_this = do
    241 244 
                 , importPaths = []
    242 245 
                 -- Synthesize the flags
    243 246 
                 , packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
    244 
    -              let uid = unwireUnit unit_state
    247 
    +              let uid = unwireUnit unit_index
    245 248 
                             $ renameHoleUnit unit_state (listToUFM insts) uid0
    246 249 
                   in ExposePackage
    247 250 
                     (showSDoc dflags
    ... ... @@ -348,9 +351,9 @@ buildUnit session cid insts lunit = do
    348 351 
                   | otherwise
    349 352 
                   = [Nothing]
    350 353 
             linkables <- liftIO $ catMaybes <$> concatHpt takeLinkables (hsc_HPT hsc_env)
    354 
    +        unit_index <- liftIO $ hscUnitIndex hsc_env
    351 355 
             let
    352 356 
                 obj_files = concatMap linkableFiles linkables
    353 
    -            state     = hsc_units hsc_env
    354 357
    355 358 
                 compat_fs = unitIdFS cid
    356 359 
                 compat_pn = PackageName compat_fs
    ... ... @@ -376,7 +379,7 @@ buildUnit session cid insts lunit = do
    376 379 
                             -- really used for anything, so we leave it
    377 380 
                             -- blank for now.
    378 381 
                             TcSession -> []
    379 
    -                        _ -> map (toUnitId . unwireUnit state)
    382 
    +                        _ -> map (toUnitId . unwireUnit unit_index)
    380 383 
                                     $ deps ++ [ moduleUnit mod
    381 384 
                                               | (_, mod) <- insts
    382 385 
                                               , not (isHoleModule mod) ],
    ... ... @@ -435,18 +438,24 @@ addUnit u = do
    435 438 
         logger <- getLogger
    436 439 
         let dflags0 = hsc_dflags hsc_env
    437 440 
         let old_unit_env = hsc_unit_env hsc_env
    438 
    -    newdbs <- case ue_unit_dbs old_unit_env of
    439 
    -        Nothing  -> panic "addUnit: called too early"
    440 
    -        Just dbs ->
    441 
    -         let newdb = UnitDatabase
    442 
    -               { unitDatabasePath  = unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
    443 
    -               , unitDatabaseUnits = [u]
    444 
    -               }
    445 
    -         in return (dbs ++ [newdb]) -- added at the end because ordering matters
    446 
    -    (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
    441 
    +
    442 
    +    -- TODO @fendor: provide an API to programmatically add an in-memory DB
    443 
    +    let newdb = UnitDatabase
    444 
    +          { unitDatabasePath  = unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
    445 
    +          , unitDatabaseUnits = [u]
    446 
    +          }
    447 
    +    let eud = hscEUDC hsc_env
    448 
    +    liftIO $ cacheExternalUnitDatabase eud newdb
    449 
    +    -- added at the end because ordering matters
    450 
    +    let dflags1 = dflags0
    451 
    +          { packageDBFlags = packageDBFlags dflags0 ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))]
    452 
    +          }
    453 
    +
    454 
    +    (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_unit_index old_unit_env) eud (hsc_all_home_unit_ids hsc_env)
    455 
    +
    447 456
    448 457 
         -- update platform constants
    449 
    -    dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
    458 
    +    dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
    450 459
    451 460 
         let unit_env = UnitEnv
    452 461 
               { ue_platform  = targetPlatform dflags
    ... ... @@ -456,9 +465,11 @@ addUnit u = do
    456 465 
               , ue_home_unit_graph =
    457 466 
                     HUG.unitEnv_singleton
    458 467 
                         (homeUnitId home_unit)
    459 
    -                    (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit))
    468 
    +                    (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) (Just home_unit))
    460 469 
               , ue_eps       = ue_eps old_unit_env
    461 470 
               , ue_module_graph = ue_module_graph old_unit_env
    471 
    +          , ue_eud       = ue_eud old_unit_env
    472 
    +          , ue_unit_index = ue_unit_index old_unit_env
    462 473 
               }
    463 474 
         setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
    464 475

  • compiler/GHC/Driver/Env.hs
    ... ... @@ -13,6 +13,8 @@ module GHC.Driver.Env
    13 13 
        , hsc_HUE
    14 14 
        , hsc_HUG
    15 15 
        , hsc_all_home_unit_ids
    16 
    +   , hscUnitIndex
    17 
    +   , hsc_unit_index
    16 18 
        , hscUpdateLoggerFlags
    17 19 
        , hscUpdateHUG
    18 20 
        , hscInsertHPT
    ... ... @@ -24,6 +26,8 @@ module GHC.Driver.Env
    24 26 
        , mkInteractiveHscEnv
    25 27 
        , runInteractiveHsc
    26 28 
        , hscEPS
    29 
    +   , hscEUD
    30 
    +   , hscEUDC
    27 31 
        , hscInterp
    28 32 
        , prepareAnnotations
    29 33 
        , discardIC
    ... ... @@ -89,6 +93,7 @@ import GHC.Builtin.Names
    89 93
    90 94 
     import Data.IORef
    91 95 
     import qualified Data.Set as Set
    96 
    +import GHC.Unit.External.Database (ExternalUnitDatabaseCache, readExternalUnitDatabases, ExternalUnitDatabases)
    92 97
    93 98 
     runHsc :: HscEnv -> Hsc a -> IO a
    94 99 
     runHsc hsc_env hsc = do
    ... ... @@ -221,6 +226,18 @@ configured via command-line flags (in `GHC.setTopSessionDynFlags`).
    221 226 
     hscEPS :: HscEnv -> IO ExternalPackageState
    222 227 
     hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env)))
    223 228
    229 
    +hscEUD :: HscEnv -> IO (ExternalUnitDatabases UnitId)
    230 
    +hscEUD = readExternalUnitDatabases . hscEUDC
    231 
    +
    232 
    +hscEUDC :: HscEnv -> ExternalUnitDatabaseCache UnitId
    233 
    +hscEUDC hsc_env = ue_eud (hsc_unit_env hsc_env)
    234 
    +
    235 
    +hscUnitIndex :: HscEnv -> IO UnitIndex
    236 
    +hscUnitIndex hsc_env = readIORef $ ue_unit_index (hsc_unit_env hsc_env)
    237 
    +
    238 
    +hsc_unit_index :: HscEnv -> IORef UnitIndex
    239 
    +hsc_unit_index hsc_env = ue_unit_index (hsc_unit_env hsc_env)
    240 
    +
    224 241 
     --------------------------------------------------------------------------------
    225 242 
     -- * Queries on Transitive Closure
    226 243 
     --------------------------------------------------------------------------------

  • compiler/GHC/Driver/Main/Hsc.hs
    ... ... @@ -110,7 +110,7 @@ newHscEnv top_dir dflags = do
    110 110 
       where
    111 111 
         home_unit_graph hpt = HUG.unitEnv_singleton
    112 112 
                             (homeUnitId_ dflags)
    113 
    -                        (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt Nothing)
    113 
    +                        (HUG.mkHomeUnitEnv emptyUnitState dflags hpt Nothing)
    114 114
    115 115 
     newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
    116 116 
     newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do

  • compiler/GHC/Driver/Main/Interactive.hs
    ... ... @@ -275,7 +275,7 @@ hscCheckSafe' m l = do
    275 275 
                 Sf_Safe | not trust_own_pkg         -> True
    276 276 
                 Sf_SafeInferred | not trust_own_pkg -> True
    277 277 
                 _ | isHomeModule home_unit mod      -> True
    278 
    -            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)
    278 
    +            _ -> isUnitTrusted unit_state (moduleUnit m)
    279 279
    280 280 
         lookup' :: Module -> Hsc (Maybe ModIface)
    281 281 
         lookup' m = do
    ... ... @@ -297,7 +297,7 @@ checkPkgTrust pkgs = do
    297 297 
             errors = S.foldr go emptyBag pkgs
    298 298 
             state  = hsc_units hsc_env
    299 299 
             go pkg acc
    300 
    -            | unitIsTrusted $ unsafeLookupUnitId state pkg
    300 
    +            | isUnitIdTrusted state pkg
    301 301 
                 = acc
    302 302 
                 | otherwise
    303 303 
                 = (`consBag` acc)

  • compiler/GHC/Driver/Main/Passes.hs
    ... ... @@ -1328,7 +1328,7 @@ hscCheckSafe' m l = do
    1328 1328 
                 Sf_Safe | not trust_own_pkg         -> True
    1329 1329 
                 Sf_SafeInferred | not trust_own_pkg -> True
    1330 1330 
                 _ | isHomeModule home_unit mod      -> True
    1331 
    -            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)
    1331 
    +            _ -> isUnitTrusted unit_state (moduleUnit m)
    1332 1332
    1333 1333 
         lookup' :: Module -> Hsc (Maybe ModIface)
    1334 1334 
         lookup' m = do
    ... ... @@ -1350,7 +1350,7 @@ checkPkgTrust pkgs = do
    1350 1350 
             errors = S.foldr go emptyBag pkgs
    1351 1351 
             state  = hsc_units hsc_env
    1352 1352 
             go pkg acc
    1353 
    -            | unitIsTrusted $ unsafeLookupUnitId state pkg
    1353 
    +            | isUnitIdTrusted state pkg
    1354 1354 
                 = acc
    1355 1355 
                 | otherwise
    1356 1356 
                 = (`consBag` acc)

  • compiler/GHC/Driver/Session/Units.hs
    ... ... @@ -129,16 +129,14 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do
    129 129 
       let home_units = HUG.allUnits initial_home_graph
    130 130
    131 131 
       home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
    132 
    -    let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
    133 
    -        hue_flags = homeUnitEnv_dflags homeUnitEnv
    132 
    +    let hue_flags = homeUnitEnv_dflags homeUnitEnv
    134 133 
             dflags = homeUnitEnv_dflags homeUnitEnv
    135 
    -    (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
    134 
    +    (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hsc_unit_index hsc_env) (hscEUDC hsc_env) home_units
    136 135
    137 136 
         updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
    138 137 
         emptyHpt <- liftIO $ emptyHomePackageTable
    139 138 
         pure $ HomeUnitEnv
    140 139 
           { homeUnitEnv_units = unit_state
    141 
    -      , homeUnitEnv_unit_dbs = Just dbs
    142 140 
           , homeUnitEnv_dflags = updated_dflags
    143 141 
           , homeUnitEnv_hpt = emptyHpt
    144 142 
           , homeUnitEnv_home_unit = Just home_unit
    ... ... @@ -239,7 +237,7 @@ createUnitEnvFromFlags unitDflags = do
    239 237 
       unitEnvList <- forM unitDflags $ \dflags -> do
    240 238 
         emptyHpt <- emptyHomePackageTable
    241 239 
         let newInternalUnitEnv =
    242 
    -          HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing
    240 
    +          HUG.mkHomeUnitEnv emptyUnitState dflags emptyHpt Nothing
    243 241 
         return (homeUnitId_ dflags, newInternalUnitEnv)
    244 242 
       let activeUnit = fst $ NE.head unitEnvList
    245 243 
       return (HUG.hugFromList (NE.toList unitEnvList), activeUnit)

  • compiler/GHC/Unit/Env.hs
    ... ... @@ -80,7 +80,6 @@ module GHC.Unit.Env
    80 80
    81 81 
         -- ** Queries on the current active home unit
    82 82 
         , ue_homeUnitState
    83 
    -    , ue_unit_dbs
    84 83 
         , ue_homeUnit
    85 84 
         , ue_unitFlags
    86 85
    ... ... @@ -110,6 +109,7 @@ import GHC.Prelude
    110 109 
     import qualified Data.Set as Set
    111 110
    112 111 
     import GHC.Unit.External
    112 
    +import GHC.Unit.External.Database
    113 113 
     import GHC.Unit.State
    114 114 
     import GHC.Unit.Home
    115 115 
     import GHC.Unit.Types
    ... ... @@ -131,6 +131,7 @@ import GHC.Types.Annotations
    131 131 
     import GHC.Types.CompleteMatch
    132 132 
     import GHC.Core.InstEnv
    133 133 
     import GHC.Core.FamInstEnv
    134 
    +import Data.IORef
    134 135
    135 136 
     --------------------------------------------------------------------------------
    136 137 
     -- The hard queries
    ... ... @@ -174,6 +175,11 @@ data UnitEnv = UnitEnv
    174 175
    175 176 
         , ue_namever   :: !GhcNameVersion
    176 177 
             -- ^ GHC name/version (used for dynamic library suffix)
    178 
    +
    179 
    +    , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId)
    180 
    +        -- TODO: @fendor Docs
    181 
    +    , ue_unit_index :: {-# UNPACK #-} !(IORef UnitIndex)
    182 
    +        -- TODO: @fendor Docs
    177 183 
         }
    178 184
    179 185 
     ueEPS :: UnitEnv -> IO ExternalPackageState
    ... ... @@ -182,6 +188,8 @@ ueEPS = eucEPS . ue_eps
    182 188 
     initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
    183 189 
     initUnitEnv cur_unit hug namever platform = do
    184 190 
       eps <- initExternalUnitCache
    191 
    +  eud <- initExternalUnitDatabaseCache
    192 
    +  unit_index <- newIORef (initUnitIndex)
    185 193 
       return $ UnitEnv
    186 194 
         { ue_eps             = eps
    187 195 
         , ue_home_unit_graph = hug
    ... ... @@ -189,6 +197,8 @@ initUnitEnv cur_unit hug namever platform = do
    189 197 
         , ue_current_unit    = cur_unit
    190 198 
         , ue_platform        = platform
    191 199 
         , ue_namever         = namever
    200 
    +    , ue_eud             = eud
    201 
    +    , ue_unit_index      = unit_index
    192 202 
         }
    193 203
    194 204 
     updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv
    ... ... @@ -258,9 +268,6 @@ ue_findHomeUnitEnv uid e = case HUG.lookupHugUnitId uid (ue_home_unit_graph e) o
    258 268 
     ue_homeUnitState :: HasDebugCallStack => UnitEnv -> UnitState
    259 269 
     ue_homeUnitState = HUG.homeUnitEnv_units . ue_currentHomeUnitEnv
    260 270
    261 
    -ue_unit_dbs :: UnitEnv ->  Maybe [UnitDatabase UnitId]
    262 
    -ue_unit_dbs = HUG.homeUnitEnv_unit_dbs . ue_currentHomeUnitEnv
    263 
    -
    264 271 
     -- -------------------------------------------------------
    265 272 
     -- Query and modify Home Package Table in HomeUnitEnv
    266 273 
     -- -------------------------------------------------------

  • compiler/GHC/Unit/External/Database.hs
    1 
    +module GHC.Unit.External.Database (
    2 
    +  -- *
    3 
    +  ExternalUnitDatabaseCache (..),
    4 
    +  initExternalUnitDatabaseCache,
    5 
    +  readExternalUnitDatabases,
    6 
    +  readExternalUnitDatabase,
    7 
    +  cacheExternalUnitDatabase,
    8 
    +  clearExternalUnitDatabaseCache,
    9 
    +  -- *
    10 
    +  ExternalUnitDatabases,
    11 
    +  emptyExternalUnitDatabases,
    12 
    +  insertExternalUnitDatabases,
    13 
    +  deleteExternalUnitDatabases,
    14 
    +  lookupExternalUnitDatabases,
    15 
    +  -- *
    16 
    +  UnitDatabase (..),
    17 
    +) where
    18 
    +
    19 
    +import GHC.Prelude
    20 
    +
    21 
    +import GHC.Data.OsPath
    22 
    +import GHC.Unit.Info
    23 
    +import GHC.Utils.Outputable
    24 
    +
    25 
    +import Data.IORef (IORef)
    26 
    +import Data.IORef qualified as IORef
    27 
    +import Data.Map.Strict
    28 
    +import Data.Map.Strict qualified as Map
    29 
    +
    30 
    +-- ----------------------------------------------------------------------------
    31 
    +-- ExternalUnitDatabaseCache
    32 
    +-- ----------------------------------------------------------------------------
    33 
    +
    34 
    +newtype ExternalUnitDatabaseCache unit = ExternalUnitDatabaseCache
    35 
    +  { eudc_databases :: IORef (ExternalUnitDatabases unit)
    36 
    +  }
    37 
    +
    38 
    +initExternalUnitDatabaseCache :: IO (ExternalUnitDatabaseCache unit)
    39 
    +initExternalUnitDatabaseCache =
    40 
    +  ExternalUnitDatabaseCache <$> IORef.newIORef emptyExternalUnitDatabases
    41 
    +
    42 
    +readExternalUnitDatabases :: ExternalUnitDatabaseCache unit -> IO (ExternalUnitDatabases unit)
    43 
    +readExternalUnitDatabases eudc =
    44 
    +  IORef.readIORef (eudc_databases eudc)
    45 
    +
    46 
    +modifyExternalUnitDatabaseCache :: ExternalUnitDatabaseCache unit -> (ExternalUnitDatabases unit -> ExternalUnitDatabases unit) -> IO ()
    47 
    +modifyExternalUnitDatabaseCache eudc f =
    48 
    +  IORef.modifyIORef' (eudc_databases eudc) f
    49 
    +
    50 
    +readExternalUnitDatabase :: ExternalUnitDatabaseCache unit -> OsPath -> IO (Maybe (UnitDatabase unit))
    51 
    +readExternalUnitDatabase eudc path = do
    52 
    +  dbs <- readExternalUnitDatabases eudc
    53 
    +  pure $ lookupExternalUnitDatabases path dbs
    54 
    +
    55 
    +cacheExternalUnitDatabase :: ExternalUnitDatabaseCache unit -> UnitDatabase unit -> IO ()
    56 
    +cacheExternalUnitDatabase eudc db =
    57 
    +  modifyExternalUnitDatabaseCache eudc (insertExternalUnitDatabases db)
    58 
    +
    59 
    +clearExternalUnitDatabaseCache :: ExternalUnitDatabaseCache unit -> IO ()
    60 
    +clearExternalUnitDatabaseCache eudc =
    61 
    +  modifyExternalUnitDatabaseCache eudc (const emptyExternalUnitDatabases)
    62 
    +
    63 
    +-- ----------------------------------------------------------------------------
    64 
    +-- ExternalUnitDatabases
    65 
    +-- ----------------------------------------------------------------------------
    66 
    +
    67 
    +data ExternalUnitDatabases unit = ExternalUnitDatabases
    68 
    +  { eud_cachedDatabases :: !(Map OsPath (UnitDatabase unit))
    69 
    +  }
    70 
    +
    71 
    +emptyExternalUnitDatabases :: ExternalUnitDatabases unit
    72 
    +emptyExternalUnitDatabases =
    73 
    +  ExternalUnitDatabases
    74 
    +    { eud_cachedDatabases = Map.empty
    75 
    +    }
    76 
    +
    77 
    +insertExternalUnitDatabases :: UnitDatabase unit -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit
    78 
    +insertExternalUnitDatabases unit_db eud =
    79 
    +  ExternalUnitDatabases
    80 
    +    { eud_cachedDatabases = Map.insert (unitDatabasePath unit_db) unit_db (eud_cachedDatabases eud)
    81 
    +    }
    82 
    +
    83 
    +deleteExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit
    84 
    +deleteExternalUnitDatabases unit_db_path eud =
    85 
    +  ExternalUnitDatabases
    86 
    +    { eud_cachedDatabases = Map.delete unit_db_path (eud_cachedDatabases eud)
    87 
    +    }
    88 
    +
    89 
    +lookupExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> Maybe (UnitDatabase unit)
    90 
    +lookupExternalUnitDatabases key eud =
    91 
    +  Map.lookup key (eud_cachedDatabases eud)
    92 
    +
    93 
    +-- ----------------------------------------------------------------------------
    94 
    +-- UnitDatabase
    95 
    +-- ----------------------------------------------------------------------------
    96 
    +
    97 
    +-- | Unit database
    98 
    +data UnitDatabase unit = UnitDatabase
    99 
    +  { unitDatabasePath :: OsPath
    100 
    +  , unitDatabaseUnits :: [GenUnitInfo unit]
    101 
    +  }
    102 
    +
    103 
    +instance (Outputable u) => Outputable (UnitDatabase u) where
    104 
    +  ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp

  • compiler/GHC/Unit/Home/Graph.hs
    ... ... @@ -128,16 +128,6 @@ data HomeUnitEnv = HomeUnitEnv
    128 128 
       { homeUnitEnv_units     :: !UnitState
    129 129 
           -- ^ External units
    130 130
    131 
    -  , homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId])
    132 
    -      -- ^ Stack of unit databases for the target platform.
    133 
    -      --
    134 
    -      -- This field is populated with the result of `initUnits`.
    135 
    -      --
    136 
    -      -- 'Nothing' means the databases have never been read from disk.
    137 
    -      --
    138 
    -      -- Usually we don't reload the databases from disk if they are
    139 
    -      -- cached, even if the database flags changed!
    140 
    -
    141 131 
       , homeUnitEnv_dflags :: DynFlags
    142 132 
         -- ^ The dynamic flag settings
    143 133 
       , homeUnitEnv_hpt :: HomePackageTable
    ... ... @@ -164,10 +154,9 @@ data HomeUnitEnv = HomeUnitEnv
    164 154 
         -- ^ Home-unit
    165 155 
       }
    166 156
    167 
    -mkHomeUnitEnv :: UnitState -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
    168 
    -mkHomeUnitEnv us dbs dflags hpt home_unit = HomeUnitEnv
    157 
    +mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
    158 
    +mkHomeUnitEnv us dflags hpt home_unit = HomeUnitEnv
    169 159 
       { homeUnitEnv_units = us
    170 
    -  , homeUnitEnv_unit_dbs = dbs
    171 160 
       , homeUnitEnv_dflags = dflags
    172 161 
       , homeUnitEnv_hpt = hpt
    173 162 
       , homeUnitEnv_home_unit = home_unit

  • compiler/GHC/Unit/State.hs
    ... ... @@ -5,12 +5,20 @@
    5 5 
     module GHC.Unit.State (
    6 6 
             module GHC.Unit.Info,
    7 7
    8 
    +        UnitIndex(..),
    9 
    +        initUnitIndex,
    10 
    +        setWireMap,
    11 
    +        isWireMapEmpty,
    12 
    +        addUnitInfoMap,
    13 
    +        -- lookupUnitInfoMap,
    14 
    +
    8 15 
             -- * Reading the package config, and processing cmdline args
    9 16 
             UnitState(..),
    10 17 
             UnitDatabase (..),
    11 18 
             UnitErr (..),
    12 19 
             emptyUnitState,
    13 20 
             initUnits,
    21 
    +        readOrGetUnitDatabase,
    14 22 
             readUnitDatabases,
    15 23 
             readUnitDatabase,
    16 24 
             getUnitDbRefs,
    ... ... @@ -25,6 +33,9 @@ module GHC.Unit.State (
    25 33 
             lookupUnitId,
    26 34 
             lookupUnitId',
    27 35 
             unsafeLookupUnitId,
    36 
    +        isUnitTrusted,
    37 
    +        isUnitIdTrusted,
    38 
    +        isUnitInfoTrusted,
    28 39
    29 40 
             lookupPackageName,
    30 41 
             resolvePackageImport,
    ... ... @@ -118,6 +129,9 @@ import Data.Monoid (First(..))
    118 129 
     import qualified Data.Semigroup as Semigroup
    119 130 
     import qualified Data.Set as Set
    120 131 
     import Control.Applicative
    132 
    +import GHC.Unit.External.Database
    133 
    +import Data.IORef
    134 
    +import Data.Either (partitionEithers)
    121 135
    122 136 
     -- ---------------------------------------------------------------------------
    123 137 
     -- The Unit state
    ... ... @@ -342,7 +356,7 @@ data UnitConfig = UnitConfig
    342 356 
        , unitConfigHideAll        :: !Bool     -- ^ Hide all units by default
    343 357 
        , unitConfigHideAllPlugins :: !Bool     -- ^ Hide all plugins units by default
    344 358
    345 
    -   , unitConfigDBCache      :: Maybe [UnitDatabase UnitId]
    359 
    +   , unitConfigDBCache      :: !(ExternalUnitDatabaseCache UnitId)
    346 360 
           -- ^ Cache of databases to use, in the order they were specified on the
    347 361 
           -- command line (later databases shadow earlier ones).
    348 362 
           -- If Nothing, databases will be found using `unitConfigFlagsDB`.
    ... ... @@ -356,7 +370,7 @@ data UnitConfig = UnitConfig
    356 370 
        , unitConfigHomeUnits    :: Set.Set UnitId
    357 371 
        }
    358 372
    359 
    -initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig
    373 
    +initUnitConfig :: DynFlags -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> UnitConfig
    360 374 
     initUnitConfig dflags cached_dbs home_units =
    361 375 
        let !hu_id             = homeUnitId_ dflags
    362 376 
            !hu_instanceof     = homeUnitInstanceOf_ dflags
    ... ... @@ -419,25 +433,73 @@ initUnitConfig dflags cached_dbs home_units =
    419 433 
     type ModuleNameProvidersMap =
    420 434 
         UniqMap ModuleName (UniqMap Module ModuleOrigin)
    421 435
    436 
    +data GlobalUnitKey =
    437 
    +  GlobalUnitKey
    438 
    +    UnitId -- ^ Unit Id of the 'UnitInfo'
    439 
    +    ST.ShortText
    440 
    +
    441 
    +data UnitIndex = UnitIndex
    442 
    +  { ui_wireMap :: WiringMap
    443 
    +  -- ^ TODO @fendor: document global property
    444 
    +  , ui_unwireMap :: UnwiringMap
    445 
    +  -- ^ TODO @fendor: document global property
    446 
    +  , ui_unitInfoMap :: UnitInfoMap
    447 
    +  -- ^ TODO @fendor: This needs to be Map (UnitId, AbiHash) UnitInfo for absolut correctness
    448 
    +  }
    449 
    +
    450 
    +initUnitIndex :: UnitIndex
    451 
    +initUnitIndex = UnitIndex
    452 
    +  { ui_wireMap = emptyUniqMap
    453 
    +  , ui_unwireMap = emptyUniqMap
    454 
    +  , ui_unitInfoMap = emptyUniqMap
    455 
    +  }
    456 
    +
    457 
    +setWireMap :: WiringMap -> UnitIndex -> UnitIndex
    458 
    +setWireMap wired_map unit_index =
    459 
    +  unit_index
    460 
    +    { ui_wireMap = wired_map
    461 
    +    , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
    462 
    +    }
    463 
    +
    464 
    +isWireMapEmpty :: UnitIndex -> Bool
    465 
    +isWireMapEmpty unit_index =
    466 
    +  isNullUniqMap (ui_wireMap unit_index)
    467 
    +
    468 
    +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex
    469 
    +addUnitInfoMap unit_info_map unit_index =
    470 
    +  unit_index
    471 
    +    { ui_unitInfoMap = unit_info_map `plusUniqMap` ui_unitInfoMap unit_index
    472 
    +    }
    473 
    +
    474 
    +-- lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo
    475 
    +-- lookupUnitInfoMap unit_index unit_id =
    476 
    +--   lookupUniqMap (ui_unitInfoMap unit_index) unit_id
    477 
    +
    422 478 
     data UnitState = UnitState {
    423 479 
       -- | A mapping of 'Unit' to 'UnitInfo'.  This list is adjusted
    424 480 
       -- so that only valid units are here.  'UnitInfo' reflects
    425 481 
       -- what was stored *on disk*, except for the 'trusted' flag, which
    426 482 
       -- is adjusted at runtime.  (In particular, some units in this map
    427 483 
       -- may have the 'exposed' flag be 'False'.)
    484 
    +  --
    485 
    +  -- TODO @fendor: All values are shared with 'UnitIndex.ui_unitInfoMap'.
    428 486 
       unitInfoMap :: UnitInfoMap,
    429 487
    488 
    +  -- | Local overlay for the unit info so that sharing is more accurate
    489 
    +  trustedUnits :: Set.Set UnitId, -- TODO @fendor: UniqSet
    490 
    +  distrustedUnits :: Set.Set UnitId, -- TODO @fendor: UniqSet
    491 
    +
    430 492 
       -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same
    431 493 
       -- package name (e.g. different instantiations), then we return one of them...
    432 494 
       -- This is used when users refer to packages in Backpack includes.
    433 495 
       -- And also to resolve package qualifiers with the PackageImports extension.
    434 496 
       packageNameMap            :: UniqFM PackageName UnitId,
    435 497
    436 
    -  -- | A mapping from database unit keys to wired in unit ids.
    437 
    -  wireMap :: UniqMap UnitId UnitId,
    498 
    +  -- -- | A mapping from database unit keys to wired in unit ids.
    499 
    +  -- wireMap :: WiringMap,
    438 500
    439 
    -  -- | A mapping from wired in unit ids to unit keys from the database.
    440 
    -  unwireMap :: UniqMap UnitId UnitId,
    501 
    +  -- -- | A mapping from wired in unit ids to unit keys from the database.
    502 
    +  -- unwireMap :: UnwiringMap,
    441 503
    442 504 
       -- | The units we're going to link in eagerly.  This list
    443 505 
       -- should be in reverse dependency order; that is, a unit
    ... ... @@ -479,9 +541,11 @@ data UnitState = UnitState {
    479 541 
     emptyUnitState :: UnitState
    480 542 
     emptyUnitState = UnitState {
    481 543 
         unitInfoMap    = emptyUniqMap,
    544 
    +    trustedUnits   = Set.empty,
    545 
    +    distrustedUnits = Set.empty,
    482 546 
         packageNameMap = emptyUFM,
    483 
    -    wireMap        = emptyUniqMap,
    484 
    -    unwireMap      = emptyUniqMap,
    547 
    +    -- wireMap        = emptyUniqMap,
    548 
    +    -- unwireMap      = emptyUniqMap,
    485 549 
         preloadUnits   = [],
    486 550 
         explicitUnits  = [],
    487 551 
         homeUnitDepends = Set.empty,
    ... ... @@ -491,15 +555,6 @@ emptyUnitState = UnitState {
    491 555 
         allowVirtualUnits = False
    492 556 
         }
    493 557
    494 
    --- | Unit database
    495 
    -data UnitDatabase unit = UnitDatabase
    496 
    -   { unitDatabasePath  :: OsPath
    497 
    -   , unitDatabaseUnits :: [GenUnitInfo unit]
    498 
    -   }
    499 
    -
    500 
    -instance Outputable u => Outputable (UnitDatabase u) where
    501 
    -  ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp
    502 
    -
    503 558 
     type UnitInfoMap = UniqMap UnitId UnitInfo
    504 559
    505 560 
     -- | Find the unit we know about with the given unit, if any
    ... ... @@ -618,6 +673,21 @@ mkUnitInfoMap infos = foldl' add emptyUniqMap infos
    618 673 
     listUnitInfo :: UnitState -> [UnitInfo]
    619 674 
     listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
    620 675
    676 
    +isUnitTrusted :: HasDebugCallStack => UnitState -> Unit -> Bool
    677 
    +isUnitTrusted ue u =
    678 
    +     Set.member (toUnitId u) (trustedUnits ue) && (Set.notMember (toUnitId u) (distrustedUnits ue))
    679 
    +  || unitIsTrusted (unsafeLookupUnit ue u)
    680 
    +
    681 
    +isUnitIdTrusted :: HasDebugCallStack => UnitState -> UnitId -> Bool
    682 
    +isUnitIdTrusted ue u =
    683 
    +     Set.member u (trustedUnits ue) && (Set.notMember u (distrustedUnits ue))
    684 
    +  || unitIsTrusted (unsafeLookupUnitId ue u)
    685 
    +
    686 
    +isUnitInfoTrusted :: HasDebugCallStack => UnitState -> UnitInfo -> Bool
    687 
    +isUnitInfoTrusted ue unit_info =
    688 
    +     Set.member (unitId unit_info) (trustedUnits ue) && (Set.notMember (unitId unit_info) (distrustedUnits ue))
    689 
    +  || unitIsTrusted unit_info
    690 
    +
    621 691 
     -- ----------------------------------------------------------------------------
    622 692 
     -- Loading the unit db files and building up the unit state
    623 693
    ... ... @@ -628,20 +698,22 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
    628 698 
     -- 'initUnits' can be called again subsequently after updating the
    629 699 
     -- 'packageFlags' field of the 'DynFlags', and it will update the
    630 700 
     -- 'unitState' in 'DynFlags'.
    631 
    -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
    632 
    -initUnits logger dflags cached_dbs home_units = do
    701 
    +initUnits :: Logger -> DynFlags -> IORef UnitIndex -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants)
    702 
    +initUnits logger dflags unit_index cached_dbs home_units = do
    633 703
    634 
    -  let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
    704 
    +  let forceUnitInfoMap state = unitInfoMap state `seq` ()
    635 705
    636 
    -  (unit_state,dbs) <- withTiming logger (text "initializing unit database")
    706 
    +  unit_state <- withTiming logger (text "initializing unit database")
    637 707 
                        forceUnitInfoMap
    638 
    -                 $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
    708 
    +                 $ mkUnitState logger unit_index (initUnitConfig dflags cached_dbs home_units)
    639 709
    640 710 
       putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
    641 711 
         FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
    642 712 
                     $ pprModuleMap (moduleNameProvidersMap unit_state))
    643 713
    644 
    -  let home_unit = mkHomeUnit unit_state
    714 
    +  wireMap <- ui_wireMap <$> readIORef unit_index
    715 
    +
    716 
    +  let home_unit = mkHomeUnit wireMap
    645 717 
                                  (homeUnitId_ dflags)
    646 718 
                                  (homeUnitInstanceOf_ dflags)
    647 719 
                                  (homeUnitInstantiations_ dflags)
    ... ... @@ -663,19 +735,18 @@ initUnits logger dflags cached_dbs home_units = do
    663 735 
             Nothing   -> return Nothing
    664 736 
             Just info -> lookupPlatformConstants (fmap ST.unpack (unitIncludeDirs info))
    665 737
    666 
    -  return (dbs,unit_state,home_unit,mconstants)
    738 
    +  return (unit_state,home_unit,mconstants)
    667 739
    668 740 
     mkHomeUnit
    669 
    -    :: UnitState
    741 
    +    :: WiringMap
    670 742 
         -> UnitId                 -- ^ Home unit id
    671 743 
         -> Maybe UnitId           -- ^ Home unit instance of
    672 744 
         -> [(ModuleName, Module)] -- ^ Home unit instantiations
    673 745 
         -> HomeUnit
    674 
    -mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ =
    746 
    +mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ =
    675 747 
         let
    676 748 
             -- Some wired units can be used to instantiate the home unit. We need to
    677 749 
             -- replace their unit keys with their wired unit ids.
    678 
    -        wmap              = wireMap unit_state
    679 750 
             hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_
    680 751 
         in case (hu_instanceof, hu_instantiations) of
    681 752 
           (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing
    ... ... @@ -700,7 +771,7 @@ readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
    700 771 
     readUnitDatabases logger cfg = do
    701 772 
       conf_refs <- getUnitDbRefs cfg
    702 773 
       confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
    703 
    -  mapM (readUnitDatabase logger cfg) confs
    774 
    +  mapM (readOrGetUnitDatabase logger cfg) confs
    704 775
    705 776
    706 777 
     getUnitDbRefs :: UnitConfig -> IO [PkgDbRef]
    ... ... @@ -752,6 +823,18 @@ resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
    752 823 
       if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
    753 824 
     resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
    754 825
    826 
    +-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.
    827 
    +readOrGetUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId)
    828 
    +readOrGetUnitDatabase logger cfg conf_file =
    829 
    +  readExternalUnitDatabase (unitConfigDBCache cfg) conf_file >>= \ case
    830 
    +    Nothing -> do
    831 
    +      new_db <- readUnitDatabase logger cfg conf_file
    832 
    +      cacheExternalUnitDatabase (unitConfigDBCache cfg) new_db
    833 
    +      pure new_db
    834 
    +    Just db ->
    835 
    +      pure db
    836 
    +
    837 
    +-- | Read the 'UnitDatabase' at the given location.
    755 838 
     readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId)
    756 839 
     readUnitDatabase logger cfg conf_file = do
    757 840 
       isdir <- OsPath.doesDirectoryExist conf_file
    ... ... @@ -782,7 +865,8 @@ readUnitDatabase logger cfg conf_file = do
    782 865 
           pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
    783 866 
                              proto_pkg_configs
    784 867 
       --
    785 
    -  return $ UnitDatabase conf_file' pkg_configs1
    868 
    +  pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1
    869 
    +  return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2
    786 870 
       where
    787 871 
         readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
    788 872 
         readDirStyleUnitInfo conf_dir = do
    ... ... @@ -834,11 +918,6 @@ readUnitDatabase logger cfg conf_file = do
    834 918 
                  else return (Just []) -- ghc-pkg will create it when it's updated
    835 919 
             else return Nothing
    836 920
    837 
    -distrustAllUnits :: [UnitInfo] -> [UnitInfo]
    838 
    -distrustAllUnits pkgs = map distrust pkgs
    839 
    -  where
    840 
    -    distrust pkg = pkg{ unitIsTrusted = False }
    841 
    -
    842 921 
     mungeUnitInfo :: OsPath -> OsPath
    843 922 
                        -> UnitInfo -> UnitInfo
    844 923 
     mungeUnitInfo top_dir pkgroot =
    ... ... @@ -866,6 +945,29 @@ mungeBytecodeLibFields pkg =
    866 945 
              ds -> ds
    867 946 
         }
    868 947
    948 
    +evaluateUnitInfo :: UnitInfo -> IO UnitInfo
    949 
    +evaluateUnitInfo ui = do
    950 
    +  importDirs <- evaluate $ unitImportDirs ui
    951 
    +  includeDirs <- evaluate $ unitIncludeDirs ui
    952 
    +  libraryDirs <- evaluate $ unitLibraryDirs ui
    953 
    +  libraryBytecodeDirs <- evaluate $ unitLibraryBytecodeDirs ui
    954 
    +  extDepFrameworkDirs <- evaluate $ unitExtDepFrameworkDirs ui
    955 
    +  haddockInterfaces <- evaluate $ unitHaddockInterfaces ui
    956 
    +  haddockHTMLs <- evaluate $ unitHaddockHTMLs ui
    957 
    +  libraryDynDirs <- evaluate $ unitLibraryDynDirs ui
    958 
    +  libraryDirsStatic <- evaluate $ unitLibraryDirsStatic ui
    959 
    +  evaluate ui
    960 
    +    { unitImportDirs = importDirs
    961 
    +    , unitIncludeDirs = includeDirs
    962 
    +    , unitLibraryDirs = libraryDirs
    963 
    +    , unitLibraryDynDirs = libraryDynDirs
    964 
    +    , unitLibraryDirsStatic = libraryDirsStatic
    965 
    +    , unitLibraryBytecodeDirs = libraryBytecodeDirs
    966 
    +    , unitExtDepFrameworkDirs = extDepFrameworkDirs
    967 
    +    , unitHaddockInterfaces = haddockInterfaces
    968 
    +    , unitHaddockHTMLs = haddockHTMLs
    969 
    +    }
    970 
    +
    869 971 
     -- -----------------------------------------------------------------------------
    870 972 
     -- Modify our copy of the unit database based on trust flags,
    871 973 
     -- -trust and -distrust.
    ... ... @@ -874,22 +976,28 @@ applyTrustFlag
    874 976 
        :: UnitPrecedenceMap
    875 977 
        -> UnusableUnits
    876 978 
        -> [UnitInfo]
    979 
    +   -> (Set.Set UnitId, Set.Set UnitId)
    877 980 
        -> TrustFlag
    878 
    -   -> MaybeErr UnitErr [UnitInfo]
    879 
    -applyTrustFlag prec_map unusable pkgs flag =
    981 
    +   -> MaybeErr UnitErr (Set.Set UnitId, Set.Set UnitId)
    982 
    +applyTrustFlag prec_map unusable pkgs (trusted, distrusted) flag =
    880 983 
       case flag of
    881 984 
         -- we trust all matching packages. Maybe should only trust first one?
    882 985 
         -- and leave others the same or set them untrusted
    883 986 
         TrustPackage str ->
    884 987 
            case selectPackages prec_map (PackageArg str) pkgs unusable of
    885 988 
              Left ps       -> Failed (TrustFlagErr flag ps)
    886 
    -         Right (ps,qs) -> Succeeded (map trust ps ++ qs)
    887 
    -          where trust p = p {unitIsTrusted=True}
    989 
    +         Right (ps,_) -> Succeeded (insertAll ps trusted, removeAll ps distrusted)
    888 990
    889 991 
         DistrustPackage str ->
    890 992 
            case selectPackages prec_map (PackageArg str) pkgs unusable of
    891 993 
              Left ps       -> Failed (TrustFlagErr flag ps)
    892 
    -         Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs)
    994 
    +         Right (ps,_) -> Succeeded (removeAll ps trusted, insertAll ps distrusted)
    995 
    +
    996 
    +insertAll :: [UnitInfo] -> Set UnitId -> Set UnitId
    997 
    +insertAll elements set = foldl' (\ acc -> flip Set.insert acc . unitId) set elements
    998 
    +
    999 
    +removeAll :: [UnitInfo] -> Set UnitId -> Set UnitId
    1000 
    +removeAll elements set = foldl' (\ acc -> flip Set.delete acc . unitId) set elements
    893 1001
    894 1002 
     applyPackageFlag
    895 1003 
        :: UnitPrecedenceMap
    ... ... @@ -1093,6 +1201,7 @@ pprTrustFlag flag = case flag of
    1093 1201 
     -- See Note [Wired-in units] in GHC.Unit.Types
    1094 1202
    1095 1203 
     type WiringMap = UniqMap UnitId UnitId
    1204 
    +type UnwiringMap = UniqMap UnitId UnitId
    1096 1205
    1097 1206 
     findWiredInUnits
    1098 1207 
        :: Logger
    ... ... @@ -1100,9 +1209,7 @@ findWiredInUnits
    1100 1209 
        -> [UnitInfo]           -- database
    1101 1210 
        -> VisibilityMap             -- info on what units are visible
    1102 1211 
                                     -- for wired in selection
    1103 
    -   -> IO ([UnitInfo],  -- unit database updated for wired in
    1104 
    -          WiringMap)   -- map from unit id to wired identity
    1105 
    -
    1212 
    +   -> IO WiringMap   -- map from unit id to wired identity
    1106 1213 
     findWiredInUnits logger prec_map pkgs vis_map = do
    1107 1214 
       -- Now we must find our wired-in units, and rename them to
    1108 1215 
       -- their canonical names (eg. base-1.0 ==> base), as described
    ... ... @@ -1165,27 +1272,41 @@ findWiredInUnits logger prec_map pkgs vis_map = do
    1165 1272 
               , not (unitIsIndefinite realUnitInfo)
    1166 1273 
               ]
    1167 1274
    1168 
    -        updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
    1169 
    -          where upd_pkg pkg
    1170 
    -                  | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg)
    1171 
    -                  = pkg { unitId         = wiredInUnitId
    1172 
    -                        , unitInstanceOf = wiredInUnitId
    1173 
    -                           -- every non instantiated unit is an instance of
    1174 
    -                           -- itself (required by Backpack...)
    1175 
    -                           --
    1176 
    -                           -- See Note [About units] in GHC.Unit
    1177 
    -                        }
    1178 
    -                  | otherwise
    1179 
    -                  = pkg
    1180 
    -                upd_deps pkg = pkg {
    1181 
    -                      unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),
    1182 
    -                      unitExposedModules
    1183 
    -                        = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))
    1184 
    -                              (unitExposedModules pkg)
    1185 
    -                    }
    1186 
    -
    1187 
    -
    1188 
    -  return (updateWiredInDependencies pkgs, wiredInMap)
    1275 
    +  return wiredInMap
    1276 
    +
    1277 
    +updateWiredInUnits :: WiringMap -> UnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo]
    1278 
    +updateWiredInUnits wiredInMap knownInfos pkgs =
    1279 
    +  map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs
    1280 
    +
    1281 
    +updateWiredInUnitsInUnitInfo :: WiringMap -> UnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo
    1282 
    +updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg =
    1283 
    +  let
    1284 
    +    upd_pkg pkg
    1285 
    +      | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg)
    1286 
    +      = pkg { unitId         = wiredInUnitId
    1287 
    +            , unitInstanceOf = wiredInUnitId
    1288 
    +                -- every non instantiated unit is an instance of
    1289 
    +                -- itself (required by Backpack...)
    1290 
    +                --
    1291 
    +                -- See Note [About units] in GHC.Unit
    1292 
    +            }
    1293 
    +      | otherwise
    1294 
    +      = pkg
    1295 
    +    upd_deps pkg = pkg {
    1296 
    +          unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),
    1297 
    +          unitExposedModules
    1298 
    +            = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))
    1299 
    +                  (unitExposedModules pkg)
    1300 
    +        }
    1301 
    +  in
    1302 
    +    case lookupUniqMap knownInfos (unitId pkg) of
    1303 
    +      Just ui ->
    1304 
    +        Right ui
    1305 
    +      Nothing ->
    1306 
    +        let
    1307 
    +          updated_pkg = upd_deps $ upd_pkg pkg
    1308 
    +        in
    1309 
    +          Left updated_pkg
    1189 1310
    1190 1311 
     -- Helper functions for rewiring Module and Unit.  These
    1191 1312 
     -- rewrite Units of modules in wired-in packages to the form known to the
    ... ... @@ -1468,9 +1589,10 @@ validateDatabase cfg pkg_map1 =
    1468 1589
    1469 1590 
     mkUnitState
    1470 1591 
         :: Logger
    1592 
    +    -> IORef UnitIndex
    1471 1593 
         -> UnitConfig
    1472 
    -    -> IO (UnitState,[UnitDatabase UnitId])
    1473 
    -mkUnitState logger cfg = do
    1594 
    +    -> IO UnitState
    1595 
    +mkUnitState logger unit_index cfg = do
    1474 1596 
     {-
    1475 1597 
        Plan.
    1476 1598
    ... ... @@ -1524,15 +1646,19 @@ mkUnitState logger cfg = do
    1524 1646 
               we build a mapping saying what every in scope module name points to.
    1525 1647 
     -}
    1526 1648
    1527 
    -  -- if databases have not been provided, read the database flags
    1528 
    -  raw_dbs <- case unitConfigDBCache cfg of
    1529 
    -               Nothing  -> readUnitDatabases logger cfg
    1530 
    -               Just dbs -> return dbs
    1649 
    +  raw_dbs <- readUnitDatabases logger cfg
    1531 1650
    1532 1651 
       -- distrust all units if the flag is set
    1533 
    -  let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
    1534 
    -      dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
    1535 
    -          | otherwise                 = raw_dbs
    1652 
    +  let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db)
    1653 
    +      allUnits = Set.unions $ map unitsOf raw_dbs
    1654 
    +
    1655 
    +      distrustedUnits
    1656 
    +        | unitConfigDistrustAll cfg = allUnits
    1657 
    +        | otherwise = Set.empty
    1658 
    +
    1659 
    +      trustedUnits = Set.empty
    1660 
    +
    1661 
    +      dbs = raw_dbs
    1536 1662
    1537 1663
    1538 1664 
       -- This, and the other reverse's that you will see, are due to the fact that
    ... ... @@ -1555,11 +1681,12 @@ mkUnitState logger cfg = do
    1555 1681 
       reportCycles   logger sccs
    1556 1682 
       reportUnusable logger unusable
    1557 1683
    1558 
    -  -- Apply trust flags (these flags apply regardless of whether
    1684 
    +  -- Compute trust flags (these flags apply regardless of whether
    1559 1685 
       -- or not packages are visible or not)
    1560 
    -  pkgs1 <- mayThrowUnitErr
    1561 
    -            $ foldM (applyTrustFlag prec_map unusable)
    1562 
    -                 (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
    1686 
    +  (!trusted, !distrusted) <- mayThrowUnitErr
    1687 
    +            $ foldM (applyTrustFlag prec_map unusable (nonDetEltsUniqMap pkg_map2))
    1688 
    +                 (trustedUnits, distrustedUnits) (reverse (unitConfigFlagsTrusted cfg))
    1689 
    +  let pkgs1 = nonDetEltsUniqMap pkg_map2
    1563 1690 
       let prelim_pkg_db = mkUnitInfoMap pkgs1
    1564 1691
    1565 1692 
       --
    ... ... @@ -1625,7 +1752,21 @@ mkUnitState logger cfg = do
    1625 1752 
       -- it modifies the unit ids of wired in packages, but when we process
    1626 1753 
       -- package arguments we need to key against the old versions.
    1627 1754 
       --
    1628 
    -  (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
    1755 
    +  ui <- readIORef unit_index
    1756 
    +  (wired_map, pkgs2) <- do
    1757 
    +    wireMap <- if isWireMapEmpty ui
    1758 
    +      then do
    1759 
    +        wmap <- findWiredInUnits logger prec_map pkgs1 vis_map2
    1760 
    +        modifyIORef' unit_index (setWireMap wmap)
    1761 
    +        pure wmap
    1762 
    +      else do
    1763 
    +        pure $ ui_wireMap ui
    1764 
    +
    1765 
    +    let all_pkgs = updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1
    1766 
    +        (new_pkgs, _pkgs_set) = partitionEithers all_pkgs
    1767 
    +    modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs)
    1768 
    +    pure (wireMap, map (either id id) all_pkgs)
    1769 
    +
    1629 1770 
       let pkg_db = mkUnitInfoMap pkgs2
    1630 1771
    1631 1772 
       -- Update the visibility map, so we treat wired packages as visible.
    ... ... @@ -1707,15 +1848,17 @@ mkUnitState logger cfg = do
    1707 1848 
              , explicitUnits                = explicit_pkgs
    1708 1849 
              , homeUnitDepends              = home_unit_deps
    1709 1850 
              , unitInfoMap                  = pkg_db
    1851 
    +         , trustedUnits                 = trusted
    1852 
    +         , distrustedUnits              = distrusted
    1710 1853 
              , moduleNameProvidersMap       = mod_map
    1711 1854 
              , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map
    1712 1855 
              , packageNameMap               = pkgname_map
    1713 
    -         , wireMap                      = wired_map
    1714 
    -         , unwireMap                    = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
    1856 
    +        --  , wireMap                      = wired_map
    1857 
    +        --  , unwireMap                    = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
    1715 1858 
              , requirementContext           = req_ctx
    1716 1859 
              , allowVirtualUnits            = unitConfigAllowVirtual cfg
    1717 1860 
              }
    1718 
    -  return (state, raw_dbs)
    1861 
    +  return state
    1719 1862
    1720 1863 
     selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool
    1721 1864 
     selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True
    ... ... @@ -1732,9 +1875,9 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags
    1732 1875
    1733 1876 
     -- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
    1734 1877 
     -- that it was recorded as in the package database.
    1735 
    -unwireUnit :: UnitState -> Unit -> Unit
    1878 
    +unwireUnit :: UnitIndex -> Unit -> Unit
    1736 1879 
     unwireUnit state uid@(RealUnit (Definite def_uid)) =
    1737 
    -    maybe uid (RealUnit . Definite) (lookupUniqMap (unwireMap state) def_uid)
    1880 
    +    maybe uid (RealUnit . Definite) (lookupUniqMap (ui_unwireMap state) def_uid)
    1738 1881 
     unwireUnit _ uid = uid
    1739 1882
    1740 1883 
     -- -----------------------------------------------------------------------------
    ... ... @@ -2151,10 +2294,10 @@ pprUnitsWith pprIPI pkgstate =
    2151 2294 
     -- The idea is to only print package id, and any information that might
    2152 2295 
     -- be different from the package databases (exposure, trust)
    2153 2296 
     pprUnitsSimple :: UnitState -> SDoc
    2154 
    -pprUnitsSimple = pprUnitsWith pprIPI
    2297 
    +pprUnitsSimple ue = pprUnitsWith pprIPI ue
    2155 2298 
         where pprIPI ipi = let i = unitIdFS (unitId ipi)
    2156 2299 
                                e = if unitIsExposed ipi then text "E" else text " "
    2157 
    -                           t = if unitIsTrusted ipi then text "T" else text " "
    2300 
    +                           t = if isUnitInfoTrusted ue ipi then text "T" else text " "
    2158 2301 
                            in e <> t <> text "  " <> ftext i
    2159 2302
    2160 2303 
     -- | Show the mapping of modules to where they come from.

  • compiler/ghc.cabal.in
    ... ... @@ -966,6 +966,7 @@ Library
    966 966 
             GHC.Unit
    967 967 
             GHC.Unit.Env
    968 968 
             GHC.Unit.External
    969 
    +        GHC.Unit.External.Database
    969 970 
             GHC.Unit.Finder
    970 971 
             GHC.Unit.Finder.Types
    971 972 
             GHC.Unit.Home

  • ghc/GHCi/UI.hs
    ... ... @@ -856,10 +856,12 @@ installInteractiveHomeUnits dflags = do
    856 856 
       where
    857 857 
         setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> m HomeUnitEnv
    858 858 
         setupHomeUnitFor logger dflags all_home_units = do
    859 
    -      (dbs,unit_state,home_unit,_mconstants) <-
    860 
    -        liftIO $ initUnits logger dflags Nothing all_home_units
    859 
    +      env <- GHC.getSession
    860 
    +      let unit_index = hsc_unit_index env
    861 
    +      (unit_state,home_unit,_mconstants) <-
    862 
    +        liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units
    861 863 
           hpt <- liftIO emptyHomePackageTable
    862 
    -      pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit))
    864 
    +      pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit))
    863 865
    864 866 
         concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag]
    865 867 
         concatPackageDbStacksUsingLongestCommonPrefix stacks =
    ... ... @@ -2919,11 +2921,11 @@ isSafeModule m = do
    2919 2921
    2920 2922 
         packageTrusted hsc_env md
    2921 2923 
             | isHomeModule (hsc_home_unit hsc_env) md = True
    2922 
    -        | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md)
    2924 
    +        | otherwise = isUnitTrusted (hsc_units hsc_env) (moduleUnit md)
    2923 2925
    2924 2926 
         tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty)
    2925 2927 
                               | otherwise = S.partition part deps
    2926 
    -        where part pkg   = unitIsTrusted $ unsafeLookupUnitId unit_state pkg
    2928 
    +        where part pkg   = isUnitIdTrusted unit_state pkg
    2927 2929 
                   unit_state = hsc_units hsc_env
    2928 2930 
                   dflags     = hsc_dflags hsc_env
    2929 2931

  • libraries/ghc-boot/GHC/Unit/Database.hs
    ... ... @@ -746,11 +746,20 @@ mungeUnitInfoPaths top_dir pkgroot pkg =
    746 746 
           , unitHaddockHTMLs        = munge_paths (munge_urls (unitHaddockHTMLs pkg))
    747 747 
           }
    748 748 
        where
    749 
    -      munge_paths = map munge_path
    750 
    -      munge_urls  = map munge_url
    749 
    +      munge_paths = strictMap munge_path
    750 
    +      munge_urls  = strictMap munge_url
    751 751 
           (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot
    752 752
    753 753 
     -- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
    754 754 
     -- Prefer 'decodeUtf' and gracious error handling.
    755 755 
     unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath
    756 756 
     unsafeDecodeUtf = OsPath.Internal.so
    757 
    +
    758 
    +strictMap :: (a -> b) -> [a] -> [b]
    759 
    +strictMap _ []     = []
    760 
    +strictMap f (x:xs) =
    761 
    +  let
    762 
    +    !x' = f x
    763 
    +    !xs' = strictMap f xs
    764 
    +  in
    765 
    +    x' : xs'

  • utils/haddock/haddock-api/src/Haddock.hs
    ... ... @@ -258,7 +258,9 @@ haddockWithGhc ghc args = handleTopExceptions $ do
    258 258 
         logger' <- getLogger
    259 259 
         let logger = setLogFlags logger' (initLogFlags dflags)
    260 260 
         let parserOpts = Parser.initParserOpts dflags
    261 
    -    !unit_state <- hsc_units <$> getSession
    261 
    +    env <- getSession
    262 
    +    let !unit_state = hsc_units env
    263 
    +    !unit_index <- liftIO $ hscUnitIndex env
    262 264
    263 265 
         -- If any --show-interface was used, show the given interfaces
    264 266 
         forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
    ... ... @@ -285,7 +287,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
    285 287 
               }
    286 288
    287 289 
           -- Render the interfaces.
    288 
    -      liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages ifaces
    290 
    +      liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem packages ifaces
    289 291
    290 292 
         -- If we were not given any input files, error if documentation was
    291 293 
         -- requested
    ... ... @@ -298,7 +300,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
    298 300 
           packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
    299 301
    300 302 
           -- Render even though there are no input files (usually contents/index).
    301 
    -      liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages []
    303 
    +      liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem packages []
    302 304
    303 305 
     -- | Run the GHC action using a temporary output directory
    304 306 
     withTempOutputDir :: Ghc a -> Ghc a
    ... ... @@ -354,6 +356,7 @@ renderStep
    354 356 
       :: DynFlags
    355 357 
       -> ParserOpts
    356 358 
       -> Logger
    359 
    +  -> UnitIndex
    357 360 
       -> UnitState
    358 361 
       -> [Flag]
    359 362 
       -> SinceQual
    ... ... @@ -362,7 +365,7 @@ renderStep
    362 365 
       -> [(DocPaths, Visibility, FilePath, InterfaceFile)]
    363 366 
       -> [Interface]
    364 367 
       -> IO ()
    365 
    -renderStep dflags parserOpts logger unit_state flags sinceQual nameQual concSem pkgs interfaces = do
    368 
    +renderStep dflags parserOpts logger unit_index unit_state flags sinceQual nameQual concSem pkgs interfaces = do
    366 369 
       updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) ->
    367 370 
                               ( case baseUrl flags of
    368 371 
                                   Nothing  -> docPathsHtml docPath
    ... ... @@ -378,7 +381,7 @@ renderStep dflags parserOpts logger unit_state flags sinceQual nameQual concSem
    378 381 
           (DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs
    379 382 
           iface <- ifInstalledIfaces ifile
    380 383 
           return (instMod iface, path)
    381 
    -  render dflags parserOpts logger unit_state flags sinceQual nameQual concSem interfaces installedIfaces extSrcMap
    384 
    +  render dflags parserOpts logger unit_index unit_state flags sinceQual nameQual concSem interfaces installedIfaces extSrcMap
    382 385 
       where
    383 386 
         -- get package name from unit-id
    384 387 
         packageName :: Unit -> String
    ... ... @@ -392,6 +395,7 @@ render
    392 395 
       :: DynFlags
    393 396 
       -> ParserOpts
    394 397 
       -> Logger
    398 
    +  -> UnitIndex
    395 399 
       -> UnitState
    396 400 
       -> [Flag]
    397 401 
       -> SinceQual
    ... ... @@ -401,7 +405,7 @@ render
    401 405 
       -> [(FilePath, PackageInterfaces)]
    402 406 
       -> Map Module FilePath
    403 407 
       -> IO ()
    404 
    -render dflags parserOpts logger unit_state flags sinceQual qual concSem ifaces packages extSrcMap = do
    408 
    +render dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem ifaces packages extSrcMap = do
    405 409 
       let
    406 410 
         packageInfo = PackageInfo { piPackageName    = fromMaybe (PackageName mempty)
    407 411 
                                                      $ optPackageName flags
    ... ... @@ -503,7 +507,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual concSem ifaces p
    503 507 
         -- records the *wired in* identity base.  So untranslate it
    504 508 
         -- so that we can service the request.
    505 509 
         unwire :: Module -> Module
    506 
    -    unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) }
    510 
    +    unwire m = m { moduleUnit = unwireUnit unit_index (moduleUnit m) }
    507 511
    508 512 
       reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do
    509 513 
         let warn' = hPutStrLn stderr . ("Warning: " ++)

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