diff options
Diffstat (limited to 'compiler')
54 files changed, 2230 insertions, 1139 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index d70ca74d25..770cdf62b8 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -31,7 +31,10 @@ module GHC ( DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt, GhcMode(..), GhcLink(..), parseDynamicFlags, parseTargetFiles, - getSessionDynFlags, setSessionDynFlags, + getSessionDynFlags, + setTopSessionDynFlags, + setSessionDynFlags, + setUnitDynFlags, getProgramDynFlags, setProgramDynFlags, getInteractiveDynFlags, setInteractiveDynFlags, interpretPackageEnv, @@ -425,6 +428,7 @@ import System.IO.Error ( isDoesNotExistError ) import System.Environment ( getEnv, getProgName ) import System.Directory import Data.List (isPrefixOf) +import qualified Data.Set as S -- %************************************************************************ @@ -632,22 +636,84 @@ checkBrokenTablesNextToCode' logger dflags -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' -- retrieves the program @DynFlags@ (for backwards compatibility). - --- | Updates both the interactive and program DynFlags in a Session. --- This also reads the package database (unless it has already been --- read), and prepares the compilers knowledge about packages. It can --- be called again to load new packages: just add new package flags to --- (packageFlags dflags). -setSessionDynFlags :: GhcMonad m => DynFlags -> m () +-- This is a compatability function which sets dynflags for the top session +-- as well as the unit. +setSessionDynFlags :: (HasCallStack, GhcMonad m) => DynFlags -> m () setSessionDynFlags dflags0 = do + hsc_env <- getSession + logger <- getLogger + dflags <- checkNewDynFlags logger dflags0 + let all_uids = hsc_all_home_unit_ids hsc_env + case S.toList all_uids of + [uid] -> do + setUnitDynFlagsNoCheck uid dflags + modifySession (hscSetActiveUnitId (homeUnitId_ dflags)) + dflags' <- getDynFlags + setTopSessionDynFlags dflags' + [] -> panic "nohue" + _ -> panic "setSessionDynFlags can only be used with a single home unit" + + +setUnitDynFlags :: GhcMonad m => UnitId -> DynFlags -> m () +setUnitDynFlags uid dflags0 = do logger <- getLogger dflags1 <- checkNewDynFlags logger dflags0 + setUnitDynFlagsNoCheck uid dflags1 + +setUnitDynFlagsNoCheck :: GhcMonad m => UnitId -> DynFlags -> m () +setUnitDynFlagsNoCheck uid dflags1 = do + logger <- getLogger hsc_env <- getSession - let old_unit_env = hsc_unit_env hsc_env - let cached_unit_dbs = ue_unit_dbs old_unit_env - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs - dflags <- liftIO $ updatePlatformConstants dflags1 mconstants + let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env) + let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env) + updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants + + let upd hue = + hue + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_home_unit = Just home_unit + } + + let unit_env = ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env) + + let dflags = updated_dflags + + let unit_env0 = unit_env + { ue_platform = targetPlatform dflags + , ue_namever = ghcNameVersion dflags + } + + -- if necessary, change the key for the currently active unit + -- as the dynflags might have been changed + + -- This function is called on every --make invocation because at the start of + -- the session there is one fake unit called main which is immediately replaced + -- after the DynFlags are parsed. + let !unit_env1 = + if homeUnitId_ dflags /= uid + then + ue_renameUnitId + uid + (homeUnitId_ dflags) + unit_env0 + else unit_env0 + + modifySession $ \h -> h{ hsc_unit_env = unit_env1 + } + + invalidateModSummaryCache + + + + +setTopSessionDynFlags :: GhcMonad m => DynFlags -> m () +setTopSessionDynFlags dflags = do + hsc_env <- getSession + logger <- getLogger -- Interpreter interp <- if gopt Opt_ExternalInterpreter dflags @@ -685,22 +751,10 @@ setSessionDynFlags dflags0 = do return Nothing #endif - let unit_env = UnitEnv - { ue_platform = targetPlatform dflags - , ue_namever = ghcNameVersion dflags - , ue_home_unit = Just home_unit - , ue_hpt = ue_hpt old_unit_env - , ue_eps = ue_eps old_unit_env - , ue_units = unit_state - , ue_unit_dbs = Just dbs - } - modifySession $ \h -> hscSetFlags dflags $ + modifySession $ \h -> hscSetFlags dflags h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags } , hsc_interp = hsc_interp h <|> interp - -- we only update the interpreter if there wasn't - -- already one set up - , hsc_unit_env = unit_env } invalidateModSummaryCache @@ -722,22 +776,35 @@ setProgramDynFlags_ invalidate_needed dflags = do let changed = packageFlagsChanged dflags_prev dflags0 if changed then do - old_unit_env <- hsc_unit_env <$> getSession - let cached_unit_dbs = ue_unit_dbs old_unit_env - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 cached_unit_dbs - - dflags1 <- liftIO $ updatePlatformConstants dflags0 mconstants + -- additionally, set checked dflags so we don't lose fixes + old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession + + home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + dflags = homeUnitEnv_dflags homeUnitEnv + old_hpt = homeUnitEnv_hpt homeUnitEnv + home_units = unitEnv_keys (ue_home_unit_graph old_unit_env) + + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants + pure HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = old_hpt + , homeUnitEnv_home_unit = Just home_unit + } + let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph let unit_env = UnitEnv - { ue_platform = targetPlatform dflags1 - , ue_namever = ghcNameVersion dflags1 - , ue_home_unit = Just home_unit - , ue_hpt = ue_hpt old_unit_env - , ue_eps = ue_eps old_unit_env - , ue_units = unit_state - , ue_unit_dbs = Just dbs + { ue_platform = targetPlatform dflags1 + , ue_namever = ghcNameVersion dflags1 + , ue_home_unit_graph = home_unit_graph + , ue_current_unit = ue_currentUnit old_unit_env + , ue_eps = ue_eps old_unit_env } - modifySession $ \h -> hscSetFlags dflags1 $ h{ hsc_unit_env = unit_env } + modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) when invalidate_needed $ invalidateModSummaryCache @@ -828,7 +895,8 @@ parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], parseTargetFiles dflags0 fileish_args = let normal_fileish_paths = map normalise_hyp fileish_args - (srcs, objs) = partition_args normal_fileish_paths [] [] + (srcs, raw_objs) = partition_args normal_fileish_paths [] [] + objs = map (augmentByWorkingDirectory dflags0) raw_objs dflags1 = dflags0 { ldInputs = map (FileOption "") objs ++ ldInputs dflags0 } @@ -1025,7 +1093,7 @@ unitIdOrHomeUnit mUnitId = do workingDirectoryChanged :: GhcMonad m => m () workingDirectoryChanged = do hsc_env <- getSession - liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env) + liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) -- %************************************************************************ @@ -1389,7 +1457,7 @@ availsToGlobalRdrEnv mod_name avails getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = - case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of + case lookupHugByModule mdl (hsc_HUG hsc_env) of Nothing -> return Nothing Just hmi -> do let details = hm_details hmi @@ -1643,25 +1711,22 @@ findModule mod_name maybe_pkg = do findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do - let fc = hsc_FC hsc_env - let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags + let mhome_unit = hsc_home_unit_maybe hsc_env + let dflags = hsc_dflags hsc_env case pkgqual of - ThisPkg _ -> do - home <- lookupLoadedHomeModule mod_name + ThisPkg uid -> do + home <- lookupLoadedHomeModule uid mod_name case home of Just m -> return m Nothing -> liftIO $ do - res <- findImportedModule fc fopts units mhome_unit mod_name pkgqual + res <- findImportedModule hsc_env mod_name pkgqual case res of Found loc m | notHomeModuleMaybe mhome_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err _ -> liftIO $ do - res <- findImportedModule fc fopts units mhome_unit mod_name pkgqual + res <- findImportedModule hsc_env mod_name pkgqual case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err @@ -1693,7 +1758,7 @@ lookupModule mod_name maybe_pkg = do lookupQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do - home <- lookupLoadedHomeModule mod_name + home <- lookupLoadedHomeModule (homeUnitId $ hsc_home_unit hsc_env) mod_name case home of Just m -> return m Nothing -> liftIO $ do @@ -1707,9 +1772,9 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name -lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) -lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) mod_name of +lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module) +lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> + case lookupHug (hsc_HUG hsc_env) uid mod_name of Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 6b68ccee64..41bae56242 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -72,6 +72,7 @@ import GHC.Types.Name.Ppr import Control.Monad import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.Module {- ************************************************************************ * * @@ -106,7 +107,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod where logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env - home_pkg_rules = hptRules hsc_env (dep_direct_mods deps) + home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod + , gwib_isBoot = NotBoot }) hpt_rule_base = mkRuleBase home_pkg_rules print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 8ca120e462..b4e530a3e9 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -183,7 +183,8 @@ withBkpSession cid insts deps session_type do_this = do , not (null insts) = sub_comp (key_base p) </> uid_str | otherwise = sub_comp (key_base p) - mk_temp_env hsc_env = hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env + mk_temp_env hsc_env = + hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env mk_temp_dflags unit_state dflags = dflags { backend = case session_type of TcSession -> NoBackend @@ -322,7 +323,7 @@ buildUnit session cid insts lunit = do conf <- withBkpSession cid insts deps_w_rns session $ do dflags <- getDynFlags - mod_graph <- hsunitModuleGraph (unLoc lunit) + mod_graph <- hsunitModuleGraph False (unLoc lunit) msg <- mkBackpackMsg (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph @@ -412,7 +413,7 @@ compileExe lunit = do forM_ (zip [1..] deps) $ \(i, dep) -> compileInclude (length deps) (i, dep) withBkpExeSession deps_w_rns $ do - mod_graph <- hsunitModuleGraph (unLoc lunit) + mod_graph <- hsunitModuleGraph True (unLoc lunit) msg <- mkBackpackMsg (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1)) @@ -432,19 +433,21 @@ addUnit u = do , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env) -- update platform constants dflags <- liftIO $ updatePlatformConstants dflags0 mconstants - let unit_env = UnitEnv + let unit_env = ue_setUnits unit_state $ ue_setUnitDbs (Just dbs) $ UnitEnv { ue_platform = targetPlatform dflags , ue_namever = ghcNameVersion dflags - , ue_home_unit = Just home_unit - , ue_hpt = ue_hpt old_unit_env + , ue_current_unit = homeUnitId home_unit + + , ue_home_unit_graph = + unitEnv_singleton + (homeUnitId home_unit) + (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env - , ue_units = unit_state - , ue_unit_dbs = Just dbs } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } @@ -565,7 +568,7 @@ mkBackpackMsg = do msg <> showModMsg dflags (recompileRequired recomp) node <> reason in case node of - InstantiationNode _ -> + InstantiationNode _ _ -> case recomp of MustCompile -> showMsg (text "Instantiating ") empty UpToDate @@ -573,7 +576,7 @@ mkBackpackMsg = do | otherwise -> return () RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> pprWithUnitState state (ppr reason) <> text "]") - ModuleNode _ -> + ModuleNode _ _ -> case recomp of MustCompile -> showMsg (text "Compiling ") empty UpToDate @@ -581,6 +584,7 @@ mkBackpackMsg = do | otherwise -> return () RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> pprWithUnitState state (ppr reason) <> text "]") + LinkNode _ _ -> showMsg (text "Linking ") empty -- | 'PprStyle' for Backpack messages; here we usually want the module to -- be qualified (so we can tell how it was instantiated.) But we try not @@ -709,38 +713,40 @@ convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsCo -- -- We don't bother trying to support GHC.Driver.Make for now, it's more trouble -- than it's worth for inline modules. -hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph -hsunitModuleGraph unit = do +hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph +hsunitModuleGraph do_link unit = do hsc_env <- getSession let decls = hsunitBody unit pn = hsPackageName (unLoc (hsunitName unit)) home_unit = hsc_home_unit hsc_env + sig_keys = flip map (homeUnitInstantiations home_unit) $ \(mod_name, _) -> NodeKey_Module (ModNodeKeyWithUid (GWIB mod_name NotBoot) (homeUnitId home_unit)) + keys = [NodeKey_Module (ModNodeKeyWithUid gwib (homeUnitId home_unit)) | (DeclD hsc_src lmodname _) <- map unLoc decls, let gwib = GWIB (unLoc lmodname) (hscSourceToIsBoot hsc_src) ] + -- 1. Create a HsSrcFile/HsigFile summary for every -- explicitly mentioned module/signature. let get_decl (L _ (DeclD hsc_src lmodname hsmod)) = - Just `fmap` summariseDecl pn hsc_src lmodname hsmod + Just <$> summariseDecl pn hsc_src lmodname hsmod (keys ++ sig_keys) get_decl _ = return Nothing - nodes <- catMaybes `fmap` mapM get_decl decls + nodes <- mapMaybeM get_decl decls -- 2. For each hole which does not already have an hsig file, -- create an "empty" hsig file to induce compilation for the -- requirement. let hsig_set = Set.fromList [ ms_mod_name ms - | ExtendedModSummary { emsModSummary = ms } <- nodes + | ModuleNode _ ms <- nodes , ms_hsc_src ms == HsigFile ] req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) -> if Set.member mod_name hsig_set then return Nothing - else fmap (Just . extendModSummaryNoDeps) $ summariseRequirement pn mod_name - -- Using extendModSummaryNoDeps here is okay because we're making a leaf node - -- representing a signature that can't depend on any other unit. + else fmap Just $ summariseRequirement pn mod_name - let graph_nodes = (ModuleNode <$> (nodes ++ req_nodes)) ++ (instantiationNodes (hsc_units hsc_env)) + let graph_nodes = nodes ++ req_nodes ++ (instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env)) key_nodes = map mkNodeKey graph_nodes + all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link] -- This error message is not very good but .bkp mode is just for testing so -- better to be direct rather than pretty. when @@ -748,10 +754,10 @@ hsunitModuleGraph unit = do (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes)) -- 3. Return the kaboodle - return $ mkModuleGraph' $ graph_nodes + return $ mkModuleGraph $ all_nodes -summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary +summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode summariseRequirement pn mod_name = do hsc_env <- getSession let dflags = hsc_dflags hsc_env @@ -773,7 +779,7 @@ summariseRequirement pn mod_name = do extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name - return ModSummary { + let ms = ModSummary { ms_mod = mod, ms_hsc_src = HsigFile, ms_location = location, @@ -802,25 +808,29 @@ summariseRequirement pn mod_name = do ms_hspp_opts = dflags, ms_hspp_buf = Nothing } + let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ] + return (ModuleNode nodes ms) summariseDecl :: PackageName -> HscSource -> Located ModuleName -> Located HsModule - -> BkpM ExtendedModSummary -summariseDecl pn hsc_src (L _ modname) hsmod = hsModuleToModSummary pn hsc_src modname hsmod + -> [NodeKey] + -> BkpM ModuleGraphNode +summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod -- | Up until now, GHC has assumed a single compilation target per source file. -- Backpack files with inline modules break this model, since a single file -- may generate multiple output files. How do we decide to name these files? -- Should there only be one output file? This function our current heuristic, -- which is we make a "fake" module and use that. -hsModuleToModSummary :: PackageName +hsModuleToModSummary :: [NodeKey] + -> PackageName -> HscSource -> ModuleName -> Located HsModule - -> BkpM ExtendedModSummary -hsModuleToModSummary pn hsc_src modname + -> BkpM ModuleGraphNode +hsModuleToModSummary home_keys pn hsc_src modname hsmod = do let imps = hsmodImports (unLoc hsmod) loc = getLoc hsmod @@ -876,9 +886,7 @@ hsModuleToModSummary pn hsc_src modname let home_unit = hsc_home_unit hsc_env let fc = hsc_FC hsc_env addHomeModuleToFinder fc home_unit modname location - return $ ExtendedModSummary - { emsModSummary = - ModSummary { + let ms = ModSummary { ms_mod = this_mod, ms_hsc_src = hsc_src, ms_location = location, @@ -909,8 +917,12 @@ hsModuleToModSummary pn hsc_src modname ms_iface_date = hi_timestamp, ms_hie_date = hie_timestamp } - , emsInstantiatedUnits = inst_deps - } + + -- Now, what are the dependencies. + let inst_nodes = map NodeKey_Unit inst_deps + mod_nodes = [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys] + + return (ModuleNode (mod_nodes ++ inst_nodes) ms) -- | Create a new, externally provided hashed unit id from -- a hash. diff --git a/compiler/GHC/Driver/Config/Finder.hs b/compiler/GHC/Driver/Config/Finder.hs index 3d830fc6d2..6a7ad78972 100644 --- a/compiler/GHC/Driver/Config/Finder.hs +++ b/compiler/GHC/Driver/Config/Finder.hs @@ -7,6 +7,7 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Unit.Finder.Types +import GHC.Data.FastString -- | Create a new 'FinderOpts' from DynFlags. @@ -17,6 +18,10 @@ initFinderOpts flags = FinderOpts , finder_bypassHiFileCheck = MkDepend == (ghcMode flags) , finder_ways = ways flags , finder_enableSuggestions = gopt Opt_HelpfulErrors flags + , finder_workingDirectory = workingDirectory flags + , finder_thisPackageName = mkFastString <$> thisPackageName flags + , finder_hiddenModules = hiddenModules flags + , finder_reexportedModules = reexportedModules flags , finder_hieDir = hieDir flags , finder_hieSuf = hieSuf flags , finder_hiDir = hiDir flags diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 02d9249bd1..777f97768e 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -9,8 +9,15 @@ module GHC.Driver.Env , hsc_home_unit_maybe , hsc_units , hsc_HPT - , hscUpdateHPT + , hsc_HUE + , hsc_HUG + , hsc_all_home_unit_ids , hscUpdateLoggerFlags + , hscUpdateHUG + , hscUpdateHPT + , hscSetActiveHomeUnit + , hscSetActiveUnitId + , hscActiveUnitId , runHsc , runHsc' , mkInteractiveHscEnv @@ -47,7 +54,6 @@ import GHC.Unit import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails -import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo import GHC.Unit.Env import GHC.Unit.External @@ -109,17 +115,29 @@ hsc_home_unit :: HscEnv -> HomeUnit hsc_home_unit = unsafeGetHomeUnit . hsc_unit_env hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit -hsc_home_unit_maybe = ue_home_unit . hsc_unit_env +hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env -hsc_units :: HscEnv -> UnitState +hsc_units :: HasDebugCallStack => HscEnv -> UnitState hsc_units = ue_units . hsc_unit_env hsc_HPT :: HscEnv -> HomePackageTable hsc_HPT = ue_hpt . hsc_unit_env +hsc_HUE :: HscEnv -> HomeUnitEnv +hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env + +hsc_HUG :: HscEnv -> HomeUnitGraph +hsc_HUG = ue_home_unit_graph . hsc_unit_env + +hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId +hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG + hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHpt f (hsc_unit_env hsc_env) } +hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv +hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } + {- Note [Target code interpreter] @@ -209,42 +227,47 @@ hptAllInstances hsc_env in (concat insts, concat famInsts) -- | Find instances visible from the given set of imports -hptInstancesBelow :: HscEnv -> ModuleName -> Set ModuleNameWithIsBoot -> ([ClsInst], [FamInst]) -hptInstancesBelow hsc_env mn mns = - hptSomeThingsBelowUs (\mod_info -> - let details = hm_details mod_info - -- Don't include instances for the current module - in if moduleName (mi_module (hm_iface mod_info)) == mn - then mempty - else (md_insts details, md_fam_insts details)) - True -- Include -hi-boot - hsc_env - mns +hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> ([ClsInst], [FamInst]) +hptInstancesBelow hsc_env uid mnwib = + let + mn = gwib_mod mnwib + (insts, famInsts) = + unzip $ hptSomeThingsBelowUs (\mod_info -> + let details = hm_details mod_info + -- Don't include instances for the current module + in if moduleName (mi_module (hm_iface mod_info)) == mn + then [] + else [(md_insts details, md_fam_insts details)]) + True -- Include -hi-boot + hsc_env + uid + mnwib + in (concat insts, concat famInsts) -- | Get rules from modules "below" this one (in the dependency sense) -hptRules :: HscEnv -> Set ModuleNameWithIsBoot -> [CoreRule] +hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule] hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False -- | Get annotations from modules "below" this one (in the dependency sense) -hptAnns :: HscEnv -> Maybe (Set ModuleNameWithIsBoot) -> [Annotation] -hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps +hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation] +hptAnns hsc_env (Just (uid, mn)) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] -hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env)) +hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd) + (hugElts (hsc_HUG hsc_env)) -- | This function returns all the modules belonging to the home-unit that can -- be reached by following the given dependencies. Additionally, if both the -- boot module and the non-boot module can be reached, it only returns the -- non-boot one. -hptModulesBelow :: HscEnv -> Set ModuleNameWithIsBoot -> Set ModuleNameWithIsBoot -hptModulesBelow hsc_env mn = filtered_mods $ [ mnwib | NodeKey_Module mnwib <- modules_below] +hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid +hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below] where td_map = mgTransDeps (hsc_mod_graph hsc_env) - modules_below = Set.toList (Set.unions (mapMaybe (\mn -> Map.lookup (NodeKey_Module mn) td_map) (Set.toList mn)) - `Set.union` (Set.map NodeKey_Module mn)) + modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map filtered_mods = Set.fromDistinctAscList . filter_mods . sort @@ -253,8 +276,9 @@ hptModulesBelow hsc_env mn = filtered_mods $ [ mnwib | NodeKey_Module mnwib <- -- linear sweep with a window of size 2 to remove boot modules for which we -- have the corresponding non-boot. filter_mods = \case - (r1@(GWIB m1 b1) : r2@(GWIB m2 _) : rs) - | m1 == m2 -> let !r' = case b1 of + (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs) + | m1 == m2 && uid1 == uid2 -> + let !r' = case b1 of NotBoot -> r1 IsBoot -> r2 in r' : filter_mods rs @@ -265,16 +289,17 @@ hptModulesBelow hsc_env mn = filtered_mods $ [ mnwib | NodeKey_Module mnwib <- -- | Get things from modules "below" this one (in the dependency sense) -- C.f Inst.hptInstances -hptSomeThingsBelowUs :: Monoid a => (HomeModInfo -> a) -> Bool -> HscEnv -> Set ModuleNameWithIsBoot -> a -hptSomeThingsBelowUs extract include_hi_boot hsc_env deps - | isOneShot (ghcMode (hsc_dflags hsc_env)) = mempty +hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a] +hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn + | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] | otherwise - = let hpt = hsc_HPT hsc_env - in mconcat + = let hug = hsc_HUG hsc_env + in [ thing - | -- Find each non-hi-boot module below me - GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- Set.toList (hptModulesBelow hsc_env deps) + | + -- Find each non-hi-boot module below me + (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) uid) <- Set.toList (hptModulesBelow hsc_env uid mn) , include_hi_boot || (is_boot == NotBoot) -- unsavoury: when compiling the base package with --make, we @@ -284,12 +309,13 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps , mod /= moduleName gHC_PRIM -- Look it up in the HPT - , let thing = case lookupHpt hpt mod of + , let things = case lookupHug hug uid mod of Just info -> extract info Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty msg = vcat [text "missing module" <+> ppr mod, text "Probable cause: out-of-date interface files"] -- This really shouldn't happen, but see #962 + , thing <- things ] @@ -304,7 +330,8 @@ prepareAnnotations hsc_env mb_guts = do -- Extract dependencies of the module if we are supplied one, -- otherwise load annotations from all home package table -- entries regardless of dependency ordering. - home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_direct_mods . mg_deps) mb_guts + get_mod mg = (moduleUnitId (mg_module mg), GWIB (moduleName (mg_module mg)) NotBoot) + home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap get_mod mb_guts other_pkg_anns = eps_ann_env eps ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, Just home_pkg_anns, @@ -320,7 +347,7 @@ lookupType :: HscEnv -> Name -> IO (Maybe TyThing) lookupType hsc_env name = do eps <- liftIO $ hscEPS hsc_env let pte = eps_PTE eps - hpt = hsc_HPT hsc_env + hpt = hsc_HUG hsc_env mod = assertPpr (isExternalName name) (ppr name) $ if isHoleName name @@ -330,7 +357,7 @@ lookupType hsc_env name = do !ty = if isOneShot (ghcMode (hsc_dflags hsc_env)) -- in one-shot, we don't use the HPT then lookupNameEnv pte name - else case lookupHptByModule hpt mod of + else case lookupHugByModule mod hpt of Just hm -> lookupNameEnv (md_types (hm_details hm)) name Nothing -> lookupNameEnv pte name pure ty @@ -338,12 +365,12 @@ lookupType hsc_env name = do -- | Find the 'ModIface' for a 'Module', searching in both the loaded home -- and external package module information lookupIfaceByModule - :: HomePackageTable + :: HomeUnitGraph -> PackageIfaceTable -> Module -> Maybe ModIface -lookupIfaceByModule hpt pit mod - = case lookupHptByModule hpt mod of +lookupIfaceByModule hug pit mod + = case lookupHugByModule mod hug of Just hm -> Just (hm_iface hm) Nothing -> lookupModuleEnv pit mod -- If the module does come from the home package, why do we look in the PIT as well? @@ -353,8 +380,8 @@ lookupIfaceByModule hpt pit mod -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package -- of its own, but it doesn't seem worth the bother. -mainModIs :: HscEnv -> Module -mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env)) +mainModIs :: HomeUnitEnv -> Module +mainModIs hue = mkHomeModule (expectJust "mainModIs" $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) -- | Retrieve the target code interpreter -- @@ -375,8 +402,19 @@ hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv hscUpdateFlags f h = hscSetFlags (f (hsc_dflags h)) h -- | Set Flags -hscSetFlags :: DynFlags -> HscEnv -> HscEnv +hscSetFlags :: HasDebugCallStack => DynFlags -> HscEnv -> HscEnv hscSetFlags dflags h = - -- update LogFlags from the new DynFlags - hscUpdateLoggerFlags - $ h { hsc_dflags = dflags } + hscUpdateLoggerFlags $ h { hsc_dflags = dflags + , hsc_unit_env = ue_setFlags dflags (hsc_unit_env h) } + +-- See Note [Multiple Home Units] +hscSetActiveHomeUnit :: HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv +hscSetActiveHomeUnit home_unit = hscSetActiveUnitId (homeUnitId home_unit) + +hscSetActiveUnitId :: HasDebugCallStack => UnitId -> HscEnv -> HscEnv +hscSetActiveUnitId uid e = e + { hsc_unit_env = ue_setActiveUnit uid (hsc_unit_env e) + , hsc_dflags = ue_unitFlags uid (hsc_unit_env e) } + +hscActiveUnitId :: HscEnv -> UnitId +hscActiveUnitId e = ue_currentUnit (hsc_unit_env e) diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs index b0fcc6fd64..9db617780b 100644 --- a/compiler/GHC/Driver/Env/Types.hs +++ b/compiler/GHC/Driver/Env/Types.hs @@ -7,7 +7,7 @@ module GHC.Driver.Env.Types import GHC.Driver.Errors.Types ( GhcMessage ) import {-# SOURCE #-} GHC.Driver.Hooks -import GHC.Driver.Session ( DynFlags, ContainsDynFlags(..), HasDynFlags(..) ) +import GHC.Driver.Session ( ContainsDynFlags(..), HasDynFlags(..), DynFlags ) import GHC.Prelude import GHC.Runtime.Context import GHC.Runtime.Interpreter.Types ( Interp ) diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs index 2d90e935c8..1b604e1071 100644 --- a/compiler/GHC/Driver/Errors/Ppr.hs +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -88,6 +88,18 @@ instance Diagnostic DriverMessage where 4 (sep (map ppr missing)) in mkSimpleDecorated msg + DriverUnknownHiddenModules missing + -> let msg = hang + (text "Modules are listened as hidden but not part of the unit: ") + 4 + (sep (map ppr missing)) + in mkSimpleDecorated msg + DriverUnknownReexportedModules missing + -> let msg = hang + (text "Modules are listened as reexported but can't be found in any dependency: ") + 4 + (sep (map ppr missing)) + in mkSimpleDecorated msg DriverUnusedPackages unusedArgs -> let msg = vcat [ text "The following packages were specified" <+> text "via -package or -package-id flags," @@ -171,6 +183,16 @@ instance Diagnostic DriverMessage where <> (pprWithUnitState state $ ppr (moduleUnit m)) <> text ") the module resides in isn't trusted." ] + DriverRedirectedNoMain mod_name + -> mkSimpleDecorated $ (text + ("Output was redirected with -o, " ++ + "but no output will be generated.") $$ + (text "There is no module named" <+> + quotes (ppr mod_name) <> text ".")) + DriverHomePackagesNotClosed needed_unit_ids + -> mkSimpleDecorated $ vcat ([text "Home units are not closed." + , text "It is necessary to also load the following units:" ] + ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids) diagnosticReason = \case DriverUnknownMessage m @@ -179,6 +201,10 @@ instance Diagnostic DriverMessage where -> ErrorWithoutFlag DriverMissingHomeModules{} -> WarningWithFlag Opt_WarnMissingHomeModules + DriverUnknownHiddenModules {} + -> ErrorWithoutFlag + DriverUnknownReexportedModules {} + -> ErrorWithoutFlag DriverUnusedPackages{} -> WarningWithFlag Opt_WarnUnusedPackages DriverUnnecessarySourceImports{} @@ -217,6 +243,10 @@ instance Diagnostic DriverMessage where -> ErrorWithoutFlag DriverCannotImportFromUntrustedPackage{} -> ErrorWithoutFlag + DriverRedirectedNoMain {} + -> ErrorWithoutFlag + DriverHomePackagesNotClosed {} + -> ErrorWithoutFlag diagnosticHints = \case DriverUnknownMessage m @@ -225,6 +255,10 @@ instance Diagnostic DriverMessage where -> diagnosticHints psMsg DriverMissingHomeModules{} -> noHints + DriverUnknownHiddenModules {} + -> noHints + DriverUnknownReexportedModules {} + -> noHints DriverUnusedPackages{} -> noHints DriverUnnecessarySourceImports{} @@ -265,3 +299,7 @@ instance Diagnostic DriverMessage where -> noHints DriverCannotImportFromUntrustedPackage{} -> noHints + DriverRedirectedNoMain {} + -> noHints + DriverHomePackagesNotClosed {} + -> noHints diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs index 178455187f..7257b23903 100644 --- a/compiler/GHC/Driver/Errors/Types.hs +++ b/compiler/GHC/Driver/Errors/Types.hs @@ -128,6 +128,16 @@ data DriverMessage where -} DriverMissingHomeModules :: [ModuleName] -> !BuildingCabalPackage -> DriverMessage + {-| DriverUnknown is a warning that arises when a user tries to + reexport a module which isn't part of that unit. + -} + DriverUnknownReexportedModules :: [ModuleName] -> DriverMessage + + {-| DriverUnknownHiddenModules is a warning that arises when a user tries to + hide a module which isn't part of that unit. + -} + DriverUnknownHiddenModules :: [ModuleName] -> DriverMessage + {-| DriverUnusedPackages occurs when when package is requested on command line, but was never needed during compilation. Activated by -Wunused-packages. @@ -337,6 +347,10 @@ data DriverMessage where -} DriverCannotImportFromUntrustedPackage :: !UnitState -> !Module -> DriverMessage + DriverRedirectedNoMain :: !ModuleName -> DriverMessage + + DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage + -- | Pass to a 'DriverMessage' the information whether or not the -- '-fbuilding-cabal-package' flag is set. data BuildingCabalPackage diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 39c1f7af4e..38406fe172 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -39,9 +39,10 @@ module GHC.Driver.Main ( -- * Making an HscEnv newHscEnv + , newHscEnvWithHUG -- * Compiling complete source files - , Messager, batchMsg + , Messager, batchMsg, batchMultiMsg , HscBackendAction (..), HscRecompStatus (..) , initModDetails , hscMaybeWriteIface @@ -249,14 +250,22 @@ import Data.List.NonEmpty (NonEmpty ((:|))) %********************************************************************* -} newHscEnv :: DynFlags -> IO HscEnv -newHscEnv dflags = do +newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph + where + home_unit_graph = unitEnv_singleton + (homeUnitId_ dflags) + (mkHomeUnitEnv dflags emptyHomePackageTable Nothing) + +newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv +newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do nc_var <- initNameCache 'r' knownKeyNames fc_var <- initFinderCache logger <- initLogger tmpfs <- initTmpFs - unit_env <- initUnitEnv (ghcNameVersion dflags) (targetPlatform dflags) - return HscEnv { hsc_dflags = dflags - , hsc_logger = setLogFlags logger (initLogFlags dflags) + let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph + unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) + return HscEnv { hsc_dflags = top_dynflags + , hsc_logger = setLogFlags logger (initLogFlags top_dynflags) , hsc_targets = [] , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags @@ -728,8 +737,7 @@ hscRecompStatus = do let msg what = case mHscMessage of - -- We use extendModSummaryNoDeps because extra backpack deps are only needed for batch mode - Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary)) + Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary) Nothing -> return () -- First check to see if the interface file agrees with the @@ -1107,31 +1115,33 @@ oneShotMsg logger recomp = _ -> return () batchMsg :: Messager -batchMsg hsc_env mod_index recomp node = case node of - InstantiationNode _ -> - case recomp of - MustCompile -> showMsg (text "Instantiating ") empty - UpToDate - | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty - | otherwise -> return () - RecompBecause reason -> showMsg (text "Instantiating ") - (text " [" <> pprWithUnitState state (ppr reason) <> text "]") - ModuleNode _ -> - case recomp of - MustCompile -> showMsg (text "Compiling ") empty - UpToDate - | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty - | otherwise -> return () - RecompBecause reason -> showMsg (text "Compiling ") - (text " [" <> pprWithUnitState state (ppr reason) <> text "]") +batchMsg = batchMsgWith (\_ _ _ _ -> empty) +batchMultiMsg :: Messager +batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (moduleGraphNodeUnitId node))) + +batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager +batchMsgWith extra hsc_env_start mod_index recomp node = + case recomp of + MustCompile -> showMsg (text herald) empty + UpToDate + | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty + | otherwise -> return () + RecompBecause reason -> showMsg (text herald) + (text " [" <> pprWithUnitState state (ppr reason) <> text "]") where + herald = case node of + LinkNode {} -> "Linking" + InstantiationNode {} -> "Instantiating" + ModuleNode {} -> "Compiling" + hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env state = hsc_units hsc_env showMsg msg reason = compilationProgressMsg logger $ (showModuleIndex mod_index <> - msg <> showModMsg dflags (recompileRequired recomp) node) + msg <+> showModMsg dflags (recompileRequired recomp) node) + <> extra hsc_env mod_index recomp node <> reason -------------------------------------------------------------- @@ -1420,8 +1430,8 @@ hscCheckSafe' m l = do hsc_env <- getHscEnv hsc_eps <- liftIO $ hscEPS hsc_env let pkgIfaceT = eps_PIT hsc_eps - homePkgT = hsc_HPT hsc_env - iface = lookupIfaceByModule homePkgT pkgIfaceT m + hug = hsc_HUG hsc_env + iface = lookupIfaceByModule hug pkgIfaceT m -- the 'lookupIfaceByModule' method will always fail when calling from GHCi -- as the compiler hasn't filled in the various module tables -- so we need to call 'getModuleInterface' to load from disk diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 3a37a06809..afeec69c8e 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -16,6 +16,8 @@ {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiWayIf #-} -- ----------------------------------------------------------------------------- -- @@ -26,7 +28,7 @@ -- -- ----------------------------------------------------------------------------- module GHC.Driver.Make ( - depanal, depanalE, depanalPartial, + depanal, depanalE, depanalPartial, checkHomeUnitsClosed, load, loadWithCache, load', LoadHowMuch(..), instantiationNodes, @@ -37,6 +39,7 @@ module GHC.Driver.Make ( ms_home_srcimps, ms_home_imps, summariseModule, + SummariseResult(..), summariseFile, hscSourceToIsBoot, findExtraSigImports, @@ -46,7 +49,8 @@ module GHC.Driver.Make ( SummaryNode, IsBootInterface(..), mkNodeKey, - ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert + ModNodeKey, ModNodeKeyWithUid(..), + ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith ) where import GHC.Prelude @@ -104,8 +108,6 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.Unique.FM -import GHC.Types.Unique.DSet -import GHC.Types.Unique.Set import GHC.Types.Name import GHC.Types.PkgQual @@ -118,19 +120,17 @@ import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo -import Data.Either ( rights, partitionEithers ) +import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified GHC.Data.FiniteMap as Map ( insertListWith ) -import Control.Concurrent ( forkIO, newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) +import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) import qualified GHC.Conc as CC import Control.Concurrent.MVar import Control.Monad import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC import Data.IORef -import Data.Foldable (toList) import Data.Maybe import Data.Time import Data.Bifunctor (first) @@ -190,9 +190,21 @@ depanalE excluded_mods allow_dup_roots = do (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots if isEmptyMessages errs then do - let unused_home_mod_err = warnMissingHomeModules hsc_env mod_graph - unused_pkg_err = warnUnusedPackages hsc_env mod_graph - logDiagnostics (GhcDriverMessage <$> (unused_home_mod_err `unionMessages` unused_pkg_err)) + hsc_env <- getSession + let one_unit_messages get_mod_errs k hue = do + errs <- get_mod_errs + unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph + + let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph + unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph + + + return $ errs `unionMessages` unused_home_mod_err + `unionMessages` unused_pkg_err + `unionMessages` unknown_module_err + + all_errs <- liftIO $ unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env) + logDiagnostics (GhcDriverMessage <$> all_errs) setSession hsc_env { hsc_mod_graph = mod_graph } pure (emptyMessages, mod_graph) else do @@ -233,16 +245,13 @@ depanalPartial excluded_mods allow_dup_roots = do -- source files may have appeared in the home package that shadow -- external package modules, so we have to discard the existing -- cached finder data. - liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env) + liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) - mod_summariesE <- liftIO $ downsweep - hsc_env (mgExtendedModSummaries old_graph) + (errs, graph_nodes) <- liftIO $ downsweep + hsc_env (mgModSummaries old_graph) excluded_mods allow_dup_roots let - (errs, mod_summaries) = partitionEithers mod_summariesE - mod_graph = mkModuleGraph' $ - (instantiationNodes (hsc_units hsc_env)) - ++ fmap ModuleNode mod_summaries + mod_graph = mkModuleGraph graph_nodes return (unionManyMessages errs, mod_graph) -- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes. @@ -253,8 +262,8 @@ depanalPartial excluded_mods allow_dup_roots = do -- In the future, perhaps more of the work of instantiation could be moved here, -- instead of shoved in with the module compilation nodes. That could simplify -- backpack, and maybe hs-boot too. -instantiationNodes :: UnitState -> [ModuleGraphNode] -instantiationNodes unit_state = InstantiationNode <$> iuids_to_check +instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode] +instantiationNodes uid unit_state = InstantiationNode uid <$> iuids_to_check where iuids_to_check :: [InstantiatedUnit] iuids_to_check = @@ -267,6 +276,35 @@ instantiationNodes unit_state = InstantiationNode <$> iuids_to_check , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst ] +-- The linking plan for each module. If we need to do linking for a home unit +-- then this function returns a graph node which depends on all the modules in the home unit. + +-- At the moment nothing can depend on these LinkNodes. +linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode) +linkNodes summaries uid hue = + let dflags = homeUnitEnv_dflags hue + ofile = outputFile_ dflags + + unit_nodes :: [NodeKey] + unit_nodes = map mkNodeKey (filter ((== uid) . moduleGraphNodeUnitId) summaries) + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + no_hs_main = gopt Opt_NoHsMain dflags + + main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes + + do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib + + in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking -> + Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags)) + -- This should be an error, not a warning (#10895). + | do_linking -> Just (Right (LinkNode unit_nodes uid)) + | otherwise -> Nothing + -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Sometimes user doesn't want GHC to pick up modules, not explicitly listed @@ -281,14 +319,12 @@ instantiationNodes unit_state = InstantiationNode <$> iuids_to_check -- about module "C" not being listed in a command line. -- -- The warning in enabled by `-Wmissing-home-modules`. See #13129 -warnMissingHomeModules :: HscEnv -> ModuleGraph -> DriverMessages -warnMissingHomeModules hsc_env mod_graph = - if null missing - then emptyMessages - else warn +warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages +warnMissingHomeModules dflags targets mod_graph = + if null missing + then emptyMessages + else warn where - dflags = hsc_dflags hsc_env - targets = map targetId (hsc_targets hsc_env) diag_opts = initDiagOpts dflags is_known_module mod = any (is_my_target mod) targets @@ -301,36 +337,78 @@ warnMissingHomeModules hsc_env mod_graph = -- `ghc --make -isrc-exe Main` are supposed to be equivalent. -- Note also that we can't always infer the associated module name -- directly from the filename argument. See #13727. - is_my_target mod (TargetModule name) - = moduleName (ms_mod mod) == name - is_my_target mod (TargetFile target_file _) - | Just mod_file <- ml_hs_file (ms_location mod) - = target_file == mod_file || - - -- Don't warn on B.hs-boot if B.hs is specified (#16551) - addBootSuffix target_file == mod_file || - - -- We can get a file target even if a module name was - -- originally specified in a command line because it can - -- be converted in guessTarget (by appending .hs/.lhs). - -- So let's convert it back and compare with module name - mkModuleName (fst $ splitExtension target_file) - == moduleName (ms_mod mod) - is_my_target _ _ = False + is_my_target mod target = + let tuid = targetUnitId target + in case targetId target of + TargetModule name + -> moduleName (ms_mod mod) == name + && tuid == ms_unitid mod + TargetFile target_file _ + | Just mod_file <- ml_hs_file (ms_location mod) + -> + target_file == mod_file || + + -- Don't warn on B.hs-boot if B.hs is specified (#16551) + addBootSuffix target_file == mod_file || + + -- We can get a file target even if a module name was + -- originally specified in a command line because it can + -- be converted in guessTarget (by appending .hs/.lhs). + -- So let's convert it back and compare with module name + mkModuleName (fst $ splitExtension target_file) + == moduleName (ms_mod mod) + _ -> False missing = map (moduleName . ms_mod) $ - filter (not . is_known_module) (mgModSummaries mod_graph) + filter (not . is_known_module) $ + (filter (\ms -> ms_unitid ms == homeUnitId_ dflags) + (mgModSummaries mod_graph)) warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags) +-- Check that any modules we want to reexport or hide are actually in the package. +warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages +warnUnknownModules hsc_env dflags mod_graph = do + reexported_warns <- filterM check_reexport (Set.toList reexported_mods) + return $ final_msgs hidden_warns reexported_warns + where + diag_opts = initDiagOpts dflags + + unit_mods = Set.fromList (map ms_mod_name + (filter (\ms -> ms_unitid ms == homeUnitId_ dflags) + (mgModSummaries mod_graph))) + + reexported_mods = reexportedModules dflags + hidden_mods = hiddenModules dflags + + hidden_warns = hidden_mods `Set.difference` unit_mods + + lookupModule mn = findImportedModule hsc_env mn NoPkgQual + + check_reexport mn = do + fr <- lookupModule mn + case fr of + Found _ m -> return (moduleUnitId m == homeUnitId_ dflags) + _ -> return True + + + warn flag mod = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan + $ flag mod + + final_msgs hidden_warns reexported_warns + = + unionManyMessages $ + [warn DriverUnknownHiddenModules (Set.toList hidden_warns) | not (Set.null hidden_warns)] + ++ [warn DriverUnknownReexportedModules reexported_warns | not (null reexported_warns)] + -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch = LoadAllTargets -- ^ Load all targets and its dependencies. - | LoadUpTo ModuleName + | LoadUpTo HomeUnitModule -- ^ Load only the given module and its dependencies. - | LoadDependenciesOf ModuleName + | LoadDependenciesOf HomeUnitModule -- ^ Load only the dependencies of the given module, but not the module -- itself. @@ -352,10 +430,18 @@ data LoadHowMuch load :: GhcMonad f => LoadHowMuch -> f SuccessFlag load how_much = fst <$> loadWithCache [] how_much +mkBatchMsg :: HscEnv -> Messager +mkBatchMsg hsc_env = + if length (hsc_all_home_unit_ids hsc_env) > 1 + -- This also displays what unit each module is from. + then batchMultiMsg + else batchMsg + loadWithCache :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> m (SuccessFlag, [HomeModInfo]) loadWithCache cache how_much = do (errs, mod_graph) <- depanalE [] False -- #17459 - success <- load' cache how_much (Just batchMsg) mod_graph + msg <- mkBatchMsg <$> getSession + success <- load' cache how_much (Just msg) mod_graph if isEmptyMessages errs then pure success else throwErrors (fmap GhcDriverMessage errs) @@ -367,22 +453,20 @@ loadWithCache cache how_much = do -- actually loaded packages. All the packages, specified on command line, -- but never loaded, are probably unused dependencies. -warnUnusedPackages :: HscEnv -> ModuleGraph -> DriverMessages -warnUnusedPackages hsc_env mod_graph = - let dflags = hsc_dflags hsc_env - state = hsc_units hsc_env - diag_opts = initDiagOpts dflags - us = hsc_units hsc_env +warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages +warnUnusedPackages us dflags mod_graph = + let diag_opts = initDiagOpts dflags -- Only need non-source imports here because SOURCE imports are always HPT loadedPackages = concat $ mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs) - $ concatMap ms_imps (mgModSummaries mod_graph) + $ concatMap ms_imps ( + filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)) requestedArgs = mapMaybe packageArg (packageFlags dflags) unusedArgs - = filter (\arg -> not $ any (matching state arg) loadedPackages) + = filter (\arg -> not $ any (matching us arg) loadedPackages) requestedArgs warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs) @@ -441,7 +525,7 @@ countMods (ResolvedCycle ns) = length ns countMods (UnresolvedCycle ns) = length ns -- See Note [Upsweep] for a high-level description. -createBuildPlan :: ModuleGraph -> Maybe ModuleName -> [BuildPlan] +createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan] createBuildPlan mod_graph maybe_top_mod = let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod @@ -466,22 +550,24 @@ createBuildPlan mod_graph maybe_top_mod = (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph) trans_deps_map = allReachable mg (mkNodeKey . node_payload) - boot_path mn = + boot_path mn uid = map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $ - Set.delete (NodeKey_Module (GWIB mn IsBoot)) $ - expectJust "boot_path" (M.lookup (NodeKey_Module (GWIB mn NotBoot)) trans_deps_map) - `Set.difference` (expectJust "boot_path" (M.lookup (NodeKey_Module (GWIB mn IsBoot)) trans_deps_map)) + Set.delete (NodeKey_Module (key IsBoot)) $ + expectJust "boot_path" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map) + `Set.difference` (expectJust "boot_path" (M.lookup (NodeKey_Module (key IsBoot)) trans_deps_map)) + where + key ib = ModNodeKeyWithUid (GWIB mn ib) uid -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists boot_modules = mkModuleEnv - [ (ms_mod ms, (m, boot_path (ms_mod_name ms))) | m@(ModuleNode (ExtendedModSummary ms _)) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot] + [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot] select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode] select_boot_modules = mapMaybe (fmap fst . get_boot_module) get_boot_module :: (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])) - get_boot_module m = case m of ModuleNode (ExtendedModSummary ms _) | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing + get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing -- Any cycles should be resolved now collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] @@ -512,7 +598,7 @@ createBuildPlan mod_graph maybe_top_mod = in assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph)) - (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr build_plan), (text "GRAPH:" <+> ppr (mgModSummaries' mod_graph ))]) + (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (length (mgModSummaries' mod_graph )))]) build_plan -- | Generalized version of 'load' which also supports a custom @@ -533,7 +619,7 @@ load' cache how_much mHscMessage mod_graph = do -- The downsweep should have ensured this does not happen -- (see msDeps) let all_home_mods = - mkUniqSet [ ms_mod_name s + Set.fromList [ Module (ms_unitid s) (ms_mod_name s) | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot] -- TODO: Figure out what the correct form of this assert is. It's violated -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot @@ -549,10 +635,10 @@ load' cache how_much mHscMessage mod_graph = do checkHowMuch _ = id checkMod m and_then - | m `elementOfUniqSet` all_home_mods = and_then + | m `Set.member` all_home_mods = and_then | otherwise = do liftIO $ errorMsg logger - (text "no such module:" <+> quotes (ppr m)) + (text "no such module:" <+> quotes (ppr (moduleUnit m) <> colon <> ppr (moduleName m))) return (Failed, []) checkHowMuch how_much $ do @@ -574,8 +660,6 @@ load' cache how_much mHscMessage mod_graph = do build_plan = createBuildPlan mod_graph maybe_top_mod - - let -- prune the HPT so everything is not retained when doing an -- upsweep. @@ -586,7 +670,9 @@ load' cache how_much mHscMessage mod_graph = do -- before we unload anything, make sure we don't leave an old -- interactive context around pointing to dead bindings. Also, -- write an empty HPT to allow the old HPT to be GC'd. - setSession $ discardIC $ hscUpdateHPT (const emptyHomePackageTable) hsc_env + + let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } + setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env -- Unload everything liftIO $ unload interp hsc_env @@ -596,103 +682,33 @@ load' cache how_much mHscMessage mod_graph = do let direct_deps = mkDepsMap (mgModSummaries' mod_graph) - n_jobs <- case parMakeCount dflags of + n_jobs <- case parMakeCount (hsc_dflags hsc_env) of Nothing -> liftIO getNumProcessors Just n -> return n - setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env + setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env hsc_env <- getSession (upsweep_ok, hsc_env1, new_cache) <- withDeferredDiagnostics $ liftIO $ upsweep n_jobs hsc_env mHscMessage (toCache pruned_cache) direct_deps build_plan setSession hsc_env1 fmap (, new_cache) $ case upsweep_ok of - Failed -> loadFinish upsweep_ok Succeeded - + Failed -> loadFinish upsweep_ok Succeeded -> do - -- Make modsDone be the summaries for each home module now - -- available; this should equal the domain of hpt3. - -- Get in in a roughly top .. bottom order (hence reverse). - - -- Try and do linking in some form, depending on whether the - -- upsweep was completely or only partially successful. - - -- Easy; just relink it all. - do liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.") - + liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.") -- Clean up after ourselves - hsc_env1 <- getSession liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags + loadFinish upsweep_ok - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - let ofile = outputFile_ dflags - let no_hs_main = gopt Opt_NoHsMain dflags - let - main_mod = mainModIs hsc_env - a_root_is_Main = mgElemModule mod_graph main_mod - do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib - - -- link everything together - hsc_env <- getSession - linkresult <- liftIO $ link (ghcLink dflags) - logger - (hsc_tmpfs hsc_env) - (hsc_hooks hsc_env) - dflags - (hsc_unit_env hsc_env) - do_linking - (hsc_HPT hsc_env1) - - if ghcLink dflags == LinkBinary && isJust ofile && not do_linking - then do - liftIO $ errorMsg logger $ text - ("output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ - moduleNameString (moduleName main_mod) ++ " module.") - -- This should be an error, not a warning (#10895). - loadFinish Failed linkresult - else - loadFinish Succeeded linkresult - -partitionNodes - :: [ModuleGraphNode] - -> ( [InstantiatedUnit] - , [ExtendedModSummary] - ) -partitionNodes ns = partitionEithers $ flip fmap ns $ \case - InstantiationNode x -> Left x - ModuleNode x -> Right x - --- | Finish up after a load. -loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag --- If the link failed, unload everything and return. -loadFinish _all_ok Failed - = do hsc_env <- getSession - let interp = hscInterp hsc_env - liftIO $ unload interp hsc_env - modifySession discardProg - return Failed +-- | Finish up after a load. +loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. -loadFinish all_ok Succeeded +loadFinish all_ok = do modifySession discardIC return all_ok - --- | Forget the current program, but retain the persistent info in HscEnv -discardProg :: HscEnv -> HscEnv -discardProg hsc_env - = discardIC - $ hscUpdateHPT (const emptyHomePackageTable) - $ hsc_env { hsc_mod_graph = emptyMG } - -- | Discard the contents of the InteractiveContext, but keep the DynFlags and -- the loaded plugins. It will also keep ic_int_print and ic_monad if their -- names are from external packages. @@ -721,34 +737,42 @@ discardIC hsc_env -- by using top-level source file name as a base. guessOutputFile :: GhcMonad m => m () guessOutputFile = modifySession $ \env -> - let dflags = hsc_dflags env - platform = targetPlatform dflags - -- Force mod_graph to avoid leaking env - !mod_graph = hsc_mod_graph env - mainModuleSrcPath :: Maybe String - mainModuleSrcPath = do - ms <- mgLookupModule mod_graph (mainModIs env) - ml_hs_file (ms_location ms) - name = fmap dropExtension mainModuleSrcPath - - !name_exe = do - -- we must add the .exe extension unconditionally here, otherwise - -- when name has an extension of its own, the .exe extension will - -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248 - !name' <- if platformOS platform == OSMinGW32 - then fmap (<.> "exe") name - else name - mainModuleSrcPath' <- mainModuleSrcPath - -- #9930: don't clobber input files (unless they ask for it) - if name' == mainModuleSrcPath' - then throwGhcException . UsageError $ - "default output name would overwrite the input file; " ++ - "must specify -o explicitly" - else Just name' - in - case outputFile_ dflags of - Just _ -> env - Nothing -> hscSetFlags (dflags { outputFile_ = name_exe }) env + -- Force mod_graph to avoid leaking env + let !mod_graph = hsc_mod_graph env + new_home_graph = + flip unitEnv_map (hsc_HUG env) $ \hue -> + let dflags = homeUnitEnv_dflags hue + platform = targetPlatform dflags + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + ms <- mgLookupModule mod_graph (mainModIs hue) + ml_hs_file (ms_location ms) + name = fmap dropExtension mainModuleSrcPath + + -- MP: This exception is quite sensitive to being forced, if you + -- force it here then the error message is different because it gets + -- caught by a different error handler than the test (T9930fail) expects. + -- Putting an exception into DynFlags is probably not a great design but + -- I'll write this comment rather than more eagerly force the exception. + name_exe = do + -- we must add the .exe extension unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248 + !name' <- if platformOS platform == OSMinGW32 + then fmap (<.> "exe") name + else name + mainModuleSrcPath' <- mainModuleSrcPath + -- #9930: don't clobber input files (unless they ask for it) + if name' == mainModuleSrcPath' + then throwGhcException . UsageError $ + "default output name would overwrite the input file; " ++ + "must specify -o explicitly" + else Just name' + in + case outputFile_ dflags of + Just _ -> hue + Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } } + in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } } -- ----------------------------------------------------------------------------- -- @@ -923,7 +947,7 @@ data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey (SDoc, ResultVa -- the appropiate result of compiling a module but with -- cycles there can be additional indirection and can point to the result of typechecking a loop , nNODE :: Int - , hpt_var :: MVar HomePackageTable + , hug_var :: MVar HomeUnitGraph -- A global variable which is incrementally updated with the result -- of compiling modules. } @@ -960,7 +984,7 @@ data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be au -- For -j1, this wrapper doesn't do anything -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output -- into the log queue. - , withLogger :: forall a . Int -> ((Logger -> Logger) -> RunMakeM a) -> RunMakeM a + , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a , env_messager :: !(Maybe Messager) } @@ -970,15 +994,16 @@ type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a -- get its direct dependencies from. This might not be the corresponding build action -- if the module participates in a loop. This step also labels each node with a number for the output. -- See Note [Upsweep] for a high-level description. -interpretBuildPlan :: (M.Map ModuleNameWithIsBoot HomeModInfo) +interpretBuildPlan :: HomeUnitGraph + -> M.Map ModNodeKeyWithUid HomeModInfo -> (NodeKey -> [NodeKey]) -> [BuildPlan] -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle , [MakeAction] -- Actions we need to run in order to build everything , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end. -interpretBuildPlan old_hpt deps_map plan = do - hpt_var <- newMVar emptyHomePackageTable - ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hpt_var) +interpretBuildPlan hug old_hpt deps_map plan = do + hug_var <- newMVar hug + ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hug_var) return (mcycle, plans, collect_results (buildDep build_map)) where @@ -1016,28 +1041,35 @@ interpretBuildPlan old_hpt deps_map plan = do buildSingleModule rehydrate_nodes mod = do mod_idx <- nodeId home_mod_map <- getBuildMap - hpt_var <- gets hpt_var + hug_var <- gets hug_var -- 1. Get the transitive dependencies of this module, by looking up in the dependency map let direct_deps = deps_map (mkNodeKey mod) - doc_build_deps = catMaybes $ map (flip M.lookup home_mod_map) direct_deps + doc_build_deps = map (expectJust "dep_map" . flip M.lookup home_mod_map) direct_deps build_deps = map snd doc_build_deps -- 2. Set the default way to build this node, not in a loop here - let build_action = do - hsc_env <- asks hsc_env + let build_action = withCurrentUnit (moduleGraphNodeUnitId mod) $ case mod of - InstantiationNode iu -> const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) iu - ModuleNode ms -> do - let !old_hmi = M.lookup (msKey $ emsModSummary ms) old_hpt + InstantiationNode uid iu -> + const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hug hug_var build_deps) uid iu + ModuleNode build_deps ms -> do + let !old_hmi = M.lookup (msKey ms) old_hpt rehydrate_mods = mapMaybe moduleGraphNodeModule <$> rehydrate_nodes - hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hpt hpt_var build_deps) rehydrate_mods (emsModSummary ms) + build_deps_vars = map snd $ map (expectJust "build_deps" . flip M.lookup home_mod_map) build_deps + hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hug hug_var build_deps_vars) rehydrate_mods ms -- This global MVar is incrementally modified in order to avoid having to -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - hmi' <- liftIO $ modifyMVar hpt_var (\hpt -> do - let new_hpt = addHomeModInfoToHpt hmi hpt - new_hsc = setHPT new_hpt hsc_env + hsc_env <- asks hsc_env + hmi' <- liftIO $ modifyMVar hug_var (\hug -> do + let new_hpt = addHomeModInfoToHug hmi hug + new_hsc = setHUG new_hpt hsc_env maybeRehydrateAfter hmi new_hsc rehydrate_mods ) return (Just hmi') + LinkNode nks uid -> do + let link_deps = map snd $ map (\nk -> expectJust "build_deps_link" . flip M.lookup home_mod_map $ nk) nks + executeLinkNode (wait_deps_hug hug_var link_deps) (mod_idx, n_mods) uid nks + return Nothing + res_var <- liftIO newEmptyMVar let result_var = mkResultVar res_var @@ -1049,7 +1081,7 @@ interpretBuildPlan old_hpt deps_map plan = do buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) = buildSingleModule (Just deps) mn - buildModuleLoop :: [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] -> BuildM [MakeAction] + buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction] buildModuleLoop ms = do (build_modules, wait_modules) <- mapAndUnzipM (either (buildSingleModule Nothing) buildOneLoopyModule) ms res_var <- liftIO newEmptyMVar @@ -1060,21 +1092,26 @@ interpretBuildPlan old_hpt deps_map plan = do -- module loop will see the updated interfaces for all the identifiers in the loop. let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i) - let ms_i = zip (mapMaybe (fmap (msKey . emsModSummary) . moduleGraphNodeModSum . either id getNode) ms) [0..] + let ms_i = zip (mapMaybe (fmap msKey . moduleGraphNodeModSum . either id getNode) ms) [0..] mapM update_module_pipeline ms_i return $ build_modules ++ [MakeAction loop_action res_var] +withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a +withCurrentUnit uid = do + local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)}) + + upsweep :: Int -- ^ The number of workers we wish to run in parallel -> HscEnv -- ^ The base HscEnv, which is augmented for each module -> Maybe Messager - -> M.Map ModuleNameWithIsBoot HomeModInfo + -> M.Map ModNodeKeyWithUid HomeModInfo -> (NodeKey -> [NodeKey]) -- A function which computes the direct dependencies of a NodeKey -> [BuildPlan] -> IO (SuccessFlag, HscEnv, [HomeModInfo]) upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do - (cycle, pipelines, collect_result) <- interpretBuildPlan old_hpt direct_deps build_plan + (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) old_hpt direct_deps build_plan runPipelines n_jobs hsc_env mHscMessage pipelines res <- collect_result @@ -1092,18 +1129,22 @@ upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do let success_flag = successIf (all isJust res) return (success_flag, hsc_env', completed) -toCache :: [HomeModInfo] -> M.Map ModuleNameWithIsBoot HomeModInfo -toCache hmis = M.fromList ([(mi_mnwib $ hm_iface hmi, hmi) | hmi <- hmis]) +toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo +toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis]) + +miKey :: ModIface -> ModNodeKeyWithUid +miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi))) upsweep_inst :: HscEnv -> Maybe Messager -> Int -- index of module -> Int -- total number of modules + -> UnitId -> InstantiatedUnit -> IO () -upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do +upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do case mHscMessage of - Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid) + Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode uid iuid) Nothing -> return () runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid pure () @@ -1262,7 +1303,7 @@ topSortModuleGraph :: Bool -- ^ Drop hi-boot nodes? (see below) -> ModuleGraph - -> Maybe ModuleName + -> Maybe HomeUnitModule -- ^ Root module name. If @Nothing@, use the full graph. -> [SCC ModuleGraphNode] -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes @@ -1284,7 +1325,7 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod = -- the summaries we get a stable topological sort. topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod -topSortModules :: Bool -> [ModuleGraphNode] -> Maybe ModuleName -> [SCC ModuleGraphNode] +topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode] topSortModules drop_hs_boot_nodes summaries mb_root_mod = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph where @@ -1293,29 +1334,18 @@ topSortModules drop_hs_boot_nodes summaries mb_root_mod initial_graph = case mb_root_mod of Nothing -> graph - Just root_mod -> + Just (Module uid root_mod) -> -- restrict the graph to just those modules reachable from -- the specified module. We do this by building a graph with -- the full set of nodes, and determining the reachable set from -- the specified node. - let root | Just node <- lookup_node $ NodeKey_Module $ GWIB root_mod NotBoot + let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid , graph `hasVertexG` node = node | otherwise = throwGhcException (ProgramError "module does not exist") in graphFromEdgedVerticesUniq (seq root (reachableG graph root)) --- The nodes of the graph are keyed by (mod, is boot?) pairs for the current --- modules, and indefinite unit IDs for dependencies which are instantiated with --- our holes. --- --- NB: hsig files show up as *normal* nodes (not boot!), since they don't --- participate in cycles (for now) - -mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary -mkNodeMap summaries = ModNodeMap $ Map.fromList - [ (ms_mnwib $ emsModSummary s, s) | s <- summaries] - newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a } deriving (Functor, Traversable, Foldable) @@ -1331,6 +1361,12 @@ modNodeMapElems (ModNodeMap m) = Map.elems m modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a modNodeMapLookup k (ModNodeMap m) = Map.lookup k m +modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a +modNodeMapSingleton k v = ModNodeMap (M.singleton k v) + +modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a +modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n) + -- | Efficiently construct a map from a NodeKey to its list of transitive dependencies mkDepsMap :: [ModuleGraphNode] -> (NodeKey -> [NodeKey]) mkDepsMap nodes = @@ -1358,6 +1394,10 @@ warnUnnecessarySourceImports sccs = do logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs)) +-- This caches the answer to the question, if we are in this unit, what does +-- an import of this module mean. +type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary] + ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis) @@ -1374,69 +1414,95 @@ warnUnnecessarySourceImports sccs = do -- module, plus one for any hs-boot files. The imports of these nodes -- are all there, including the imports of non-home-package modules. downsweep :: HscEnv - -> [ExtendedModSummary] + -> [ModSummary] -- ^ Old summaries -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have -- the same module name; this is -- very useful for ghc -M - -> IO [Either DriverMessages ExtendedModSummary] + -> IO ([DriverMessages], [ModuleGraphNode]) -- The non-error elements of the returned list all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats downsweep hsc_env old_summaries excl_mods allow_dup_roots = do rootSummaries <- mapM getRootSummary roots - let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549 + let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549 root_map = mkRootMap rootSummariesOk checkDuplicates root_map - map0 <- loop (concatMap calcDeps rootSummariesOk) root_map + (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map) + let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps) + let unit_env = hsc_unit_env hsc_env + let tmpfs = hsc_tmpfs hsc_env + + let downsweep_errs = lefts $ concat $ M.elems map0 + downsweep_nodes = M.elems deps + + (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) + all_nodes = downsweep_nodes ++ unit_nodes + all_errs = all_root_errs ++ downsweep_errs ++ other_errs + all_root_errs = closure_errs ++ map snd root_errs + -- if we have been passed -fno-code, we enable code generation -- for dependencies of modules that have -XTemplateHaskell, -- otherwise those modules will fail to compile. -- See Note [-fno-code mode] #8025 - let default_backend = platformDefaultBackend (targetPlatform dflags) - let home_unit = hsc_home_unit hsc_env - let tmpfs = hsc_tmpfs hsc_env - map1 <- case backend dflags of - NoBackend -> enableCodeGenForTH logger tmpfs home_unit default_backend map0 - _ -> return map0 - if null errs - then pure $ concat $ modNodeMapElems map1 - else pure $ map Left errs + th_enabled_nodes <- case backend dflags of + NoBackend -> enableCodeGenForTH logger tmpfs unit_env all_nodes + _ -> return all_nodes + if null all_root_errs + then return (all_errs, th_enabled_nodes) + else pure $ (all_root_errs, []) where - -- TODO(@Ericson2314): Probably want to include backpack instantiations - -- in the map eventually for uniformity - calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms + -- Dependencies arising on a unit (backpack and module linking deps) + unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] + unitModuleNodes summaries uid hue = + let instantiation_nodes = instantiationNodes uid (homeUnitEnv_units hue) + in map Right instantiation_nodes + ++ maybeToList (linkNodes (instantiation_nodes ++ summaries) uid hue) + + calcDeps ms = [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ] dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env roots = hsc_targets hsc_env - old_summary_map :: ModNodeMap ExtendedModSummary - old_summary_map = mkNodeMap old_summaries + -- A cache from file paths to the already summarised modules. + -- Reuse these if we can because the most expensive part of downsweep is + -- reading the headers. + old_summary_map :: M.Map FilePath ModSummary + old_summary_map = M.fromList [(msHsFilePath ms, ms) | ms <- old_summaries] - getRootSummary :: Target -> IO (Either DriverMessages ExtendedModSummary) + getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary) getRootSummary Target { targetId = TargetFile file mb_phase , targetContents = maybe_buf + , targetUnitId = uid } - = do exists <- liftIO $ doesFileExist file + = do let offset_file = augmentByWorkingDirectory dflags file + exists <- liftIO $ doesFileExist offset_file if exists || isJust maybe_buf - then summariseFile hsc_env old_summaries file mb_phase + then first (uid,) <$> + summariseFile hsc_env home_unit old_summary_map offset_file mb_phase maybe_buf - else return $ Left $ singleMessage - $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound file) + else return $ Left $ (uid,) $ singleMessage + $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file) + where + dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)) + home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) getRootSummary Target { targetId = TargetModule modl , targetContents = maybe_buf + , targetUnitId = uid } - = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot - (L rootLoc modl) + = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot + (L rootLoc modl) (ThisPkg (homeUnitId home_unit)) maybe_buf excl_mods case maybe_summary of - Nothing -> return $ Left $ moduleNotFoundErr modl - Just s -> return s - + FoundHome s -> return (Right s) + FoundHomeWithError err -> return (Left err) + _ -> return $ Left $ (uid, moduleNotFoundErr modl) + where + home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) rootLoc = mkGeneralSrcSpan (fsLit "<command line>") -- In a root module, the filename is allowed to diverge from the module @@ -1444,53 +1510,134 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- defining the same module (otherwise the duplicates will be silently -- ignored, leading to confusing behaviour). checkDuplicates - :: ModNodeMap - [Either DriverMessages - ExtendedModSummary] + :: DownsweepCache -> IO () checkDuplicates root_map | allow_dup_roots = return () | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr (emsModSummary <$> head dup_roots) + | otherwise = liftIO $ multiRootsErr (head dup_roots) where - dup_roots :: [[ExtendedModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton $ map rights (M.elems root_map) + + -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit + loopSummaries :: [ModSummary] + -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId), + DownsweepCache) + -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache) + loopSummaries [] done = return done + loopSummaries (ms:next) (done, pkgs, summarised) + | Just {} <- M.lookup k done + = loopSummaries next (done, pkgs, summarised) + -- Didn't work out what the imports mean yet, now do that. + | otherwise = do + (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised + -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. + (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' + loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'') + where + k = NodeKey_Module (msKey ms) + + hs_file_for_boot + | HsBootFile <- ms_hsc_src ms = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) + | otherwise = Nothing + - loop :: [GenWithIsBoot (Located ModuleName)] + -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover + -- a new module by doing this. + loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))] -- Work list: process these modules - -> ModNodeMap [Either DriverMessages ExtendedModSummary] + -> M.Map NodeKey ModuleGraphNode + -> DownsweepCache -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True - -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary]) + -> IO ([NodeKey], Set.Set (UnitId, UnitId), + + M.Map NodeKey ModuleGraphNode, DownsweepCache) -- The result is the completed NodeMap - loop [] done = return done - loop (s : ss) done - | Just summs <- modNodeMapLookup key done - = if isSingleton summs then - loop ss done - else - do { multiRootsErr (emsModSummary <$> rights summs) - ; return (ModNodeMap Map.empty) - } + loopImports [] done summarised = return ([], Set.empty, done, summarised) + loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised + | Just summs <- M.lookup cache_key summarised + = case summs of + [Right ms] -> do + let nk = NodeKey_Module (msKey ms) + (rest, pkgs, summarised', done') <- loopImports ss done summarised + return (nk: rest, pkgs, summarised', done') + [Left _err] -> + loopImports ss done summarised + _errs -> do + loopImports ss done summarised | otherwise - = do mb_s <- summariseModule hsc_env old_summary_map - is_boot wanted_mod + = do + mb_s <- summariseModule hsc_env home_unit old_summary_map + is_boot wanted_mod mb_pkg Nothing excl_mods case mb_s of - Nothing -> loop ss done - Just (Left e) -> loop ss (modNodeMapInsert key [Left e] done) - Just (Right s)-> do - new_map <- - loop (calcDeps s) (modNodeMapInsert key [Right s] done) - loop ss new_map + NotThere -> loopImports ss done summarised + External uid -> do + (other_deps, pkgs, done', summarised') <- loopImports ss done summarised + return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised') + FoundInstantiation iud -> do + (other_deps, pkgs, done', summarised') <- loopImports ss done summarised + return (NodeKey_Unit iud : other_deps, pkgs, done', summarised') + FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) + FoundHome s -> do + (done', pkgs1, summarised') <- + loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised) + (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised' + + -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. + return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised) where - GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s + cache_key = (home_uid, mb_pkg, unLoc <$> gwib) + home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib wanted_mod = L loc mod - key = GWIB - { gwib_mod = unLoc wanted_mod - , gwib_isBoot = is_boot - } + +-- This function checks then important property that if both p and q are home units +-- then any dependency of p, which transitively depends on q is also a home unit. +checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages] +-- Fast path, trivially closed. +checkHomeUnitsClosed ue home_id_set home_imp_ids + | Set.size home_id_set == 1 = [] + | otherwise = + let res = foldMap loop home_imp_ids + -- Now check whether everything which transitively depends on a home_unit is actually a home_unit + -- These units are the ones which we need to load as home packages but failed to do for some reason, + -- it's a bug in the tool invoking GHC. + bad_unit_ids = Set.difference res home_id_set + in if Set.null bad_unit_ids + then [] + else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] + + where + rootLoc = mkGeneralSrcSpan (fsLit "<command line>") + -- TODO: This could repeat quite a bit of work but I struggled to write this function. + -- Which units transitively depend on a home unit + loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit + loop (from_uid, uid) = + let us = ue_findHomeUnitEnv from_uid ue in + let um = unitInfoMap (homeUnitEnv_units us) in + case Map.lookup uid um of + Nothing -> pprPanic "uid not found" (ppr uid) + Just ui -> + let depends = unitDepends ui + home_depends = Set.fromList depends `Set.intersection` home_id_set + other_depends = Set.fromList depends `Set.difference` home_id_set + in + -- Case 1: The unit directly depends on a home_id + if not (null home_depends) + then + let res = foldMap (loop . (from_uid,)) other_depends + in Set.insert uid res + -- Case 2: Check the rest of the dependencies, and then see if any of them depended on + else + let res = foldMap (loop . (from_uid,)) other_depends + in + if not (Set.null res) + then Set.insert uid res + else res -- | Update the every ModSummary that is depended on -- by a module that needs template haskell. We enable codegen to @@ -1500,19 +1647,18 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots enableCodeGenForTH :: Logger -> TmpFs - -> HomeUnit - -> Backend - -> ModNodeMap [Either DriverMessages ExtendedModSummary] - -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary]) -enableCodeGenForTH logger tmpfs home_unit = - enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession + -> UnitEnv + -> [ModuleGraphNode] + -> IO [ModuleGraphNode] +enableCodeGenForTH logger tmpfs unit_env = + enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession unit_env where condition = isTemplateHaskellOrQQNonBoot - should_modify (ModSummary { ms_hspp_opts = dflags }) = + should_modify ms@(ModSummary { ms_hspp_opts = dflags }) = backend dflags == NoBackend && -- Don't enable codegen for TH on indefinite packages; we -- can't compile anything anyway! See #16219. - isHomeUnitDefinite home_unit + isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env) -- | Helper used to implement 'enableCodeGenForTH'. -- In particular, this enables @@ -1527,22 +1673,22 @@ enableCodeGenWhen -> (ModSummary -> Bool) -> TempFileLifetime -> TempFileLifetime - -> Backend - -> ModNodeMap [Either DriverMessages ExtendedModSummary] - -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary]) -enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap = - traverse (traverse (traverse enable_code_gen)) nodemap + -> UnitEnv + -> [ModuleGraphNode] + -> IO [ModuleGraphNode] +enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife unit_env mod_graph = + mapM enable_code_gen mod_graph where - enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary - enable_code_gen (ExtendedModSummary ms bkp_deps) + defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env) + enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode + enable_code_gen n@(ModuleNode deps ms) | ModSummary - { ms_mod = ms_mod - , ms_location = ms_location + { ms_location = ms_location , ms_hsc_src = HsSrcFile , ms_hspp_opts = dflags } <- ms , should_modify ms - , ms_mod `Set.member` needs_codegen_set + , mkNodeKey n `Set.member` needs_codegen_set = do let new_temp_file suf dynsuf = do tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf @@ -1567,65 +1713,28 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd , ml_obj_file = o_file , ml_dyn_hi_file = dyn_hi_file , ml_dyn_obj_file = dyn_o_file } - , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd} + , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms} } - pure (ExtendedModSummary ms' bkp_deps) - | otherwise = return (ExtendedModSummary ms bkp_deps) + pure (ModuleNode deps ms') + enable_code_gen ms = return ms + + + (mg, lookup_node) = moduleGraphNodes False mod_graph + needs_codegen_set = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) has_th_set) - needs_codegen_set = transitive_deps_set - [ ms - | mss <- modNodeMapElems nodemap - , Right (ExtendedModSummary { emsModSummary = ms }) <- mss + + has_th_set = + [ mkNodeKey mn + | mn@(ModuleNode _ ms) <- mod_graph , condition ms ] - -- find the set of all transitive dependencies of a list of modules. - transitive_deps_set :: [ModSummary] -> Set.Set Module - transitive_deps_set modSums = foldl' go Set.empty modSums - where - go marked_mods ms@ModSummary{ms_mod} - | ms_mod `Set.member` marked_mods = marked_mods - | otherwise = - let deps = - [ dep_ms - -- If a module imports a boot module, msDeps helpfully adds a - -- dependency to that non-boot module in it's result. This - -- means we don't have to think about boot modules here. - | dep <- msDeps ms - , NotBoot == gwib_isBoot dep - , dep_ms_0 <- toList $ modNodeMapLookup (unLoc <$> dep) nodemap - , dep_ms_1 <- toList $ dep_ms_0 - , (ExtendedModSummary { emsModSummary = dep_ms }) <- toList $ dep_ms_1 - ] - new_marked_mods = Set.insert ms_mod marked_mods - in foldl' go new_marked_mods deps - +-- | Populate the Downsweep cache with the root modules. mkRootMap - :: [ExtendedModSummary] - -> ModNodeMap [Either DriverMessages ExtendedModSummary] -mkRootMap summaries = ModNodeMap $ Map.insertListWith - (flip (++)) - [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ] - Map.empty - --- | Returns the dependencies of the ModSummary s. --- A wrinkle is that for a {-# SOURCE #-} import we return --- *both* the hs-boot file --- *and* the source file --- as "dependencies". That ensures that the list of all relevant --- modules always contains B.hs if it contains B.hs-boot. --- Remember, this pass isn't doing the topological sort. It's --- just gathering the list of all relevant ModSummaries -msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)] -msDeps s = [ d - | m <- ms_home_srcimps s - , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot } - , GWIB { gwib_mod = m, gwib_isBoot = NotBoot } - ] - ] - ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot } - | m <- ms_home_imps s - ] + :: [ModSummary] + -> DownsweepCache +mkRootMap summaries = Map.fromListWith (flip (++)) + [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ] ----------------------------------------------------------------------------- -- Summarising modules @@ -1642,19 +1751,20 @@ msDeps s = [ d summariseFile :: HscEnv - -> [ExtendedModSummary] -- old summaries + -> HomeUnit + -> M.Map FilePath ModSummary -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase -> Maybe (StringBuffer,UTCTime) - -> IO (Either DriverMessages ExtendedModSummary) + -> IO (Either DriverMessages ModSummary) -summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf +summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, But we have to look up the summary -- by source file, rather than module name as we do in summarise. - | Just old_summary <- findSummaryBySourceFile old_summaries src_fn + | Just old_summary <- M.lookup src_fn old_summaries = do - let location = ms_location $ emsModSummary old_summary + let location = ms_location $ old_summary src_hash <- get_src_hash -- The file exists; we checked in getRootSummary above. @@ -1671,6 +1781,8 @@ summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf = do src_hash <- get_src_hash new_summary src_fn src_hash where + -- change the main active unit so all operations happen relative to the given unit + hsc_env = hscSetActiveHomeUnit home_unit hsc_env' -- src_fn does not necessarily exist on the filesystem, so we need to -- check what kind of target we are dealing with get_src_hash = case maybe_buf of @@ -1706,26 +1818,14 @@ summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf , nms_preimps = preimps } -findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary -findSummaryBySourceFile summaries file = case - [ ms - | ms <- summaries - , HsSrcFile <- [ms_hsc_src $ emsModSummary ms] - , let derived_file = ml_hs_file $ ms_location $ emsModSummary ms - , expectJust "findSummaryBySourceFile" derived_file == file - ] - of - [] -> Nothing - (x:_) -> Just x - checkSummaryHash :: HscEnv - -> (Fingerprint -> IO (Either e ExtendedModSummary)) - -> ExtendedModSummary -> ModLocation -> Fingerprint - -> IO (Either e ExtendedModSummary) + -> (Fingerprint -> IO (Either e ModSummary)) + -> ModSummary -> ModLocation -> Fingerprint + -> IO (Either e ModSummary) checkSummaryHash hsc_env new_summary - (ExtendedModSummary { emsModSummary = old_summary, emsInstantiatedUnits = bkp_deps}) + old_summary location src_hash | ms_hs_hash old_summary == src_hash && not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do @@ -1737,88 +1837,78 @@ checkSummaryHash -- and it was likely flushed in depanal. This is not technically -- needed when we're called from sumariseModule but it shouldn't -- hurt. + -- Also, only add to finder cache for non-boot modules as the finder cache + -- makes sure to add a boot suffix for boot files. _ <- do - let home_unit = hsc_home_unit hsc_env let fc = hsc_FC hsc_env - addHomeModuleToFinder fc home_unit - (moduleName (ms_mod old_summary)) location + case ms_hsc_src old_summary of + HsSrcFile -> addModuleToFinder fc (ms_mod old_summary) location + _ -> return () hi_timestamp <- modificationTimeIfExists (ml_hi_file location) hie_timestamp <- modificationTimeIfExists (ml_hie_file location) return $ Right - ( ExtendedModSummary { emsModSummary = old_summary + ( old_summary { ms_obj_date = obj_timestamp , ms_iface_date = hi_timestamp , ms_hie_date = hie_timestamp } - , emsInstantiatedUnits = bkp_deps - } ) | otherwise = -- source changed: re-summarise. new_summary src_hash +data SummariseResult = + FoundInstantiation InstantiatedUnit + | FoundHomeWithError (UnitId, DriverMessages) + | FoundHome ModSummary + | External UnitId + | NotThere + -- Summarise a module, and pick up source and timestamp. summariseModule :: HscEnv - -> ModNodeMap ExtendedModSummary + -> HomeUnit + -> M.Map FilePath ModSummary -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised + -> PkgQual -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude - -> IO (Maybe (Either DriverMessages ExtendedModSummary)) -- Its new summary + -> IO SummariseResult + -summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) +summariseModule hsc_env' home_unit old_summary_map is_boot (L loc wanted_mod) mb_pkg maybe_buf excl_mods | wanted_mod `elem` excl_mods - = return Nothing - - | Just old_summary <- modNodeMapLookup - (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot }) - old_summary_map - = do -- Find its new timestamp; all the - -- ModSummaries in the old map have valid ml_hs_files - let location = ms_location $ emsModSummary old_summary - src_fn = expectJust "summariseModule" (ml_hs_file location) - - -- check the hash on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has disappeared, we need to call the Finder again. - case maybe_buf of - Just (buf,_) -> - Just <$> check_hash old_summary location src_fn (fingerprintStringBuffer buf) - Nothing -> do - mb_hash <- fileHashIfExists src_fn - case mb_hash of - Just hash -> Just <$> check_hash old_summary location src_fn hash - Nothing -> find_it - + = return NotThere | otherwise = find_it where - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags - mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - fc = hsc_FC hsc_env - units = hsc_units hsc_env + -- Temporarily change the currently active home unit so all operations + -- happen relative to it + hsc_env = hscSetActiveHomeUnit home_unit hsc_env' + dflags = hsc_dflags hsc_env - check_hash old_summary location src_fn = - checkSummaryHash - hsc_env - (new_summary location (ms_mod $ emsModSummary old_summary) src_fn) - old_summary location + find_it :: IO SummariseResult find_it = do - found <- findImportedModule fc fopts units mhome_unit wanted_mod NoPkgQual + found <- findImportedModule hsc_env wanted_mod mb_pkg case found of Found location mod - | isJust (ml_hs_file location) -> + | isJust (ml_hs_file location) -> do -- Home package - Just <$> just_found location mod - - _ -> return Nothing + fresult <- just_found location mod + return $ case fresult of + Left err -> FoundHomeWithError (moduleUnitId mod, err) + Right ms -> FoundHome ms + | VirtUnit iud <- moduleUnit mod + , not (isHomeModule home_unit mod) + -> return $ FoundInstantiation iud + | otherwise -> return $ External (moduleUnitId mod) + _ -> return NotThere -- Not found -- (If it is TRULY not found at all, we'll -- error when we actually try to compile) @@ -1836,12 +1926,32 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_h <- fileHashIfExists src_fn case maybe_h of Nothing -> return $ Left $ noHsFileErr loc src_fn - Just h -> new_summary location' mod src_fn h + Just h -> new_summary_cache_check location' mod src_fn h + new_summary_cache_check loc mod src_fn h + | Just old_summary <- Map.lookup src_fn old_summary_map = + + -- check the hash on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has changed then need to resummarise. + case maybe_buf of + Just (buf,_) -> + checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf) + Nothing -> + checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h + | otherwise = new_summary loc mod src_fn h + + new_summary :: ModLocation + -> Module + -> FilePath + -> Fingerprint + -> IO (Either DriverMessages ModSummary) new_summary location mod src_fn src_hash = runExceptT $ do preimps@PreprocessedImports {..} - <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf + -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP + -- See multiHomeUnits_cpp2 test + <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf -- NB: Despite the fact that is_boot is a top-level parameter, we -- don't actually know coming into this function what the HscSource @@ -1859,7 +1969,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc $ DriverFileModuleNameMismatch pi_mod_name wanted_mod - let instantiations = fromMaybe [] (homeUnitInstantiations <$> mhome_unit) + let instantiations = homeUnitInstantiations home_unit when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations @@ -1887,7 +1997,7 @@ data MakeNewModSummary , nms_preimps :: PreprocessedImports } -makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary +makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary makeNewModSummary hsc_env MakeNewModSummary{..} = do let PreprocessedImports{..} = nms_preimps obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location) @@ -1896,10 +2006,9 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name - (implicit_sigs, inst_deps) <- implicitRequirementsShallow hsc_env pi_theimps + (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps - return $ ExtendedModSummary - { emsModSummary = + return $ ModSummary { ms_mod = nms_mod , ms_hsc_src = nms_hsc_src @@ -1920,8 +2029,6 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do , ms_obj_date = obj_timestamp , ms_dyn_obj_date = dyn_obj_timestamp } - , emsInstantiatedUnits = inst_deps - } data PreprocessedImports = PreprocessedImports @@ -2012,8 +2119,7 @@ noHsFileErr loc path = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path) moduleNotFoundErr :: ModuleName -> DriverMessages -moduleNotFoundErr mod - = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod) +moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod) multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" @@ -2032,10 +2138,7 @@ cyclicModuleErr mss case findCycle graph of Nothing -> text "Unexpected non-cycle" <+> ppr mss Just path0 -> vcat - [ case partitionNodes path0 of - ([],_) -> text "Module imports form a cycle:" - (_,[]) -> text "Module instantiations form a cycle:" - _ -> text "Module imports and instantiations form a cycle:" + [ text "Module graph contains a cycle:" , nest 2 (show_path path0)] where graph :: [Node NodeKey ModuleGraphNode] @@ -2043,25 +2146,11 @@ cyclicModuleErr mss [ DigraphNode { node_payload = ms , node_key = mkNodeKey ms - , node_dependencies = get_deps ms + , node_dependencies = nodeDependencies False ms } | ms <- mss ] - get_deps :: ModuleGraphNode -> [NodeKey] - get_deps = \case - InstantiationNode iuid -> - [ NodeKey_Module $ GWIB { gwib_mod = hole, gwib_isBoot = NotBoot } - | hole <- uniqDSetToList $ instUnitHoles iuid - ] - ModuleNode (ExtendedModSummary ms bds) -> - [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot } - | m <- ms_home_srcimps ms ] ++ - [ NodeKey_Unit inst_unit - | inst_unit <- bds ] ++ - [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot } - | m <- ms_home_imps ms ] - show_path :: [ModuleGraphNode] -> SDoc show_path [] = panic "show_path" show_path [m] = ppr_node m <+> text "imports itself" @@ -2073,8 +2162,9 @@ cyclicModuleErr mss go (m:ms) = (text "which imports" <+> ppr_node m) : go ms ppr_node :: ModuleGraphNode -> SDoc - ppr_node (ModuleNode m) = text "module" <+> ppr_ms (emsModSummary m) - ppr_node (InstantiationNode u) = text "instantiated unit" <+> ppr u + ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m + ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u + ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid) ppr_ms :: ModSummary -> SDoc ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> @@ -2089,12 +2179,16 @@ cleanCurrentModuleTempFilesMaybe logger tmpfs dflags = addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv addDepsToHscEnv deps hsc_env = - hscUpdateHPT (const $ listHMIToHpt deps) hsc_env + hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug deps) hsc_env setHPT :: HomePackageTable -> HscEnv -> HscEnv setHPT deps hsc_env = hscUpdateHPT (const $ deps) hsc_env +setHUG :: HomeUnitGraph -> HscEnv -> HscEnv +setHUG deps hsc_env = + hscUpdateHUG (const $ deps) hsc_env + -- | Wrap an action to catch and handle exceptions. wrapAction :: HscEnv -> IO a -> IO (Maybe a) wrapAction hsc_env k = do @@ -2119,9 +2213,9 @@ wrapAction hsc_env k = do _ -> errorMsg lcl_logger (text (show exc)) return Nothing -withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> RunMakeM b) -> RunMakeM b +withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b withParLog lqq_var k cont = do - let init_log = liftIO $ do + let init_log = do -- Make a new log queue lq <- newLogQueue k -- Add it into the LogQueueQueue @@ -2130,49 +2224,49 @@ withParLog lqq_var k cont = do finish_log lq = liftIO (finishLogQueue lq) MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq))) -withLoggerHsc :: Int -> (HscEnv -> RunMakeM a) -> RunMakeM a -withLoggerHsc k cont = do - MakeEnv{withLogger, hsc_env} <- ask +withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a +withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do withLogger k $ \modifyLogger -> do let lcl_logger = modifyLogger (hsc_logger hsc_env) hsc_env' = hsc_env { hsc_logger = lcl_logger } -- Run continuation with modified logger cont hsc_env' --- Executing compilation graph nodes executeInstantiationNode :: Int -> Int - -> RunMakeM HomePackageTable + -> RunMakeM HomeUnitGraph + -> UnitId -> InstantiatedUnit -> RunMakeM () -executeInstantiationNode k n wait_deps iu = do - withLoggerHsc k $ \hsc_env -> do +executeInstantiationNode k n wait_deps uid iu = do -- Wait for the dependencies of this node deps <- wait_deps + env <- ask -- Output of the logger is mediated by a central worker to -- avoid output interleaving - let lcl_hsc_env = setHPT deps hsc_env msg <- asks env_messager - lift $ MaybeT $ wrapAction lcl_hsc_env $ do - res <- upsweep_inst lcl_hsc_env msg k n iu - cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) - return res + lift $ MaybeT $ withLoggerHsc k env $ \hsc_env -> + let lcl_hsc_env = setHUG deps hsc_env + in wrapAction lcl_hsc_env $ do + res <- upsweep_inst lcl_hsc_env msg k n uid iu + cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) + return res executeCompileNode :: Int -> Int -> Maybe HomeModInfo - -> RunMakeM HomePackageTable + -> RunMakeM HomeUnitGraph -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling -> ModSummary -> RunMakeM HomeModInfo executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do - MakeEnv{..} <- ask - deps <- wait_deps - -- Rehydrate any dependencies if this module had a boot file or is a signature file. - withLoggerHsc k $ \hsc_env -> do - hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHPT deps hsc_env) mod fixed_mrehydrate_mods + me@MakeEnv{..} <- ask + deps <- wait_deps + -- Rehydrate any dependencies if this module had a boot file or is a signature file. + lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do + hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHUG deps hsc_env) mod fixed_mrehydrate_mods let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas lcl_dynflags = ms_hspp_opts mod let lcl_hsc_env = @@ -2181,7 +2275,7 @@ executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do hydrated_hsc_env -- Compile the module, locking with a semphore to avoid too many modules -- being compiled at the same time leading to high memory usage. - lift $ MaybeT (withAbstractSem compile_sem $ wrapAction lcl_hsc_env $ do + wrapAction lcl_hsc_env $ do res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags return res) @@ -2238,14 +2332,14 @@ maybeRehydrateBefore hsc_env mod (Just mns) = do maybeRehydrateAfter :: HomeModInfo -> HscEnv -> Maybe [ModuleName] - -> IO (HomePackageTable, HomeModInfo) -maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HPT new_hsc, hmi) + -> IO (HomeUnitGraph, HomeModInfo) +maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HUG new_hsc, hmi) maybeRehydrateAfter hmi new_hsc (Just mns) = do let new_hpt = hsc_HPT new_hsc hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns new_mod_name = moduleName (mi_module (hm_iface hmi)) - final_hpt <- hsc_HPT <$> rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis) - return (final_hpt, expectJust "rehydrate" $ lookupHpt final_hpt new_mod_name) + hsc_env <- rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis) + return (hsc_HUG hsc_env, expectJust "rehydrate" $ lookupHpt (hsc_HPT hsc_env) new_mod_name) {- Note [Hydrating Modules] @@ -2373,12 +2467,35 @@ Also closely related are -} +executeLinkNode :: RunMakeM HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM () +executeLinkNode wait_deps kn uid deps = do + withCurrentUnit uid $ do + MakeEnv{..} <- ask + hug <- wait_deps + let dflags = hsc_dflags hsc_env + let hsc_env' = setHUG hug hsc_env + msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager + + linkresult <- liftIO $ withAbstractSem compile_sem $ do + link (ghcLink dflags) + (hsc_logger hsc_env') + (hsc_tmpfs hsc_env') + (hsc_hooks hsc_env') + dflags + (hsc_unit_env hsc_env') + True -- We already decided to link + msg' + (hsc_HPT hsc_env') + case linkresult of + Failed -> fail "Link Failed" + Succeeded -> return () + -- | Wait for some dependencies to finish and then read from the given MVar. -wait_deps_hpt :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b -wait_deps_hpt hpt_var deps = do +wait_deps_hug :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b +wait_deps_hug hug_var deps = do _ <- wait_deps deps - liftIO $ readMVar hpt_var + liftIO $ readMVar hug_var -- | Wait for dependencies to finish, and then return their results. @@ -2394,27 +2511,6 @@ wait_deps (x:xs) = do -- Executing the pipelines -- | Start a thread which reads from the LogQueueQueue -logThread :: Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit - -> TVar LogQueueQueue -- Queue for logs - -> IO (IO ()) -logThread logger stopped lqq_var = do - finished_var <- newEmptyMVar - _ <- forkIO $ print_logs *> putMVar finished_var () - return (takeMVar finished_var) - where - finish = mapM (printLogs logger) - - print_logs = join $ atomically $ do - lqq <- readTVar lqq_var - case dequeueLogQueueQueue lqq of - Just (lq, lqq') -> do - writeTVar lqq_var lqq' - return (printLogs logger lq *> print_logs) - Nothing -> do - -- No log to print, check if we are finished. - stopped <- readTVar stopped - if not stopped then retry - else return (finish (allLogQueues lqq)) label_self :: String -> IO () @@ -2458,7 +2554,7 @@ runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do -- will add it's LogQueue into this queue. log_queue_queue_var <- newTVarIO newLogQueueQueue -- Thread which coordinates the printing of logs - wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var + wait_log_thread <- logThread n_jobs (length all_pipelines) (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue. diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index ffe5a73399..a461ead22c 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -16,7 +16,6 @@ where import GHC.Prelude import qualified GHC -import GHC.Driver.Config.Finder import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ppr @@ -36,7 +35,6 @@ import GHC.Utils.TmpFs import GHC.Iface.Load (cannotFindModule) -import GHC.Unit.Env import GHC.Unit.Module import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph @@ -216,14 +214,15 @@ processDeps dflags _ _ _ _ (CyclicSCC nodes) throwGhcExceptionIO $ ProgramError $ showSDoc dflags $ GHC.cyclicModuleErr nodes -processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node)) +processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node)) = -- There shouldn't be any backpack instantiations; report them as well throwGhcExceptionIO $ ProgramError $ showSDoc dflags $ vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:" , nest 2 $ ppr node ] +processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return () -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _))) +processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node)) = do { let extra_suffixes = depSuffixes dflags include_pkg_deps = depIncludePkgDeps dflags src_file = msHsFilePath node @@ -291,14 +290,9 @@ findDependency :: HscEnv -> Bool -- Record dependency on package modules -> IO (Maybe FilePath) -- Interface file findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do - let fc = hsc_FC hsc_env - let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags -- Find the module; this will be fast because -- we've done it once during downsweep - r <- findImportedModule fc fopts units mhome_unit imp pkg + r <- findImportedModule hsc_env imp pkg case r of Found loc _ -- Home package: just depend on the .hi or hi-boot file @@ -395,10 +389,9 @@ dumpModCycles logger module_graph | otherwise = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles) where - topoSort = filterToposortToModules $ - GHC.topSortModuleGraph True module_graph Nothing + topoSort = GHC.topSortModuleGraph True module_graph Nothing - cycles :: [[ModSummary]] + cycles :: [[ModuleGraphNode]] cycles = [ c | CyclicSCC c <- topoSort ] @@ -406,14 +399,16 @@ dumpModCycles logger module_graph $$ pprCycle c $$ blankLine | (n,c) <- [1..] `zip` cycles ] -pprCycle :: [ModSummary] -> SDoc +pprCycle :: [ModuleGraphNode] -> SDoc -- Print a cycle, but show only the imports within the cycle pprCycle summaries = pp_group (CyclicSCC summaries) where cycle_mods :: [ModuleName] -- The modules in this cycle - cycle_mods = map (moduleName . ms_mod) summaries + cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries] - pp_group (AcyclicSCC ms) = pp_ms ms + pp_group :: SCC ModuleGraphNode -> SDoc + pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms + pp_group (AcyclicSCC _) = empty pp_group (CyclicSCC mss) = assert (not (null boot_only)) $ -- The boot-only list must be non-empty, else there would @@ -422,14 +417,15 @@ pprCycle summaries = pp_group (CyclicSCC summaries) pp_ms loop_breaker $$ vcat (map pp_group groups) where (boot_only, others) = partition is_boot_only mss - is_boot_only ms = not (any in_group (map snd (ms_imps ms))) + is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms))) + is_boot_only _ = False in_group (L _ m) = m `elem` group_mods - group_mods = map (moduleName . ms_mod) mss + group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss] - loop_breaker = head boot_only + loop_breaker = head ([ms | ModuleNode _ ms <- boot_only]) all_others = tail boot_only ++ others - groups = filterToposortToModules $ - GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing + groups = + GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <+> (pp_imps empty (map snd (ms_imps summary)) $$ diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 22bd9c3280..3aaf9f298e 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -75,6 +75,7 @@ import GHC.Utils.TmpFs import GHC.Linker.ExtraObj import GHC.Linker.Static +import GHC.Linker.Static.Utils import GHC.Linker.Types import GHC.Utils.Outputable @@ -121,6 +122,7 @@ import Data.Either ( partitionEithers ) import qualified Data.Set as Set import Data.Time ( getCurrentTime ) +import GHC.Iface.Recomp -- Simpler type synonym for actions in the pipeline monad type P m = TPipelineClass TPhase m @@ -301,10 +303,12 @@ compileOne' mHscMessage = (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp) | otherwise = (backend dflags, dflags2) - dflags = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] } + -- Note [Filepaths and Multiple Home Units] + dflags = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] } upd_summary = summary { ms_hspp_opts = dflags } hsc_env = hscSetFlags dflags hsc_env0 + -- --------------------------------------------------------------------------- -- Link -- @@ -364,6 +368,7 @@ link :: GhcLink -- ^ interactive or batch -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode? + -> Maybe (RecompileRequired -> IO ()) -> HomePackageTable -- ^ what to link -> IO SuccessFlag @@ -374,7 +379,7 @@ link :: GhcLink -- ^ interactive or batch -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt = +link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt = case linkHook hooks of Nothing -> case ghcLink of NoLink -> return Succeeded @@ -390,7 +395,7 @@ link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt = -> panicBadLink LinkInMemory Just h -> h ghcLink dflags batch_attempt_linking hpt where - normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking hpt + normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt panicBadLink :: GhcLink -> a @@ -402,10 +407,11 @@ link' :: Logger -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode? + -> Maybe (RecompileRequired -> IO ()) -> HomePackageTable -- ^ what to link -> IO SuccessFlag -link' logger tmpfs dflags unit_env batch_attempt_linking hpt +link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt | batch_attempt_linking = do let @@ -439,12 +445,12 @@ link' logger tmpfs dflags unit_env batch_attempt_linking hpt linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps - if not (gopt Opt_ForceRecomp dflags) && not linking_needed + forM_ mHscMessager $ \hscMessage -> hscMessage linking_needed + if not (gopt Opt_ForceRecomp dflags) && (linking_needed == UpToDate) then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.") return Succeeded else do - compilationProgressMsg logger (text "Linking " <> text exe_file <> text " ...") -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of @@ -465,7 +471,7 @@ link' logger tmpfs dflags unit_env batch_attempt_linking hpt return Succeeded -linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool +linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit @@ -475,7 +481,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do exe_file = exeFileName platform staticLink (outputFile_ dflags) e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of - Left _ -> return True + Left _ -> return MustCompile Right t -> do -- first check object files and extra_ld_inputs let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] @@ -483,7 +489,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do let (errs,extra_times) = partitionEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times if not (null errs) || any (t <) obj_times - then return True + then return (RecompBecause ObjectsChanged) else do -- next, check libraries. XXX this only checks Haskell libraries, @@ -493,13 +499,18 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ] pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs - if any isNothing pkg_libfiles then return True else do + if any isNothing pkg_libfiles then return (RecompBecause LibraryChanged) else do e_lib_times <- mapM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles) let (lib_errs,lib_times) = partitionEithers e_lib_times if not (null lib_errs) || any (t <) lib_times - then return True - else checkLinkInfo logger dflags unit_env pkg_deps exe_file + then return (RecompBecause LibraryChanged) + else do + res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file + if res + then return (RecompBecause FlagsChanged) + else return UpToDate + findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath) findHSLib platform ws dirs lib = do diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index 2c371d17c9..c1f7c3769a 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -358,7 +358,7 @@ runCcPhase cc_phase pipe_env hsc_env input_fn = do let platform = ue_platform unit_env let hcc = cc_phase `eqPhase` HCc - let cmdline_include_paths = includePaths dflags + let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags) -- HC files have the dependent packages stamped into them pkgs <- if hcc then getHCFilePackages input_fn else return [] @@ -379,10 +379,13 @@ runCcPhase cc_phase pipe_env hsc_env input_fn = do -- (#16737). Doing it in this way is simpler and also enable the C -- compiler to perform preprocessing and parsing in a single pass, -- but it may introduce inconsistency if a different pgm_P is specified. - let more_preprocessor_opts = concat + let opts = getOpts dflags opt_P + aug_imports = augmentImports dflags opts + + more_preprocessor_opts = concat [ ["-Xpreprocessor", i] | not hcc - , i <- getOpts dflags opt_P + , i <- aug_imports ] let gcc_extra_viac_flags = extraGccViaCFlags dflags @@ -935,6 +938,12 @@ llvmOptions dflags = ArchRISCV64 -> "lp64d" _ -> "" + +-- Note [Filepaths and Multiple Home Units] +offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs +offsetIncludePaths dflags (IncludeSpecs incs quotes impl) = + let go = map (augmentByWorkingDirectory dflags) + in IncludeSpecs (go incs) (go quotes) (go impl) -- ----------------------------------------------------------------------------- -- Running CPP @@ -944,12 +953,21 @@ llvmOptions dflags = doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do let hscpp_opts = picPOpts dflags - let cmdline_include_paths = includePaths dflags + let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags) let unit_state = ue_units unit_env pkg_include_dirs <- mayThrowUnitErr (collectIncludeDirs <$> preloadUnitsInfo unit_env) + -- MP: This is not quite right, the headers which are supposed to be installed in + -- the package might not be the same as the provided include paths, but it's a close + -- enough approximation for things to work. A proper solution would be to have to declare which paths should + -- be propagated to dependent packages. + let home_pkg_deps = + [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env] + dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps] + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs + ++ concatMap includePathsGlobal dep_pkg_extra_inputs) let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] (includePathsQuote cmdline_include_paths ++ includePathsQuoteImplicit cmdline_include_paths) diff --git a/compiler/GHC/Driver/Pipeline/LogQueue.hs b/compiler/GHC/Driver/Pipeline/LogQueue.hs index 55026d8669..454cc8c870 100644 --- a/compiler/GHC/Driver/Pipeline/LogQueue.hs +++ b/compiler/GHC/Driver/Pipeline/LogQueue.hs @@ -5,13 +5,13 @@ module GHC.Driver.Pipeline.LogQueue ( LogQueue(..) , finishLogQueue , writeLogQueue , parLogAction - , printLogs , LogQueueQueue(..) , initLogQueue , allLogQueues , newLogQueueQueue - , dequeueLogQueueQueue + + , logThread ) where import GHC.Prelude @@ -22,6 +22,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Logger import qualified Data.IntMap as IM import Control.Concurrent.STM +import Control.Monad -- LogQueue Abstraction @@ -99,3 +100,24 @@ dequeueLogQueueQueue (LogQueueQueue n lqq) = case IM.minViewWithKey lqq of Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq') _ -> Nothing +logThread :: Int -> Int -> Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit + -> TVar LogQueueQueue -- Queue for logs + -> IO (IO ()) +logThread _ _ logger stopped lqq_var = do + finished_var <- newEmptyMVar + _ <- forkIO $ print_logs *> putMVar finished_var () + return (takeMVar finished_var) + where + finish = mapM (printLogs logger) + + print_logs = join $ atomically $ do + lqq <- readTVar lqq_var + case dequeueLogQueueQueue lqq of + Just (lq, lqq') -> do + writeTVar lqq_var lqq' + return (printLogs logger lq *> print_logs) + Nothing -> do + -- No log to print, check if we are finished. + stopped <- readTVar stopped + if not stopped then retry + else return (finish (allLogQueues lqq)) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index d1c29bc824..b0b37a822c 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -145,6 +145,7 @@ module GHC.Driver.Session ( defaultFatalMessager, defaultFlushOut, setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, + augmentByWorkingDirectory, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags, @@ -515,6 +516,12 @@ data DynFlags = DynFlags { homeUnitInstanceOf_ :: Maybe UnitId, -- ^ Id of the unit to instantiate homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations + -- Note [Filepaths and Multiple Home Units] + workingDirectory :: Maybe FilePath, + thisPackageName :: Maybe String, -- ^ What the package is called, use with multiple home units + hiddenModules :: Set.Set ModuleName, + reexportedModules :: Set.Set ModuleName, + -- ways targetWays_ :: Ways, -- ^ Target way flags from the command line @@ -1136,6 +1143,11 @@ defaultDynFlags mySettings llvmConfig = homeUnitInstanceOf_ = Nothing, homeUnitInstantiations_ = [], + workingDirectory = Nothing, + thisPackageName = Nothing, + hiddenModules = Set.empty, + reexportedModules = Set.empty, + objectDir = Nothing, dylibInstallName = Nothing, hiDir = Nothing, @@ -2938,6 +2950,12 @@ package_flags_deps = [ , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> upd (setUnitId name)) , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) + + , make_ord_flag defGhcFlag "working-dir" (hasArg setWorkingDirectory) + , make_ord_flag defGhcFlag "this-package-name" (hasArg setPackageName) + , make_ord_flag defGhcFlag "hidden-module" (HasArg addHiddenModule) + , make_ord_flag defGhcFlag "reexported-module" (HasArg addReexportedModule) + , make_ord_flag defFlag "package" (HasArg exposePackage) , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) @@ -4279,6 +4297,43 @@ parseUnitArg = setUnitId :: String -> DynFlags -> DynFlags setUnitId p d = d { homeUnitId_ = stringToUnitId p } +setWorkingDirectory :: String -> DynFlags -> DynFlags +setWorkingDirectory p d = d { workingDirectory = Just p } + +{- +Note [Filepaths and Multiple Home Units] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is common to assume that a package is compiled in the directory where its +cabal file resides. Thus, all paths used in the compiler are assumed to be relative +to this directory. When there are multiple home units the compiler is often +not operating in the standard directory and instead where the cabal.project +file is located. In this case the `-working-dir` option can be passed which specifies +the path from the current directory to the directory the unit assumes to be it's root, +normally the directory which contains the cabal file. + +When the flag is passed, any relative paths used by the compiler are offset +by the working directory. Notably this includes `-i`, `-I⟨dir⟩`, `-hidir`, `-odir` etc and +the location of input files. + +-} + +augmentByWorkingDirectory :: DynFlags -> FilePath -> FilePath +augmentByWorkingDirectory dflags fp | isRelative fp, Just offset <- workingDirectory dflags = offset </> fp +augmentByWorkingDirectory _ fp = fp + +setPackageName :: String -> DynFlags -> DynFlags +setPackageName p d = d { thisPackageName = Just p } + +addHiddenModule :: String -> DynP () +addHiddenModule p = + upd (\s -> s{ hiddenModules = Set.insert (mkModuleName p) (hiddenModules s) }) + +addReexportedModule :: String -> DynP () +addReexportedModule p = + upd (\s -> s{ reexportedModules = Set.insert (mkModuleName p) (reexportedModules s) }) + + -- If we're linking a binary, then only backends that produce object -- code are allowed (requests for other target types are ignored). setBackend :: Backend -> DynP () diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index fa4f08c2ef..fbde84deda 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -155,7 +155,7 @@ mkObjectUsage pit hsc_env mnwib = do Nothing -> do -- This should only happen for home package things but oneshot puts -- home package ifaces in the PIT. - let miface = lookupIfaceByModule (hsc_HPT hsc_env) pit m + let miface = lookupIfaceByModule (hsc_HUG hsc_env) pit m case miface of Nothing -> pprPanic "mkObjectUsage" (ppr m) Just iface -> @@ -176,7 +176,7 @@ mk_mod_usage_info :: PackageIfaceTable mk_mod_usage_info pit hsc_env this_mod direct_imports used_names = mapMaybe mkUsage usage_mods where - hpt = hsc_HPT hsc_env + hpt = hsc_HUG hsc_env dflags = hsc_dflags hsc_env home_unit = hsc_home_unit hsc_env diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs index 93666ca3d5..6fecc023c5 100644 --- a/compiler/GHC/Iface/Errors.hs +++ b/compiler/GHC/Iface/Errors.hs @@ -17,7 +17,7 @@ import GHC.Platform.Profile import GHC.Platform.Ways import GHC.Utils.Panic.Plain import GHC.Driver.Session -import GHC.Driver.Env.Types +import GHC.Driver.Env import GHC.Driver.Errors.Types import GHC.Data.Maybe import GHC.Prelude @@ -213,7 +213,7 @@ cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find = cannot_find <+> quotes (ppr mod_name) $$ more_info where - mhome_unit = ue_home_unit unit_env + mhome_unit = ue_homeUnit unit_env more_info = case find_result of NoPackage pkg diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index f1da9d7e0a..d30d39372c 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -94,7 +94,6 @@ import GHC.Types.SourceText import GHC.Types.SourceFile import GHC.Types.SafeHaskell import GHC.Types.TypeEnv -import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.SrcLoc import GHC.Types.TyThing @@ -318,12 +317,7 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg -- interface; it will call the Finder again, but the ModLocation will be -- cached from the first search. = do hsc_env <- getTopEnv - let fc = hsc_FC hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - let units = hsc_units hsc_env - let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - res <- liftIO $ findImportedModule fc fopts units mhome_unit mod maybe_pkg + res <- liftIO $ findImportedModule hsc_env mod maybe_pkg case res of Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) -- TODO: Make sure this error message is good @@ -449,15 +443,15 @@ loadInterface doc_str mod from logger <- getLogger withTimingSilent logger (text "loading interface") (pure ()) $ do { -- Read the state - (eps,hpt) <- getEpsAndHpt + (eps,hug) <- getEpsAndHug ; gbl_env <- getGblEnv ; liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already ; hsc_env <- getTopEnv - ; let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { + ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env) + ; case lookupIfaceByModule hug (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded -- The (src_imp == mi_boot iface) test checks that the already-loaded @@ -497,7 +491,7 @@ loadInterface doc_str mod from in initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ - dontLeakTheHPT $ do + dontLeakTheHUG $ do -- Load the new ModIface into the External Package State -- Even home-package interfaces loaded by loadInterface @@ -515,6 +509,14 @@ loadInterface doc_str mod from -- If we do loadExport first the wrong info gets into the cache (unless we -- explicitly tag each export which seems a bit of a bore) + -- Crucial assertion that checks if you are trying to load a HPT module into the EPS. + -- If you start loading HPT modules into the EPS then you get strange errors about + -- overlapping instances. + ; massertPpr + ((isOneShot (ghcMode (hsc_dflags hsc_env))) + || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env + || mod == gHC_PRIM) + (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod)) ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas ; new_eps_decls <- tcIfaceDecls ignore_prags (mi_decls iface) ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) @@ -630,8 +632,8 @@ home-package modules however, so it's safe for the HPT to be empty. -} -- Note [GHC Heap Invariants] -dontLeakTheHPT :: IfL a -> IfL a -dontLeakTheHPT thing_inside = do +dontLeakTheHUG :: IfL a -> IfL a +dontLeakTheHUG thing_inside = do env <- getTopEnv let inOneShot = @@ -656,10 +658,11 @@ dontLeakTheHPT thing_inside = do keepFor20509 hmi | isHoleModule (mi_semantic_module (hm_iface hmi)) = True | otherwise = False + pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } !unit_env = old_unit_env - { ue_hpt = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_hpt old_unit_env - else emptyHomePackageTable + { ue_home_unit_graph = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_home_unit_graph old_unit_env + else unitEnv_map pruneHomeUnitEnv (ue_home_unit_graph old_unit_env) } in hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets" @@ -709,14 +712,8 @@ computeInterface -> IO (MaybeErr SDoc (ModIface, FilePath)) computeInterface hsc_env doc_str hi_boot_file mod0 = do massert (not (isHoleModule mod0)) - let name_cache = hsc_NC hsc_env - let fc = hsc_FC hsc_env - let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let hooks = hsc_hooks hsc_env - let find_iface m = findAndReadIface logger name_cache fc hooks units mhome_unit dflags doc_str + let mhome_unit = hsc_home_unit_maybe hsc_env + let find_iface m = findAndReadIface hsc_env doc_str m mod0 hi_boot_file case getModuleInstantiation mod0 of (imod, Just indef) @@ -751,7 +748,7 @@ moduleFreeHolesPrecise doc_str mod let insts = instUnitInsts (moduleUnit indef) liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> text "to compute precise free module holes") - (eps, hpt) <- getEpsAndHpt + (eps, hpt) <- getEpsAndHug case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of Just r -> return (Succeeded r) Nothing -> readAndCache imod insts @@ -765,14 +762,7 @@ moduleFreeHolesPrecise doc_str mod _otherwise -> Nothing readAndCache imod insts = do hsc_env <- getTopEnv - let nc = hsc_NC hsc_env - let fc = hsc_FC hsc_env - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let hooks = hsc_hooks hsc_env - let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - mb_iface <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags + mb_iface <- liftIO $ findAndReadIface hsc_env (text "moduleFreeHolesPrecise" <+> doc_str) imod mod NotBoot case mb_iface of @@ -806,7 +796,7 @@ wantHiBootFile mhome_unit eps mod from -- We never import boot modules from other packages! | otherwise - -> case lookupUFM (eps_is_boot eps) (moduleName mod) of + -> case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of Just (GWIB { gwib_isBoot = is_boot }) -> Succeeded is_boot Nothing -> @@ -864,13 +854,7 @@ See #8320. -} findAndReadIface - :: Logger - -> NameCache - -> FinderCache - -> Hooks - -> UnitState - -> Maybe HomeUnit - -> DynFlags + :: HscEnv -> SDoc -- ^ Reason for loading the iface (used for tracing) -> InstalledModule -- ^ The unique identifier of the on-disk module we're looking for -> Module -- ^ The *actual* module we're looking for. We use @@ -878,8 +862,18 @@ findAndReadIface -- module we read out. -> IsBootInterface -- ^ Looking for .hi-boot or .hi file -> IO (MaybeErr SDoc (ModIface, FilePath)) -findAndReadIface logger name_cache fc hooks unit_state mhome_unit dflags doc_str mod wanted_mod hi_boot_file = do +findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do + let profile = targetProfile dflags + unit_state = hsc_units hsc_env + fc = hsc_FC hsc_env + name_cache = hsc_NC hsc_env + mhome_unit = hsc_home_unit_maybe hsc_env + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + hooks = hsc_hooks hsc_env + other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) + trace_if logger (sep [hsep [text "Reading", if hi_boot_file == IsBoot @@ -901,7 +895,7 @@ findAndReadIface logger name_cache fc hooks unit_state mhome_unit dflags doc_str else do let fopts = initFinderOpts dflags -- Look for the file - mb_found <- liftIO (findExactModule fc fopts unit_state mhome_unit mod) + mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod) case mb_found of InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do -- See Note [Home module load error] diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 6b184787fa..fc12701b61 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -53,8 +53,6 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Fixity.Env - -import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State @@ -78,6 +76,7 @@ import qualified Data.Semigroup import GHC.List (uncons) import Data.Ord import Data.Containers.ListUtils +import Data.Bifunctor {- ----------------------------------------------- @@ -121,6 +120,11 @@ data RecompileRequired -- to force recompilation; the String says what (one-line summary) deriving (Eq) +instance Outputable RecompileRequired where + ppr UpToDate = text "UpToDate" + ppr MustCompile = text "MustCompile" + ppr (RecompBecause r) = text "RecompBecause" <+> ppr r + instance Semigroup RecompileRequired where UpToDate <> r = r mc <> _ = mc @@ -141,8 +145,8 @@ data RecompReason | HieOutdated | SigsMergeChanged | ModuleChanged ModuleName - | ModuleRemoved ModuleName - | ModuleAdded ModuleName + | ModuleRemoved (UnitId, ModuleName) + | ModuleAdded (UnitId, ModuleName) | ModuleChangedRaw ModuleName | ModuleChangedIface ModuleName | FileChanged FilePath @@ -155,6 +159,8 @@ data RecompReason | MissingDynObjectFile | MissingDynHiFile | MismatchedDynHiFile + | ObjectsChanged + | LibraryChanged deriving (Eq) instance Outputable RecompReason where @@ -173,8 +179,8 @@ instance Outputable RecompReason where ModuleChanged m -> ppr m <+> text "changed" ModuleChangedRaw m -> ppr m <+> text "changed (raw)" ModuleChangedIface m -> ppr m <+> text "changed (interface)" - ModuleRemoved m -> ppr m <+> text "removed" - ModuleAdded m -> ppr m <+> text "added" + ModuleRemoved (_uid, m) -> ppr m <+> text "removed" + ModuleAdded (_uid, m) -> ppr m <+> text "added" FileChanged fp -> text fp <+> text "changed" CustomReason s -> text s FlagsChanged -> text "Flags changed" @@ -185,6 +191,8 @@ instance Outputable RecompReason where MissingDynObjectFile -> text "Missing dynamic object file" MissingDynHiFile -> text "Missing dynamic interface file" MismatchedDynHiFile -> text "Mismatched dynamic interface file" + ObjectsChanged -> text "Objects changed" + LibraryChanged -> text "Library changed" recompileRequired :: RecompileRequired -> Bool recompileRequired UpToDate = False @@ -526,7 +534,7 @@ checkMergedSignatures hsc_env mod_summary iface = do checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface = do - res_normal <- classify_import (findImportedModule fc fopts units mhome_unit) (ms_textual_imps summary ++ ms_srcimps summary) + res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary) res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary) case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of Left recomp -> return recomp @@ -539,6 +547,11 @@ checkDependencies hsc_env summary iface return (res1 `mappend` res2) where + classify_import :: (ModuleName -> t -> IO FindResult) + -> [(t, GenLocated l ModuleName)] + -> IfG + [Either + RecompileRequired (Either (UnitId, ModuleName) (String, UnitId))] classify_import find_import imports = liftIO $ traverse (\(mb_pkg, L _ mod) -> let reason = ModuleChanged mod @@ -548,9 +561,10 @@ checkDependencies hsc_env summary iface fopts = initFinderOpts dflags logger = hsc_logger hsc_env fc = hsc_FC hsc_env - mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + mhome_unit = hsc_home_unit_maybe hsc_env + all_home_units = hsc_all_home_unit_ids hsc_env units = hsc_units hsc_env - prev_dep_mods = map gwib_mod $ Set.toAscList $ dep_direct_mods (mi_deps iface) + prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) (dep_plugin_pkgs (mi_deps iface))) bkpk_units = map (("Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) @@ -560,23 +574,26 @@ checkDependencies hsc_env summary iface -- GHC.Prim is very special and doesn't appear in ms_textual_imps but -- ghc-prim will appear in the package dependencies still. In order to not confuse -- the recompilation logic we need to not forget we imported GHC.Prim. - fake_ghc_prim_import = if notHomeUnitId mhome_unit primUnitId - then Right ("GHC.Prim", primUnitId) - else Left (mkModuleName "GHC.Prim") + fake_ghc_prim_import = case mhome_unit of + Just home_unit + | homeUnitId home_unit == primUnitId + -> Left (primUnitId, mkModuleName "GHC.Prim") + _ -> Right ("GHC.Prim", primUnitId) classify _ (Found _ mod) - | Just home_unit <- mhome_unit - , isHomeUnit home_unit (moduleUnit mod) = Right (Left (moduleName mod)) + | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) | otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason) + check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired check_mods [] [] = return UpToDate check_mods [] (old:_) = do -- This case can happen when a module is change from HPT to package import trace_hi_diffs logger $ - text "module no longer " <> quotes (ppr old) <> + text "module no longer" <+> quotes (ppr old) <+> text "in dependencies" + return (RecompBecause (ModuleRemoved old)) check_mods (new:news) olds | Just (old, olds') <- uncons olds @@ -1255,21 +1272,14 @@ addFingerprints hsc_env iface0 -- to recompile C and everything else. getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] getOrphanHashes hsc_env mods = do - eps <- hscEPS hsc_env let - hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env - pit = eps_PIT eps ctx = initSDocContext dflags defaultUserStyle - get_orph_hash mod = - case lookupIfaceByModule hpt pit mod of - Just iface -> return (mi_orphan_hash (mi_final_exts iface)) - Nothing -> do -- similar to 'mkHashFun' - iface <- initIfaceLoad hsc_env . withException ctx + get_orph_hash mod = do + iface <- initIfaceLoad hsc_env . withException ctx $ loadInterface (text "getOrphanHashes") mod ImportBySystem - return (mi_orphan_hash (mi_final_exts iface)) + return (mi_orphan_hash (mi_final_exts iface)) - -- mapM get_orph_hash mods @@ -1546,7 +1556,7 @@ mkHashFun hsc_env eps name where home_unit = hsc_home_unit hsc_env dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env + hpt = hsc_HUG hsc_env pit = eps_PIT eps ctx = initSDocContext dflags defaultUserStyle occ = nameOccName name diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs index 15e8623404..dc358d1c2d 100644 --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -37,7 +37,7 @@ fingerprintDynFlags :: HscEnv -> Module fingerprintDynFlags hsc_env this_mod nameio = let dflags@DynFlags{..} = hsc_dflags hsc_env - mainis = if mainModIs hsc_env == this_mod then Just mainFunIs else Nothing + mainis = if mainModIs (hsc_HUE hsc_env) == this_mod then Just mainFunIs else Nothing -- see #5878 -- pkgopts = (homeUnit home_unit, sort $ packageFlags dflags) safeHs = setSafeMode safeHaskell diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 782b572cf8..4b3316f632 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -539,8 +539,8 @@ tcHiBootIface hsc_src mod -- (it's been replaced by the mother module) so we can't check it. -- And that's fine, because if M's ModInfo is in the HPT, then -- it's been compiled once, and we don't need to check the boot iface - then do { hpt <- getHpt - ; case lookupHpt hpt (moduleName mod) of + then do { (_, hug) <- getEpsAndHug + ; case lookupHugByModule mod hug of Just info | mi_boot (hm_iface info) == IsBoot -> mkSelfBootInfo (hm_iface info) (hm_details info) _ -> return NoSelfBoot } @@ -551,14 +551,7 @@ tcHiBootIface hsc_src mod -- to check consistency against, rather than just when we notice -- that an hi-boot is necessary due to a circular import. { hsc_env <- getTopEnv - ; let nc = hsc_NC hsc_env - ; let fc = hsc_FC hsc_env - ; let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - ; let units = hsc_units hsc_env - ; let dflags = hsc_dflags hsc_env - ; let logger = hsc_logger hsc_env - ; let hooks = hsc_hooks hsc_env - ; read_result <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags + ; read_result <- liftIO $ findAndReadIface hsc_env need (fst (getModuleInstantiation mod)) mod IsBoot -- Hi-boot file @@ -575,7 +568,7 @@ tcHiBootIface hsc_src mod -- a SOURCE import) or that our hi-boot file has mysteriously -- disappeared. do { eps <- getEps - ; case lookupUFM (eps_is_boot eps) (moduleName mod) of + ; case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of -- The typical case Nothing -> return NoSelfBoot -- error cases diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 80e303b046..6fc324e27a 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -54,7 +54,6 @@ import GHC.Tc.Utils.Monad import GHC.Runtime.Interpreter import GHCi.RemoteTypes -import GHC.Iface.Load import GHC.ByteCode.Linker import GHC.ByteCode.Asm @@ -72,7 +71,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Constants (isWindowsHost, isDarwinHost) -import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.TmpFs @@ -82,7 +80,6 @@ import GHC.Unit.Finder import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps -import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.State as Packages @@ -119,6 +116,12 @@ import GHC.Utils.Exception import qualified Data.Map as M import Data.Either (partitionEithers) +import GHC.Unit.Module.Graph +import GHC.Types.SourceFile +import GHC.Utils.Misc +import GHC.Iface.Load +import GHC.Unit.Home + uninitialised :: a uninitialised = panic "Loader not initialised" @@ -210,7 +213,6 @@ loadDependencies -> IO (LoaderState, SuccessFlag) loadDependencies interp hsc_env pls span needed_mods = do -- initLoaderState (hsc_dflags hsc_env) dl - let hpt = hsc_HPT hsc_env let dflags = hsc_dflags hsc_env -- The interpreter and dynamic linker can only handle object code built -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. @@ -219,11 +221,11 @@ loadDependencies interp hsc_env pls span needed_mods = do maybe_normal_osuf <- checkNonStdWay dflags interp (fst span) -- Find what packages and linkables are required - (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env hpt pls + (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env pls maybe_normal_osuf (fst span) needed_mods let pls1 = - case (snd span) of + case snd span of Just mn -> pls { module_deps = M.insertWith (++) mn all_lnks (module_deps pls) } Nothing -> pls @@ -310,8 +312,9 @@ reallyInitLoaderState interp hsc_env = do -- (a) initialise the C dynamic linker initObjLinker interp + -- (b) Load packages from the command-line (Note [preload packages]) - pls <- loadPackages' interp hsc_env (preloadUnits (hsc_units hsc_env)) pls0 + pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env) -- steps (c), (d) and (e) loadCmdLineLibs' interp hsc_env pls @@ -323,13 +326,33 @@ loadCmdLineLibs interp hsc_env = do modifyLoaderState_ interp $ \pls -> loadCmdLineLibs' interp hsc_env pls -loadCmdLineLibs' + +loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState +loadCmdLineLibs' interp hsc_env pls = snd <$> + foldM + (\(done', pls') cur_uid -> load done' cur_uid pls') + (Set.empty, pls) + (hsc_all_home_unit_ids hsc_env) + + where + load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState) + load done uid pls | uid `Set.member` done = return (done, pls) + load done uid pls = do + let hsc' = hscSetActiveUnitId uid hsc_env + -- Load potential dependencies first + (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) + (homeUnitDepends (hsc_units hsc')) + pls'' <- loadCmdLineLibs'' interp hsc' pls' + return $ (Set.insert uid done', pls'') + +loadCmdLineLibs'' :: Interp -> HscEnv -> LoaderState -> IO LoaderState -loadCmdLineLibs' interp hsc_env pls = +loadCmdLineLibs'' interp hsc_env pls = do + let dflags@(DynFlags { ldInputs = cmdline_ld_inputs , libraryPaths = lib_paths_base}) = hsc_dflags hsc_env @@ -661,7 +684,7 @@ failNonStd dflags srcspan = dieWith dflags srcspan $ Prof -> "with -prof" Dyn -> "with -dynamic" -getLinkDeps :: HscEnv -> HomePackageTable +getLinkDeps :: HscEnv -> LoaderState -> Maybe FilePath -- replace object suffixes? -> SrcSpan -- for error messages @@ -669,13 +692,21 @@ getLinkDeps :: HscEnv -> HomePackageTable -> IO ([Linkable], [Linkable], [UnitId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files -getLinkDeps hsc_env hpt pls replace_osuf span mods +getLinkDeps hsc_env pls replace_osuf span mods -- Find all the packages and linkables that a set of modules depends on = do { -- 1. Find the dependent home-pkg-modules/packages from each iface -- (omitting modules from the interactive package, which is already linked) - ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) - emptyUniqDSet emptyUniqDSet; + ; (mods_s, pkgs_s) <- + -- Why two code paths here? There is a significant amount of repeated work + -- performed calculating transitive dependencies + -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests) + if isOneShot (ghcMode dflags) + then follow_deps (filterOut isInteractiveModule mods) + emptyUniqDSet emptyUniqDSet; + else do + (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods + return (catMaybes mmods, Set.toList (Set.unions (init_pkg_set : pkgs))) ; let -- 2. Exclude ones already linked @@ -683,11 +714,11 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods (mods_needed, mods_got) = partitionEithers (map split_mods mods_s) pkgs_needed = pkgs_s `minusList` pkgs_loaded pls - split_mods mod_name = - let is_linked = find ((== mod_name) . (moduleName . linkableModule)) (objs_loaded pls ++ bcos_loaded pls) + split_mods mod = + let is_linked = find ((== mod) . (linkableModule)) (objs_loaded pls ++ bcos_loaded pls) in case is_linked of Just linkable -> Right linkable - Nothing -> Left mod_name + Nothing -> Left mod -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot @@ -698,16 +729,62 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods ; return (lnks_needed, mods_got ++ lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env + mod_graph = hsc_mod_graph hsc_env - -- The ModIface contains the transitive closure of the module dependencies - -- within the current package, *except* for boot modules: if we encounter - -- a boot module, we have to find its real interface and discover the - -- dependencies of that. Hence we need to traverse the dependency - -- tree recursively. See bug #936, testcase ghci/prog007. + -- This code is used in `--make` mode to calculate the home package and unit dependencies + -- for a set of modules. + -- + -- It is significantly more efficient to use the shared transitive dependency + -- calculation than to compute the transitive dependency set in the same manner as oneShot mode. + + -- It is also a matter of correctness to use the module graph so that dependencies between home units + -- is resolved correctly. + make_deps_loop :: (Set.Set UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (Set.Set UnitId, Set.Set NodeKey) + make_deps_loop found [] = found + make_deps_loop found@(found_units, found_mods) (nk:nexts) + | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts + | otherwise = + case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of + Just trans_deps -> + let deps = Set.insert (NodeKey_Module nk) trans_deps + -- See #936 and the ghci.prog007 test for why we have to continue traversing through + -- boot modules. + todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps] + in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts) + Nothing -> + let (ModNodeKeyWithUid _ uid) = nk + in make_deps_loop (uid `Set.insert` found_units, found_mods) nexts + + mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m) + (init_pkg_set, all_deps) = make_deps_loop (Set.empty, Set.empty) $ map mkNk (filterOut isInteractiveModule mods) + + all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps] + + get_mod_info (ModNodeKeyWithUid gwib uid) = + case lookupHug (hsc_HUG hsc_env) uid (gwib_mod gwib) of + Just hmi -> + let iface = (hm_iface hmi) + mmod = case mi_hsc_src iface of + HsBootFile -> link_boot_mod_error (mi_module iface) + _ -> return $ Just (mi_module iface) + + in (dep_direct_pkgs (mi_deps iface),) <$> mmod + Nothing -> + let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid + in throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + + + -- This code is used in one-shot mode to traverse downwards through the HPT + -- to find all link dependencies. + -- The ModIface contains the transitive closure of the module dependencies + -- within the current package, *except* for boot modules: if we encounter + -- a boot module, we have to find its real interface and discover the + -- dependencies of that. Hence we need to traverse the dependency + -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow - -> UniqDSet ModuleName -- accum. module dependencies + -> UniqDSet Module -- accum. module dependencies -> UniqDSet UnitId -- accum. package dependencies - -> IO ([ModuleName], [UnitId]) -- result + -> IO ([Module], [UnitId]) -- result follow_deps [] acc_mods acc_pkgs = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -727,23 +804,28 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods pkg_deps = dep_direct_pkgs deps (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $ \case - GWIB m IsBoot -> Left m - GWIB m NotBoot -> Right m - - mod_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) (boot_deps ++ mod_deps) - acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) + (_, GWIB m IsBoot) -> Left m + (_, GWIB m NotBoot) -> Right m + + mod_deps' = case hsc_home_unit_maybe hsc_env of + Nothing -> [] + Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps)) + acc_mods' = case hsc_home_unit_maybe hsc_env of + Nothing -> acc_mods + Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps) acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) - -- - case ue_home_unit (hsc_unit_env hsc_env) of - Just home_unit - | isHomeUnit home_unit pkg - -> follow_deps (map (mkHomeModule home_unit) mod_deps' ++ mods) acc_mods' acc_pkgs' - _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) + + case hsc_home_unit_maybe hsc_env of + Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods) + acc_mods' acc_pkgs' + _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) where - msg = text "need to link module" <+> ppr mod <+> + msg = text "need to link module" <+> ppr mod <+> text "due to use of Template Haskell" + + link_boot_mod_error :: Module -> IO a link_boot_mod_error mod = throwGhcExceptionIO (ProgramError (showSDoc dflags ( text "module" <+> ppr mod <+> @@ -759,22 +841,23 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods -- This one is a build-system bug - get_linkable osuf mod_name -- A home-package module - | Just mod_info <- lookupHpt hpt mod_name + get_linkable osuf mod -- A home-package module + | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env) = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) | otherwise = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... - case ue_home_unit (hsc_unit_env hsc_env) of - Nothing -> no_obj mod_name + case hsc_home_unit_maybe hsc_env of + Nothing -> no_obj mod Just home_unit -> do + let fc = hsc_FC hsc_env let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags - mb_stuff <- findHomeModule fc fopts home_unit mod_name + mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) case mb_stuff of Found loc mod -> found loc mod - _ -> no_obj mod_name + _ -> no_obj (moduleName mod) where found loc mod = do { -- ...and then find the linkable for it diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs index 108dbec525..5d63d59461 100644 --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -2,7 +2,6 @@ module GHC.Linker.Static ( linkBinary , linkBinary' , linkStaticLib - , exeFileName ) where @@ -29,6 +28,7 @@ import GHC.Linker.Unit import GHC.Linker.Dynamic import GHC.Linker.ExtraObj import GHC.Linker.Windows +import GHC.Linker.Static.Utils import GHC.Driver.Session @@ -306,30 +306,3 @@ linkStaticLib logger dflags unit_env o_files dep_units = do -- run ranlib over the archive. write*Ar does *not* create the symbol index. runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn] - - - --- | Compute the output file name of a program. --- --- StaticLink boolean is used to indicate if the program is actually a static library --- (e.g., on iOS). --- --- Use the provided filename (if any), otherwise use "main.exe" (Windows), --- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the --- extension if it is missing. -exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath -exeFileName platform staticLink output_fn - | Just s <- output_fn = - case platformOS platform of - OSMinGW32 -> s <?.> "exe" - _ -> if staticLink - then s <?.> "a" - else s - | otherwise = - if platformOS platform == OSMinGW32 - then "main.exe" - else if staticLink - then "liba.a" - else "a.out" - where s <?.> ext | null (takeExtension s) = s <.> ext - | otherwise = s diff --git a/compiler/GHC/Linker/Static/Utils.hs b/compiler/GHC/Linker/Static/Utils.hs new file mode 100644 index 0000000000..6439d197d8 --- /dev/null +++ b/compiler/GHC/Linker/Static/Utils.hs @@ -0,0 +1,31 @@ +module GHC.Linker.Static.Utils where + +import GHC.Prelude +import GHC.Platform +import System.FilePath + +-- | Compute the output file name of a program. +-- +-- StaticLink boolean is used to indicate if the program is actually a static library +-- (e.g., on iOS). +-- +-- Use the provided filename (if any), otherwise use "main.exe" (Windows), +-- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the +-- extension if it is missing. +exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath +exeFileName platform staticLink output_fn + | Just s <- output_fn = + case platformOS platform of + OSMinGW32 -> s <?.> "exe" + _ -> if staticLink + then s <?.> "a" + else s + | otherwise = + if platformOS platform == OSMinGW32 + then "main.exe" + else if staticLink + then "liba.a" + else "a.out" + where s <?.> ext | null (takeExtension s) = s <.> ext + | otherwise = s + diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 34141ab9f4..8108a9e873 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -73,7 +73,6 @@ import GHC.Types.Basic ( TopLevelFlag(..) ) import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.HpcInfo -import GHC.Types.Unique.FM import GHC.Types.Error import GHC.Types.PkgQual @@ -217,7 +216,7 @@ rnImports imports = do clobberSourceImports imp_avails = imp_avails { imp_boot_mods = imp_boot_mods' } where - imp_boot_mods' = mergeUFM combJ id (const mempty) + imp_boot_mods' = mergeInstalledModuleEnv combJ id (const emptyInstalledModuleEnv) (imp_boot_mods imp_avails) (imp_direct_dep_mods imp_avails) @@ -327,6 +326,7 @@ rnImportDecl this_mod let imp_mod_name = unLoc loc_imp_mod_name doc = ppr imp_mod_name <+> import_reason + hsc_env <- getTopEnv unit_env <- hsc_unit_env <$> getTopEnv let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual @@ -348,7 +348,7 @@ rnImportDecl this_mod -- or the name of this_mod's package. Yurgh! -- c.f. GHC.findModule, and #9997 NoPkgQual -> True - ThisPkg _ -> True + ThisPkg uid -> uid == homeUnitId_ (hsc_dflags hsc_env) OtherPkg _ -> False)) (addErr $ TcRnUnknownMessage $ mkPlainError noHints $ (text "A module cannot import itself:" <+> ppr imp_mod_name)) @@ -413,6 +413,7 @@ rnImportDecl this_mod hsc_env <- getTopEnv let home_unit = hsc_home_unit hsc_env + other_home_units = hsc_all_home_unit_ids hsc_env imv = ImportedModsVal { imv_name = qual_mod_name , imv_span = locA loc @@ -421,7 +422,7 @@ rnImportDecl this_mod , imv_all_exports = potential_gres , imv_qualified = qual_only } - imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv) + imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv) -- Complain if we import a deprecated module case mi_warns iface of @@ -463,8 +464,11 @@ renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual renamePkgQual unit_env mn mb_pkg = case mb_pkg of Nothing -> NoPkgQual Just pkg_fs - | Just uid <- homeUnitId <$> ue_home_unit unit_env - , pkg_fs == fsLit "this" || pkg_fs == unitFS uid + | Just uid <- homeUnitId <$> ue_homeUnit unit_env + , pkg_fs == fsLit "this" + -> ThisPkg uid + + | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names -> ThisPkg uid | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs) @@ -474,16 +478,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -> OtherPkg (UnitId pkg_fs) -- not really correct as pkg_fs is unlikely to be a valid unit-id but -- we will report the failure later... + where + home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps + + units = ue_units unit_env + + hpt_deps :: [UnitId] + hpt_deps = homeUnitDepends units + -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit + -> S.Set UnitId -> ModIface -> IsSafeImport -> IsBootInterface -> ImportedBy -> ImportAvails -calculateAvails home_unit iface mod_safe' want_boot imported_by = +calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by = let imp_mod = mi_module iface imp_sem_mod= mi_semantic_module iface orph_iface = mi_orphan (mi_final_exts iface) @@ -545,24 +558,24 @@ calculateAvails home_unit iface mod_safe' want_boot imported_by = | isHomeUnit home_unit pkg = ptrust | otherwise = False - dependent_pkgs = if isHomeUnit home_unit pkg + dependent_pkgs = if toUnitId pkg `S.member` other_home_units then S.empty else S.singleton ipkg - direct_mods = mkModDeps $ if isHomeUnit home_unit pkg - then S.singleton (GWIB (moduleName imp_mod) want_boot) + direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units + then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot)) else S.empty dep_boot_mods_map = mkModDeps (dep_boot_mods deps) boot_mods -- If we are looking for a boot module, it must be HPT - | IsBoot <- want_boot = addToUFM dep_boot_mods_map (moduleName imp_mod) (GWIB (moduleName imp_mod) IsBoot) + | IsBoot <- want_boot = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot) -- Now we are importing A properly, so don't go looking for -- A.hs-boot | isHomeUnit home_unit pkg = dep_boot_mods_map -- There's no boot files to find in external imports - | otherwise = emptyUFM + | otherwise = emptyInstalledModuleEnv sig_mods = if is_sig diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index e934692334..3d4e92d438 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -134,6 +134,7 @@ import GHC.Tc.Utils.Instantiate (instDFunType) import GHC.Tc.Solver (simplifyWantedsTcM) import GHC.Tc.Utils.Monad import GHC.Core.Class (classTyCon) +import GHC.Unit.Env -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -150,7 +151,7 @@ getHistoryModule = breakInfo_module . historyBreakInfo getHistorySpan :: HscEnv -> History -> SrcSpan getHistorySpan hsc_env History{..} = let BreakInfo{..} = historyBreakInfo in - case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of + case lookupHugByModule breakInfo_module (hsc_HUG hsc_env) of Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number _ -> panic "getHistorySpan" @@ -161,7 +162,7 @@ getHistorySpan hsc_env History{..} = findEnclosingDecls :: HscEnv -> BreakInfo -> [String] findEnclosingDecls hsc_env (BreakInfo modl ix) = let hmi = expectJust "findEnclosingDecls" $ - lookupHpt (hsc_HPT hsc_env) (moduleName modl) + lookupHugByModule modl (hsc_HUG hsc_env) mb = getModBreaks hmi in modBreaks_decls mb ! ix @@ -1248,8 +1249,7 @@ showModule mod_summary = withSession $ \hsc_env -> do interpreted <- moduleIsBootOrNotObjectLinkable mod_summary let dflags = hsc_dflags hsc_env - -- extendModSummaryNoDeps because the message doesn't look at the deps - return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode (extendModSummaryNoDeps mod_summary))) + return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary)) moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index e93e6969bc..3803bc39fe 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -270,7 +270,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let fc = hsc_FC hsc_env let unit_env = hsc_unit_env hsc_env let unit_state = ue_units unit_env - let mhome_unit = ue_home_unit unit_env + let mhome_unit = hsc_home_unit_maybe hsc_env -- First find the unit the module resides in by searching exposed units and home modules found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name case found_module of diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index ca4e7de21e..73b3835282 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -49,10 +49,21 @@ runUnlit logger dflags args = traceToolCommand logger "unlit" $ do runSomething logger "Literate pre-processor" prog (map Option opts ++ args) +-- | Prepend the working directory to the search path. +-- Note [Filepaths and Multiple Home Units] +augmentImports :: DynFlags -> [FilePath] -> [FilePath] +augmentImports dflags fps | Nothing <- workingDirectory dflags = fps +augmentImports _ [] = [] +augmentImports _ [x] = [x] +augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirectory dflags fp : augmentImports dflags fps +augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps) + runCpp :: Logger -> DynFlags -> [Option] -> IO () runCpp logger dflags args = traceToolCommand logger "cpp" $ do + let opts = getOpts dflags opt_P + modified_imports = augmentImports dflags opts let (p,args0) = pgm_P dflags - args1 = map Option (getOpts dflags opt_P) + args1 = map Option modified_imports args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] mb_env <- getGccEnv args2 diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index acf5a9da3f..40a3732a0e 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -174,7 +174,7 @@ rnExports explicit_mod exports , tcg_rdr_env = rdr_env , tcg_imports = imports , tcg_src = hsc_src } = tcg_env - default_main | mainModIs hsc_env == this_mod + default_main | mainModIs (hsc_HUE hsc_env) == this_mod , Just main_fun <- mainFunIs dflags = mkUnqual varName (fsLit main_fun) | otherwise diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index d1e8ce2abe..a38d6d436f 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1209,6 +1209,10 @@ instance TH.Quasi TcM where -- we'll only fail higher up. qRecover recover main = tryTcDiscardingErrs recover main + qGetPackageRoot = do + dflags <- getDynFlags + return $ fromMaybe "." (workingDirectory dflags) + qAddDependentFile fp = do ref <- fmap tcg_dependent_files getGblEnv dep_files <- readTcRef ref @@ -1627,6 +1631,7 @@ handleTHMessage msg = case msg of wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) ReifyModule m -> wrapTHResult $ TH.qReifyModule m ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm + GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f AddTempFile s -> wrapTHResult $ TH.qAddTempFile s AddModFinalizer r -> do diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 01b5433cdc..6ce522385b 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -61,6 +61,7 @@ import qualified Data.List.NonEmpty as NE import Data.Function ( on ) import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.Env (unitEnv_hpts) {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -293,14 +294,14 @@ This is basically the idea from #13092, comment:14. -- See Note [The type family instance consistency story]. checkFamInstConsistency :: [Module] -> TcM () checkFamInstConsistency directlyImpMods - = do { (eps, hpt) <- getEpsAndHpt + = do { (eps, hug) <- getEpsAndHug ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) ; let { -- Fetch the iface of a given module. Must succeed as -- all directly imported modules must already have been loaded. modIface mod = - case lookupIfaceByModule hpt (eps_PIT eps) mod of + case lookupIfaceByModule hug (eps_PIT eps) mod of Nothing -> panicDoc "FamInst.checkFamInstConsistency" - (ppr mod $$ pprHPT hpt) + (ppr mod $$ ppr hug) Just iface -> iface -- Which family instance modules were checked for consistency @@ -318,7 +319,8 @@ checkFamInstConsistency directlyImpMods ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv . md_fam_insts . hm_details ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) - | hmi <- eltsHpt hpt] + | hpt <- unitEnv_hpts hug + , hmi <- eltsHpt hpt ] } diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 68bfba4448..66f7406745 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -375,18 +375,18 @@ tcRnImports hsc_env import_decls = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; ; this_mod <- getModule - ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot - ; dep_mods = imp_direct_dep_mods imports - - -- We want instance declarations from all home-package + ; gbl_env <- getGblEnv + ; let { -- We want instance declarations from all home-package -- modules below this one, including boot modules, except -- ourselves. The 'except ourselves' is so that we don't -- get the instances from this module's hs-boot file. This -- filtering also ensures that we don't see instances from -- modules batch (@--make@) compiled before this one, but -- which are not below this one. - ; (home_insts, home_fam_insts) = hptInstancesBelow hsc_env (moduleName this_mod) - (S.fromList (nonDetEltsUFM dep_mods)) + ; (home_insts, home_fam_insts) = + + hptInstancesBelow hsc_env (homeUnitId $ hsc_home_unit hsc_env) (GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env))) + } ; -- Record boot-file info in the EPS, so that it's @@ -1790,7 +1790,7 @@ checkMainType :: TcGblEnv -> TcRn WantedConstraints -- See Note [Dealing with main] checkMainType tcg_env = do { hsc_env <- getTopEnv - ; if tcg_mod tcg_env /= mainModIs hsc_env + ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env) then return emptyWC else do { rdr_env <- getGlobalRdrEnv @@ -1822,7 +1822,7 @@ checkMain explicit_mod_hdr export_ies ; tcg_env <- getGblEnv ; let dflags = hsc_dflags hsc_env - main_mod = mainModIs hsc_env + main_mod = mainModIs (hsc_HUE hsc_env) main_occ = getMainOcc dflags exported_mains :: [Name] @@ -2953,7 +2953,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ppr_fam_insts fam_insts , ppr_rules rules , text "Dependent modules:" <+> - pprUFM (imp_direct_dep_mods imports) (ppr . sort) + (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) , text "Dependent packages:" <+> ppr (S.toList $ imp_dep_direct_pkgs imports)] -- The use of sort is just to reduce unnecessary diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs index 5a4f9a8deb..2edee72207 100644 --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -73,7 +73,6 @@ import GHC.Tc.Types.Evidence ( CoercionHole, EvTerm(..) , EvExpr, EvBindsVar, EvBind, mkGivenEvBind ) import GHC.Types.Var ( EvVar ) -import GHC.Unit.Env import GHC.Unit.Module ( ModuleName, Module ) import GHC.Types.Name ( OccName, Name ) import GHC.Types.TyThing ( TyThing ) @@ -81,8 +80,7 @@ import GHC.Core.Reduction ( Reduction ) import GHC.Core.TyCon ( TyCon ) import GHC.Core.DataCon ( DataCon ) import GHC.Core.Class ( Class ) -import GHC.Driver.Config.Finder ( initFinderOpts ) -import GHC.Driver.Env ( HscEnv(..), hsc_units ) +import GHC.Driver.Env ( HscEnv(..) ) import GHC.Utils.Outputable ( SDoc ) import GHC.Core.Type ( Kind, Type, PredType ) import GHC.Types.Id ( Id ) @@ -103,12 +101,7 @@ tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do hsc_env <- getTopEnv - let fc = hsc_FC hsc_env - let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - tcPluginIO $ Finder.findImportedModule fc fopts units mhome_unit mod_name mb_pkg + tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg lookupOrig :: Module -> OccName -> TcPluginM Name lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 393b9678d2..df9384fea2 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -1374,16 +1374,16 @@ peCategory NoDataKindsDC = "data constructor" -} -mkModDeps :: Set ModuleNameWithIsBoot - -> ModuleNameEnv ModuleNameWithIsBoot -mkModDeps deps = S.foldl' add emptyUFM deps +mkModDeps :: Set (UnitId, ModuleNameWithIsBoot) + -> InstalledModuleEnv ModuleNameWithIsBoot +mkModDeps deps = S.foldl' add emptyInstalledModuleEnv deps where - add env elt = addToUFM env (gwib_mod elt) elt + add env (uid, elt) = extendInstalledModuleEnv env (mkModule uid (gwib_mod elt)) elt -plusModDeps :: ModuleNameEnv ModuleNameWithIsBoot - -> ModuleNameEnv ModuleNameWithIsBoot - -> ModuleNameEnv ModuleNameWithIsBoot -plusModDeps = plusUFM_C plus_mod_dep +plusModDeps :: InstalledModuleEnv ModuleNameWithIsBoot + -> InstalledModuleEnv ModuleNameWithIsBoot + -> InstalledModuleEnv ModuleNameWithIsBoot +plusModDeps = plusInstalledModuleEnv plus_mod_dep where plus_mod_dep r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 }) r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2}) @@ -1396,12 +1396,12 @@ plusModDeps = plusUFM_C plus_mod_dep emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, - imp_direct_dep_mods = emptyUFM, + imp_direct_dep_mods = emptyInstalledModuleEnv, imp_dep_direct_pkgs = S.empty, imp_sig_mods = [], imp_trust_pkgs = S.empty, imp_trust_own_pkg = False, - imp_boot_mods = emptyUFM, + imp_boot_mods = emptyInstalledModuleEnv, imp_orphs = [], imp_finsts = [] } diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index cf4925d2cb..659fc8a474 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -18,7 +18,6 @@ module GHC.Tc.Utils.Backpack ( import GHC.Prelude -import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session @@ -41,7 +40,6 @@ import GHC.Types.Name.Shape import GHC.Types.PkgQual import GHC.Unit -import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface @@ -307,17 +305,13 @@ implicitRequirements :: HscEnv implicitRequirements hsc_env normal_imports = fmap concat $ forM normal_imports $ \(mb_pkg, L _ imp) -> do - found <- findImportedModule fc fopts units mhome_unit imp mb_pkg + found <- findImportedModule hsc_env imp mb_pkg case found of Found _ mod | notHomeModuleMaybe mhome_unit mod -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where - fc = hsc_FC hsc_env - mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - units = hsc_units hsc_env - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags + mhome_unit = hsc_home_unit_maybe hsc_env -- | Like @implicitRequirements'@, but returns either the module name, if it is -- a free hole, or the instantiated unit the imported module is from, so that @@ -329,15 +323,11 @@ implicitRequirementsShallow -> IO ([ModuleName], [InstantiatedUnit]) implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports where - fc = hsc_FC hsc_env - mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - units = hsc_units hsc_env - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags + mhome_unit = hsc_home_unit_maybe hsc_env go acc [] = pure acc go (accL, accR) ((mb_pkg, L _ imp):imports) = do - found <- findImportedModule fc fopts units mhome_unit imp mb_pkg + found <- findImportedModule hsc_env imp mb_pkg let acc' = case found of Found _ mod | notHomeModuleMaybe mhome_unit mod -> case moduleUnit mod of @@ -376,7 +366,7 @@ tcRnCheckUnit hsc_env uid = initTc hsc_env HsigFile -- bogus False - (mainModIs hsc_env) + (mainModIs (hsc_HUE hsc_env)) (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus $ checkUnit uid where @@ -569,12 +559,7 @@ mergeSignatures let inner_mod = tcg_semantic_mod tcg_env let mod_name = moduleName (tcg_mod tcg_env) let unit_state = hsc_units hsc_env - let fc = hsc_FC hsc_env - let nc = hsc_NC hsc_env - let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let hooks = hsc_hooks hsc_env -- STEP 1: Figure out all of the external signature interfaces -- we are going to merge in. @@ -589,7 +574,7 @@ mergeSignatures ctx = initSDocContext dflags defaultUserStyle fmap fst . withException ctx - $ findAndReadIface logger nc fc hooks unit_state mhome_unit dflags + $ findAndReadIface hsc_env (text "mergeSignatures") im m NotBoot -- STEP 3: Get the unrenamed exports of all these interfaces, @@ -886,8 +871,9 @@ mergeSignatures -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } home_unit = hsc_home_unit hsc_env + other_home_units = hsc_all_home_unit_ids hsc_env avails = plusImportAvails (tcg_imports tcg_env) $ - calculateAvails home_unit iface' False NotBoot ImportedBySystem + calculateAvails home_unit other_home_units iface' False NotBoot ImportedBySystem return tcg_env { tcg_inst_env = inst_env, tcg_insts = insts, @@ -956,6 +942,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do hsc_env <- getTopEnv let unit_state = hsc_units hsc_env home_unit = hsc_home_unit hsc_env + other_home_units = hsc_all_home_unit_ids hsc_env addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do let insts = instUnitInsts uid @@ -976,7 +963,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") (dep_orphs (mi_deps impl_iface)) - let avails = calculateAvails home_unit + let avails = calculateAvails home_unit other_home_units impl_iface False{- safe -} NotBoot ImportedBySystem fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) | (occ, f) <- mi_fixities impl_iface @@ -1002,14 +989,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do let sig_mod = mkModule (VirtUnit uid) mod_name isig_mod = fst (getModuleInstantiation sig_mod) hsc_env <- getTopEnv - let nc = hsc_NC hsc_env - let fc = hsc_FC hsc_env - let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let hooks = hsc_hooks hsc_env - mb_isig_iface <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags + mb_isig_iface <- liftIO $ findAndReadIface hsc_env (text "checkImplements 2") isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index f922e87876..be4facc922 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -106,7 +106,6 @@ import GHC.Core.Class import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.External -import GHC.Unit.Env import GHC.Utils.Outputable import GHC.Utils.Panic @@ -162,7 +161,7 @@ lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) lookupGlobal_maybe hsc_env name = do { -- Try local envt let mod = icInteractiveModule (hsc_IC hsc_env) - mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + mhome_unit = hsc_home_unit_maybe hsc_env tcg_semantic_mod = homeModuleInstantiation mhome_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 7aad60649e..5cf866072e 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -32,7 +32,7 @@ module GHC.Tc.Utils.Monad( getEpsVar, getEps, updateEps, updateEps_, - getHpt, getEpsAndHpt, + getHpt, getEpsAndHug, -- * Arrow scopes newArrowScope, escapeArrowScope, @@ -268,7 +268,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this let { -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env ; - !mhome_unit = ue_home_unit (hsc_unit_env hsc_env) ; + !mhome_unit = hsc_home_unit_maybe hsc_env; !logger = hsc_logger hsc_env ; maybe_rn_syntax :: forall a. a -> Maybe a ; @@ -597,9 +597,9 @@ updateEps_ upd_fn = updateEps (\eps -> (upd_fn eps, ())) getHpt :: TcRnIf gbl lcl HomePackageTable getHpt = do { env <- getTopEnv; return (hsc_HPT env) } -getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) -getEpsAndHpt = do { env <- getTopEnv; eps <- liftIO $ hscEPS env - ; return (eps, hsc_HPT env) } +getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph) +getEpsAndHug = do { env <- getTopEnv; eps <- liftIO $ hscEPS env + ; return (eps, hsc_HUG env) } -- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing -- an exception if it is an error. @@ -2073,7 +2073,7 @@ initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv ; hsc_env <- getTopEnv -- bangs to avoid leaking the envs (#19356) - ; let !mhome_unit = ue_home_unit (hsc_unit_env hsc_env) + ; let !mhome_unit = hsc_home_unit_maybe hsc_env !knot_vars = tcg_type_env_var tcg_env -- When we are instantiating a signature, we DEFINITELY -- do not want to knot tie. diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs index 96a60b61ae..27eb17afed 100644 --- a/compiler/GHC/Types/Name/Ppr.hs +++ b/compiler/GHC/Types/Name/Ppr.hs @@ -72,7 +72,7 @@ mkPrintUnqualified unit_env env (mkQualPackage unit_state) where unit_state = ue_units unit_env - home_unit = ue_home_unit unit_env + home_unit = ue_homeUnit unit_env qual_name mod occ | [gre] <- unqual_gres , right_name gre diff --git a/compiler/GHC/Types/PkgQual.hs b/compiler/GHC/Types/PkgQual.hs index 2ac5894d72..9154ae7578 100644 --- a/compiler/GHC/Types/PkgQual.hs +++ b/compiler/GHC/Types/PkgQual.hs @@ -3,6 +3,7 @@ module GHC.Types.PkgQual where +import GHC.Prelude import GHC.Types.SourceText import GHC.Unit.Types import GHC.Utils.Outputable @@ -23,7 +24,7 @@ data PkgQual = NoPkgQual -- ^ No package qualifier | ThisPkg UnitId -- ^ Import from home-unit | OtherPkg UnitId -- ^ Import from another unit - deriving (Data) + deriving (Data, Ord, Eq) instance Outputable RawPkgQual where ppr = \case @@ -34,7 +35,7 @@ instance Outputable RawPkgQual where instance Outputable PkgQual where ppr = \case NoPkgQual -> empty - ThisPkg _ -> doubleQuotes (text "this") + ThisPkg u -> doubleQuotes (ppr u) OtherPkg u -> doubleQuotes (ppr u) diff --git a/compiler/GHC/Types/Target.hs b/compiler/GHC/Types/Target.hs index 191f84eb2f..8622156caf 100644 --- a/compiler/GHC/Types/Target.hs +++ b/compiler/GHC/Types/Target.hs @@ -55,8 +55,8 @@ type InputFileBuffer = StringBuffer pprTarget :: Target -> SDoc -pprTarget Target { targetId = id, targetAllowObjCode = obj } = - (if obj then empty else char '*') <> pprTargetId id +pprTarget Target { targetUnitId = uid, targetId = id, targetAllowObjCode = obj } = + (if obj then empty else char '*') <> ppr uid <> colon <> pprTargetId id instance Outputable Target where ppr = pprTarget diff --git a/compiler/GHC/Unit.hs b/compiler/GHC/Unit.hs index d5d338e549..155d5b3525 100644 --- a/compiler/GHC/Unit.hs +++ b/compiler/GHC/Unit.hs @@ -24,7 +24,7 @@ import GHC.Unit.State Note [About Units] ~~~~~~~~~~~~~~~~~~ -Haskell users are used to manipulate Cabal packages. These packages are +Haskell users are used to manipulating Cabal packages. These packages are identified by: - a package name :: String - a package version :: Version diff --git a/compiler/GHC/Unit/Env.hs b/compiler/GHC/Unit/Env.hs index 2655bb166c..c3b7aaed4a 100644 --- a/compiler/GHC/Unit/Env.hs +++ b/compiler/GHC/Unit/Env.hs @@ -1,11 +1,61 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv , unsafeGetHomeUnit + , updateHug , updateHpt + -- * Unit Env helper functions + , ue_units + , ue_currentHomeUnitEnv + , ue_setUnits + , ue_setUnitFlags + , ue_unit_dbs + , ue_setUnitDbs + , ue_hpt + , ue_homeUnit + , ue_unsafeHomeUnit + , ue_setFlags + , ue_setActiveUnit + , ue_currentUnit + , ue_findHomeUnitEnv + , ue_updateHomeUnitEnv + , ue_unitHomeUnit + , ue_unitFlags + , ue_renameUnitId + , ue_transitiveHomeDeps + -- * HomeUnitEnv + , HomeUnitGraph + , HomeUnitEnv (..) + , mkHomeUnitEnv + , lookupHugByModule + , hugElts + , lookupHug + , addHomeModInfoToHug + -- * UnitEnvGraph + , UnitEnvGraph (..) + , unitEnv_insert + , unitEnv_delete + , unitEnv_adjust + , unitEnv_new + , unitEnv_singleton + , unitEnv_map + , unitEnv_member + , unitEnv_lookup_maybe + , unitEnv_lookup + , unitEnv_keys + , unitEnv_elts + , unitEnv_hpts + , unitEnv_foldWithKey + , unitEnv_mapWithKey + -- * Invariants + , assertUnitEnvInvariant + -- * Preload units info , preloadUnitsInfo , preloadUnitsInfo' - ) + -- * Home Module functions + , isUnitEnvInstalledModule ) where import GHC.Prelude @@ -20,48 +70,26 @@ import GHC.Platform import GHC.Settings import GHC.Data.Maybe import GHC.Utils.Panic.Plain +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import GHC.Utils.Misc (HasDebugCallStack) +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Utils.Panic (pprPanic) +import GHC.Unit.Module.ModIface +import GHC.Unit.Module +import qualified Data.Set as Set data UnitEnv = UnitEnv - { ue_units :: !UnitState - -- ^ External units - - , ue_unit_dbs :: !(Maybe [UnitDatabase UnitId]) - -- ^ Stack of unit databases for the target platform. - -- - -- This field is populated with the result of `initUnits`. - -- - -- 'Nothing' means the databases have never been read from disk. - -- - -- Usually we don't reload the databases from disk if they are - -- cached, even if the database flags changed! - - , ue_eps :: {-# UNPACK #-} !ExternalUnitCache + { ue_eps :: {-# UNPACK #-} !ExternalUnitCache -- ^ Information about the currently loaded external packages. -- This is mutable because packages will be demand-loaded during -- a compilation run as required. - , ue_home_unit :: !(Maybe HomeUnit) - -- ^ Home unit - - , ue_hpt :: !HomePackageTable - -- ^ The home package table describes already-compiled - -- home-package modules, /excluding/ the module we - -- are compiling right now. - -- (In one-shot mode the current module is the only - -- home-package module, so hsc_HPT is empty. All other - -- modules count as \"external-package\" modules. - -- However, even in GHCi mode, hi-boot interfaces are - -- demand-loaded into the external-package table.) - -- - -- 'hsc_HPT' is not mutable because we only demand-load - -- external packages; the home package is eagerly - -- loaded, module by module, by the compilation manager. - -- - -- The HPT may contain modules compiled earlier by @--make@ - -- but not actually below the current module in the dependency - -- graph. - -- - -- (This changes a previous invariant: changed Jan 05.) + , ue_current_unit :: UnitId + + , ue_home_unit_graph :: !HomeUnitGraph + -- See Note [Multiple Home Units] , ue_platform :: !Platform -- ^ Platform @@ -70,29 +98,39 @@ data UnitEnv = UnitEnv -- ^ GHC name/version (used for dynamic library suffix) } -initUnitEnv :: GhcNameVersion -> Platform -> IO UnitEnv -initUnitEnv namever platform = do +initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv +initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache return $ UnitEnv - { ue_units = emptyUnitState - , ue_unit_dbs = Nothing - , ue_eps = eps - , ue_home_unit = Nothing - , ue_hpt = emptyHomePackageTable - , ue_platform = platform - , ue_namever = namever + { ue_eps = eps + , ue_home_unit_graph = hug + , ue_current_unit = cur_unit + , ue_platform = platform + , ue_namever = namever } -- | Get home-unit -- -- Unsafe because the home-unit may not be set unsafeGetHomeUnit :: UnitEnv -> HomeUnit -unsafeGetHomeUnit ue = case ue_home_unit ue of - Nothing -> panic "unsafeGetHomeUnit: No home unit" - Just h -> h +unsafeGetHomeUnit ue = ue_unsafeHomeUnit ue updateHpt :: (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv -updateHpt f ue = ue { ue_hpt = f (ue_hpt ue) } +updateHpt = ue_updateHPT + +updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv +updateHug = ue_updateHUG + +ue_transitiveHomeDeps :: UnitId -> UnitEnv -> [UnitId] +ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid]) + where + loop acc [] = acc + loop acc (uid:uids) + | uid `Set.member` acc = loop acc uids + | otherwise = + let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env)) + in loop (Set.insert uid acc) (hue ++ uids) + -- ----------------------------------------------------------------------------- -- Extracting information from the packages in scope @@ -113,7 +151,7 @@ preloadUnitsInfo' unit_env ids0 = all_infos where unit_state = ue_units unit_env ids = ids0 ++ inst_ids - inst_ids = case ue_home_unit unit_env of + inst_ids = case ue_homeUnit unit_env of Nothing -> [] Just home_unit -- An indefinite package will have insts to HOLE, @@ -132,3 +170,401 @@ preloadUnitsInfo' unit_env ids0 = all_infos -- unit used to instantiate the home unit. preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo] preloadUnitsInfo unit_env = preloadUnitsInfo' unit_env [] + +-- ----------------------------------------------------------------------------- + +data HomeUnitEnv = HomeUnitEnv + { homeUnitEnv_units :: !UnitState + -- ^ External units + + , homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId]) + -- ^ Stack of unit databases for the target platform. + -- + -- This field is populated with the result of `initUnits`. + -- + -- 'Nothing' means the databases have never been read from disk. + -- + -- Usually we don't reload the databases from disk if they are + -- cached, even if the database flags changed! + + , homeUnitEnv_dflags :: DynFlags + -- ^ The dynamic flag settings + , homeUnitEnv_hpt :: HomePackageTable + -- ^ The home package table describes already-compiled + -- home-package modules, /excluding/ the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so homeUnitEnv_hpt is empty. All other + -- modules count as \"external-package\" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loaded into the external-package table.) + -- + -- 'homeUnitEnv_hpt' is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by @--make@ + -- but not actually below the current module in the dependency + -- graph. + -- + -- (This changes a previous invariant: changed Jan 05.) + + , homeUnitEnv_home_unit :: !(Maybe HomeUnit) + -- ^ Home-unit + } + +instance Outputable HomeUnitEnv where + ppr hug = pprHPT (homeUnitEnv_hpt hug) + +homeUnitEnv_unsafeHomeUnit :: HomeUnitEnv -> HomeUnit +homeUnitEnv_unsafeHomeUnit hue = case homeUnitEnv_home_unit hue of + Nothing -> panic "homeUnitEnv_unsafeHomeUnit: No home unit" + Just h -> h + +mkHomeUnitEnv :: DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv +mkHomeUnitEnv dflags hpt home_unit = HomeUnitEnv + { homeUnitEnv_units = emptyUnitState + , homeUnitEnv_unit_dbs = Nothing + , homeUnitEnv_dflags = dflags + , homeUnitEnv_hpt = hpt + , homeUnitEnv_home_unit = home_unit + } + +-- | Test if the module comes from the home unit +isUnitEnvInstalledModule :: UnitEnv -> InstalledModule -> Bool +isUnitEnvInstalledModule ue m = maybe False (`isHomeInstalledModule` m) hu + where + hu = ue_unitHomeUnit_maybe (moduleUnit m) ue + + +type HomeUnitGraph = UnitEnvGraph HomeUnitEnv + +lookupHugByModule :: Module -> HomeUnitGraph -> Maybe HomeModInfo +lookupHugByModule mod hug + | otherwise = do + env <- (unitEnv_lookup_maybe (toUnitId $ moduleUnit mod) hug) + lookupHptByModule (homeUnitEnv_hpt env) mod + +hugElts :: HomeUnitGraph -> [(UnitId, HomeUnitEnv)] +hugElts hug = unitEnv_elts hug + +addHomeModInfoToHug :: HomeModInfo -> HomeUnitGraph -> HomeUnitGraph +addHomeModInfoToHug hmi hug = unitEnv_alter go hmi_unit hug + where + hmi_mod :: Module + hmi_mod = mi_module (hm_iface hmi) + + hmi_unit = toUnitId (moduleUnit hmi_mod) + _hmi_mn = moduleName hmi_mod + + go :: Maybe HomeUnitEnv -> Maybe HomeUnitEnv + go Nothing = pprPanic "addHomeInfoToHug" (ppr hmi_mod) + go (Just hue) = Just (updateHueHpt (addHomeModInfoToHpt hmi) hue) + +updateHueHpt :: (HomePackageTable -> HomePackageTable) -> HomeUnitEnv -> HomeUnitEnv +updateHueHpt f hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue)} + + +lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo +lookupHug hug uid mod = unitEnv_lookup_maybe uid hug >>= flip lookupHpt mod . homeUnitEnv_hpt + + +instance Outputable (UnitEnvGraph HomeUnitEnv) where + ppr g = ppr [(k, length (homeUnitEnv_hpt hue)) | (k, hue) <- (unitEnv_elts g)] + + +type UnitEnvGraphKey = UnitId + +newtype UnitEnvGraph v = UnitEnvGraph + { unitEnv_graph :: Map UnitEnvGraphKey v + } deriving (Functor, Foldable, Traversable) + +unitEnv_insert :: UnitEnvGraphKey -> v -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_insert unitId env unitEnv = unitEnv + { unitEnv_graph = Map.insert unitId env (unitEnv_graph unitEnv) + } + +unitEnv_delete :: UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_delete uid unitEnv = + unitEnv + { unitEnv_graph = Map.delete uid (unitEnv_graph unitEnv) + } + +unitEnv_adjust :: (v -> v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_adjust f uid unitEnv = unitEnv + { unitEnv_graph = Map.adjust f uid (unitEnv_graph unitEnv) + } + +unitEnv_alter :: (Maybe v -> Maybe v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_alter f uid unitEnv = unitEnv + { unitEnv_graph = Map.alter f uid (unitEnv_graph unitEnv) + } + +unitEnv_mapWithKey :: (UnitEnvGraphKey -> v -> b) -> UnitEnvGraph v -> UnitEnvGraph b +unitEnv_mapWithKey f (UnitEnvGraph u) = UnitEnvGraph $ Map.mapWithKey f u + +unitEnv_new :: Map UnitEnvGraphKey v -> UnitEnvGraph v +unitEnv_new m = + UnitEnvGraph + { unitEnv_graph = m + } + +unitEnv_singleton :: UnitEnvGraphKey -> v -> UnitEnvGraph v +unitEnv_singleton active m = UnitEnvGraph + { unitEnv_graph = Map.singleton active m + } + +unitEnv_map :: (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_map f m = m { unitEnv_graph = Map.map f (unitEnv_graph m)} + +unitEnv_member :: UnitEnvGraphKey -> UnitEnvGraph v -> Bool +unitEnv_member u env = Map.member u (unitEnv_graph env) + +unitEnv_lookup_maybe :: UnitEnvGraphKey -> UnitEnvGraph v -> Maybe v +unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env) + +unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v +unitEnv_lookup u env = fromJust $ unitEnv_lookup_maybe u env + +unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey +unitEnv_keys env = Map.keysSet (unitEnv_graph env) + +unitEnv_elts :: UnitEnvGraph v -> [(UnitEnvGraphKey, v)] +unitEnv_elts env = Map.toList (unitEnv_graph env) + +unitEnv_hpts :: UnitEnvGraph HomeUnitEnv -> [HomePackageTable] +unitEnv_hpts env = map homeUnitEnv_hpt (Map.elems (unitEnv_graph env)) + +unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b +unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g + +-- ------------------------------------------------------- +-- Query and modify UnitState in HomeUnitEnv +-- ------------------------------------------------------- + +ue_units :: HasDebugCallStack => UnitEnv -> UnitState +ue_units = homeUnitEnv_units . ue_currentHomeUnitEnv + +ue_setUnits :: UnitState -> UnitEnv -> UnitEnv +ue_setUnits units ue = ue_updateHomeUnitEnv f (ue_currentUnit ue) ue + where + f hue = hue { homeUnitEnv_units = units } + +ue_unit_dbs :: UnitEnv -> Maybe [UnitDatabase UnitId] +ue_unit_dbs = homeUnitEnv_unit_dbs . ue_currentHomeUnitEnv + +ue_setUnitDbs :: Maybe [UnitDatabase UnitId] -> UnitEnv -> UnitEnv +ue_setUnitDbs unit_dbs ue = ue_updateHomeUnitEnv f (ue_currentUnit ue) ue + where + f hue = hue { homeUnitEnv_unit_dbs = unit_dbs } + +-- ------------------------------------------------------- +-- Query and modify Home Package Table in HomeUnitEnv +-- ------------------------------------------------------- + +ue_hpt :: HasDebugCallStack => UnitEnv -> HomePackageTable +ue_hpt = homeUnitEnv_hpt . ue_currentHomeUnitEnv + +ue_updateHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv +ue_updateHPT f e = ue_updateUnitHPT f (ue_currentUnit e) e + +ue_updateHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv +ue_updateHUG f e = ue_updateUnitHUG f e + +ue_updateUnitHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitId -> UnitEnv -> UnitEnv +ue_updateUnitHPT f uid ue_env = ue_updateHomeUnitEnv update uid ue_env + where + update unitEnv = unitEnv { homeUnitEnv_hpt = f $ homeUnitEnv_hpt unitEnv } + +ue_updateUnitHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv +ue_updateUnitHUG f ue_env = ue_env { ue_home_unit_graph = f (ue_home_unit_graph ue_env)} + +-- ------------------------------------------------------- +-- Query and modify DynFlags in HomeUnitEnv +-- ------------------------------------------------------- + +ue_setFlags :: HasDebugCallStack => DynFlags -> UnitEnv -> UnitEnv +ue_setFlags dflags ue_env = ue_setUnitFlags (ue_currentUnit ue_env) dflags ue_env + +ue_setUnitFlags :: HasDebugCallStack => UnitId -> DynFlags -> UnitEnv -> UnitEnv +ue_setUnitFlags uid dflags e = + ue_updateUnitFlags (const dflags) uid e + +ue_unitFlags :: HasDebugCallStack => UnitId -> UnitEnv -> DynFlags +ue_unitFlags uid ue_env = homeUnitEnv_dflags $ ue_findHomeUnitEnv uid ue_env + +ue_updateUnitFlags :: HasDebugCallStack => (DynFlags -> DynFlags) -> UnitId -> UnitEnv -> UnitEnv +ue_updateUnitFlags f uid e = ue_updateHomeUnitEnv update uid e + where + update hue = hue { homeUnitEnv_dflags = f $ homeUnitEnv_dflags hue } + +-- ------------------------------------------------------- +-- Query and modify home units in HomeUnitEnv +-- ------------------------------------------------------- + +ue_homeUnit :: UnitEnv -> Maybe HomeUnit +ue_homeUnit = homeUnitEnv_home_unit . ue_currentHomeUnitEnv + +ue_unsafeHomeUnit :: UnitEnv -> HomeUnit +ue_unsafeHomeUnit ue = case ue_homeUnit ue of + Nothing -> panic "unsafeGetHomeUnit: No home unit" + Just h -> h + +ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit +ue_unitHomeUnit_maybe uid ue_env = + homeUnitEnv_unsafeHomeUnit <$> (ue_findHomeUnitEnv_maybe uid ue_env) + +ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit +ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env + + +-- ------------------------------------------------------- +-- Query and modify the currently active unit +-- ------------------------------------------------------- + +ue_currentHomeUnitEnv :: HasDebugCallStack => UnitEnv -> HomeUnitEnv +ue_currentHomeUnitEnv e = + case ue_findHomeUnitEnv_maybe (ue_currentUnit e) e of + Just unitEnv -> unitEnv + Nothing -> pprPanic "packageNotFound" $ + (ppr $ ue_currentUnit e) $$ ppr (ue_home_unit_graph e) + +ue_setActiveUnit :: UnitId -> UnitEnv -> UnitEnv +ue_setActiveUnit u ue_env = assertUnitEnvInvariant $ ue_env + { ue_current_unit = u + } + +ue_currentUnit :: UnitEnv -> UnitId +ue_currentUnit = ue_current_unit + +-- ------------------------------------------------------- +-- Operations on arbitrary elements of the home unit graph +-- ------------------------------------------------------- + +ue_findHomeUnitEnv_maybe :: UnitId -> UnitEnv -> Maybe HomeUnitEnv +ue_findHomeUnitEnv_maybe uid e = + unitEnv_lookup_maybe uid (ue_home_unit_graph e) + +ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv +ue_findHomeUnitEnv uid e = case unitEnv_lookup_maybe uid (ue_home_unit_graph e) of + Nothing -> pprPanic "Unit unknown to the internal unit environment" + $ text "unit (" <> ppr uid <> text ")" + $$ pprUnitEnvGraph e + Just hue -> hue + +ue_updateHomeUnitEnv :: (HomeUnitEnv -> HomeUnitEnv) -> UnitId -> UnitEnv -> UnitEnv +ue_updateHomeUnitEnv f uid e = e + { ue_home_unit_graph = unitEnv_adjust f uid $ ue_home_unit_graph e + } + + +-- | Rename a unit id in the internal unit env. +-- +-- @'ue_renameUnitId' oldUnit newUnit UnitEnv@, it is assumed that the 'oldUnit' exists in the map, +-- otherwise we panic. +-- The 'DynFlags' associated with the home unit will have its field 'homeUnitId' set to 'newUnit'. +ue_renameUnitId :: HasDebugCallStack => UnitId -> UnitId -> UnitEnv -> UnitEnv +ue_renameUnitId oldUnit newUnit unitEnv = case ue_findHomeUnitEnv_maybe oldUnit unitEnv of + Nothing -> + pprPanic "Tried to rename unit, but it didn't exist" + $ text "Rename old unit \"" <> ppr oldUnit <> text "\" to \""<> ppr newUnit <> text "\"" + $$ nest 2 (pprUnitEnvGraph unitEnv) + Just oldEnv -> + let + activeUnit :: UnitId + !activeUnit = if ue_currentUnit unitEnv == oldUnit + then newUnit + else ue_currentUnit unitEnv + + newInternalUnitEnv = oldEnv + { homeUnitEnv_dflags = (homeUnitEnv_dflags oldEnv) + { homeUnitId_ = newUnit + } + } + in + unitEnv + { ue_current_unit = activeUnit + , ue_home_unit_graph = + unitEnv_insert newUnit newInternalUnitEnv + $ unitEnv_delete oldUnit + $ ue_home_unit_graph unitEnv + } + +-- --------------------------------------------- +-- Asserts to enforce invariants for the UnitEnv +-- --------------------------------------------- + +assertUnitEnvInvariant :: HasDebugCallStack => UnitEnv -> UnitEnv +assertUnitEnvInvariant u = + if ue_current_unit u `unitEnv_member` ue_home_unit_graph u + then u + else pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (ue_home_unit_graph u)) + +-- ----------------------------------------------------------------------------- +-- Pretty output functions +-- ----------------------------------------------------------------------------- + +pprUnitEnvGraph :: UnitEnv -> SDoc +pprUnitEnvGraph env = text "pprInternalUnitMap" + $$ nest 2 (pprHomeUnitGraph $ ue_home_unit_graph env) + +pprHomeUnitGraph :: HomeUnitGraph -> SDoc +pprHomeUnitGraph unitEnv = vcat (map (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv) + +pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> SDoc +pprHomeUnitEnv uid env = + ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->" + $$ nest 4 (pprHPT $ homeUnitEnv_hpt env) + +{- +Note [Multiple Home Units] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of multiple home units is quite simple. Instead of allowing one +home unit, you can multiple home units + +The flow: + +1. Dependencies between units are specified between each other in the normal manner, + a unit is identified by the -this-unit-id flag and dependencies specified by + the normal -package-id flag. +2. Downsweep is augmented to know to know how to look for dependencies in any home unit. +3. The rest of the compiler is modified appropiately to offset paths to the right places. +4. --make mode can parallelise between home units and multiple units are allowed to produce linkables. + +Closure Property +---------------- + +You must perform a clean cut of the dependency graph. + +> Any dependency which is not a home unit must not (transitively) depend on a home unit. + +For example, if you have three packages p, q and r, then if p depends on q which +depends on r then it is illegal to load both p and r as home units but not q, +because q is a dependency of the home unit p which depends on another home unit r. + +Offsetting Paths +---------------- + +The main complication to the implementation is to do with offsetting paths appropiately. +For a long time it has been assumed that GHC will execute in the top-directory for a unit, +normally where the .cabal file is and all paths are interpreted relative to there. +When you have multiple home units then it doesn't make sense to pick one of these +units to choose as the base-unit, and you can't robustly change directories when +using parralelism. + +Therefore there is an option `-working-directory`, which tells GHC where the relative +paths for each unit should be interpreted relative to. For example, if you specify +`-working-dir a -ib`, then GHC will offset the relative path `b`, by `a`, and look for +source files in `a/b`. The same thing happens for any path passed on the command line. + +A non-exhaustive list is + +* -i +* -I +* -odir/-hidir/-outputdir/-stubdir/-hiedir +* Target files passed on the command line + +There is also a template-haskell function, makeRelativeToProject, which uses the `-working-directory` option +in order to allow users to offset their own relative paths. + +-} diff --git a/compiler/GHC/Unit/External.hs b/compiler/GHC/Unit/External.hs index 177a9db2ba..4ed3479bf4 100644 --- a/compiler/GHC/Unit/External.hs +++ b/compiler/GHC/Unit/External.hs @@ -30,7 +30,6 @@ import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv ) import GHC.Types.CompleteMatch import GHC.Types.TypeEnv import GHC.Types.Unique.DSet -import GHC.Types.Unique.FM import Data.IORef @@ -62,7 +61,7 @@ initExternalUnitCache = ExternalUnitCache <$> newIORef initExternalPackageState initExternalPackageState :: ExternalPackageState initExternalPackageState = EPS - { eps_is_boot = emptyUFM + { eps_is_boot = emptyInstalledModuleEnv , eps_PIT = emptyPackageIfaceTable , eps_free_holes = emptyInstalledModuleEnv , eps_PTE = emptyTypeEnv @@ -89,7 +88,7 @@ initExternalPackageState = EPS -- their interface files data ExternalPackageState = EPS { - eps_is_boot :: !(ModuleNameEnv ModuleNameWithIsBoot), + eps_is_boot :: !(InstalledModuleEnv ModuleNameWithIsBoot), -- ^ In OneShot mode (only), home-package modules -- accumulate in the external package state, and are -- sucked in lazily. For these home-pkg modules diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs index d4de80947b..c7b6a2eb65 100644 --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} -- | Module finder module GHC.Unit.Finder ( @@ -24,6 +25,7 @@ module GHC.Unit.Finder ( mkHiOnlyModLocation, mkHiPath, mkObjPath, + addModuleToFinder, addHomeModuleToFinder, uncacheModule, mkStubPaths, @@ -41,6 +43,7 @@ import GHC.Platform.Ways import GHC.Builtin.Names ( gHC_PRIM ) +import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module import GHC.Unit.Home @@ -64,7 +67,10 @@ import System.FilePath import Control.Monad import Data.Time import qualified Data.Map as M - +import GHC.Driver.Env + ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) ) +import GHC.Driver.Config.Finder +import qualified Data.Set as Set type FileExt = String -- Filename extension type BaseName = String -- Basename of file @@ -90,12 +96,12 @@ initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv -- remove all the home modules from the cache; package modules are -- assumed to not move around during a session; also flush the file hash -- cache -flushFinderCaches :: FinderCache -> HomeUnit -> IO () -flushFinderCaches (FinderCache ref file_ref) home_unit = do +flushFinderCaches :: FinderCache -> UnitEnv -> IO () +flushFinderCaches (FinderCache ref file_ref) ue = do atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) atomicModifyIORef' file_ref $ \_ -> (M.empty, ()) where - is_ext mod _ = not (isHomeInstalledModule home_unit mod) + is_ext mod _ = not (isUnitEnvInstalledModule ue mod) addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO () addToFinderCache (FinderCache ref _) key val = @@ -130,32 +136,66 @@ lookupFileCache (FinderCache _ ref) key = do -- packages to find the module, if a package is specified then only -- that package is searched for the module. -findImportedModule +findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult +findImportedModule hsc_env mod fs = + let fc = hsc_FC hsc_env + mhome_unit = hsc_home_unit_maybe hsc_env + dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags + in do + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod fs + +findImportedModuleNoHsc :: FinderCache -> FinderOpts - -> UnitState + -> UnitEnv -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult -findImportedModule fc fopts units mhome_unit mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import - ThisPkg _ -> home_import + ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import + | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) + | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where - home_import - | Just home_unit <- mhome_unit - = findHomeModule fc fopts home_unit mod_name - | otherwise - = pure $ NoPackage (panic "findImportedModule: no home-unit") + all_opts = case mhome_unit of + Nothing -> other_fopts + Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts + + + home_import = case mhome_unit of + Just home_unit -> findHomeModule fc fopts home_unit mod_name + Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit") + + + home_pkg_import (uid, opts) + -- If the module is reexported, then look for it as if it was from the perspective + -- of that package which reexports it. + | mod_name `Set.member` finder_reexportedModules opts = + findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual + | mod_name `Set.member` finder_hiddenModules opts = + return (mkHomeHidden uid) + | otherwise = + findHomePackageModule fc opts uid mod_name - pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg + any_home_import = foldr orIfNotFound home_import (map home_pkg_import other_fopts) - unqual_import = home_import + pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg + + unqual_import = any_home_import `orIfNotFound` findExposedPackageModule fc fopts units mod_name NoPkgQual + units = case mhome_unit of + Nothing -> ue_units ue + Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue + hpt_deps :: [UnitId] + hpt_deps = homeUnitDepends units + other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps + -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or @@ -174,12 +214,14 @@ findPluginModule fc fopts units Nothing mod_name = -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult -findExactModule fc fopts unit_state mhome_unit mod = do +findExactModule :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult +findExactModule fc fopts other_fopts unit_state mhome_unit mod = do case mhome_unit of Just home_unit - | isHomeInstalledModule home_unit mod - -> findInstalledHomeModule fc fopts home_unit (moduleName mod) + | isHomeInstalledModule home_unit mod + -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod) + | Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts + -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod) _ -> findPackageModule fc unit_state fopts mod -- ----------------------------------------------------------------------------- @@ -215,9 +257,9 @@ orIfNotFound this or_this = do -- been done. Otherwise, do the lookup (with the IO action) and save -- the result in the finder cache and the module location cache (if it -- was successful.) -homeSearchCache :: FinderCache -> HomeUnit -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult +homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult homeSearchCache fc home_unit mod_name do_this = do - let mod = mkHomeInstalledModule home_unit mod_name + let mod = mkModule home_unit mod_name modLocationCache fc mod do_this findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult @@ -285,6 +327,11 @@ modLocationCache fc mod do_this = do addToFinderCache fc mod result return result +addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO () +addModuleToFinder fc mod loc = do + let imod = toUnitId <$> mod + addToFinderCache fc imod (InstalledFound loc imod) + -- This returns a module because it's more convenient for users addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module addHomeModuleToFinder fc home_unit mod_name loc = do @@ -303,7 +350,7 @@ uncacheModule fc home_unit mod_name = do findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult findHomeModule fc fopts home_unit mod_name = do let uid = homeUnitAsUnit home_unit - r <- findInstalledHomeModule fc fopts home_unit mod_name + r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name return $ case r of InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name) InstalledNoPackage _ -> NoPackage uid -- impossible @@ -316,6 +363,32 @@ findHomeModule fc fopts home_unit mod_name = do fr_suggestions = [] } +mkHomeHidden :: UnitId -> FindResult +mkHomeHidden uid = + NotFound { fr_paths = [] + , fr_pkg = Just (RealUnit (Definite uid)) + , fr_mods_hidden = [RealUnit (Definite uid)] + , fr_pkgs_hidden = [] + , fr_unusables = [] + , fr_suggestions = []} + +findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult +findHomePackageModule fc fopts home_unit mod_name = do + let uid = RealUnit (Definite home_unit) + r <- findInstalledHomeModule fc fopts home_unit mod_name + return $ case r of + InstalledFound loc _ -> Found loc (mkModule uid mod_name) + InstalledNoPackage _ -> NoPackage uid -- impossible + InstalledNotFound fps _ -> NotFound { + fr_paths = fps, + fr_pkg = Just uid, + fr_mods_hidden = [], + fr_pkgs_hidden = [], + fr_unusables = [], + fr_suggestions = [] + } + + -- | Implements the search for a module name in the home package only. Calling -- this function directly is usually *not* what you want; currently, it's used -- as a building block for the following operations: @@ -332,13 +405,16 @@ findHomeModule fc fopts home_unit mod_name = do -- -- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to -- call this.) -findInstalledHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO InstalledFindResult +findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO InstalledFindResult findInstalledHomeModule fc fopts home_unit mod_name = do homeSearchCache fc home_unit mod_name $ let - home_path = finder_importPaths fopts + maybe_working_dir = finder_workingDirectory fopts + home_path = case maybe_working_dir of + Nothing -> finder_importPaths fopts + Just fp -> augmentImports fp (finder_importPaths fopts) hisuf = finder_hiSuf fopts - mod = mkHomeInstalledModule home_unit mod_name + mod = mkModule home_unit mod_name source_exts = [ ("hs", mkHomeModLocationSearched fopts mod_name "hs") @@ -367,6 +443,11 @@ findInstalledHomeModule fc fopts home_unit mod_name = do then return (InstalledFound (error "GHC.Prim ModLocation") mod) else searchPathExts home_path mod exts +-- | Prepend the working directory to the search path. +augmentImports :: FilePath -> [FilePath] -> [FilePath] +augmentImports _work_dir [] = [] +augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps + | otherwise = (work_dir </> fp) : augmentImports work_dir fps -- | Search for a module in external packages only. findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult diff --git a/compiler/GHC/Unit/Finder/Types.hs b/compiler/GHC/Unit/Finder/Types.hs index 26baea564c..d3dad77eda 100644 --- a/compiler/GHC/Unit/Finder/Types.hs +++ b/compiler/GHC/Unit/Finder/Types.hs @@ -14,6 +14,8 @@ import GHC.Fingerprint import GHC.Platform.Ways import Data.IORef +import GHC.Data.FastString +import qualified Data.Set as Set -- | The 'FinderCache' maps modules to the result of -- searching for that module. It records the results of searching for @@ -86,6 +88,10 @@ data FinderOpts = FinderOpts , finder_enableSuggestions :: Bool -- ^ If we encounter unknown modules, should we suggest modules -- that have a similar name. + , finder_workingDirectory :: Maybe FilePath + , finder_thisPackageName :: Maybe FastString + , finder_hiddenModules :: Set.Set ModuleName + , finder_reexportedModules :: Set.Set ModuleName , finder_hieDir :: Maybe FilePath , finder_hieSuf :: String , finder_hiDir :: Maybe FilePath @@ -95,4 +101,4 @@ data FinderOpts = FinderOpts , finder_objectSuf :: String , finder_dynObjectSuf :: String , finder_stubDir :: Maybe FilePath - } + } deriving Show diff --git a/compiler/GHC/Unit/Home/ModInfo.hs b/compiler/GHC/Unit/Home/ModInfo.hs index 2173b7431b..d66019a3ea 100644 --- a/compiler/GHC/Unit/Home/ModInfo.hs +++ b/compiler/GHC/Unit/Home/ModInfo.hs @@ -132,7 +132,6 @@ lookupHptByModule hpt mod pprHPT :: HomePackageTable -> SDoc -- A bit arbitrary for now pprHPT hpt = pprUDFM hpt $ \hms -> - vcat [ hang (ppr (mi_module (hm_iface hm))) - 2 (ppr (md_types (hm_details hm))) + vcat [ ppr (mi_module (hm_iface hm)) | hm <- hms ] diff --git a/compiler/GHC/Unit/Module.hs b/compiler/GHC/Unit/Module.hs index 0ebfa73d16..b9813b95f5 100644 --- a/compiler/GHC/Unit/Module.hs +++ b/compiler/GHC/Unit/Module.hs @@ -108,7 +108,7 @@ getModuleInstantiation m = getUnitInstantiations :: Unit -> (UnitId, Maybe InstantiatedUnit) getUnitInstantiations (VirtUnit iuid) = (instUnitInstanceOf iuid, Just iuid) getUnitInstantiations (RealUnit (Definite uid)) = (uid, Nothing) -getUnitInstantiations HoleUnit = error "Hole unit" +getUnitInstantiations (HoleUnit {}) = error "Hole unit" -- | Remove instantiations of the given instantiated unit uninstantiateInstantiatedUnit :: InstantiatedUnit -> InstantiatedUnit diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs index 73412c002c..3a59703f88 100644 --- a/compiler/GHC/Unit/Module/Deps.hs +++ b/compiler/GHC/Unit/Module/Deps.hs @@ -23,7 +23,6 @@ import GHC.Prelude import GHC.Types.SafeHaskell import GHC.Types.Name -import GHC.Types.Unique.FM import GHC.Unit.Module.Name import GHC.Unit.Module.Imported @@ -38,6 +37,7 @@ import GHC.Utils.Outputable import Data.List (sortBy, sort, partition) import Data.Set (Set) import qualified Data.Set as Set +import Data.Bifunctor -- | Dependency information about ALL modules and packages below this one -- in the import hierarchy. This is the serialisable version of `ImportAvails`. @@ -50,7 +50,7 @@ import qualified Data.Set as Set -- -- See Note [Transitive Information in Dependencies] data Dependencies = Deps - { dep_direct_mods :: Set ModuleNameWithIsBoot + { dep_direct_mods :: Set (UnitId, ModuleNameWithIsBoot) -- ^ All home-package modules which are directly imported by this one. , dep_direct_pkgs :: Set UnitId @@ -72,7 +72,7 @@ data Dependencies = Deps -- when the module is imported as a safe import -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names - , dep_boot_mods :: Set ModuleNameWithIsBoot + , dep_boot_mods :: Set (UnitId, ModuleNameWithIsBoot) -- ^ All modules which have boot files below this one, and whether we -- should use the boot file or not. -- This information is only used to populate the eps_is_boot field. @@ -109,15 +109,15 @@ mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies mkDependencies home_unit mod imports plugin_mods = let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins) - all_direct_mods = foldr (\mn m -> addToUFM m mn (GWIB mn NotBoot)) + all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot)) (imp_direct_dep_mods imports) - (map moduleName home_plugins) + (map (fmap toUnitId) home_plugins) - modDepsElts = Set.fromList . nonDetEltsUFM + modDepsElts = Set.fromList . installedModuleEnvElts -- It's OK to use nonDetEltsUFM here because sorting by module names -- restores determinism - direct_mods = modDepsElts (delFromUFM all_direct_mods (moduleName mod)) + direct_mods = first moduleUnit `Set.map` modDepsElts (delInstalledModuleEnv all_direct_mods (toUnitId <$> mod)) -- M.hi-boot can be in the imp_dep_mods, but we must remove -- it before recording the modules on which this one depends! -- (We want to retain M.hi-boot in imp_dep_mods so that @@ -137,7 +137,7 @@ mkDependencies home_unit mod imports plugin_mods = -- If there's a non-boot import, then it shadows the boot import -- coming from the dependencies - source_mods = modDepsElts (imp_boot_mods imports) + source_mods = first moduleUnit `Set.map` modDepsElts (imp_boot_mods imports) sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports @@ -227,8 +227,8 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods text "family instance modules:" <+> fsep (map ppr finsts) ] where - ppr_mod (GWIB mod IsBoot) = ppr mod <+> text "[boot]" - ppr_mod (GWIB mod NotBoot) = ppr mod + ppr_mod (uid, (GWIB mod IsBoot)) = ppr uid <> colon <> ppr mod <+> text "[boot]" + ppr_mod (uid, (GWIB mod NotBoot)) = ppr uid <> colon <> ppr mod ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc ppr_set w = fsep . fmap w . Set.toAscList @@ -478,7 +478,7 @@ data ImportAvails -- different packages. (currently not the case, but might be in the -- future). - imp_direct_dep_mods :: ModuleNameEnv ModuleNameWithIsBoot, + imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot, -- ^ Home-package modules directly imported by the module being compiled. imp_dep_direct_pkgs :: Set UnitId, @@ -499,7 +499,7 @@ data ImportAvails -- we are dependent on a trustworthy module in that package. -- See Note [Tracking Trust Transitively] in "GHC.Rename.Names" - imp_boot_mods :: ModuleNameEnv ModuleNameWithIsBoot, + imp_boot_mods :: InstalledModuleEnv ModuleNameWithIsBoot, -- ^ Domain is all modules which have hs-boot files, and whether -- we should import the boot version of interface file. Only used -- in one-shot mode to populate eps_is_boot. diff --git a/compiler/GHC/Unit/Module/Env.hs b/compiler/GHC/Unit/Module/Env.hs index 905b446fe2..a69c865aef 100644 --- a/compiler/GHC/Unit/Module/Env.hs +++ b/compiler/GHC/Unit/Module/Env.hs @@ -28,7 +28,9 @@ module GHC.Unit.Module.Env , extendInstalledModuleEnv , filterInstalledModuleEnv , delInstalledModuleEnv + , mergeInstalledModuleEnv , plusInstalledModuleEnv + , installedModuleEnvElts ) where @@ -49,6 +51,7 @@ import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Set as Set import qualified GHC.Data.FiniteMap as Map +import GHC.Utils.Outputable -- | A map keyed off of 'Module's newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) @@ -209,6 +212,10 @@ type DModuleNameEnv elt = UniqDFM ModuleName elt -- | A map keyed off of 'InstalledModule' newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) +instance Outputable elt => Outputable (InstalledModuleEnv elt) where + ppr (InstalledModuleEnv env) = ppr env + + emptyInstalledModuleEnv :: InstalledModuleEnv a emptyInstalledModuleEnv = InstalledModuleEnv Map.empty @@ -225,6 +232,27 @@ filterInstalledModuleEnv f (InstalledModuleEnv e) = delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) --- | Left-biased -plusInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModuleEnv a -> InstalledModuleEnv a -plusInstalledModuleEnv (InstalledModuleEnv a) (InstalledModuleEnv b) = InstalledModuleEnv (a `mappend` b) +installedModuleEnvElts :: InstalledModuleEnv a -> [(InstalledModule, a)] +installedModuleEnvElts (InstalledModuleEnv e) = Map.assocs e + +mergeInstalledModuleEnv + :: (elta -> eltb -> Maybe eltc) + -> (InstalledModuleEnv elta -> InstalledModuleEnv eltc) -- map X + -> (InstalledModuleEnv eltb -> InstalledModuleEnv eltc) -- map Y + -> InstalledModuleEnv elta + -> InstalledModuleEnv eltb + -> InstalledModuleEnv eltc +mergeInstalledModuleEnv f g h (InstalledModuleEnv xm) (InstalledModuleEnv ym) + = InstalledModuleEnv $ Map.mergeWithKey + (\_ x y -> (x `f` y)) + (coerce g) + (coerce h) + xm ym + +plusInstalledModuleEnv :: (elt -> elt -> elt) + -> InstalledModuleEnv elt + -> InstalledModuleEnv elt + -> InstalledModuleEnv elt +plusInstalledModuleEnv f (InstalledModuleEnv xm) (InstalledModuleEnv ym) = + InstalledModuleEnv $ Map.unionWith f xm ym + diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs index 0df5779416..a225c50f27 100644 --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -6,9 +6,9 @@ module GHC.Unit.Module.Graph ( ModuleGraph , ModuleGraphNode(..) + , nodeDependencies , emptyMG , mkModuleGraph - , mkModuleGraph' , extendMG , extendMGInst , extendMG' @@ -16,7 +16,6 @@ module GHC.Unit.Module.Graph , mapMG , mgModSummaries , mgModSummaries' - , mgExtendedModSummaries , mgElemModule , mgLookupModule , mgBootModules @@ -36,6 +35,10 @@ module GHC.Unit.Module.Graph , mkNodeKey , msKey + + , moduleGraphNodeUnitId + + , ModNodeKeyWithUid(..) ) where @@ -60,9 +63,9 @@ import GHC.Utils.Outputable import System.FilePath import qualified Data.Map as Map import GHC.Types.Unique.DSet -import GHC.Types.SrcLoc import qualified Data.Set as Set import GHC.Unit.Module +import GHC.Linker.Static.Utils -- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'. -- Edges between nodes mark dependencies arising from module imports @@ -70,21 +73,51 @@ import GHC.Unit.Module data ModuleGraphNode -- | Instantiation nodes track the instantiation of other units -- (backpack dependencies) with the holes (signatures) of the current package. - = InstantiationNode InstantiatedUnit + = InstantiationNode UnitId InstantiatedUnit -- | There is a module summary node for each module, signature, and boot module being built. - | ModuleNode ExtendedModSummary + | ModuleNode [NodeKey] ModSummary + -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit. + | LinkNode [NodeKey] UnitId -moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ExtendedModSummary +moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName +moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn) + +moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ModSummary moduleGraphNodeModSum (InstantiationNode {}) = Nothing -moduleGraphNodeModSum (ModuleNode ems) = Just ems +moduleGraphNodeModSum (LinkNode {}) = Nothing +moduleGraphNodeModSum (ModuleNode _ ms) = Just ms -moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName -moduleGraphNodeModule = fmap (ms_mod_name . emsModSummary) . moduleGraphNodeModSum +moduleGraphNodeUnitId :: ModuleGraphNode -> UnitId +moduleGraphNodeUnitId mgn = + case mgn of + InstantiationNode uid _iud -> uid + ModuleNode _ ms -> toUnitId (moduleUnit (ms_mod ms)) + LinkNode _ uid -> uid instance Outputable ModuleGraphNode where ppr = \case - InstantiationNode iuid -> ppr iuid - ModuleNode ems -> ppr ems + InstantiationNode _ iuid -> ppr iuid + ModuleNode nks ms -> ppr (ms_mnwib ms) <+> ppr nks + LinkNode uid _ -> text "LN:" <+> ppr uid + +data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit + | NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid + | NodeKey_Link !UnitId + deriving (Eq, Ord) + +instance Outputable NodeKey where + ppr nk = pprNodeKey nk + +pprNodeKey :: NodeKey -> SDoc +pprNodeKey (NodeKey_Unit iu) = ppr iu +pprNodeKey (NodeKey_Module mk) = ppr mk +pprNodeKey (NodeKey_Link uid) = ppr uid + +data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: ModuleNameWithIsBoot + , mnkUnitId :: UnitId } deriving (Eq, Ord) + +instance Outputable ModNodeKeyWithUid where + ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib -- | A '@ModuleGraph@' contains all the nodes from the home package (only). See -- '@ModuleGraphNode@' for information about the nodes. @@ -125,8 +158,9 @@ needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg { mg_mss = flip fmap mg_mss $ \case - InstantiationNode iuid -> InstantiationNode iuid - ModuleNode (ExtendedModSummary ms bds) -> ModuleNode (ExtendedModSummary (f ms) bds) + InstantiationNode uid iuid -> InstantiationNode uid iuid + LinkNode uid nks -> LinkNode uid nks + ModuleNode deps ms -> ModuleNode deps (f ms) , mg_non_boot = mapModuleEnv f mg_non_boot } @@ -137,10 +171,7 @@ mgTransDeps :: ModuleGraph -> Map.Map NodeKey (Set.Set NodeKey) mgTransDeps = mg_trans_deps mgModSummaries :: ModuleGraph -> [ModSummary] -mgModSummaries mg = [ m | ModuleNode (ExtendedModSummary m _) <- mgModSummaries' mg ] - -mgExtendedModSummaries :: ModuleGraph -> [ExtendedModSummary] -mgExtendedModSummaries mg = [ ems | ModuleNode ems <- mgModSummaries' mg ] +mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ] mgModSummaries' :: ModuleGraph -> [ModuleGraphNode] mgModSummaries' = mg_mss @@ -163,9 +194,9 @@ isTemplateHaskellOrQQNonBoot ms = -- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is -- not an element of the ModuleGraph. -extendMG :: ModuleGraph -> ExtendedModSummary -> ModuleGraph -extendMG ModuleGraph{..} ems@(ExtendedModSummary ms _) = ModuleGraph - { mg_mss = ModuleNode ems : mg_mss +extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph +extendMG ModuleGraph{..} deps ms = ModuleGraph + { mg_mss = ModuleNode deps ms : mg_mss , mg_trans_deps = td , mg_non_boot = case isBootSummary ms of IsBoot -> mg_non_boot @@ -176,24 +207,25 @@ extendMG ModuleGraph{..} ems@(ExtendedModSummary ms _) = ModuleGraph , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms } where - (gg, _lookup_node) = moduleGraphNodes False (ModuleNode ems : mg_mss) + (gg, _lookup_node) = moduleGraphNodes False (ModuleNode deps ms : mg_mss) td = allReachable gg (mkNodeKey . node_payload) -extendMGInst :: ModuleGraph -> InstantiatedUnit -> ModuleGraph -extendMGInst mg depUnitId = mg - { mg_mss = InstantiationNode depUnitId : mg_mss mg +extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph +extendMGInst mg uid depUnitId = mg + { mg_mss = InstantiationNode uid depUnitId : mg_mss mg } +extendMGLink :: ModuleGraph -> UnitId -> [NodeKey] -> ModuleGraph +extendMGLink mg uid nks = mg { mg_mss = LinkNode nks uid : mg_mss mg } + extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph extendMG' mg = \case - InstantiationNode depUnitId -> extendMGInst mg depUnitId - ModuleNode ems -> extendMG mg ems - -mkModuleGraph :: [ExtendedModSummary] -> ModuleGraph -mkModuleGraph = foldr (flip extendMG) emptyMG + InstantiationNode uid depUnitId -> extendMGInst mg uid depUnitId + ModuleNode deps ms -> extendMG mg deps ms + LinkNode deps uid -> extendMGLink mg uid deps -mkModuleGraph' :: [ModuleGraphNode] -> ModuleGraph -mkModuleGraph' = foldr (flip extendMG') emptyMG +mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph +mkModuleGraph = foldr (flip extendMG') emptyMG -- | This function filters out all the instantiation nodes from each SCC of a -- topological sort. Use this with care, as the resulting "strongly connected components" @@ -202,8 +234,9 @@ mkModuleGraph' = foldr (flip extendMG') emptyMG filterToposortToModules :: [SCC ModuleGraphNode] -> [SCC ModSummary] filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case - InstantiationNode _ -> Nothing - ModuleNode (ExtendedModSummary node _) -> Just node + InstantiationNode _ _ -> Nothing + LinkNode{} -> Nothing + ModuleNode _deps node -> Just node where -- This higher order function is somewhat bogus, -- as the definition of "strongly connected component" @@ -217,9 +250,17 @@ filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case as -> Just $ CyclicSCC as showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc -showModMsg _ _ (InstantiationNode indef_unit) = +showModMsg dflags _ (LinkNode {}) = + let staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> False + + platform = targetPlatform dflags + exe_file = exeFileName platform staticLink (outputFile_ dflags) + in text exe_file +showModMsg _ _ (InstantiationNode _uid indef_unit) = ppr $ instUnitInstanceOf indef_unit -showModMsg dflags recomp (ModuleNode (ExtendedModSummary mod_summary _)) = +showModMsg dflags recomp (ModuleNode _ mod_summary) = if gopt Opt_HideSourcePaths dflags then text mod_str else hsep $ @@ -244,7 +285,6 @@ showModMsg dflags recomp (ModuleNode (ExtendedModSummary mod_summary _)) = - type SummaryNode = Node Int ModuleGraphNode summaryNodeKey :: SummaryNode -> Int @@ -261,22 +301,23 @@ summaryNodeSummary = node_payload -- .hs, by introducing a cycle. Additionally, it ensures that we will always -- process the .hs-boot before the .hs, and so the HomePackageTable will always -- have the most up to date information. -unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey] -unfilteredEdges drop_hs_boot_nodes = \case - InstantiationNode iuid -> - NodeKey_Module . flip GWIB NotBoot <$> uniqDSetToList (instUnitHoles iuid) - ModuleNode (ExtendedModSummary ms bds) -> - [ NodeKey_Unit inst_unit | inst_unit <- bds ] ++ - (NodeKey_Module . flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++ - [ NodeKey_Module $ GWIB (ms_mod_name ms) IsBoot +nodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey] +nodeDependencies drop_hs_boot_nodes = \case + LinkNode deps _uid -> deps + InstantiationNode uid iuid -> + NodeKey_Module . (\mod -> ModNodeKeyWithUid (GWIB mod NotBoot) uid) <$> uniqDSetToList (instUnitHoles iuid) + ModuleNode deps ms -> + [ NodeKey_Module $ (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot) (ms_unitid ms)) | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile - ] ++ - (NodeKey_Module . flip GWIB NotBoot . unLoc <$> ms_home_imps ms) + ] ++ map drop_hs_boot deps where -- Drop hs-boot nodes by using HsSrcFile as the key hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature | otherwise = IsBoot + drop_hs_boot (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid)) + drop_hs_boot x = x + moduleGraphNodes :: Bool -> [ModuleGraphNode] -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode) moduleGraphNodes drop_hs_boot_nodes summaries = @@ -299,39 +340,30 @@ moduleGraphNodes drop_hs_boot_nodes summaries = -- We use integers as the keys for the SCC algorithm nodes :: [SummaryNode] - nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s + nodes = [ DigraphNode s key $ out_edge_keys $ nodeDependencies drop_hs_boot_nodes s | (s, key) <- numbered_summaries -- Drop the hi-boot ones if told to do so , case s of - InstantiationNode _ -> True - ModuleNode ems -> not $ isBootSummary (emsModSummary ems) == IsBoot && drop_hs_boot_nodes + InstantiationNode {} -> True + LinkNode {} -> True + ModuleNode _ ms -> not $ isBootSummary ms == IsBoot && drop_hs_boot_nodes ] out_edge_keys :: [NodeKey] -> [Int] out_edge_keys = mapMaybe lookup_key -- If we want keep_hi_boot_nodes, then we do lookup_key with -- IsBoot; else False - -type ModNodeKey = ModuleNameWithIsBoot - -data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey - deriving (Eq, Ord) - -instance Outputable NodeKey where - ppr nk = pprNodeKey nk - newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a } deriving (Functor, Traversable, Foldable) mkNodeKey :: ModuleGraphNode -> NodeKey mkNodeKey = \case - InstantiationNode x -> NodeKey_Unit x - ModuleNode x -> NodeKey_Module $ ms_mnwib (emsModSummary x) + InstantiationNode _ iu -> NodeKey_Unit iu + ModuleNode _ x -> NodeKey_Module $ msKey x + LinkNode _ uid -> NodeKey_Link uid -msKey :: ModSummary -> ModuleNameWithIsBoot -msKey = ms_mnwib +msKey :: ModSummary -> ModNodeKeyWithUid +msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms) -pprNodeKey :: NodeKey -> SDoc -pprNodeKey (NodeKey_Unit iu) = ppr iu -pprNodeKey (NodeKey_Module mk) = ppr mk +type ModNodeKey = ModuleNameWithIsBoot diff --git a/compiler/GHC/Unit/Module/ModSummary.hs b/compiler/GHC/Unit/Module/ModSummary.hs index 0f29c5a477..3fd972632f 100644 --- a/compiler/GHC/Unit/Module/ModSummary.hs +++ b/compiler/GHC/Unit/Module/ModSummary.hs @@ -4,9 +4,7 @@ -- | A ModSummary is a node in the compilation manager's dependency graph -- (ModuleGraph) module GHC.Unit.Module.ModSummary - ( ExtendedModSummary (..) - , extendModSummaryNoDeps - , ModSummary (..) + ( ModSummary (..) , ms_unitid , ms_installed_mod , ms_mod_name @@ -20,6 +18,7 @@ module GHC.Unit.Module.ModSummary , msHsFilePath , msObjFilePath , msDynObjFilePath + , msDeps , isBootSummary , findTarget ) @@ -47,21 +46,6 @@ import GHC.Utils.Outputable import Data.Time --- | Enrichment of 'ModSummary' with backpack dependencies -data ExtendedModSummary = ExtendedModSummary - { emsModSummary :: {-# UNPACK #-} !ModSummary - , emsInstantiatedUnits :: [InstantiatedUnit] - -- ^ Extra backpack deps - -- NB: This is sometimes left empty in situations where the instantiated units - -- would not be used. See call sites of 'extendModSummaryNoDeps'. - } - -instance Outputable ExtendedModSummary where - ppr = \case - ExtendedModSummary ms bds -> ppr ms <+> ppr bds - -extendModSummaryNoDeps :: ModSummary -> ExtendedModSummary -extendModSummaryNoDeps ms = ExtendedModSummary ms [] -- | Data for a module node in a 'ModuleGraph'. Module nodes of the module graph -- are one of: @@ -127,22 +111,23 @@ ms_plugin_imps ms = map ((NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms) -- say, each of these module names could be a home import if an appropriately -- named file existed. (This is in contrast to package qualified imports, which -- are guaranteed not to be home imports.) -home_imps :: [(PkgQual, Located ModuleName)] -> [Located ModuleName] -home_imps imps = fmap snd (filter (maybe_home . fst) imps) +home_imps :: [(PkgQual, Located ModuleName)] -> [(PkgQual, Located ModuleName)] +home_imps imps = filter (maybe_home . fst) imps where maybe_home NoPkgQual = True maybe_home (ThisPkg _) = True maybe_home (OtherPkg _) = False -- | Like 'ms_home_imps', but for SOURCE imports. -ms_home_srcimps :: ModSummary -> [Located ModuleName] -ms_home_srcimps = home_imps . ms_srcimps +ms_home_srcimps :: ModSummary -> ([Located ModuleName]) +-- [] here because source imports can only refer to the current package. +ms_home_srcimps = map snd . home_imps . ms_srcimps -- | All of the (possibly) home module imports from a -- 'ModSummary'; that is to say, each of these module names -- could be a home import if an appropriately named file -- existed. (This is in contrast to package qualified -- imports, which are guaranteed not to be home imports.) -ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps :: ModSummary -> ([(PkgQual, Located ModuleName)]) ms_home_imps = home_imps . ms_imps -- The ModLocation contains both the original source filename and the @@ -169,12 +154,25 @@ isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot ms_mnwib :: ModSummary -> ModuleNameWithIsBoot ms_mnwib ms = GWIB (ms_mod_name ms) (isBootSummary ms) +-- | Returns the dependencies of the ModSummary s. +msDeps :: ModSummary -> ([(PkgQual, GenWithIsBoot (Located ModuleName))]) +msDeps s = + [ (NoPkgQual, d) + | m <- ms_home_srcimps s + , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot } + ] + ] + ++ [ (pkg, (GWIB { gwib_mod = m, gwib_isBoot = NotBoot })) + | (pkg, m) <- ms_imps s + ] + instance Outputable ModSummary where ppr ms = sep [text "ModSummary {", nest 3 (sep [text "ms_hs_hash = " <> text (show (ms_hs_hash ms)), text "ms_mod =" <+> ppr (ms_mod ms) <> text (hscSourceString (ms_hsc_src ms)) <> comma, + text "unit =" <+> ppr (ms_unitid ms), text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), char '}' diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index 859b99f1a1..8644848310 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -346,10 +346,11 @@ data UnitConfig = UnitConfig , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units , unitConfigFlagsTrusted :: [TrustFlag] -- ^ Trusted units , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units + , unitConfigHomeUnits :: Set.Set UnitId } -initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitConfig -initUnitConfig dflags cached_dbs = +initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig +initUnitConfig dflags cached_dbs home_units = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags !hu_instantiations = homeUnitInstantiations_ dflags @@ -383,19 +384,27 @@ initUnitConfig dflags cached_dbs = , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags , unitConfigDBCache = cached_dbs - , unitConfigFlagsDB = packageDBFlags dflags + , unitConfigFlagsDB = map (offsetPackageDb (workingDirectory dflags)) $ packageDBFlags dflags , unitConfigFlagsExposed = packageFlags dflags , unitConfigFlagsIgnored = ignorePackageFlags dflags , unitConfigFlagsTrusted = trustFlags dflags , unitConfigFlagsPlugins = pluginPackageFlags dflags + , unitConfigHomeUnits = home_units } + where + offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag + offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset </> p)) + offsetPackageDb _ p = p + + -- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and -- its 'ModuleOrigin'). -- -- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one -- origin for a given 'Module' + type ModuleNameProvidersMap = Map ModuleName (Map Module ModuleOrigin) @@ -435,6 +444,8 @@ data UnitState = UnitState { -- We'll use this to generate version macros. explicitUnits :: [Unit], + homeUnitDepends :: [UnitId], + -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want -- to report them in error messages), or it may be an ambiguous import. @@ -468,6 +479,7 @@ emptyUnitState = UnitState { unwireMap = Map.empty, preloadUnits = [], explicitUnits = [], + homeUnitDepends = [], moduleNameProvidersMap = Map.empty, pluginModuleNameProvidersMap = Map.empty, requirementContext = Map.empty, @@ -480,6 +492,9 @@ data UnitDatabase unit = UnitDatabase , unitDatabaseUnits :: [GenUnitInfo unit] } +instance Outputable u => Outputable (UnitDatabase u) where + ppr (UnitDatabase fp _u) = text "DB:" <+> text fp + type UnitInfoMap = Map UnitId UnitInfo -- | Find the unit we know about with the given unit, if any @@ -598,14 +613,14 @@ listUnitInfo state = Map.elems (unitInfoMap state) -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) -initUnits logger dflags cached_dbs = do +initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) +initUnits logger dflags cached_dbs home_units = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () (unit_state,dbs) <- withTiming logger (text "initializing unit database") forceUnitInfoMap - $ mkUnitState logger (initUnitConfig dflags cached_dbs) + $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) @@ -1159,7 +1174,7 @@ upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap upd_wired_in_uid :: WiringMap -> Unit -> Unit upd_wired_in_uid wiredInMap u = case u of - HoleUnit -> HoleUnit + HoleUnit -> HoleUnit RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) VirtUnit indef_uid -> VirtUnit $ mkInstantiatedUnit @@ -1491,10 +1506,13 @@ mkUnitState logger cfg = do -- This, and the other reverse's that you will see, are due to the fact that -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order -- than they are on the command line. - let other_flags = reverse (unitConfigFlagsExposed cfg) + let raw_other_flags = reverse (unitConfigFlagsExposed cfg) + (hpt_flags, other_flags) = partition (selectHptFlag (unitConfigHomeUnits cfg)) raw_other_flags debugTraceMsg logger 2 $ text "package flags" <+> ppr other_flags + let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags + -- Merge databases together, without checking validity (pkg_map1, prec_map) <- mergeDatabases logger dbs @@ -1654,6 +1672,7 @@ mkUnitState logger cfg = do let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs + , homeUnitDepends = Set.toList home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet , moduleNameProvidersMap = mod_map @@ -1666,6 +1685,19 @@ mkUnitState logger cfg = do } return (state, raw_dbs) +selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool +selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True +selectHptFlag _ _ = False + +selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId +selectHomeUnits home_units flags = foldl' go Set.empty flags + where + go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId + go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = Set.insert (toUnitId uid) cur + -- MP: This does not yet support thinning/renaming + go cur _ = cur + + -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' -- that it was recorded as in the package database. unwireUnit :: UnitState -> Unit -> Unit diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index fd35e70957..51a09f72e1 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -14,8 +14,10 @@ module GHC.Unit.Types GenModule (..) , Module , InstalledModule + , HomeUnitModule , InstantiatedModule , mkModule + , moduleUnitId , pprModule , pprInstantiatedModule , moduleFreeHoles @@ -117,10 +119,17 @@ data GenModule unit = Module -- | A Module is a pair of a 'Unit' and a 'ModuleName'. type Module = GenModule Unit +moduleUnitId :: Module -> UnitId +moduleUnitId = toUnitId . moduleUnit + -- | A 'InstalledModule' is a 'Module' whose unit is identified with an -- 'UnitId'. type InstalledModule = GenModule UnitId +-- | A 'HomeUnitModule' is like an 'InstalledModule' but we expect to find it in +-- one of the home units rather than the package database. +type HomeUnitModule = GenModule UnitId + -- | An `InstantiatedModule` is a 'Module' whose unit is identified with an `InstantiatedUnit`. type InstantiatedModule = GenModule InstantiatedUnit diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 51315c8b75..487fd7971c 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -485,6 +485,7 @@ Library GHC.Linker.Loader GHC.Linker.MacOS GHC.Linker.Static + GHC.Linker.Static.Utils GHC.Linker.Types GHC.Linker.Unit GHC.Linker.Windows |