diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-11-12 10:36:58 +0100 |
|---|---|---|
| committer | Sylvain Henry <sylvain@haskus.fr> | 2020-12-14 19:45:13 +0100 |
| commit | d0e8c10d587e4b9984526d0dfcfcb258b75733b8 (patch) | |
| tree | e0993719d76f87a0f4f8eccef089526217bf5bb4 | |
| parent | 92377c27e1a48d0d3776f65c7074dfeb122b46db (diff) | |
| download | haskell-d0e8c10d587e4b9984526d0dfcfcb258b75733b8.tar.gz | |
Move Unit related fields from DynFlags to HscEnv
The unit database cache, the home unit and the unit state were stored in
DynFlags while they ought to be stored in the compiler session state
(HscEnv). This patch fixes this.
It introduces a new UnitEnv type that should be used in the future to
handle separate unit environments (especially host vs target units).
Related to #17957
Bump haddock submodule
58 files changed, 1308 insertions, 1219 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index d6fe5094d5..65c1f4130b 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -384,6 +384,7 @@ import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Unit +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.State import GHC.Unit.Finder @@ -625,8 +626,9 @@ checkBrokenTablesNextToCode' dflags -- (packageFlags dflags). setSessionDynFlags :: GhcMonad m => DynFlags -> m () setSessionDynFlags dflags0 = do - dflags1 <- checkNewDynFlags dflags0 - dflags <- liftIO $ initUnits dflags1 + dflags <- checkNewDynFlags dflags0 + hsc_env <- getSession + (dbs,unit_state,home_unit) <- liftIO $ initUnits dflags (hsc_unit_dbs hsc_env) -- Interpreter interp <- if gopt Opt_ExternalInterpreter dflags @@ -661,12 +663,19 @@ setSessionDynFlags dflags0 = do return Nothing #endif + let unit_env = UnitEnv + { ue_platform = targetPlatform dflags + , ue_namever = ghcNameVersion dflags + , ue_home_unit = home_unit + , ue_units = unit_state + } modifySession $ \h -> h{ hsc_dflags = dflags , 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_home_unit = mkHomeUnitFromFlags dflags + , hsc_unit_env = unit_env + , hsc_unit_dbs = Just dbs } invalidateModSummaryCache @@ -693,10 +702,21 @@ setProgramDynFlags_ invalidate_needed dflags = do dflags' <- checkNewDynFlags dflags dflags_prev <- getProgramDynFlags let changed = packageFlagsChanged dflags_prev dflags' - dflags'' <- if changed - then liftIO $ initUnits dflags' - else return dflags' - modifySession $ \h -> h{ hsc_dflags = dflags'' } + if changed + then do + hsc_env <- getSession + (dbs,unit_state,home_unit) <- liftIO $ initUnits dflags' (hsc_unit_dbs hsc_env) + let unit_env = UnitEnv + { ue_platform = targetPlatform dflags' + , ue_namever = ghcNameVersion dflags' + , ue_home_unit = home_unit + , ue_units = unit_state + } + modifySession $ \h -> h{ hsc_dflags = dflags' + , hsc_unit_dbs = Just dbs + , hsc_unit_env = unit_env + } + else modifySession $ \h -> h{ hsc_dflags = dflags' } when invalidate_needed $ invalidateModSummaryCache return changed @@ -1292,11 +1312,7 @@ getInsts = withSession $ \hsc_env -> getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual = withSession $ \hsc_env -> do - let dflags = hsc_dflags hsc_env - return $ icPrintUnqual - (unitState dflags) - (hsc_home_unit hsc_env) - (hsc_IC hsc_env) + return $ icPrintUnqual (hsc_unit_env hsc_env) (hsc_IC hsc_env) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { @@ -1403,10 +1419,7 @@ mkPrintUnqualifiedForModule :: GhcMonad m => ModuleInfo -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do - let dflags = hsc_dflags hsc_env - mk_print_unqual = mkPrintUnqualified - (unitState dflags) - (hsc_home_unit hsc_env) + let mk_print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) return (fmap mk_print_unqual (minf_rdr_env minf)) modInfoLookupName :: GhcMonad m => @@ -1633,14 +1646,14 @@ showRichTokenStream ts = go startLoc ts "" -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = withSession $ \hsc_env -> do - let dflags = hsc_dflags hsc_env - home_unit = hsc_home_unit hsc_env + let dflags = hsc_dflags hsc_env + home_unit = hsc_home_unit hsc_env case maybe_pkg of Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found _ m -> return m - err -> throwOneError $ noModError dflags noSrcSpan mod_name err + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err _otherwise -> do home <- lookupLoadedHomeModule mod_name case home of @@ -1650,7 +1663,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do case res of Found loc m | not (isHomeModule home_unit m) -> return m | otherwise -> modNotLoadedError dflags m loc - err -> throwOneError $ noModError dflags noSrcSpan mod_name err + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ @@ -1675,7 +1688,7 @@ lookupModule mod_name Nothing = withSession $ \hsc_env -> do res <- findExposedPackageModule hsc_env mod_name Nothing case res of Found _ m -> return m - err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x index a8ceaff809..3828685645 100644 --- a/compiler/GHC/Cmm/Lexer.x +++ b/compiler/GHC/Cmm/Lexer.x @@ -362,8 +362,8 @@ alexGetByte (loc,s) s' = stepOn s getInput :: PD AlexInput -getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b) +getInput = PD $ \_ _ s@PState{ loc=l, buffer=b } -> POk s (l,b) setInput :: AlexInput -> PD () -setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } () +setInput (l,b) = PD $ \_ _ s -> POk s{ loc=l, buffer=b } () } diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 5067e04e79..b0a7465a48 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -244,6 +244,7 @@ import GHC.Parser.Errors import GHC.Types.CostCentre import GHC.Types.ForeignCall import GHC.Unit.Module +import GHC.Unit.Home import GHC.Types.Literal import GHC.Types.Unique import GHC.Types.Unique.FM @@ -1104,7 +1105,7 @@ isPtrGlobalReg (VanillaReg _ VGcPtr) = True isPtrGlobalReg _ = False happyError :: PD a -happyError = PD $ \_ s -> unP srcParseFail s +happyError = PD $ \_ _ s -> unP srcParseFail s -- ----------------------------------------------------------------------------- -- Statement-level macros @@ -1447,8 +1448,8 @@ initEnv profile = listToUFM [ ] where platform = profilePlatform profile -parseCmmFile :: DynFlags -> FilePath -> IO (Bag Warning, Bag Error, Maybe CmmGroup) -parseCmmFile dflags filename = do +parseCmmFile :: DynFlags -> HomeUnit -> FilePath -> IO (Bag Warning, Bag Error, Maybe CmmGroup) +parseCmmFile dflags home_unit filename = do buf <- hGetStringBuffer filename let init_loc = mkRealSrcLoc (mkFastString filename) 1 1 @@ -1456,7 +1457,7 @@ parseCmmFile dflags filename = do init_state = (initParserState opts buf init_loc) { lex_state = [0] } -- reset the lex_state: the Lexer monad leaves some stuff -- in there we don't want. - case unPD cmmParse dflags init_state of + case unPD cmmParse dflags home_unit init_state of PFailed pst -> do let (warnings,errors) = getMessages pst return (warnings, errors, Nothing) diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs index cbe89248c8..b8aa0180d8 100644 --- a/compiler/GHC/Cmm/Parser/Monad.hs +++ b/compiler/GHC/Cmm/Parser/Monad.hs @@ -32,7 +32,7 @@ import GHC.Types.SrcLoc import GHC.Unit.Types import GHC.Unit.Home -newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a } +newtype PD a = PD { unPD :: DynFlags -> HomeUnit -> PState -> ParseResult a } instance Functor PD where fmap = liftM @@ -45,7 +45,7 @@ instance Monad PD where (>>=) = thenPD liftP :: P a -> PD a -liftP (P f) = PD $ \_ s -> f s +liftP (P f) = PD $ \_ _ s -> f s failMsgPD :: (SrcSpan -> Error) -> PD a failMsgPD = liftP . failMsgP @@ -54,13 +54,13 @@ returnPD :: a -> PD a returnPD = liftP . return thenPD :: PD a -> (a -> PD b) -> PD b -(PD m) `thenPD` k = PD $ \d s -> - case m d s of - POk s1 a -> unPD (k a) d s1 +(PD m) `thenPD` k = PD $ \d hu s -> + case m d hu s of + POk s1 a -> unPD (k a) d hu s1 PFailed s1 -> PFailed s1 instance HasDynFlags PD where - getDynFlags = PD $ \d s -> POk s d + getDynFlags = PD $ \d _ s -> POk s d getProfile :: PD Profile getProfile = targetProfile <$> getDynFlags @@ -79,6 +79,4 @@ getPtrOpts = do -- | Return the UnitId of the home-unit. This is used to create labels. getHomeUnitId :: PD UnitId -getHomeUnitId = do - dflags <- getDynFlags - pure (homeUnitId (mkHomeUnitFromFlags dflags)) +getHomeUnitId = PD $ \_ hu s -> POk s (homeUnitId hu) diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 872edca65a..e6c970af9f 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -110,10 +110,7 @@ core2core hsc_env guts@(ModGuts { mg_module = mod dflags = hsc_dflags hsc_env home_pkg_rules = hptRules hsc_env (dep_mods deps) hpt_rule_base = mkRuleBase home_pkg_rules - print_unqual = mkPrintUnqualified - (unitState dflags) - (hsc_home_unit hsc_env) - rdr_env + 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. -- This is very convienent for the users of the monad (e.g. plugins do not have to -- consume the ModGuts to find the module) but somewhat ugly because mg_module may @@ -722,7 +719,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) } where dflags = hsc_dflags hsc_env - print_unqual = mkPrintUnqualified (unitState dflags) (hsc_home_unit hsc_env) rdr_env + print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env simpl_env = mkSimplEnv mode active_rule = activeRule mode active_unf = activeUnfolding mode diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index d38ba98622..b86ef6281b 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -56,6 +56,7 @@ import GHC.Utils.Panic import GHC.Utils.Error import GHC.Unit +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.State import GHC.Unit.Finder @@ -69,6 +70,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Maybe import GHC.Data.StringBuffer import GHC.Data.FastString +import qualified GHC.Data.EnumSet as EnumSet import qualified GHC.Data.ShortText as ST import Data.List ( partition ) @@ -103,8 +105,8 @@ doBackpack [src_filename] = do POk _ pkgname_bkp -> do -- OK, so we have an LHsUnit PackageName, but we want an -- LHsUnit HsComponentId. So let's rename it. - let pkgstate = unitState dflags - let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgname_bkp) pkgname_bkp + hsc_env <- getSession + let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp initBkpM src_filename bkp $ forM_ (zip [1..] bkp) $ \(i, lunit) -> do let comp_name = unLoc (hsunitName (unLoc lunit)) @@ -170,61 +172,67 @@ withBkpSession cid insts deps session_type do_this = do -- Special case when package is definite , not (null insts) = sub_comp (key_base p) </> uid_str | otherwise = sub_comp (key_base p) - withTempSession (overHscDynFlags (\dflags -> - -- If we're type-checking an indefinite package, we want to - -- turn on interface writing. However, if the user also - -- explicitly passed in `-fno-code`, we DON'T want to write - -- interfaces unless the user also asked for `-fwrite-interface`. - -- See Note [-fno-code mode] - (case session_type of - -- Make sure to write interfaces when we are type-checking - -- indefinite packages. - TcSession | backend dflags /= NoBackend - -> flip gopt_set Opt_WriteInterface - | otherwise -> id - CompSession -> id - ExeSession -> id) $ - dflags { - backend = case session_type of - TcSession -> NoBackend - _ -> backend dflags, - homeUnitInstantiations_ = insts, - -- if we don't have any instantiation, don't - -- fill `homeUnitInstanceOfId` as it makes no - -- sense (we're not instantiating anything) - homeUnitInstanceOf_ = if null insts then Nothing else Just (indefUnit cid), - homeUnitId_ = - case session_type of + + mk_temp_env hsc_env = hsc_env + { hsc_dflags = mk_temp_dflags (hsc_units hsc_env) (hsc_dflags hsc_env) + } + mk_temp_dflags unit_state dflags = dflags + { backend = case session_type of + TcSession -> NoBackend + _ -> backend dflags + , homeUnitInstantiations_ = insts + -- if we don't have any instantiation, don't + -- fill `homeUnitInstanceOfId` as it makes no + -- sense (we're not instantiating anything) + , homeUnitInstanceOf_ = if null insts then Nothing else Just (indefUnit cid) + , homeUnitId_ = case session_type of TcSession -> newUnitId cid Nothing -- No hash passed if no instances _ | null insts -> newUnitId cid Nothing - | otherwise -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)), - -- Setup all of the output directories according to our hierarchy - objectDir = Just (outdir objectDir), - hiDir = Just (outdir hiDir), - stubDir = Just (outdir stubDir), - -- Unset output-file for non exe builds - outputFile_ = if session_type == ExeSession - then outputFile_ dflags - else Nothing, - dynOutputFile_ = if session_type == ExeSession - then dynOutputFile_ dflags - else Nothing, - -- Clear the import path so we don't accidentally grab anything - importPaths = [], - -- Synthesized the flags - packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let state = unitState dflags - uid = unwireUnit state (improveUnit state $ renameHoleUnit state (listToUFM insts) uid0) - in ExposePackage - (showSDoc dflags - (text "-unit-id" <+> ppr uid <+> ppr rn)) - (UnitIdArg uid) rn) deps - } )) $ do - dflags <- getSessionDynFlags - -- pprTrace "flags" (ppr insts <> ppr deps) $ return () - setSessionDynFlags dflags -- calls initUnits - do_this + | otherwise -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)) + + + -- If we're type-checking an indefinite package, we want to + -- turn on interface writing. However, if the user also + -- explicitly passed in `-fno-code`, we DON'T want to write + -- interfaces unless the user also asked for `-fwrite-interface`. + -- See Note [-fno-code mode] + , generalFlags = case session_type of + -- Make sure to write interfaces when we are type-checking + -- indefinite packages. + TcSession + | backend dflags /= NoBackend + -> EnumSet.insert Opt_WriteInterface (generalFlags dflags) + _ -> generalFlags dflags + + -- Setup all of the output directories according to our hierarchy + , objectDir = Just (outdir objectDir) + , hiDir = Just (outdir hiDir) + , stubDir = Just (outdir stubDir) + -- Unset output-file for non exe builds + , outputFile_ = case session_type of + ExeSession -> outputFile_ dflags + _ -> Nothing + , dynOutputFile_ = case session_type of + ExeSession -> dynOutputFile_ dflags + _ -> Nothing + -- Clear the import path so we don't accidentally grab anything + , importPaths = [] + -- Synthesize the flags + , packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> + let uid = unwireUnit unit_state + $ improveUnit unit_state + $ renameHoleUnit unit_state (listToUFM insts) uid0 + in ExposePackage + (showSDoc dflags + (text "-unit-id" <+> ppr uid <+> ppr rn)) + (UnitIdArg uid) rn) deps + } + withTempSession mk_temp_env $ do + dflags <- getSessionDynFlags + -- pprTrace "flags" (ppr insts <> ppr deps) $ return () + setSessionDynFlags dflags -- calls initUnits + do_this withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a withBkpExeSession deps do_this = @@ -278,11 +286,11 @@ buildUnit session cid insts lunit = do -- any object files. let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit) raw_deps = map fst deps_w_rns - dflags <- getDynFlags + hsc_env <- getSession -- The compilation dependencies are just the appropriately filled -- in unit IDs which must be compiled before we can compile. let hsubst = listToUFM insts - deps0 = map (renameHoleUnit (unitState dflags) hsubst) raw_deps + deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps -- Build dependencies OR make sure they make sense. BUT NOTE, -- we can only check the ones that are fully filled; the rest @@ -293,9 +301,8 @@ buildUnit session cid insts lunit = do TcSession -> return () _ -> compileInclude (length deps0) (i, dep) - dflags <- getDynFlags -- IMPROVE IT - let deps = map (improveUnit (unitState dflags)) deps0 + let deps = map (improveUnit (hsc_units hsc_env)) deps0 mb_old_eps <- case session of TcSession -> fmap Just getEpsGhc @@ -324,7 +331,7 @@ buildUnit session cid insts lunit = do $ home_mod_infos getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) obj_files = concatMap getOfiles linkables - state = unitState (hsc_dflags hsc_env) + state = hsc_units hsc_env let compat_fs = unitIdFS (indefUnit cid) compat_pn = PackageName compat_fs @@ -380,7 +387,7 @@ buildUnit session cid insts lunit = do } - addPackage conf + addUnit conf case mb_old_eps of Just old_eps -> updateEpsGhc_ (const old_eps) _ -> return () @@ -400,22 +407,33 @@ compileExe lunit = do when (failed ok) (liftIO $ exitWith (ExitFailure 1)) -- | Register a new virtual unit database containing a single unit -addPackage :: GhcMonad m => UnitInfo -> m () -addPackage pkg = do - dflags <- GHC.getSessionDynFlags - case unitDatabases dflags of - Nothing -> panic "addPackage: called too early" - Just dbs -> do +addUnit :: GhcMonad m => UnitInfo -> m () +addUnit u = do + hsc_env <- getSession + newdbs <- case hsc_unit_dbs hsc_env of + Nothing -> panic "addUnit: called too early" + Just dbs -> let newdb = UnitDatabase - { unitDatabasePath = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")" - , unitDatabaseUnits = [pkg] + { unitDatabasePath = "(in memory " ++ showSDoc (hsc_dflags hsc_env) (ppr (unitId u)) ++ ")" + , unitDatabaseUnits = [u] } - GHC.setSessionDynFlags (dflags { unitDatabases = Just (dbs ++ [newdb]) }) + in return (dbs ++ [newdb]) -- added at the end because ordering matters + (dbs,unit_state,home_unit) <- liftIO $ initUnits (hsc_dflags hsc_env) (Just newdbs) + let unit_env = UnitEnv + { ue_platform = targetPlatform (hsc_dflags hsc_env) + , ue_namever = ghcNameVersion (hsc_dflags hsc_env) + , ue_home_unit = home_unit + , ue_units = unit_state + } + setSession $ hsc_env + { hsc_unit_dbs = Just dbs + , hsc_unit_env = unit_env + } compileInclude :: Int -> (Int, Unit) -> BkpM () compileInclude n (i, uid) = do hsc_env <- getSession - let pkgs = unitState (hsc_dflags hsc_env) + let pkgs = hsc_units hsc_env msgInclude (i, n) uid -- Check if we've compiled it already case uid of @@ -469,10 +487,6 @@ getBkpEnv = getEnv getBkpLevel :: BkpM Int getBkpLevel = bkp_level `fmap` getBkpEnv --- | Apply a function on 'DynFlags' on an 'HscEnv' -overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv -overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) } - -- | Run a 'BkpM' computation, with the nesting level bumped one. innerBkpM :: BkpM a -> BkpM a innerBkpM do_this = @@ -522,7 +536,7 @@ mkBackpackMsg = do level <- getBkpLevel return $ \hsc_env mod_index recomp mod_summary -> let dflags = hsc_dflags hsc_env - state = unitState dflags + state = hsc_units hsc_env showMsg msg reason = backpackProgressMsg level dflags $ pprWithUnitState state $ showModuleIndex mod_index <> @@ -557,8 +571,9 @@ msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do msgUnitId :: Unit -> BkpM () msgUnitId pk = do dflags <- getDynFlags + hsc_env <- getSession level <- getBkpLevel - let state = unitState dflags + let state = hsc_units hsc_env liftIO . backpackProgressMsg level dflags $ pprWithUnitState state $ text "Instantiating " @@ -568,8 +583,9 @@ msgUnitId pk = do msgInclude :: (Int,Int) -> Unit -> BkpM () msgInclude (i,n) uid = do dflags <- getDynFlags + hsc_env <- getSession level <- getBkpLevel - let state = unitState dflags + let state = hsc_units hsc_env liftIO . backpackProgressMsg level dflags $ pprWithUnitState state $ showModuleIndex (i, n) <> text "Including " diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 2bb30656dd..b251794f1a 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -64,6 +64,7 @@ import System.IO -} codeOutput :: DynFlags + -> UnitState -> Module -> FilePath -> ModLocation @@ -77,7 +78,7 @@ codeOutput :: DynFlags [(ForeignSrcLang, FilePath)]{-foreign_fps-}, a) -codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps +codeOutput dflags unit_state this_mod filenm location foreign_stubs foreign_fps pkg_deps cmm_stream = do { @@ -104,7 +105,7 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps ; return cmm } - ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs + ; stubs_exist <- outputForeignStubs dflags unit_state this_mod location foreign_stubs ; a <- case backend dflags of NCG -> outputAsm dflags this_mod location filenm linted_cmm_stream @@ -190,10 +191,10 @@ outputLlvm dflags filenm cmm_stream = ************************************************************************ -} -outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs +outputForeignStubs :: DynFlags -> UnitState -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created Maybe FilePath) -- C file created -outputForeignStubs dflags mod location stubs +outputForeignStubs dflags unit_state mod location stubs = do let stub_h = mkStubPaths dflags (moduleName mod) location stub_c <- newTempName dflags TFL_CurrentModule "c" @@ -220,7 +221,7 @@ outputForeignStubs dflags mod location stubs -- we need the #includes from the rts package for the stub files let rts_includes = - let rts_pkg = unsafeLookupUnitId (unitState dflags) rtsUnitId in + let rts_pkg = unsafeLookupUnitId unit_state rtsUnitId in concatMap mk_include (unitIncludes rts_pkg) mk_include i = "#include \"" ++ ST.unpack i ++ "\"\n" diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 6bf83c576e..596ea936ca 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -4,6 +4,8 @@ module GHC.Driver.Env ( Hsc(..) , HscEnv (..) + , hsc_home_unit + , hsc_units , runHsc , mkInteractiveHscEnv , runInteractiveHsc @@ -17,6 +19,7 @@ module GHC.Driver.Env , prepareAnnotations , lookupType , lookupIfaceByModule + , mainModIs ) where @@ -38,6 +41,7 @@ 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 import GHC.Unit.Finder.Types @@ -179,9 +183,6 @@ data HscEnv , hsc_loader :: Loader -- ^ Loader (dynamic linker) - , hsc_home_unit :: !HomeUnit - -- ^ Home-unit - , hsc_plugins :: ![LoadedPlugin] -- ^ plugins dynamically loaded after processing arguments. What -- will be loaded here is directed by DynFlags.pluginModNames. @@ -197,8 +198,31 @@ data HscEnv -- -- To add dynamically loaded plugins through the GHC API see -- 'addPluginModuleName' instead. + + , hsc_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! + + , hsc_unit_env :: UnitEnv + -- ^ Unit environment (unit state, home unit, etc.). + -- + -- Initialized from the databases cached in 'hsc_unit_dbs' and + -- from the DynFlags. } + +hsc_home_unit :: HscEnv -> HomeUnit +hsc_home_unit = ue_home_unit . hsc_unit_env + +hsc_units :: HscEnv -> UnitState +hsc_units = ue_units . hsc_unit_env + {- Note [Target code interpreter] @@ -392,3 +416,6 @@ 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)) + diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index 25e6530eef..432297b735 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -136,8 +136,7 @@ data Hooks = Hooks , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) , ghcPrimIfaceHook :: Maybe ModIface - , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags - -> CompPipeline (PhasePlus, FilePath)) + , runPhaseHook :: Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)) , runMetaHook :: Maybe (MetaHook TcM) , linkHook :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag) diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index cd37ac4f3a..8685462e7d 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -235,12 +235,16 @@ import Data.Bifunctor (first, bimap) newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do - let home_unit = mkHomeUnitFromFlags dflags - eps_var <- newIORef (initExternalPackageState home_unit) + -- we don't store the unit databases and the unit state to still + -- allow `setSessionDynFlags` to be used to set unit db flags. + eps_var <- newIORef (initExternalPackageState (homeUnitId_ dflags)) us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv emptyLoader <- uninitializedLoader + -- FIXME: it's sad that we have so many "unitialized" fields filled with + -- empty stuff or lazy panics. We should have two kinds of HscEnv + -- (initialized or not) instead and less fields that are mutable over time. return HscEnv { hsc_dflags = dflags , hsc_targets = [] , hsc_mod_graph = emptyMG @@ -252,9 +256,10 @@ newHscEnv dflags = do , hsc_type_env_var = Nothing , hsc_interp = Nothing , hsc_loader = emptyLoader - , hsc_home_unit = home_unit + , hsc_unit_env = panic "hsc_unit_env not initialized" , hsc_plugins = [] , hsc_static_plugins = [] + , hsc_unit_dbs = Nothing } -- ----------------------------------------------------------------------------- @@ -1258,6 +1263,7 @@ hscCheckSafe' m l = do where isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId) isModSafe home_unit m l = do + hsc_env <- getHscEnv dflags <- getDynFlags iface <- lookup' m case iface of @@ -1273,7 +1279,7 @@ hscCheckSafe' m l = do -- check module is trusted safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy] -- check package is trusted - safeP = packageTrusted dflags home_unit trust trust_own_pkg m + safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m -- pkg trust reqs pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface' -- warn if Safe module imports Safe-Inferred module. @@ -1293,7 +1299,7 @@ hscCheckSafe' m l = do return (trust == Sf_Trustworthy, pkgRs) where - state = unitState dflags + state = hsc_units hsc_env inferredImportWarn = unitBag $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) $ mkWarnMsg dflags l (pkgQual state) @@ -1318,17 +1324,17 @@ hscCheckSafe' m l = do -- modules are trusted without requiring that their package is trusted. For -- trustworthy modules, modules in the home package are trusted but -- otherwise we check the package trust flag. - packageTrusted :: DynFlags -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool - packageTrusted _ _ Sf_None _ _ = False -- shouldn't hit these cases - packageTrusted _ _ Sf_Ignore _ _ = False -- shouldn't hit these cases - packageTrusted _ _ Sf_Unsafe _ _ = False -- prefer for completeness. - packageTrusted dflags _ _ _ _ - | not (packageTrustOn dflags) = True - packageTrusted _ _ Sf_Safe False _ = True - packageTrusted _ _ Sf_SafeInferred False _ = True - packageTrusted dflags home_unit _ _ m - | isHomeModule home_unit m = True - | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m) + packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod = + case safe_mode of + Sf_None -> False -- shouldn't hit these cases + Sf_Ignore -> False -- shouldn't hit these cases + Sf_Unsafe -> False -- prefer for completeness. + _ | not (packageTrustOn dflags) -> True + Sf_Safe | not trust_own_pkg -> True + Sf_SafeInferred | not trust_own_pkg -> True + _ | isHomeModule home_unit mod -> True + _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do @@ -1349,8 +1355,9 @@ hscCheckSafe' m l = do checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust pkgs = do dflags <- getDynFlags + hsc_env <- getHscEnv let errors = S.foldr go [] pkgs - state = unitState dflags + state = hsc_units hsc_env go pkg acc | unitIsTrusted $ unsafeLookupUnitId state pkg = acc @@ -1542,7 +1549,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos) <- {-# SCC "codeOutput" #-} - codeOutput dflags this_mod output_filename location + codeOutput dflags (hsc_units hsc_env) this_mod output_filename location foreign_stubs foreign_files dependencies rawcmms1 return (output_filename, stub_c_exists, foreign_fps, cg_infos) @@ -1575,7 +1582,7 @@ hscInteractive hsc_env cgguts location = do comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff ----- (_istub_h_exists, istub_c_exists) - <- outputForeignStubs dflags this_mod location foreign_stubs + <- outputForeignStubs dflags (hsc_units hsc_env) this_mod location foreign_stubs return (istub_c_exists, comp_bc, spt_entries) ------------------------------ @@ -1588,7 +1595,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do cmm <- ioMsgMaybe $ do (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) - $ parseCmmFile dflags filename + $ parseCmmFile dflags home_unit filename return ((fmap pprWarning warns, fmap pprError errs), cmm) liftIO $ do dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) @@ -1611,7 +1618,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do FormatCMM (pdoc platform cmmgroup) rawCmms <- lookupHook (\x -> cmmToRawCmmHook x) (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) - _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] + _ <- codeOutput dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] [] rawCmms return () where diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 06f5014684..62eeb01e44 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -55,6 +55,7 @@ import GHC.Driver.Main import GHC.Parser.Header import GHC.Parser.Errors.Ppr +import GHC.Iface.Load ( cannotFindModule ) import GHC.IfaceToCore ( typecheckIface ) import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) @@ -329,7 +330,7 @@ warnUnusedPackages = do eps <- liftIO $ hscEPS hsc_env let dflags = hsc_dflags hsc_env - state = unitState dflags + state = hsc_units hsc_env pit = eps_PIT eps let loadedPackages @@ -569,12 +570,13 @@ load' how_much mHscMessage mod_graph = do let ofile = outputFile dflags let no_hs_main = gopt Opt_NoHsMain dflags let - main_mod = mainModIs dflags + 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 - linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + unit_env <- hsc_unit_env <$> getSession + linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env do_linking (hsc_HPT hsc_env1) if ghcLink dflags == LinkBinary && isJust ofile && not do_linking then do @@ -632,7 +634,8 @@ load' how_much mHscMessage mod_graph = do ASSERT( just_linkables ) do -- Link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5 + unit_env <- hsc_unit_env <$> getSession + linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env False hpt5 modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 } loadFinish Failed linkresult @@ -691,7 +694,7 @@ guessOutputFile = modifySession $ \env -> !mod_graph = hsc_mod_graph env mainModuleSrcPath :: Maybe String mainModuleSrcPath = do - ms <- mgLookupModule mod_graph (mainModIs dflags) + ms <- mgLookupModule mod_graph (mainModIs env) ml_hs_file (ms_location ms) name = fmap dropExtension mainModuleSrcPath @@ -998,7 +1001,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do hsc_env <- getSession let dflags = hsc_dflags hsc_env - when (not (null (instantiatedUnitsToCheck dflags))) $ + when (not (null (instantiatedUnitsToCheck (hsc_units hsc_env)))) $ throwGhcException (ProgramError "Backpack typechecking not supported with -j") -- The bits of shared state we'll be using: @@ -1413,9 +1416,9 @@ upsweep -- 3. A list of modules which succeeded loading. upsweep mHscMessage old_hpt stable_mods cleanup sccs = do - dflags <- getSessionDynFlags + hsc_env <- getSession (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs) - (instantiatedUnitsToCheck dflags) done_holes + (instantiatedUnitsToCheck (hsc_units hsc_env)) done_holes return (res, reverse $ mgModSummaries done) where done_holes = emptyUniqSet @@ -1562,9 +1565,9 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do -- -- Use explicit (instantiated) units as roots and also return their -- instantiations that are themselves instantiations and so on recursively. -instantiatedUnitsToCheck :: DynFlags -> [Unit] -instantiatedUnitsToCheck dflags = - nubSort $ concatMap goUnit (explicitUnits (unitState dflags)) +instantiatedUnitsToCheck :: UnitState -> [Unit] +instantiatedUnitsToCheck unit_state = + nubSort $ concatMap goUnit (explicitUnits unit_state) where goUnit HoleUnit = [] goUnit (RealUnit _) = [] @@ -2740,10 +2743,10 @@ withDeferredDiagnostics f = do (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) (\_ -> f) -noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg +noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg -- ToDo: we don't have a proper line number for this error -noModError dflags loc wanted_mod err - = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err +noModError hsc_env loc wanted_mod err + = mkPlainErrMsg (hsc_dflags hsc_env) loc $ cannotFindModule hsc_env wanted_mod err noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages noHsFileErr dflags loc path diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index c8c4c07d0d..86262c5ab4 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -33,6 +33,8 @@ import Data.List import GHC.Data.FastString import GHC.SysTools.FileCleanup +import GHC.Iface.Load (cannotFindModule) + import GHC.Unit.Module import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph @@ -279,7 +281,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps fail -> let dflags = hsc_dflags hsc_env in throwOneError $ mkPlainErrMsg dflags srcloc $ - cannotFindModule dflags imp fail + cannotFindModule hsc_env imp fail } ----------------------------- diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index a2dc71d957..1a3e256710 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -65,8 +65,6 @@ import GHC.SysTools.FileCleanup import GHC.Linker.ExtraObj import GHC.Linker.Dynamic -import GHC.Linker.MacOS -import GHC.Linker.Unit import GHC.Linker.Static import GHC.Linker.Types @@ -96,6 +94,7 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Unit +import GHC.Unit.Env import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.ModSummary @@ -479,10 +478,11 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- by shortening the library names, or start putting libraries into the same -- folders, such that one runpath would be sufficient for multiple/all -- libraries. -link :: GhcLink -- interactive or batch - -> DynFlags -- dynamic flags - -> Bool -- attempt linking in batch mode? - -> HomePackageTable -- what to link +link :: GhcLink -- ^ interactive or batch + -> DynFlags -- ^ dynamic flags + -> UnitEnv -- ^ unit environment + -> Bool -- ^ attempt linking in batch mode? + -> HomePackageTable -- ^ what to link -> IO SuccessFlag -- For the moment, in the batch linker, we don't bother to tell doLink @@ -492,7 +492,7 @@ link :: GhcLink -- interactive or batch -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink dflags +link ghcLink dflags unit_env = lookupHook linkHook l dflags ghcLink dflags where l LinkInMemory _ _ _ @@ -505,24 +505,25 @@ link ghcLink dflags = return Succeeded l LinkBinary dflags batch_attempt_linking hpt - = link' dflags batch_attempt_linking hpt + = link' dflags unit_env batch_attempt_linking hpt l LinkStaticLib dflags batch_attempt_linking hpt - = link' dflags batch_attempt_linking hpt + = link' dflags unit_env batch_attempt_linking hpt l LinkDynLib dflags batch_attempt_linking hpt - = link' dflags batch_attempt_linking hpt + = link' dflags unit_env batch_attempt_linking hpt panicBadLink :: GhcLink -> a panicBadLink other = panic ("link: GHC not built to link this way: " ++ show other) -link' :: DynFlags -- dynamic flags - -> Bool -- attempt linking in batch mode? - -> HomePackageTable -- what to link +link' :: DynFlags -- ^ dynamic flags + -> UnitEnv -- ^ unit environment + -> Bool -- ^ attempt linking in batch mode? + -> HomePackageTable -- ^ what to link -> IO SuccessFlag -link' dflags batch_attempt_linking hpt +link' dflags unit_env batch_attempt_linking hpt | batch_attempt_linking = do let @@ -551,7 +552,7 @@ link' dflags batch_attempt_linking hpt platform = targetPlatform dflags exe_file = exeFileName platform staticLink (outputFile dflags) - linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps + linking_needed <- linkingNeeded dflags unit_env staticLink linkables pkg_deps if not (gopt Opt_ForceRecomp dflags) && not linking_needed then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.") @@ -566,7 +567,7 @@ link' dflags batch_attempt_linking hpt LinkStaticLib -> linkStaticLib LinkDynLib -> linkDynLibCheck other -> panicBadLink other - link dflags obj_files pkg_deps + link dflags unit_env obj_files pkg_deps debugTraceMsg dflags 3 (text "link: done") @@ -579,13 +580,14 @@ link' dflags batch_attempt_linking hpt return Succeeded -linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool -linkingNeeded dflags staticLink linkables pkg_deps = do +linkingNeeded :: DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool +linkingNeeded 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 -- linking (unless the -fforce-recomp flag was given). - let platform = targetPlatform dflags - exe_file = exeFileName platform staticLink (outputFile dflags) + let platform = ue_platform unit_env + unit_state = ue_units unit_env + exe_file = exeFileName platform staticLink (outputFile dflags) e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of Left _ -> return True @@ -601,10 +603,9 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line. - let unit_state = unitState dflags - let pkg_hslibs = [ (collectLibraryPaths (ways dflags) [c], lib) + let pkg_hslibs = [ (collectLibraryDirs (ways dflags) [c], lib) | Just c <- map (lookupUnitId unit_state) pkg_deps, - lib <- packageHsLibs dflags c ] + 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 @@ -613,7 +614,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do let (lib_errs,lib_times) = partitionEithers e_lib_times if not (null lib_errs) || any (t <) lib_times then return True - else checkLinkInfo dflags pkg_deps exe_file + else checkLinkInfo dflags unit_env pkg_deps exe_file findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath) findHSLib platform ws dirs lib = do @@ -631,7 +632,7 @@ findHSLib platform ws dirs lib = do oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () oneShot hsc_env stop_phase srcs = do o_files <- mapM (compileFile hsc_env stop_phase) srcs - doLink (hsc_dflags hsc_env) stop_phase o_files + doLink hsc_env stop_phase o_files compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath compileFile hsc_env stop_phase (src, mb_phase) = do @@ -665,17 +666,20 @@ compileFile hsc_env stop_phase (src, mb_phase) = do return out_file -doLink :: DynFlags -> Phase -> [FilePath] -> IO () -doLink dflags stop_phase o_files +doLink :: HscEnv -> Phase -> [FilePath] -> IO () +doLink hsc_env stop_phase o_files | not (isStopLn stop_phase) = return () -- We stopped before the linking phase | otherwise - = case ghcLink dflags of + = let + dflags = hsc_dflags hsc_env + unit_env = hsc_unit_env hsc_env + in case ghcLink dflags of NoLink -> return () - LinkBinary -> linkBinary dflags o_files [] - LinkStaticLib -> linkStaticLib dflags o_files [] - LinkDynLib -> linkDynLibCheck dflags o_files [] + LinkBinary -> linkBinary dflags unit_env o_files [] + LinkStaticLib -> linkStaticLib dflags unit_env o_files [] + LinkDynLib -> linkDynLibCheck dflags unit_env o_files [] other -> panicBadLink other @@ -804,7 +808,18 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) $ setDynamicNow $ dflags hsc_env' <- newHscEnv dflags' - _ <- runPipeline' start_phase hsc_env' env input_fn' + (dbs,unit_state,home_unit) <- initUnits dflags' Nothing + let unit_env = UnitEnv + { ue_platform = targetPlatform dflags' + , ue_namever = ghcNameVersion dflags' + , ue_home_unit = home_unit + , ue_units = unit_state + } + let hsc_env'' = hsc_env' + { hsc_unit_env = unit_env + , hsc_unit_dbs = Just dbs + } + _ <- runPipeline' start_phase hsc_env'' env input_fn' maybe_loc foreign_os return () return r @@ -874,7 +889,7 @@ pipeLoop phase input_fn = do case phase of HscOut {} -> do let noDynToo = do - (next_phase, output_fn) <- runHookedPhase phase input_fn dflags + (next_phase, output_fn) <- runHookedPhase phase input_fn pipeLoop next_phase output_fn let dynToo = do -- if Opt_BuildDynamicToo is set and if the platform @@ -883,7 +898,7 @@ pipeLoop phase input_fn = do -- the non-dynamic ones. let dflags' = setDynamicNow dflags -- set "dynamicNow" setDynFlags dflags' - (next_phase, output_fn) <- runHookedPhase phase input_fn dflags' + (next_phase, output_fn) <- runHookedPhase phase input_fn _ <- pipeLoop next_phase output_fn -- TODO: we probably shouldn't ignore the result of -- the dynamic compilation @@ -902,13 +917,13 @@ pipeLoop phase input_fn = do -- we set DynamicNow but we unset Opt_BuildDynamicToo so -- it's weird. _ -> do - (next_phase, output_fn) <- runHookedPhase phase input_fn dflags + (next_phase, output_fn) <- runHookedPhase phase input_fn pipeLoop next_phase output_fn -runHookedPhase :: PhasePlus -> FilePath -> DynFlags - -> CompPipeline (PhasePlus, FilePath) -runHookedPhase pp input dflags = - lookupHook runPhaseHook runPhase dflags pp input dflags +runHookedPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath) +runHookedPhase pp input = do + dflags <- hsc_dflags <$> getPipeSession + lookupHook runPhaseHook runPhase dflags pp input -- ----------------------------------------------------------------------------- -- In each phase, we need to know into what filename to generate the @@ -1052,7 +1067,6 @@ llvmOptions dflags = -- runPhase :: PhasePlus -- ^ Run this phase -> FilePath -- ^ name of the input file - -> DynFlags -- ^ for convenience, we pass the current dflags in -> CompPipeline (PhasePlus, -- next phase to run FilePath) -- output filename @@ -1064,23 +1078,8 @@ runPhase :: PhasePlus -- ^ Run this phase ------------------------------------------------------------------------------- -- Unlit phase -runPhase (RealPhase (Unlit sf)) input_fn dflags - = do - output_fn <- phaseOutputFilename (Cpp sf) - - let flags = [ -- The -h option passes the file name for unlit to - -- put in a #line directive - GHC.SysTools.Option "-h" - -- See Note [Don't normalise input filenames]. - , GHC.SysTools.Option $ escape input_fn - , GHC.SysTools.FileOption "" input_fn - , GHC.SysTools.FileOption "" output_fn - ] - - liftIO $ GHC.SysTools.runUnlit dflags flags - - return (RealPhase (Cpp sf), output_fn) - where +runPhase (RealPhase (Unlit sf)) input_fn = do + let -- escape the characters \, ", and ', but don't try to escape -- Unicode or anything else (so we don't use Util.charToC -- here). If we get this wrong, then in @@ -1094,12 +1093,29 @@ runPhase (RealPhase (Unlit sf)) input_fn dflags escape (c:cs) = c : escape cs escape [] = [] + output_fn <- phaseOutputFilename (Cpp sf) + + let flags = [ -- The -h option passes the file name for unlit to + -- put in a #line directive + GHC.SysTools.Option "-h" + -- See Note [Don't normalise input filenames]. + , GHC.SysTools.Option $ escape input_fn + , GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.FileOption "" output_fn + ] + + dflags <- hsc_dflags <$> getPipeSession + liftIO $ GHC.SysTools.runUnlit dflags flags + + return (RealPhase (Cpp sf), output_fn) + ------------------------------------------------------------------------------- -- Cpp phase : (a) gets OPTIONS out of file -- (b) runs cpp if necessary -runPhase (RealPhase (Cpp sf)) input_fn dflags0 +runPhase (RealPhase (Cpp sf)) input_fn = do + dflags0 <- getDynFlags src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn (dflags1, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags0 src_opts @@ -1116,7 +1132,9 @@ runPhase (RealPhase (Cpp sf)) input_fn dflags0 return (RealPhase (HsPp sf), input_fn) else do output_fn <- phaseOutputFilename (HsPp sf) - liftIO $ doCpp dflags1 True{-raw-} + hsc_env <- getPipeSession + liftIO $ doCpp (hsc_dflags hsc_env) (hsc_unit_env hsc_env) + True{-raw-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file -- See #2464,#3457 @@ -1135,8 +1153,9 @@ runPhase (RealPhase (Cpp sf)) input_fn dflags0 ------------------------------------------------------------------------------- -- HsPp phase -runPhase (RealPhase (HsPp sf)) input_fn dflags - = if not (gopt Opt_Pp dflags) then +runPhase (RealPhase (HsPp sf)) input_fn = do + dflags <- getDynFlags + if not (gopt Opt_Pp dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. return (RealPhase (Hsc sf), input_fn) @@ -1166,8 +1185,9 @@ runPhase (RealPhase (HsPp sf)) input_fn dflags -- Compilation of a single module, in "legacy" mode (_not_ under -- the direction of the compilation manager). -runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 +runPhase (RealPhase (Hsc src_flavour)) input_fn = do -- normal Hsc mode, not mkdependHS + dflags0 <- getDynFlags PipeEnv{ stop_phase=stop, src_basename=basename, @@ -1270,7 +1290,8 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 return (HscOut src_flavour mod_name result, panic "HscOut doesn't have an input filename") -runPhase (HscOut src_flavour mod_name result) _ dflags = do +runPhase (HscOut src_flavour mod_name result) _ = do + dflags <- getDynFlags location <- getLocation src_flavour mod_name setModLocation location @@ -1335,14 +1356,18 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do ----------------------------------------------------------------------------- -- Cmm phase -runPhase (RealPhase CmmCpp) input_fn dflags - = do output_fn <- phaseOutputFilename Cmm - liftIO $ doCpp dflags False{-not raw-} +runPhase (RealPhase CmmCpp) input_fn = do + hsc_env <- getPipeSession + output_fn <- phaseOutputFilename Cmm + liftIO $ doCpp (hsc_dflags hsc_env) (hsc_unit_env hsc_env) + False{-not raw-} input_fn output_fn return (RealPhase Cmm, output_fn) -runPhase (RealPhase Cmm) input_fn dflags - = do let next_phase = hscPostBackendPhase HsSrcFile (backend dflags) +runPhase (RealPhase Cmm) input_fn = do + hsc_env <- getPipeSession + let dflags = hsc_dflags hsc_env + let next_phase = hscPostBackendPhase HsSrcFile (backend dflags) output_fn <- phaseOutputFilename next_phase PipeState{hsc_env} <- getPipeState liftIO $ hscCompileCmmFile hsc_env input_fn output_fn @@ -1351,12 +1376,15 @@ runPhase (RealPhase Cmm) input_fn dflags ----------------------------------------------------------------------------- -- Cc phase -runPhase (RealPhase cc_phase) input_fn dflags +runPhase (RealPhase cc_phase) input_fn | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx] = do - let platform = targetPlatform dflags - hcc = cc_phase `eqPhase` HCc - home_unit = mkHomeUnitFromFlags dflags + hsc_env <- getPipeSession + let dflags = hsc_dflags hsc_env + let unit_env = hsc_unit_env hsc_env + let home_unit = hsc_home_unit hsc_env + let platform = ue_platform unit_env + let hcc = cc_phase `eqPhase` HCc let cmdline_include_paths = includePaths dflags @@ -1366,11 +1394,8 @@ runPhase (RealPhase cc_phase) input_fn dflags -- add package include paths even if we're just compiling .c -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :) - pkg_include_dirs <- liftIO $ getUnitIncludePath - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - home_unit - pkgs + ps <- liftIO $ mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs) + let pkg_include_dirs = collectIncludeDirs ps let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] @@ -1395,26 +1420,17 @@ runPhase (RealPhase cc_phase) input_fn dflags -- cc-options are not passed when compiling .hc files. Our -- hc code doesn't not #include any header files anyway, so these -- options aren't necessary. - pkg_extra_cc_opts <- liftIO $ - if hcc - then return [] - else getUnitExtraCcOpts - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - home_unit - pkgs - - framework_paths <- - if platformUsesFrameworks platform - then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - home_unit - pkgs - let cmdlineFrameworkPaths = frameworkPaths dflags - return $ map ("-F"++) - (cmdlineFrameworkPaths ++ pkgFrameworkPaths) - else return [] + let pkg_extra_cc_opts + | hcc = [] + | otherwise = collectExtraCcOpts ps + + let framework_paths + | platformUsesFrameworks platform + = let pkgFrameworkPaths = collectFrameworksDirs ps + cmdlineFrameworkPaths = frameworkPaths dflags + in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths) + | otherwise + = [] let cc_opt | optLevel dflags >= 2 = [ "-O2" ] | optLevel dflags >= 1 = [ "-O" ] @@ -1441,7 +1457,7 @@ runPhase (RealPhase cc_phase) input_fn dflags -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - ghcVersionH <- liftIO $ getGhcVersionPathName dflags + ghcVersionH <- liftIO $ getGhcVersionPathName dflags unit_env liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) dflags ( [ GHC.SysTools.FileOption "" input_fn @@ -1496,14 +1512,20 @@ runPhase (RealPhase cc_phase) input_fn dflags -- As, SpitAs phase : Assembler -- This is for calling the assembler on a regular assembly file -runPhase (RealPhase (As with_cpp)) input_fn dflags +runPhase (RealPhase (As with_cpp)) input_fn = do + hsc_env <- getPipeSession + let dflags = hsc_dflags hsc_env + let unit_env = hsc_unit_env hsc_env + let platform = ue_platform unit_env + -- LLVM from version 3.0 onwards doesn't support the OS X system -- assembler, so we use clang as the assembler instead. (#5636) - let as_prog | backend dflags == LLVM && - platformOS (targetPlatform dflags) == OSDarwin + let as_prog | backend dflags == LLVM + , platformOS platform == OSDarwin = GHC.SysTools.runClang - | otherwise = GHC.SysTools.runAs + | otherwise + = GHC.SysTools.runAs let cmdline_include_paths = includePaths dflags let pic_c_flags = picCCOpts dflags @@ -1565,20 +1587,9 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags ----------------------------------------------------------------------------- -- LlvmOpt phase -runPhase (RealPhase LlvmOpt) input_fn dflags - = do - output_fn <- phaseOutputFilename LlvmLlc - - liftIO $ GHC.SysTools.runLlvmOpt dflags - ( optFlag - ++ defaultOptions ++ - [ GHC.SysTools.FileOption "" input_fn - , GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn] - ) - - return (RealPhase LlvmLlc, output_fn) - where +runPhase (RealPhase LlvmOpt) input_fn = do + hsc_env <- getPipeSession + let dflags = hsc_dflags hsc_env -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2] @@ -1587,6 +1598,8 @@ runPhase (RealPhase LlvmOpt) input_fn dflags Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " ++ "is missing passes for level " ++ show optIdx) + defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst + $ unzip (llvmOptions dflags) -- don't specify anything if user has specified commands. We do this -- for opt but not llc since opt is very specifically for optimisation @@ -1596,31 +1609,23 @@ runPhase (RealPhase LlvmOpt) input_fn dflags then map GHC.SysTools.Option $ words llvmOpts else [] - defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst - $ unzip (llvmOptions dflags) + output_fn <- phaseOutputFilename LlvmLlc ------------------------------------------------------------------------------ --- LlvmLlc phase + liftIO $ GHC.SysTools.runLlvmOpt dflags + ( optFlag + ++ defaultOptions ++ + [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn] + ) -runPhase (RealPhase LlvmLlc) input_fn dflags - = do - next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling - | gopt Opt_NoLlvmMangler dflags -> return (As False) - | otherwise -> return LlvmMangle + return (RealPhase LlvmLlc, output_fn) - output_fn <- phaseOutputFilename next_phase - liftIO $ GHC.SysTools.runLlvmLlc dflags - ( optFlag - ++ defaultOptions - ++ [ GHC.SysTools.FileOption "" input_fn - , GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn - ] - ) +----------------------------------------------------------------------------- +-- LlvmLlc phase - return (RealPhase next_phase, output_fn) - where +runPhase (RealPhase LlvmLlc) input_fn = do -- Note [Clamping of llc optimizations] -- -- See #13724 @@ -1660,45 +1665,64 @@ runPhase (RealPhase LlvmLlc) input_fn dflags -- -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa -- - llvmOpts = case optLevel dflags of - 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. - 1 -> "-O1" - _ -> "-O2" + dflags <- hsc_dflags <$> getPipeSession + let + llvmOpts = case optLevel dflags of + 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. + 1 -> "-O1" + _ -> "-O2" + + defaultOptions = map GHC.SysTools.Option . concatMap words . snd + $ unzip (llvmOptions dflags) + optFlag = if null (getOpts dflags opt_lc) + then map GHC.SysTools.Option $ words llvmOpts + else [] - optFlag = if null (getOpts dflags opt_lc) - then map GHC.SysTools.Option $ words llvmOpts - else [] + next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling + | gopt Opt_NoLlvmMangler dflags -> return (As False) + | otherwise -> return LlvmMangle + + output_fn <- phaseOutputFilename next_phase + + liftIO $ GHC.SysTools.runLlvmLlc dflags + ( optFlag + ++ defaultOptions + ++ [ GHC.SysTools.FileOption "" input_fn + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ) + + return (RealPhase next_phase, output_fn) - defaultOptions = map GHC.SysTools.Option . concatMap words . snd - $ unzip (llvmOptions dflags) ----------------------------------------------------------------------------- -- LlvmMangle phase -runPhase (RealPhase LlvmMangle) input_fn dflags - = do +runPhase (RealPhase LlvmMangle) input_fn = do let next_phase = As False output_fn <- phaseOutputFilename next_phase + dflags <- hsc_dflags <$> getPipeSession liftIO $ llvmFixupAsm dflags input_fn output_fn return (RealPhase next_phase, output_fn) ----------------------------------------------------------------------------- -- merge in stub objects -runPhase (RealPhase MergeForeign) input_fn dflags - = do +runPhase (RealPhase MergeForeign) input_fn = do PipeState{foreign_os} <- getPipeState output_fn <- phaseOutputFilename StopLn liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) if null foreign_os then panic "runPhase(MergeForeign): no foreign objects" else do + dflags <- hsc_dflags <$> getPipeSession liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn return (RealPhase StopLn, output_fn) -- warning suppression -runPhase (RealPhase other) _input_fn _dflags = +runPhase (RealPhase other) _input_fn = panic ("runPhase: don't know how to run phase " ++ show other) maybeMergeForeign :: CompPipeline Phase @@ -1769,30 +1793,29 @@ getHCFilePackages filename = return [] -linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () -linkDynLibCheck dflags o_files dep_units = do +linkDynLibCheck :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLibCheck dflags unit_env o_files dep_units = do when (haveRtsOptsFlags dflags) $ putLogMsg dflags NoReason SevInfo noSrcSpan $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") - linkDynLib dflags o_files dep_units + linkDynLib dflags unit_env o_files dep_units -- ----------------------------------------------------------------------------- -- Running CPP -doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw input_fn output_fn = do +-- | Run CPP +-- +-- UnitState is needed to compute MIN_VERSION macros +doCpp :: DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags unit_env raw input_fn output_fn = do let hscpp_opts = picPOpts dflags let cmdline_include_paths = includePaths dflags - let home_unit = mkHomeUnitFromFlags dflags - - pkg_include_dirs <- getUnitIncludePath - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - home_unit - [] + let unit_state = ue_units unit_env + pkg_include_dirs <- mayThrowUnitErr + (collectIncludeDirs <$> preloadUnitsInfo unit_env) let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] @@ -1837,13 +1860,12 @@ doCpp dflags raw input_fn output_fn = do let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] -- Default CPP defines in Haskell source - ghcVersionH <- getGhcVersionPathName dflags + ghcVersionH <- getGhcVersionPathName dflags unit_env let hsSourceCppOpts = [ "-include", ghcVersionH ] -- MIN_VERSION macros - let state = unitState dflags - uids = explicitUnits state - pkgs = catMaybes (map (lookupUnit state) uids) + let uids = explicitUnits unit_state + pkgs = catMaybes (map (lookupUnit unit_state) uids) mb_macro_include <- if not (null pkgs) && gopt Opt_VersionMacros dflags then do macro_stub <- newTempName dflags TFL_CurrentModule "h" @@ -2053,16 +2075,13 @@ touchObjectFile dflags path = do GHC.SysTools.touch dflags "Touching object file" path -- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> IO FilePath -getGhcVersionPathName dflags = do +getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath +getGhcVersionPathName dflags unit_env = do candidates <- case ghcVersionFile dflags of Just path -> return [path] - Nothing -> (map (</> "ghcversion.h")) <$> - (getUnitIncludePath - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - (mkHomeUnitFromFlags dflags) - [rtsUnitId]) + Nothing -> do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId]) + return ((</> "ghcversion.h") <$> collectIncludeDirs ps) found <- filterM doesFileExist candidates case found of diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs index 03ee6e14f6..88f19d8c2c 100644 --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -6,7 +6,8 @@ module GHC.Driver.Pipeline.Monad ( CompPipeline(..), evalP , PhasePlus(..) , PipeEnv(..), PipeState(..), PipelineOutput(..) - , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface + , getPipeEnv, getPipeState, getPipeSession + , setDynFlags, setModLocation, setForeignOs, setIface , pipeStateDynFlags, pipeStateModIface, setPlugins ) where @@ -111,6 +112,9 @@ getPipeEnv = P $ \env state -> return (state, env) getPipeState :: CompPipeline PipeState getPipeState = P $ \_env state -> return (state, state) +getPipeSession :: CompPipeline HscEnv +getPipeSession = P $ \_env state -> return (state, hsc_env state) + instance HasDynFlags CompPipeline where getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs index 2ea371f223..9d430f0466 100644 --- a/compiler/GHC/Driver/Ppr.hs +++ b/compiler/GHC/Driver/Ppr.hs @@ -24,6 +24,7 @@ where import GHC.Prelude import {-# SOURCE #-} GHC.Driver.Session +import {-# SOURCE #-} GHC.Unit.State import GHC.Utils.Exception import GHC.Utils.Misc @@ -31,7 +32,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.GlobalVars import GHC.Utils.Ppr ( Mode(..) ) -import {-# SOURCE #-} GHC.Unit.State import System.IO ( Handle ) import Control.Monad.IO.Class @@ -47,12 +47,11 @@ showPprUnsafe :: Outputable a => a -> String showPprUnsafe a = renderWithContext defaultSDocContext (ppr a) -- | Allows caller to specify the PrintUnqualified to use -showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String -showSDocForUser dflags unqual doc = renderWithContext (initSDocContext dflags sty) doc' +showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String +showSDocForUser dflags unit_state unqual doc = renderWithContext (initSDocContext dflags sty) doc' where - sty = mkUserStyle unqual AllTheWay - unit_state = unitState dflags - doc' = pprWithUnitState unit_state doc + sty = mkUserStyle unqual AllTheWay + doc' = pprWithUnitState unit_state doc showSDocDump :: SDocContext -> SDoc -> String showSDocDump ctx d = renderWithContext ctx (withPprStyle defaultDumpStyle d) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 024ac97c05..a1075f1cdb 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -39,7 +39,7 @@ module GHC.Driver.Session ( DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed, dynamicOutputFile, sccProfilingEnabled, - DynFlags(..), mainModIs, + DynFlags(..), outputFile, hiSuf, objectSuf, ways, FlagSpec(..), HasDynFlags(..), ContainsDynFlags(..), @@ -63,8 +63,6 @@ module GHC.Driver.Session ( targetProfile, - mkHomeUnitFromFlags, - -- ** Log output putLogMsg, @@ -231,13 +229,11 @@ import GHC.Platform import GHC.Platform.Ways import GHC.Platform.Profile import GHC.UniqueSubdir (uniqueSubdir) -import GHC.Unit.Home import GHC.Unit.Types import GHC.Unit.Parser import GHC.Unit.Module import GHC.Builtin.Names ( mAIN_NAME ) import {-# SOURCE #-} GHC.Driver.Hooks -import {-# SOURCE #-} GHC.Unit.State (UnitState, emptyUnitState, UnitDatabase) import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Flags import GHC.Driver.Backend @@ -594,21 +590,6 @@ data DynFlags = DynFlags { packageEnv :: Maybe FilePath, -- ^ Filepath to the package environment file (if overriding default) - unitDatabases :: Maybe [UnitDatabase UnitId], - -- ^ Stack of unit databases for the target platform. - -- - -- This field is populated by `initUnits`. - -- - -- 'Nothing' means the databases have never been read from disk. If - -- `initUnits` is called again, it doesn't reload the databases from - -- disk. - - unitState :: UnitState, - -- ^ Consolidated unit database built by 'initUnits' from the unit - -- databases in 'unitDatabases' and flags ('-ignore-package', etc.). - -- - -- It also contains mapping from module names to actual Modules. - -- Temporary files -- These have to be IORefs, because the defaultCleanupHandler needs to -- know what to clean when an exception happens @@ -1232,8 +1213,6 @@ defaultDynFlags mySettings llvmConfig = ignorePackageFlags = [], trustFlags = [], packageEnv = Nothing, - unitDatabases = Nothing, - unitState = emptyUnitState, targetWays_ = defaultWays mySettings, splitInfo = Nothing, @@ -1666,9 +1645,6 @@ lang_set dflags lang = extensionFlags = flattenExtensionFlags lang (extensions dflags) } -mainModIs :: DynFlags -> Module -mainModIs dflags = mkHomeModule (mkHomeUnitFromFlags dflags) (mainModuleNameIs dflags) - -- | Set the Haskell language standard to use setLanguage :: Language -> DynP () setLanguage l = upd (`lang_set` Just l) @@ -1815,28 +1791,6 @@ setOutputHi f d = d { outputHi = f} setJsonLogAction :: DynFlags -> DynFlags setJsonLogAction d = d { log_action = jsonLogAction } --- | Get home unit -mkHomeUnitFromFlags :: DynFlags -> HomeUnit -mkHomeUnitFromFlags dflags = - let !hu_id = homeUnitId_ dflags - !hu_instanceof = homeUnitInstanceOf_ dflags - !hu_instantiations = homeUnitInstantiations_ dflags - in case (hu_instanceof, hu_instantiations) of - (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing - (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") - (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with") - (Just u, is) - -- detect fully indefinite units: all their instantiations are hole - -- modules and the home unit id is the same as the instantiating unit - -- id (see Note [About units] in GHC.Unit) - | all (isHoleModule . snd) is && u == hu_id - -> IndefiniteHomeUnit u is - -- otherwise it must be that we (fully) instantiate an indefinite unit - -- to make it definite. - -- TODO: error when the unit is partially instantiated?? - | otherwise - -> DefiniteHomeUnit hu_id (Just (u, is)) - parseUnitInsts :: String -> Instantiations parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of [(r, "")] -> r diff --git a/compiler/GHC/Driver/Session.hs-boot b/compiler/GHC/Driver/Session.hs-boot index 2550782d37..d2125e4b9d 100644 --- a/compiler/GHC/Driver/Session.hs-boot +++ b/compiler/GHC/Driver/Session.hs-boot @@ -3,12 +3,10 @@ module GHC.Driver.Session where import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.Utils.Outputable -import {-# SOURCE #-} GHC.Unit.State data DynFlags targetPlatform :: DynFlags -> Platform -unitState :: DynFlags -> UnitState hasPprDebug :: DynFlags -> Bool hasNoDebugOutput :: DynFlags -> Bool initSDocContext :: DynFlags -> PprStyle -> SDocContext diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 9cf33aa02a..10f613f761 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -136,11 +136,7 @@ deSugar hsc_env }) = do { let dflags = hsc_dflags hsc_env - home_unit = hsc_home_unit hsc_env - print_unqual = mkPrintUnqualified - (unitState dflags) - home_unit - rdr_env + print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env ; withTiming dflags (text "Desugar"<+>brackets (ppr mod)) (const ()) $ diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index f17018492c..bdb275e5aa 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -86,11 +86,10 @@ import GHC.Builtin.Names import GHC.Data.Bag import GHC.Data.FastString +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module import GHC.Unit.Module.ModGuts -import GHC.Unit.Home -import GHC.Unit.State import GHC.Types.Name.Reader import GHC.Types.Basic ( Origin ) @@ -229,9 +228,7 @@ mkDsEnvsFromTcGbl :: MonadIO m mkDsEnvsFromTcGbl hsc_env msg_var tcg_env = do { cc_st_var <- liftIO $ newIORef newCostCentreState ; eps <- liftIO $ hscEPS hsc_env - ; let dflags = hsc_dflags hsc_env - home_unit = hsc_home_unit hsc_env - unit_state = unitState dflags + ; let unit_env = hsc_unit_env hsc_env this_mod = tcg_mod tcg_env type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env @@ -239,7 +236,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env complete_matches = hptCompleteSigs hsc_env -- from the home package ++ tcg_complete_matches tcg_env -- from the current module ++ eps_complete_matches eps -- from imports - ; return $ mkDsEnvs unit_state home_unit this_mod rdr_env type_env fam_inst_env + ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches } @@ -262,9 +259,7 @@ initDsWithModGuts hsc_env guts thing_inside = do { cc_st_var <- newIORef newCostCentreState ; msg_var <- newIORef emptyMessages ; eps <- liftIO $ hscEPS hsc_env - ; let dflags = hsc_dflags hsc_env - home_unit = hsc_home_unit hsc_env - unit_state = unitState dflags + ; let unit_env = hsc_unit_env hsc_env type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) rdr_env = mg_rdr_env guts fam_inst_env = mg_fam_inst_env guts @@ -277,7 +272,7 @@ initDsWithModGuts hsc_env guts thing_inside bindsToIds (Rec binds) = map fst binds ids = concatMap bindsToIds (mg_binds guts) - envs = mkDsEnvs unit_state home_unit this_mod rdr_env type_env + envs = mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches ; runDs hsc_env envs thing_inside @@ -313,10 +308,10 @@ initTcDsForSolver thing_inside , tcg_rdr_env = rdr_env }) $ thing_inside } -mkDsEnvs :: UnitState -> HomeUnit -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv +mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef Messages -> IORef CostCentreState -> CompleteMatches -> (DsGblEnv, DsLclEnv) -mkDsEnvs unit_state home_unit mod rdr_env type_env fam_inst_env msg_var cc_st_var +mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", if_rec_types = Just (mod, return type_env) } @@ -327,7 +322,7 @@ mkDsEnvs unit_state home_unit mod rdr_env type_env fam_inst_env msg_var cc_st_va , ds_fam_inst_env = fam_inst_env , ds_gbl_rdr_env = rdr_env , ds_if_env = (if_genv, if_lenv) - , ds_unqual = mkPrintUnqualified unit_state home_unit rdr_env + , ds_unqual = mkPrintUnqualified unit_env rdr_env , ds_msgs = msg_var , ds_complete_matches = complete_matches , ds_cc_st = cc_st_var diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index bfab4bd661..4b644621a6 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -37,8 +37,6 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps -import GHC.Linker.Unit - import GHC.Data.Maybe import Control.Monad (filterM) @@ -186,12 +184,12 @@ mkPluginUsage hsc_env pluginModule LookupFound _ pkg -> do -- The plugin is from an external package: -- search for the library files containing the plugin. - let searchPaths = collectLibraryPaths (ways dflags) [pkg] + let searchPaths = collectLibraryDirs (ways dflags) [pkg] useDyn = WayDyn `elem` ways dflags suffix = if useDyn then platformSOExt platform else "a" libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix | searchPath <- searchPaths - , libLoc <- packageHsLibs dflags pkg + , libLoc <- unitHsLibs (ghcNameVersion dflags) (ways dflags) pkg ] -- we also try to find plugin library files by adding WayDyn way, -- if it isn't already present (see trac #15492) @@ -202,7 +200,7 @@ mkPluginUsage hsc_env pluginModule let dflags' = dflags { targetWays_ = addWay WayDyn (targetWays_ dflags) } dlibLocs = [ searchPath </> platformHsSOName platform dlibLoc | searchPath <- searchPaths - , dlibLoc <- packageHsLibs dflags' pkg + , dlibLoc <- unitHsLibs (ghcNameVersion dflags') (ways dflags') pkg ] in libLocs ++ dlibLocs files <- filterM doesFileExist paths @@ -228,7 +226,7 @@ mkPluginUsage hsc_env pluginModule where dflags = hsc_dflags hsc_env platform = targetPlatform dflags - pkgs = unitState dflags + pkgs = hsc_units hsc_env pNm = moduleName $ mi_module pluginModule pPkg = moduleUnit $ mi_module pluginModule deps = map gwib_mod $ diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 4fb775db53..e7833d8145 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -7,6 +7,7 @@ {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -30,12 +31,16 @@ module GHC.Iface.Load ( needWiredInHomeIface, loadWiredInHomeIface, pprModIfaceSimple, - ifaceStats, pprModIface, showIface + ifaceStats, pprModIface, showIface, + + cannotFindModule ) where #include "HsVersions.h" import GHC.Prelude +import GHC.Platform.Ways +import GHC.Platform.Profile import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst @@ -99,6 +104,7 @@ import GHC.Unit.State import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.Finder +import GHC.Unit.Env import GHC.Data.Maybe import GHC.Data.FastString @@ -310,7 +316,7 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg ; case res of Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) -- TODO: Make sure this error message is good - err -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) } + err -> return (Failed (cannotFindModule hsc_env mod err)) } -- | Load interface directly for a fully qualified 'Module'. (This is a fairly -- rare operation, but in particular it is used to load orphan modules @@ -839,7 +845,7 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file -- Look for the file hsc_env <- getTopEnv mb_found <- liftIO (findExactModule hsc_env mod) - let home_unit = hsc_home_unit hsc_env + let home_unit = hsc_home_unit hsc_env case mb_found of InstalledFound loc mod -> do -- Found file, so read it @@ -855,20 +861,25 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file return r err -> do traceIf (text "...not found") - dflags <- getDynFlags - return (Failed (cannotFindInterface dflags - (moduleName mod) err)) + hsc_env <- getTopEnv + let profile = Profile (targetPlatform dflags) (ways dflags) + return $ Failed $ cannotFindInterface + (hsc_unit_env hsc_env) + profile + (may_show_locations (hsc_dflags hsc_env)) + (moduleName mod) + err where read_file file_path = do traceIf (text "readIFace" <+> text file_path) -- Figure out what is recorded in mi_module. If this is -- a fully definite interface, it'll match exactly, but -- if it's indefinite, the inside will be uninstantiated! - dflags <- getDynFlags + unit_state <- hsc_units <$> getTopEnv let wanted_mod = case getModuleInstantiation wanted_mod_with_insts of (_, Nothing) -> wanted_mod_with_insts (_, Just indef_mod) -> - instModuleToModule (unitState dflags) + instModuleToModule unit_state (uninstantiateInstantiatedModule indef_mod) read_result <- readIface wanted_mod file_path case read_result of @@ -946,8 +957,8 @@ readIface wanted_mod file_path ********************************************************* -} -initExternalPackageState :: HomeUnit -> ExternalPackageState -initExternalPackageState home_unit +initExternalPackageState :: UnitId -> ExternalPackageState +initExternalPackageState home_unit_id = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, @@ -966,9 +977,9 @@ initExternalPackageState home_unit } where enableBignumRules - | isHomeUnitInstanceOf home_unit primUnitId = EnableBignumRules False - | isHomeUnitInstanceOf home_unit bignumUnitId = EnableBignumRules False - | otherwise = EnableBignumRules True + | home_unit_id == primUnitId = EnableBignumRules False + | home_unit_id == bignumUnitId = EnableBignumRules False + | otherwise = EnableBignumRules True builtinRules' = builtinRules enableBignumRules {- @@ -1042,7 +1053,7 @@ For some background on this choice see trac #15269. showIface :: HscEnv -> FilePath -> IO () showIface hsc_env filename = do let dflags = hsc_dflags hsc_env - unit_state = unitState dflags + unit_state = hsc_units hsc_env printer = putLogMsg dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle -- skip the hi way check; we don't want to worry about profiled vs. @@ -1059,17 +1070,21 @@ showIface hsc_env filename = do neverQualifyPackages putLogMsg dflags NoReason SevDump noSrcSpan $ withPprStyle (mkDumpStyle print_unqual) - $ pprWithUnitState unit_state - $ pprModIface iface + $ pprModIface unit_state iface --- Show a ModIface but don't display details; suitable for ModIfaces stored in +-- | Show a ModIface but don't display details; suitable for ModIfaces stored in -- the EPT. -pprModIfaceSimple :: ModIface -> SDoc -pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface))) +pprModIfaceSimple :: UnitState -> ModIface -> SDoc +pprModIfaceSimple unit_state iface = + ppr (mi_module iface) + $$ pprDeps unit_state (mi_deps iface) + $$ nest 2 (vcat (map pprExport (mi_exports iface))) -pprModIface :: ModIface -> SDoc --- Show a ModIface -pprModIface iface@ModIface{ mi_final_exts = exts } +-- | Show a ModIface +-- +-- The UnitState is used to pretty-print units +pprModIface :: UnitState -> ModIface -> SDoc +pprModIface unit_state iface@ModIface{ mi_final_exts = exts } = vcat [ text "interface" <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface) <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty) @@ -1089,7 +1104,7 @@ pprModIface iface@ModIface{ mi_final_exts = exts } , nest 2 (text "where") , text "exports:" , nest 2 (vcat (map pprExport (mi_exports iface))) - , pprDeps (mi_deps iface) + , pprDeps unit_state (mi_deps iface) , vcat (map pprUsage (mi_usages iface)) , vcat (map pprIfaceAnnotation (mi_anns iface)) , pprFixities (mi_fixities iface) @@ -1153,10 +1168,12 @@ pprUsageImport usage usg_mod' safe | usg_safe usage = text "safe" | otherwise = text " -/ " -pprDeps :: Dependencies -> SDoc -pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, - dep_finsts = finsts }) - = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods), +-- | Pretty-print unit dependencies +pprDeps :: UnitState -> Dependencies -> SDoc +pprDeps unit_state (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, + dep_finsts = finsts }) + = pprWithUnitState unit_state $ + vcat [text "module dependencies:" <+> fsep (map ppr_mod mods), text "package dependencies:" <+> fsep (map ppr_pkg pkgs), text "orphans:" <+> fsep (map ppr orphs), text "family instance modules:" <+> fsep (map ppr finsts) @@ -1242,3 +1259,268 @@ homeModError mod location Just file -> space <> parens (text file) Nothing -> Outputable.empty) <+> text "which is not loaded" + + +-- ----------------------------------------------------------------------------- +-- Error messages + +cannotFindInterface :: UnitEnv -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc +cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") + (sLit "Ambiguous interface for") + +cantFindInstalledErr + :: PtrString + -> PtrString + -> UnitEnv + -> Profile + -> ([FilePath] -> SDoc) + -> ModuleName + -> InstalledFindResult + -> SDoc +cantFindInstalledErr cannot_find _ unit_env profile tried_these mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + home_unit = ue_home_unit unit_env + unit_state = ue_units unit_env + build_tag = waysBuildTag (profileWays profile) + + more_info + = case find_result of + InstalledNoPackage pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" $$ looks_like_srcpkgid pkg + + InstalledNotFound files mb_pkg + | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg) + -> not_found_in_package pkg files + + | null files + -> text "It is not a module in the current program, or in any known package." + + | otherwise + -> tried_these files + + _ -> panic "cantFindInstalledErr" + + looks_like_srcpkgid :: UnitId -> SDoc + looks_like_srcpkgid pk + -- Unsafely coerce a unit id (i.e. an installed package component + -- identifier) into a PackageId and see if it means anything. + | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk)) + = parens (text "This unit ID looks like the source package ID;" $$ + text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ + (if null pkgs then Outputable.empty + else text "and" <+> int (length pkgs) <+> text "other candidates")) + -- Todo: also check if it looks like a package name! + | otherwise = Outputable.empty + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ + tried_these files + + | otherwise + = text "There are files missing in the " <> quotes (ppr pkg) <> + text " package," $$ + text "try running 'ghc-pkg check'." $$ + tried_these files + +may_show_locations :: DynFlags -> [FilePath] -> SDoc +may_show_locations dflags files + | null files = Outputable.empty + | verbosity dflags < 3 = + text "Use -v (or `:set -v` in ghci) " <> + text "to see a list of the files searched for." + | otherwise = + hang (text "Locations searched:") 2 $ vcat (map text files) + +cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc +cannotFindModule hsc_env = cannotFindModule' + (hsc_dflags hsc_env) + (hsc_unit_env hsc_env) + (targetProfile (hsc_dflags hsc_env)) + + +cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc +cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $ + cantFindErr (gopt Opt_BuildingCabalPackage dflags) + (sLit cannotFindMsg) + (sLit "Ambiguous module name") + unit_env + profile + (may_show_locations dflags) + mod + res + where + cannotFindMsg = + case res of + NotFound { fr_mods_hidden = hidden_mods + , fr_pkgs_hidden = hidden_pkgs + , fr_unusables = unusables } + | not (null hidden_mods && null hidden_pkgs && null unusables) + -> "Could not load module" + _ -> "Could not find module" + +cantFindErr + :: Bool -- ^ Using Cabal? + -> PtrString + -> PtrString + -> UnitEnv + -> Profile + -> ([FilePath] -> SDoc) + -> ModuleName + -> FindResult + -> SDoc +cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods) + | Just pkgs <- unambiguousPackages + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + sep [text "it was found in multiple packages:", + hsep (map ppr pkgs) ] + ) + | otherwise + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + vcat (map pprMod mods) + ) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (moduleUnit m : xs) + unambiguousPackage _ _ = Nothing + + pprMod (m, o) = text "it is bound as" <+> ppr m <+> + text "by" <+> pprOrigin m o + pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" + pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + if e == Just True + then [text "package" <+> ppr (moduleUnit m)] + else [] ++ + map ((text "a reexport in package" <+>) + .ppr.mkUnit) res ++ + if f then [text "a package flag"] else [] + ) + +cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + home_unit = ue_home_unit unit_env + more_info + = case find_result of + NoPackage pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" + + NotFound { fr_paths = files, fr_pkg = mb_pkg + , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens + , fr_unusables = unusables, fr_suggestions = suggest } + | Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg) + -> not_found_in_package pkg files + + | not (null suggest) + -> pp_suggestions suggest $$ tried_these files + + | null files && null mod_hiddens && + null pkg_hiddens && null unusables + -> text "It is not a module in the current program, or in any known package." + + | otherwise + -> vcat (map pkg_hidden pkg_hiddens) $$ + vcat (map mod_hidden mod_hiddens) $$ + vcat (map unusable unusables) $$ + tried_these files + + _ -> panic "cantFindErr" + + build_tag = waysBuildTag (profileWays profile) + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ + tried_these files + + | otherwise + = text "There are files missing in the " <> quotes (ppr pkg) <> + text " package," $$ + text "try running 'ghc-pkg check'." $$ + tried_these files + + pkg_hidden :: Unit -> SDoc + pkg_hidden uid = + text "It is a member of the hidden package" + <+> quotes (ppr uid) + --FIXME: we don't really want to show the unit id here we should + -- show the source package id or installed package id if it's ambiguous + <> dot $$ pkg_hidden_hint uid + + pkg_hidden_hint uid + | using_cabal + = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid) + in text "Perhaps you need to add" <+> + quotes (ppr (unitPackageName pkg)) <+> + text "to the build-depends in your .cabal file." + | Just pkg <- lookupUnit (ue_units unit_env) uid + = text "You can run" <+> + quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> + text "to expose it." $$ + text "(Note: this unloads all the modules in the current scope.)" + | otherwise = Outputable.empty + + mod_hidden pkg = + text "it is a hidden module in the package" <+> quotes (ppr pkg) + + unusable (pkg, reason) + = text "It is a member of the package" + <+> quotes (ppr pkg) + $$ pprReason (text "which is") reason + + pp_suggestions :: [ModuleSuggestion] -> SDoc + pp_suggestions sugs + | null sugs = Outputable.empty + | otherwise = hang (text "Perhaps you meant") + 2 (vcat (map pp_sugg sugs)) + + -- NB: Prefer the *original* location, and then reexports, and then + -- package flags when making suggestions. ToDo: if the original package + -- also has a reexport, prefer that one + pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o + where provenance ModHidden = Outputable.empty + provenance (ModUnusable _) = Outputable.empty + provenance (ModOrigin{ fromOrigUnit = e, + fromExposedReexport = res, + fromPackageFlag = f }) + | Just True <- e + = parens (text "from" <+> ppr (moduleUnit mod)) + | f && moduleName mod == m + = parens (text "from" <+> ppr (moduleUnit mod)) + | (pkg:_) <- res + = parens (text "from" <+> ppr (mkUnit pkg) + <> comma <+> text "reexporting" <+> ppr mod) + | f + = parens (text "defined via package flags to be" + <+> ppr mod) + | otherwise = Outputable.empty + pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o + where provenance ModHidden = Outputable.empty + provenance (ModUnusable _) = Outputable.empty + provenance (ModOrigin{ fromOrigUnit = e, + fromHiddenReexport = rhs }) + | Just False <- e + = parens (text "needs flag -package-id" + <+> ppr (moduleUnit mod)) + | (pkg:_) <- rhs + = parens (text "needs flag -package-id" + <+> ppr (mkUnit pkg)) + | otherwise = Outputable.empty + diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index f333525e4b..a37ce7516a 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -146,9 +146,9 @@ mkFullIface hsc_env partial_iface mb_cg_infos = do addFingerprints hsc_env partial_iface{ mi_decls = decls } -- Debug printing - let unit_state = unitState (hsc_dflags hsc_env) + let unit_state = hsc_units hsc_env dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText - (pprWithUnitState unit_state $ pprModIface full_iface) + (pprModIface unit_state full_iface) return full_iface diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index fe0f4439f5..4c529cde83 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -377,7 +377,7 @@ checkHie mod_summary = do checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired checkFlagHash hsc_env iface = do let old_hash = mi_flag_hash (mi_final_exts iface) - new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) + new_hash <- liftIO $ fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally case old_hash == new_hash of @@ -420,12 +420,12 @@ checkHpcHash hsc_env iface = do -- If the -unit-id flags change, this can change too. checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired checkMergedSignatures mod_summary iface = do - dflags <- getDynFlags + unit_state <- hsc_units <$> getTopEnv let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ] new_merged = case Map.lookup (ms_mod_name mod_summary) - (requirementContext (unitState dflags)) of + (requirementContext unit_state) of Nothing -> [] - Just r -> sort $ map (instModuleToModule (unitState dflags)) r + Just r -> sort $ map (instModuleToModule unit_state) r if old_merged == new_merged then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged) else return (RecompBecause "signatures to merge in changed") @@ -1061,7 +1061,7 @@ addFingerprints hsc_env iface0 -- - (some of) dflags -- it returns two hashes, one that shouldn't change -- the abi hash and one that should - flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally + flag_hash <- fingerprintDynFlags hsc_env this_mod putNameLiterally opt_hash <- fingerprintOptFlags dflags putNameLiterally diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs index 1c52f4e326..4e9003944d 100644 --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -10,8 +10,10 @@ module GHC.Iface.Recomp.Flags ( import GHC.Prelude -import GHC.Utils.Binary import GHC.Driver.Session +import GHC.Driver.Env + +import GHC.Utils.Binary import GHC.Unit.Module import GHC.Types.Name import GHC.Types.SafeHaskell @@ -29,12 +31,13 @@ import System.FilePath (normalise) -- NB: The 'Module' parameter is the 'Module' recorded by the -- *interface* file, not the actual 'Module' according to our -- 'DynFlags'. -fingerprintDynFlags :: DynFlags -> Module +fingerprintDynFlags :: HscEnv -> Module -> (BinHandle -> Name -> IO ()) -> IO Fingerprint -fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = - let mainis = if mainModIs dflags == this_mod then Just mainFunIs else Nothing +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 -- see #5878 -- pkgopts = (homeUnit home_unit, sort $ packageFlags dflags) safeHs = setSafeMode safeHaskell diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 4bd9867617..66a8b477f1 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -145,7 +145,6 @@ rnDepModules sel deps = do -- because ModIface will never contain module reference for itself -- in these dependencies. fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do - dflags <- getDynFlags -- For holes, its necessary to "see through" the instantiation -- of the hole to get accurate family instance dependencies. -- For example, if B imports <A>, and <A> is instantiated with @@ -170,7 +169,7 @@ rnDepModules sel deps = do -- not to do it in this case either...) -- -- This mistake was bug #15594. - let mod' = renameHoleModule (unitState dflags) hmap mod + let mod' = renameHoleModule (hsc_units hsc_env) hmap mod if isHoleModule mod then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env $ loadSysInterface (text "rnDepModule") mod' @@ -190,9 +189,8 @@ initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape -> ShIfM a -> IO (Either ErrorMessages a) initRnIface hsc_env iface insts nsubst do_this = do errs_var <- newIORef emptyBag - let dflags = hsc_dflags hsc_env - hsubst = listToUFM insts - rn_mod = renameHoleModule (unitState dflags) hsubst + let hsubst = listToUFM insts + rn_mod = renameHoleModule (hsc_units hsc_env) hsubst env = ShIfEnv { sh_if_module = rn_mod (mi_module iface), sh_if_semantic_module = rn_mod (mi_semantic_module iface), @@ -238,8 +236,8 @@ type Rename a = a -> ShIfM a rnModule :: Rename Module rnModule mod = do hmap <- getHoleSubst - dflags <- getDynFlags - return (renameHoleModule (unitState dflags) hmap mod) + unit_state <- hsc_units <$> getTopEnv + return (renameHoleModule unit_state hmap mod) rnAvailInfo :: Rename AvailInfo rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n @@ -303,13 +301,13 @@ rnFieldLabel (FieldLabel l b sel) = do rnIfaceGlobal :: Name -> ShIfM Name rnIfaceGlobal n = do hsc_env <- getTopEnv - let dflags = hsc_dflags hsc_env - home_unit = hsc_home_unit hsc_env + let unit_state = hsc_units hsc_env + home_unit = hsc_home_unit hsc_env iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv mb_nsubst <- fmap sh_if_shape getGblEnv hmap <- getHoleSubst let m = nameModule n - m' = renameHoleModule (unitState dflags) hmap m + m' = renameHoleModule unit_state hmap m case () of -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so, -- do NOT assume B.hi is available. @@ -368,9 +366,9 @@ rnIfaceGlobal n = do rnIfaceNeverExported :: Name -> ShIfM Name rnIfaceNeverExported name = do hmap <- getHoleSubst - dflags <- getDynFlags + unit_state <- hsc_units <$> getTopEnv iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv - let m = renameHoleModule (unitState dflags) hmap $ nameModule name + let m = renameHoleModule unit_state hmap $ nameModule name -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined. MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m ) setNameModule (Just m) name diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 10d0eb1d04..7283f78666 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -384,10 +384,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod (const ()) $ do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags ; expose_all = gopt Opt_ExposeAllUnfoldings dflags - ; print_unqual = mkPrintUnqualified - (unitState dflags) - (hsc_home_unit hsc_env) - rdr_env + ; print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env ; implicit_binds = concatMap getImplicitBinds tcs } diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs index 497f51ec41..0a186bfcd6 100644 --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -16,9 +16,9 @@ import GHC.Platform.Ways import GHC.Driver.Session +import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.State -import GHC.Utils.Outputable import GHC.Linker.MacOS import GHC.Linker.Unit import GHC.SysTools.Tasks @@ -26,11 +26,11 @@ import GHC.SysTools.Tasks import qualified Data.Set as Set import System.FilePath -linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO () -linkDynLib dflags0 o_files dep_packages +linkDynLib :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLib dflags0 unit_env o_files dep_packages = do - let platform = targetPlatform dflags0 - os = platformOS platform + let platform = ue_platform unit_env + os = platformOS platform -- This is a rather ugly hack to fix dynamically linked -- GHC on Windows. If GHC is linked with -threaded, then @@ -47,22 +47,17 @@ linkDynLib dflags0 o_files dep_packages verbFlags = getVerbFlags dflags o_file = outputFile dflags - pkgs_with_rts <- getPreloadUnitsAnd - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - (mkHomeUnitFromFlags dflags) - dep_packages + pkgs_with_rts <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) - let pkg_lib_paths = collectLibraryPaths (ways dflags) pkgs_with_rts + let pkg_lib_paths = collectLibraryDirs (ways dflags) pkgs_with_rts let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths get_pkg_lib_path_opts l - | ( osElfTarget (platformOS (targetPlatform dflags)) || - osMachOTarget (platformOS (targetPlatform dflags)) ) && - dynLibLoader dflags == SystemDependent && - -- Only if we want dynamic libraries - WayDyn `Set.member` ways dflags && + | osElfTarget os || osMachOTarget os + , dynLibLoader dflags == SystemDependent + , -- Only if we want dynamic libraries + WayDyn `Set.member` ways dflags -- Only use RPath if we explicitly asked for it - gopt Opt_RPath dflags + , gopt Opt_RPath dflags = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] -- See Note [-Xlinker -rpath vs -Wl,-rpath] | otherwise = ["-L" ++ l] @@ -96,8 +91,7 @@ linkDynLib dflags0 o_files dep_packages let extra_ld_inputs = ldInputs dflags -- frameworks - pkg_framework_opts <- getUnitFrameworkOpts dflags platform - (map unitId pkgs) + pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs) let framework_opts = getFrameworkOpts dflags platform case os of diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs index c130c93ca4..455cb3c2a4 100644 --- a/compiler/GHC/Linker/ExtraObj.hs +++ b/compiler/GHC/Linker/ExtraObj.hs @@ -20,33 +20,36 @@ module GHC.Linker.ExtraObj ) where +import GHC.Prelude +import GHC.Platform + +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.State + import GHC.Utils.Asm import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable + import GHC.Driver.Session import GHC.Driver.Ppr -import GHC.Unit.State -import GHC.Platform -import GHC.Utils.Outputable as Outputable + import GHC.Types.SrcLoc ( noSrcSpan ) -import GHC.Unit -import GHC.SysTools.Elf -import GHC.Utils.Misc -import GHC.Prelude import qualified GHC.Data.ShortText as ST -import Control.Monad -import Data.Maybe - -import Control.Monad.IO.Class - +import GHC.SysTools.Elf import GHC.SysTools.FileCleanup import GHC.SysTools.Tasks import GHC.SysTools.Info import GHC.Linker.Unit -import GHC.Linker.MacOS -mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath -mkExtraObj dflags extn xs +import Control.Monad.IO.Class +import Control.Monad +import Data.Maybe + +mkExtraObj :: DynFlags -> UnitState -> Suffix -> String -> IO FilePath +mkExtraObj dflags unit_state extn xs = do cFile <- newTempName dflags TFL_CurrentModule extn oFile <- newTempName dflags TFL_GhcSession "o" writeFile cFile xs @@ -61,14 +64,12 @@ mkExtraObj dflags extn xs else asmOpts ccInfo) return oFile where - pkgs = unitState dflags - -- Pass a different set of options to the C compiler depending one whether -- we're compiling C or assembler. When compiling C, we pass the usual -- set of include directories and PIC flags. cOpts = map Option (picCCOpts dflags) ++ map (FileOption "-I" . ST.unpack) - (unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit) + (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit) -- When compiling assembler code, we drop the usual C options, and if the -- compiler is Clang, we add an extra argument to tell Clang to ignore @@ -86,15 +87,15 @@ mkExtraObj dflags extn xs -- -- On Windows, when making a shared library we also may need a DllMain. -- -mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath -mkExtraObjToLinkIntoBinary dflags = do +mkExtraObjToLinkIntoBinary :: DynFlags -> UnitState -> IO FilePath +mkExtraObjToLinkIntoBinary dflags unit_state = do when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ putLogMsg dflags NoReason SevInfo noSrcSpan $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ text " Call hs_init_ghc() from your main() function to set these options.") - mkExtraObj dflags "c" (showSDoc dflags main) + mkExtraObj dflags unit_state "c" (showSDoc dflags main) where main | gopt Opt_NoHsMain dflags = Outputable.empty @@ -152,53 +153,52 @@ mkExtraObjToLinkIntoBinary dflags = do -- this was included as inline assembly in the main.c file but this -- is pretty fragile. gas gets upset trying to calculate relative offsets -- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary dflags dep_packages = do - link_info <- getLinkInfo dflags dep_packages +mkNoteObjsToLinkIntoBinary :: DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary dflags unit_env dep_packages = do + link_info <- getLinkInfo dflags unit_env dep_packages if (platformSupportsSavingLinkOpts (platformOS platform )) - then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) + then fmap (:[]) $ mkExtraObj dflags unit_state "s" (showSDoc dflags (link_opts link_info)) else return [] where - platform = targetPlatform dflags - link_opts info = hcat [ - -- "link info" section (see Note [LinkInfo section]) - makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, + unit_state = ue_units unit_env + platform = ue_platform unit_env + link_opts info = hcat + [ -- "link info" section (see Note [LinkInfo section]) + makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info - -- ALL generated assembly must have this section to disable - -- executable stacks. See also - -- "GHC.CmmToAsm" for another instance - -- where we need to do this. - if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\"," - <> sectionType platform "progbits" <> char '\n' - else Outputable.empty - ] + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- "GHC.CmmToAsm" for another instance + -- where we need to do this. + , if platformHasGnuNonexecStack platform + then text ".section .note.GNU-stack,\"\"," + <> sectionType platform "progbits" <> char '\n' + else Outputable.empty + ] -- | Return the "link info" string -- -- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> [UnitId] -> IO String -getLinkInfo dflags dep_packages = do - package_link_opts <- getUnitLinkOpts dflags dep_packages - let unit_state = unitState dflags - home_unit = mkHomeUnitFromFlags dflags - ctx = initSDocContext dflags defaultUserStyle - pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) - then getUnitFrameworks ctx unit_state home_unit dep_packages - else return [] - let extra_ld_inputs = ldInputs dflags - let - link_info = (package_link_opts, - pkg_frameworks, - rtsOpts dflags, - rtsOptsEnabled dflags, - gopt Opt_NoHsMain dflags, - map showOpt extra_ld_inputs, - getOpts dflags opt_l) - -- - return (show link_info) +getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String +getLinkInfo dflags unit_env dep_packages = do + package_link_opts <- getUnitLinkOpts dflags unit_env dep_packages + pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env)) + then return [] + else do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) + return (collectFrameworks ps) + let link_info = + ( package_link_opts + , pkg_frameworks + , rtsOpts dflags + , rtsOptsEnabled dflags + , gopt Opt_NoHsMain dflags + , map showOpt (ldInputs dflags) + , getOpts dflags opt_l + ) + return (show link_info) platformSupportsSavingLinkOpts :: OS -> Bool platformSupportsSavingLinkOpts os @@ -216,9 +216,9 @@ ghcLinkInfoNoteName = "GHC link info" -- Returns 'False' if it was, and we can avoid linking, because the -- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool -checkLinkInfo dflags pkg_deps exe_file - | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) +checkLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo dflags unit_env pkg_deps exe_file + | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env))) -- ToDo: Windows and OS X do not use the ELF binary format, so -- readelf does not work there. We need to find another way to do -- this. @@ -227,7 +227,7 @@ checkLinkInfo dflags pkg_deps exe_file -- time so we leave it as-is. | otherwise = do - link_info <- getLinkInfo dflags pkg_deps + link_info <- getLinkInfo dflags unit_env pkg_deps debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) m_exe_link_info <- readElfNoteAsString dflags exe_file ghcLinkInfoSectionName ghcLinkInfoNoteName diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index a23a1f735d..a316af61db 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -35,6 +35,8 @@ where import GHC.Prelude +import GHC.Settings + import GHC.Platform import GHC.Platform.Ways @@ -69,6 +71,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error +import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module import GHC.Unit.Module.ModIface @@ -280,14 +283,13 @@ initLoaderState hsc_env = do reallyInitLoaderState :: HscEnv -> IO LoaderState reallyInitLoaderState hsc_env = do -- Initialise the linker state - let dflags = hsc_dflags hsc_env - pls0 = emptyLS + let pls0 = emptyLS -- (a) initialise the C dynamic linker initObjLinker hsc_env -- (b) Load packages from the command-line (Note [preload packages]) - pls <- loadPackages' hsc_env (preloadUnits (unitState dflags)) pls0 + pls <- loadPackages' hsc_env (preloadUnits (hsc_units hsc_env)) pls0 -- steps (c), (d) and (e) loadCmdLineLibs' hsc_env pls @@ -911,8 +913,9 @@ loadObjects hsc_env pls objs = do dynLoadObjs :: HscEnv -> LoaderState -> [FilePath] -> IO LoaderState dynLoadObjs _ pls [] = return pls dynLoadObjs hsc_env pls@LoaderState{..} objs = do + let unit_env = hsc_unit_env hsc_env let dflags = hsc_dflags hsc_env - let platform = targetPlatform dflags + let platform = ue_platform unit_env let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] (soFile, libPath , libName) <- @@ -962,7 +965,7 @@ dynLoadObjs hsc_env pls@LoaderState{..} objs = do -- link all "loaded packages" so symbols in those can be resolved -- Note: We are loading packages with local scope, so to see the -- symbols in this link we must link all loaded packages again. - linkDynLib dflags2 objs pkgs_loaded + linkDynLib dflags2 unit_env objs pkgs_loaded -- if we got this far, extend the lifetime of the library file changeTempFilesLifetime dflags TFL_GhcSession [soFile] @@ -1250,9 +1253,6 @@ loadPackages' hsc_env new_pks pls = do pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs' } where - dflags = hsc_dflags hsc_env - pkgstate = unitState dflags - link :: [UnitId] -> [UnitId] -> IO [UnitId] link pkgs new_pkgs = foldM link_one pkgs new_pkgs @@ -1261,7 +1261,7 @@ loadPackages' hsc_env new_pks pls = do | new_pkg `elem` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupUnitId pkgstate new_pkg + | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg = do { -- Link dependents first pkgs' <- link pkgs (unitDepends pkg_cfg) -- Now link the package itself @@ -1522,7 +1522,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib , "lib" ++ lib <.> "dll.a", lib <.> "dll.a" ] - hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags + hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags) hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name so_name = platformSOName platform lib diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs index e91ee8c5d1..09204575c1 100644 --- a/compiler/GHC/Linker/MacOS.hs +++ b/compiler/GHC/Linker/MacOS.hs @@ -1,8 +1,6 @@ module GHC.Linker.MacOS ( runInjectRPaths - , getUnitFrameworks , getUnitFrameworkOpts - , getUnitFrameworkPath , getFrameworkOpts , loadFramework ) @@ -16,17 +14,13 @@ import GHC.Driver.Env import GHC.Unit.Types import GHC.Unit.State -import GHC.Unit.Home +import GHC.Unit.Env import GHC.SysTools.Tasks import GHC.Runtime.Interpreter (loadDLL) -import GHC.Utils.Outputable import GHC.Utils.Exception -import GHC.Utils.Misc (ordNub ) - -import qualified GHC.Data.ShortText as ST import Data.List import Control.Monad (join, forM, filterM) @@ -67,26 +61,15 @@ runInjectRPaths dflags lib_paths dylib = do [] -> return () _ -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] -getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String] -getUnitFrameworkOpts dflags platform dep_packages - | platformUsesFrameworks platform = do - pkg_framework_path_opts <- do - pkg_framework_paths <- getUnitFrameworkPath - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - (mkHomeUnitFromFlags dflags) - dep_packages - return $ map ("-F" ++) pkg_framework_paths - - pkg_framework_opts <- do - pkg_frameworks <- getUnitFrameworks - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - (mkHomeUnitFromFlags dflags) - dep_packages - return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ] - - return (pkg_framework_path_opts ++ pkg_framework_opts) +getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String] +getUnitFrameworkOpts unit_env dep_packages + | platformUsesFrameworks (ue_platform unit_env) = do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) + let pkg_framework_path_opts = map ("-F" ++) (collectFrameworksDirs ps) + pkg_framework_opts = concat [ ["-framework", fw] + | fw <- collectFrameworks ps + ] + return (pkg_framework_path_opts ++ pkg_framework_opts) | otherwise = return [] @@ -104,19 +87,6 @@ getFrameworkOpts dflags platform | fw <- reverse frameworks ] --- | Find all the package framework paths in these and the preload packages -getUnitFrameworkPath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] -getUnitFrameworkPath ctx unit_state home_unit pkgs = do - ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs - return $ map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps))) - --- | Find all the package frameworks in these and the preload packages -getUnitFrameworks :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] -getUnitFrameworks ctx unit_state home_unit pkgs = do - ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs - return $ map ST.unpack (concatMap unitExtDepFrameworks ps) - - {- Note [macOS Big Sur dynamic libraries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs index 9d0862e3f3..4fa69c00e4 100644 --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -15,13 +15,13 @@ import GHC.SysTools import GHC.SysTools.Ar import GHC.SysTools.FileCleanup +import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Info import GHC.Unit.State import GHC.Utils.Monad import GHC.Utils.Misc -import GHC.Utils.Outputable import GHC.Linker.MacOS import GHC.Linker.Unit @@ -62,16 +62,16 @@ it is supported by both gcc and clang. Anecdotally nvcc supports -Xlinker, but not -Wl. -} -linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO () +linkBinary :: DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () linkBinary = linkBinary' False -linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO () -linkBinary' staticLink dflags o_files dep_units = do - let platform = targetPlatform dflags +linkBinary' :: Bool -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary' staticLink dflags unit_env o_files dep_units = do + let platform = ue_platform unit_env + unit_state = ue_units unit_env toolSettings' = toolSettings dflags verbFlags = getVerbFlags dflags output_fn = exeFileName platform staticLink (outputFile dflags) - home_unit = mkHomeUnitFromFlags dflags -- get the full list of packages to link with, by combining the -- explicit packages with the auto packages and all of their @@ -81,12 +81,8 @@ linkBinary' staticLink dflags o_files dep_units = do then return output_fn else do d <- getCurrentDirectory return $ normalise (d </> output_fn) - pkg_lib_paths <- getUnitLibraryPath - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - home_unit - (ways dflags) - dep_units + pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) + let pkg_lib_paths = collectLibraryDirs (ways dflags) pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths get_pkg_lib_path_opts l | osElfTarget (platformOS platform) && @@ -124,7 +120,7 @@ linkBinary' staticLink dflags o_files dep_units = do pkg_lib_path_opts <- if gopt Opt_SingleLibFolder dflags then do - libs <- getLibs dflags dep_units + libs <- getLibs dflags unit_env dep_units tmpDir <- newTempDir dflags sequence_ [ copyFile lib (tmpDir </> basename) | (lib, basename) <- libs] @@ -140,8 +136,8 @@ linkBinary' staticLink dflags o_files dep_units = do let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths - extraLinkObj <- mkExtraObjToLinkIntoBinary dflags - noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_units + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags unit_state + noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags unit_env dep_units let (pre_hs_libs, post_hs_libs) @@ -154,7 +150,7 @@ linkBinary' staticLink dflags o_files dep_units = do = ([],[]) pkg_link_opts <- do - (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags dep_units + (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags unit_env dep_units return $ if staticLink then package_hs_libs -- If building an executable really means making a static -- library (e.g. iOS), then we only keep the -l options for @@ -176,7 +172,7 @@ linkBinary' staticLink dflags o_files dep_units = do -- that defines the symbol." -- frameworks - pkg_framework_opts <- getUnitFrameworkOpts dflags platform dep_units + pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units let framework_opts = getFrameworkOpts dflags platform -- probably _stub.o files @@ -273,13 +269,12 @@ linkBinary' staticLink dflags o_files dep_units = do -- | Linking a static lib will not really link anything. It will merely produce -- a static archive of all dependent static libraries. The resulting library -- will still need to be linked with any remaining link flags. -linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO () -linkStaticLib dflags o_files dep_units = do - let platform = targetPlatform dflags +linkStaticLib :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkStaticLib dflags unit_env o_files dep_units = do + let platform = ue_platform unit_env extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs output_fn = exeFileName platform True (outputFile dflags) - home_unit = mkHomeUnitFromFlags dflags full_output_fn <- if isAbsolute output_fn then return output_fn @@ -288,11 +283,7 @@ linkStaticLib dflags o_files dep_units = do output_exists <- doesFileExist full_output_fn (when output_exists) $ removeFile full_output_fn - pkg_cfgs_init <- getPreloadUnitsAnd - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - home_unit - dep_units + pkg_cfgs_init <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) let pkg_cfgs | gopt Opt_LinkRts dflags diff --git a/compiler/GHC/Linker/Unit.hs b/compiler/GHC/Linker/Unit.hs index 90326859f4..7aec5263e3 100644 --- a/compiler/GHC/Linker/Unit.hs +++ b/compiler/GHC/Linker/Unit.hs @@ -3,11 +3,8 @@ module GHC.Linker.Unit ( collectLinkOpts , collectArchives - , collectLibraryPaths , getUnitLinkOpts - , getUnitLibraryPath , getLibs - , packageHsLibs ) where @@ -16,35 +13,28 @@ import GHC.Platform.Ways import GHC.Unit.Types import GHC.Unit.Info import GHC.Unit.State -import GHC.Unit.Home -import GHC.Utils.Outputable -import GHC.Utils.Panic +import GHC.Unit.Env import GHC.Utils.Misc import qualified GHC.Data.ShortText as ST import GHC.Driver.Session -import qualified Data.Set as Set -import Data.List (isPrefixOf, stripPrefix) import Control.Monad import System.Directory import System.FilePath -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags) -getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String]) -getUnitLinkOpts dflags pkgs = - collectLinkOpts dflags `fmap` getPreloadUnitsAnd - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - (mkHomeUnitFromFlags dflags) - pkgs +getUnitLinkOpts :: DynFlags -> UnitEnv -> [UnitId] -> IO ([String], [String], [String]) +getUnitLinkOpts dflags unit_env pkgs = do + ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs + return (collectLinkOpts dflags ps) collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String]) collectLinkOpts dflags ps = ( - concatMap (map ("-l" ++) . packageHsLibs dflags) ps, + concatMap (map ("-l" ++) . unitHsLibs (ghcNameVersion dflags) (ways dflags)) ps, concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps, concatMap (map ST.unpack . unitLinkerOptions) ps ) @@ -55,11 +45,7 @@ collectArchives dflags pc = | searchPath <- searchPaths , lib <- libs ] where searchPaths = ordNub . filter notNull . libraryDirsForWay (ways dflags) $ pc - libs = packageHsLibs dflags pc ++ map ST.unpack (unitExtDepLibsSys pc) - -collectLibraryPaths :: Ways -> [UnitInfo] -> [FilePath] -collectLibraryPaths ws = ordNub . filter notNull - . concatMap (libraryDirsForWay ws) + libs = unitHsLibs (ghcNameVersion dflags) (ways dflags) pc ++ map ST.unpack (unitExtDepLibsSys pc) -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. libraryDirsForWay :: Ways -> UnitInfo -> [String] @@ -67,68 +53,11 @@ libraryDirsForWay ws | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs | otherwise = map ST.unpack . unitLibraryDirs -getLibs :: DynFlags -> [UnitId] -> IO [(String,String)] -getLibs dflags pkgs = do - ps <- getPreloadUnitsAnd - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - (mkHomeUnitFromFlags dflags) - pkgs +getLibs :: DynFlags -> UnitEnv -> [UnitId] -> IO [(String,String)] +getLibs dflags unit_env pkgs = do + ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs fmap concat . forM ps $ \p -> do - let candidates = [ (l </> f, f) | l <- collectLibraryPaths (ways dflags) [p] - , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ] + let candidates = [ (l </> f, f) | l <- collectLibraryDirs (ways dflags) [p] + , f <- (\n -> "lib" ++ n ++ ".a") <$> unitHsLibs (ghcNameVersion dflags) (ways dflags) p ] filterM (doesFileExist . fst) candidates --- | Find all the library paths in these and the preload packages -getUnitLibraryPath :: SDocContext -> UnitState -> HomeUnit -> Ways -> [UnitId] -> IO [String] -getUnitLibraryPath ctx unit_state home_unit ws pkgs = - collectLibraryPaths ws `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs - -packageHsLibs :: DynFlags -> UnitInfo -> [String] -packageHsLibs dflags p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p) - where - ways0 = ways dflags - - ways1 = Set.filter (/= WayDyn) ways0 - -- the name of a shared library is libHSfoo-ghc<version>.so - -- we leave out the _dyn, because it is superfluous - - -- debug and profiled RTSs include support for -eventlog - ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1 - = Set.filter (/= WayTracing) ways1 - | otherwise - = ways1 - - tag = waysTag (fullWays ways2) - rts_tag = waysTag ways2 - - mkDynName x - | not (ways dflags `hasWay` WayDyn) = x - | "HS" `isPrefixOf` x = - x ++ '-':programName dflags ++ projectVersion dflags - -- For non-Haskell libraries, we use the name "Cfoo". The .a - -- file is libCfoo.a, and the .so is libfoo.so. That way the - -- linker knows what we mean for the vanilla (-lCfoo) and dyn - -- (-lfoo) ways. We therefore need to strip the 'C' off here. - | Just x' <- stripPrefix "C" x = x' - | otherwise - = panic ("Don't understand library name " ++ x) - - -- Add _thr and other rts suffixes to packages named - -- `rts` or `rts-1.0`. Why both? Traditionally the rts - -- package is called `rts` only. However the tooling - -- usually expects a package name to have a version. - -- As such we will gradually move towards the `rts-1.0` - -- package name, at which point the `rts` package name - -- will eventually be unused. - -- - -- This change elevates the need to add custom hooks - -- and handling specifically for the `rts` package for - -- example in ghc-cabal. - addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) - addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag) - addSuffix other_lib = other_lib ++ (expandTag tag) - - expandTag t | null t = "" - | otherwise = '_':t - diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 92ae90bedd..6a9fc8f434 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -60,7 +60,7 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import GHC.Utils.Misc ( debugIsOn, lengthExceeds, partitionWith ) import GHC.Utils.Panic -import GHC.Driver.Env ( HscEnv(..)) +import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs index 932e499e47..a69e358e32 100644 --- a/compiler/GHC/Runtime/Context.hs +++ b/compiler/GHC/Runtime/Context.hs @@ -23,6 +23,7 @@ import {-# SOURCE #-} GHC.Driver.Plugins import GHC.Runtime.Eval.Types ( Resume ) import GHC.Unit +import GHC.Unit.Env import GHC.Core.FamInstEnv import GHC.Core.InstEnv ( ClsInst, identicalClsInstHead ) @@ -289,9 +290,9 @@ icInScopeTTs :: InteractiveContext -> [TyThing] icInScopeTTs = ic_tythings -- | Get the PrintUnqualified function based on the flags and this InteractiveContext -icPrintUnqual :: UnitState -> HomeUnit -> InteractiveContext -> PrintUnqualified -icPrintUnqual unit_state home_unit InteractiveContext{ ic_rn_gbl_env = grenv } = - mkPrintUnqualified unit_state home_unit grenv +icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified +icPrintUnqual unit_env InteractiveContext{ ic_rn_gbl_env = grenv } = + mkPrintUnqualified unit_env grenv -- | extendInteractiveContext is called with new TyThings recently defined to update the -- InteractiveContext to include them. Ids are easily removed when shadowed, diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 592df3ccc8..57671e4d16 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -32,7 +32,7 @@ import GHC.Runtime.Interpreter ( wormhole, withInterp ) import GHC.Runtime.Interpreter.Types import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) -import GHC.Iface.Load ( loadPluginInterface ) +import GHC.Iface.Load ( loadPluginInterface, cannotFindModule ) import GHC.Rename.Names ( gresFromAvails ) import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) @@ -50,7 +50,7 @@ import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName , gre_name, mkRdrQual ) -import GHC.Unit.Finder ( findPluginModule, cannotFindModule, FindResult(..) ) +import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) import GHC.Unit.Module ( Module, ModuleName ) import GHC.Unit.Module.ModIface @@ -273,7 +273,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do _ -> panic "lookupRdrNameInModule" Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] - err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err + err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err where dflags = hsc_dflags hsc_env doc = text "contains a name used in an invocation of lookupRdrNameInModule" diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs index a26478d3d0..364c481cf6 100644 --- a/compiler/GHC/Settings.hs +++ b/compiler/GHC/Settings.hs @@ -9,6 +9,7 @@ module GHC.Settings , Platform (..) , PlatformMisc (..) -- * Accessors + , dynLibSuffix , sProgramName , sProjectVersion , sGhcUsagePath @@ -162,6 +163,10 @@ data GhcNameVersion = GhcNameVersion , ghcNameVersion_projectVersion :: String } +-- | Dynamic library suffix +dynLibSuffix :: GhcNameVersion -> String +dynLibSuffix (GhcNameVersion name ver) = '-':name ++ ver + ----------------------------------------------------------------------------- -- Accessessors from 'Settings' diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index d5420a4027..0e730a0b84 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -27,6 +27,7 @@ import GHC.Core.PatSyn import GHC.Data.Maybe import GHC.Utils.Misc (capitalise) import GHC.Data.FastString (fsLit) +import GHC.Driver.Env import GHC.Types.Unique.Set import GHC.Types.SrcLoc as SrcLoc @@ -172,7 +173,8 @@ tcRnExports explicit_mod exports -- thing (especially via 'module Foo' export item) do { ; dflags <- getDynFlags - ; let is_main_mod = mainModIs dflags == this_mod + ; hsc_env <- getTopEnv + ; let is_main_mod = mainModIs hsc_env == this_mod ; let default_main = case mainFunIs dflags of Just main_fun | is_main_mod -> mkUnqual varName (fsLit main_fun) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 44a92da7ae..8da6031597 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -1744,13 +1744,13 @@ checkMain :: Bool -- False => no 'module M(..) where' header at all -> TcM TcGblEnv -- If we are in module Main, check that 'main' is defined and exported. checkMain explicit_mod_hdr export_ies - = do { dflags <- getDynFlags + = do { hsc_env <- getTopEnv ; tcg_env <- getGblEnv - ; check_main dflags tcg_env explicit_mod_hdr export_ies } + ; check_main hsc_env tcg_env explicit_mod_hdr export_ies } -check_main :: DynFlags -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs]) +check_main :: HscEnv -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs]) -> TcM TcGblEnv -check_main dflags tcg_env explicit_mod_hdr export_ies +check_main hsc_env tcg_env explicit_mod_hdr export_ies | mod /= main_mod = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >> return tcg_env @@ -1791,8 +1791,9 @@ check_main dflags tcg_env explicit_mod_hdr export_ies addAmbiguousNameErr main_fn -- issue error msg return tcg_env where + dflags = hsc_dflags hsc_env mod = tcg_mod tcg_env - main_mod = mainModIs dflags + main_mod = mainModIs hsc_env main_mod_nm = moduleName main_mod main_fn = getMainFun dflags occ_main_fn = occName main_fn @@ -2880,7 +2881,7 @@ rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) tcDump :: TcGblEnv -> TcRn () tcDump env = do { dflags <- getDynFlags ; - unit_state <- unitState <$> getDynFlags ; + unit_state <- hsc_units <$> getTopEnv ; -- Dump short output if -ddump-types or -ddump-tc when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 6214434fce..7fff1a9e35 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -19,7 +19,6 @@ module GHC.Tc.Utils.Backpack ( import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Types.Basic (TypeOrKind(..)) @@ -291,7 +290,7 @@ findExtraSigImports' hsc_env HsigFile modname = $ moduleFreeHolesPrecise (text "findExtraSigImports") (mkModule (VirtUnit iuid) mod_name))) where - unit_state = unitState (hsc_dflags hsc_env) + unit_state = hsc_units hsc_env reqs = requirementMerges unit_state modname findExtraSigImports' _ _ _ = return emptyUniqDSet @@ -360,7 +359,7 @@ tcRnCheckUnit hsc_env uid = initTc hsc_env HsigFile -- bogus False - (mainModIs dflags) + (mainModIs hsc_env) (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus $ checkUnit uid where @@ -522,7 +521,6 @@ mergeSignatures -- file, which is guaranteed to exist, see -- Note [Blank hsigs for all requirements] hsc_env <- getTopEnv - dflags <- getDynFlags -- Copy over some things from the original TcGblEnv that -- we want to preserve @@ -552,7 +550,7 @@ mergeSignatures let outer_mod = tcg_mod tcg_env inner_mod = tcg_semantic_mod tcg_env mod_name = moduleName (tcg_mod tcg_env) - unit_state = unitState dflags + unit_state = hsc_units hsc_env home_unit = hsc_home_unit hsc_env -- STEP 1: Figure out all of the external signature interfaces @@ -928,9 +926,8 @@ impl_msg unit_state impl_mod (Module req_uid req_mod_name) -- explicitly.) checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv checkImplements impl_mod req_mod@(Module uid mod_name) = do - dflags <- getDynFlags hsc_env <- getTopEnv - let unit_state = unitState dflags + let unit_state = hsc_units hsc_env home_unit = hsc_home_unit hsc_env addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do let insts = instUnitInsts uid diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index 27d01a5c4d..80f3a477dd 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -42,6 +42,7 @@ module GHC.Tc.Utils.Instantiate ( import GHC.Prelude import GHC.Driver.Session +import GHC.Driver.Env import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName ) import GHC.Builtin.Names @@ -975,7 +976,7 @@ dupInstErr ispec dup_ispec addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () addClsInstsErr herald ispecs = do - unit_state <- unitState <$> getDynFlags + unit_state <- hsc_units <$> getTopEnv setSrcSpan (getSrcSpan (head sorted)) $ addErr $ pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted)) where diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index eacdf40bce..5cb8ed8d88 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -773,7 +773,7 @@ dumpOptTcRn flag title fmt doc = dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn () dumpTcRn useUserStyle dumpOpt title fmt doc = do dflags <- getDynFlags - printer <- getPrintUnqualified dflags + printer <- getPrintUnqualified real_doc <- wrapDocLoc doc let sty = if useUserStyle then mkUserStyle printer AllTheWay @@ -792,19 +792,17 @@ wrapDocLoc doc = do else return doc -getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified -getPrintUnqualified dflags +getPrintUnqualified :: TcRn PrintUnqualified +getPrintUnqualified = do { rdr_env <- getGlobalRdrEnv ; hsc_env <- getTopEnv - ; let unit_state = unitState dflags - ; let home_unit = hsc_home_unit hsc_env - ; return $ mkPrintUnqualified unit_state home_unit rdr_env } + ; return $ mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env } -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () printForUserTcRn doc = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified dflags + ; printer <- getPrintUnqualified ; liftIO (printOutputForUser dflags printer doc) } {- @@ -998,16 +996,16 @@ discardWarnings thing_inside mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg mkLongErrAt loc msg extra = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - unit_state <- unitState <$> getDynFlags ; + printer <- getPrintUnqualified ; + unit_state <- hsc_units <$> getTopEnv ; let msg' = pprWithUnitState unit_state msg in return $ mkLongErrMsg dflags loc printer msg' extra } mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg mkErrDocAt loc errDoc = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; - unit_state <- unitState <$> getDynFlags ; + printer <- getPrintUnqualified ; + unit_state <- hsc_units <$> getTopEnv ; let f = pprWithUnitState unit_state errDoc' = mapErrDoc f errDoc in @@ -1519,7 +1517,7 @@ add_warn reason msg extra_info add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () add_warn_at reason loc msg extra_info = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified dflags ; + printer <- getPrintUnqualified ; let { warn = mkLongWarnMsg dflags loc printer msg extra_info } ; reportWarning reason warn } diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs index 3b64e4bbdf..be9d26ac91 100644 --- a/compiler/GHC/Types/Name/Ppr.hs +++ b/compiler/GHC/Types/Name/Ppr.hs @@ -13,6 +13,7 @@ where import GHC.Prelude import GHC.Unit +import GHC.Unit.Env import GHC.Unit.State import GHC.Core.TyCon @@ -69,12 +70,14 @@ with some holes, we should try to give the user some more useful information. -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. -mkPrintUnqualified :: UnitState -> HomeUnit -> GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified unit_state home_unit env +mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified unit_env env = QueryQualify qual_name (mkQualModule unit_state home_unit) (mkQualPackage unit_state) where + unit_state = ue_units unit_env + home_unit = ue_home_unit unit_env qual_name mod occ | [gre] <- unqual_gres , right_name gre diff --git a/compiler/GHC/Unit/Env.hs b/compiler/GHC/Unit/Env.hs new file mode 100644 index 0000000000..d7de796434 --- /dev/null +++ b/compiler/GHC/Unit/Env.hs @@ -0,0 +1,61 @@ +module GHC.Unit.Env + ( UnitEnv (..) + , preloadUnitsInfo + , preloadUnitsInfo' + ) +where + +import GHC.Prelude + +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Unit.Types + +import GHC.Platform +import GHC.Settings +import GHC.Data.Maybe + +data UnitEnv = UnitEnv + { ue_units :: !UnitState -- ^ Units + , ue_home_unit :: !HomeUnit -- ^ Home unit + , ue_platform :: !Platform -- ^ Platform + , ue_namever :: !GhcNameVersion -- ^ GHC name/version (used for dynamic library suffix) + } + +-- ----------------------------------------------------------------------------- +-- Extracting information from the packages in scope + +-- Many of these functions take a list of packages: in those cases, +-- the list is expected to contain the "dependent packages", +-- i.e. those packages that were found to be depended on by the +-- current module/program. These can be auto or non-auto packages, it +-- doesn't really matter. The list is always combined with the list +-- of preload (command-line) packages to determine which packages to +-- use. + +-- | Lookup 'UnitInfo' for every preload unit from the UnitState, for every unit +-- used to instantiate the home unit, and for every unit explicitly passed in +-- the given list of UnitId. +preloadUnitsInfo' :: UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo] +preloadUnitsInfo' unit_env ids0 = all_infos + where + home_unit = ue_home_unit unit_env + unit_state = ue_units unit_env + ids = ids0 ++ inst_ids + inst_ids + -- An indefinite package will have insts to HOLE, + -- which is not a real package. Don't look it up. + -- Fixes #14525 + | isHomeUnitIndefinite home_unit = [] + | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) + pkg_map = unitInfoMap unit_state + preload = preloadUnits unit_state + + all_pkgs = closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing) + all_infos = map (unsafeLookupUnitId unit_state) <$> all_pkgs + + +-- | Lookup 'UnitInfo' for every preload unit from the UnitState and for every +-- unit used to instantiate the home unit. +preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo] +preloadUnitsInfo unit_env = preloadUnitsInfo' unit_env [] diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs index 36193fce94..130994b74b 100644 --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -29,9 +29,6 @@ module GHC.Unit.Finder ( findObjectLinkableMaybe, findObjectLinkable, - cannotFindModule, - cannotFindInterface, - ) where #include "HsVersions.h" @@ -198,14 +195,14 @@ findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString findExposedPackageModule hsc_env mod_name mb_pkg = findLookupResult hsc_env $ lookupModuleWithSuggestions - (unitState (hsc_dflags hsc_env)) mod_name mb_pkg + (hsc_units hsc_env) mod_name mb_pkg findExposedPluginPackageModule :: HscEnv -> ModuleName -> IO FindResult findExposedPluginPackageModule hsc_env mod_name = findLookupResult hsc_env $ lookupPluginModuleWithSuggestions - (unitState (hsc_dflags hsc_env)) mod_name Nothing + (hsc_units hsc_env) mod_name Nothing findLookupResult :: HscEnv -> LookupResult -> IO FindResult findLookupResult hsc_env r = case r of @@ -354,14 +351,10 @@ findInstalledHomeModule hsc_env mod_name = -- | Search for a module in external packages only. findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult findPackageModule hsc_env mod = do - let - dflags = hsc_dflags hsc_env - pkg_id = moduleUnit mod - pkgstate = unitState dflags - -- - case lookupUnitId pkgstate pkg_id of + let pkg_id = moduleUnit mod + case lookupUnitId (hsc_units hsc_env) pkg_id of Nothing -> return (InstalledNoPackage pkg_id) - Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf + Just u -> findPackageModule_ hsc_env mod u -- | Look up the interface file associated with module @mod@. This function -- requires a few invariants to be upheld: (1) the 'Module' in question must @@ -617,239 +610,3 @@ findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) -- We used to look for _stub.o files here, but that was a bug (#706) -- Now GHC merges the stub.o into the main .o (#3687) --- ----------------------------------------------------------------------------- --- Error messages - -cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc -cannotFindModule dflags mod res = pprWithUnitState unit_state $ - cantFindErr (sLit cannotFindMsg) - (sLit "Ambiguous module name") - dflags mod res - where - unit_state = unitState dflags - cannotFindMsg = - case res of - NotFound { fr_mods_hidden = hidden_mods - , fr_pkgs_hidden = hidden_pkgs - , fr_unusables = unusables } - | not (null hidden_mods && null hidden_pkgs && null unusables) - -> "Could not load module" - _ -> "Could not find module" - -cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc -cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") - (sLit "Ambiguous interface for") - -cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult - -> SDoc -cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) - | Just pkgs <- unambiguousPackages - = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - sep [text "it was found in multiple packages:", - hsep (map ppr pkgs) ] - ) - | otherwise - = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - vcat (map pprMod mods) - ) - where - unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) - = Just (moduleUnit m : xs) - unambiguousPackage _ _ = Nothing - - pprMod (m, o) = text "it is bound as" <+> ppr m <+> - text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( - if e == Just True - then [text "package" <+> ppr (moduleUnit m)] - else [] ++ - map ((text "a reexport in package" <+>) - .ppr.mkUnit) res ++ - if f then [text "a package flag"] else [] - ) - -cantFindErr cannot_find _ dflags mod_name find_result - = ptext cannot_find <+> quotes (ppr mod_name) - $$ more_info - where - pkgs = unitState dflags - home_unit = mkHomeUnitFromFlags dflags - more_info - = case find_result of - NoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" - - NotFound { fr_paths = files, fr_pkg = mb_pkg - , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens - , fr_unusables = unusables, fr_suggestions = suggest } - | Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg) - -> not_found_in_package pkg files - - | not (null suggest) - -> pp_suggestions suggest $$ tried_these files dflags - - | null files && null mod_hiddens && - null pkg_hiddens && null unusables - -> text "It is not a module in the current program, or in any known package." - - | otherwise - -> vcat (map pkg_hidden pkg_hiddens) $$ - vcat (map mod_hidden mod_hiddens) $$ - vcat (map unusable unusables) $$ - tried_these files dflags - - _ -> panic "cantFindErr" - - build_tag = waysBuildTag (ways dflags) - - not_found_in_package pkg files - | build_tag /= "" - = let - build = if build_tag == "p" then "profiling" - else "\"" ++ build_tag ++ "\"" - in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files dflags - - | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files dflags - - pkg_hidden :: Unit -> SDoc - pkg_hidden uid = - text "It is a member of the hidden package" - <+> quotes (ppr uid) - --FIXME: we don't really want to show the unit id here we should - -- show the source package id or installed package id if it's ambiguous - <> dot $$ pkg_hidden_hint uid - pkg_hidden_hint uid - | gopt Opt_BuildingCabalPackage dflags - = let pkg = expectJust "pkg_hidden" (lookupUnit pkgs uid) - in text "Perhaps you need to add" <+> - quotes (ppr (unitPackageName pkg)) <+> - text "to the build-depends in your .cabal file." - | Just pkg <- lookupUnit pkgs uid - = text "You can run" <+> - quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> - text "to expose it." $$ - text "(Note: this unloads all the modules in the current scope.)" - | otherwise = Outputable.empty - - mod_hidden pkg = - text "it is a hidden module in the package" <+> quotes (ppr pkg) - - unusable (pkg, reason) - = text "It is a member of the package" - <+> quotes (ppr pkg) - $$ pprReason (text "which is") reason - - pp_suggestions :: [ModuleSuggestion] -> SDoc - pp_suggestions sugs - | null sugs = Outputable.empty - | otherwise = hang (text "Perhaps you meant") - 2 (vcat (map pp_sugg sugs)) - - -- NB: Prefer the *original* location, and then reexports, and then - -- package flags when making suggestions. ToDo: if the original package - -- also has a reexport, prefer that one - pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigUnit = e, - fromExposedReexport = res, - fromPackageFlag = f }) - | Just True <- e - = parens (text "from" <+> ppr (moduleUnit mod)) - | f && moduleName mod == m - = parens (text "from" <+> ppr (moduleUnit mod)) - | (pkg:_) <- res - = parens (text "from" <+> ppr (mkUnit pkg) - <> comma <+> text "reexporting" <+> ppr mod) - | f - = parens (text "defined via package flags to be" - <+> ppr mod) - | otherwise = Outputable.empty - pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigUnit = e, - fromHiddenReexport = rhs }) - | Just False <- e - = parens (text "needs flag -package-id" - <+> ppr (moduleUnit mod)) - | (pkg:_) <- rhs - = parens (text "needs flag -package-id" - <+> ppr (mkUnit pkg)) - | otherwise = Outputable.empty - -cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName - -> InstalledFindResult -> SDoc -cantFindInstalledErr cannot_find _ dflags mod_name find_result - = ptext cannot_find <+> quotes (ppr mod_name) - $$ more_info - where - home_unit = mkHomeUnitFromFlags dflags - unit_state = unitState dflags - build_tag = waysBuildTag (ways dflags) - - more_info - = case find_result of - InstalledNoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" $$ looks_like_srcpkgid pkg - - InstalledNotFound files mb_pkg - | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg) - -> not_found_in_package pkg files - - | null files - -> text "It is not a module in the current program, or in any known package." - - | otherwise - -> tried_these files dflags - - _ -> panic "cantFindInstalledErr" - - looks_like_srcpkgid :: UnitId -> SDoc - looks_like_srcpkgid pk - -- Unsafely coerce a unit id (i.e. an installed package component - -- identifier) into a PackageId and see if it means anything. - | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk)) - = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ - (if null pkgs then Outputable.empty - else text "and" <+> int (length pkgs) <+> text "other candidates")) - -- Todo: also check if it looks like a package name! - | otherwise = Outputable.empty - - not_found_in_package pkg files - | build_tag /= "" - = let - build = if build_tag == "p" then "profiling" - else "\"" ++ build_tag ++ "\"" - in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files dflags - - | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files dflags - -tried_these :: [FilePath] -> DynFlags -> SDoc -tried_these files dflags - | null files = Outputable.empty - | verbosity dflags < 3 = - text "Use -v (or `:set -v` in ghci) " <> - text "to see a list of the files searched for." - | otherwise = - hang (text "Locations searched:") 2 $ vcat (map text files) diff --git a/compiler/GHC/Unit/Home.hs b/compiler/GHC/Unit/Home.hs index 6baa8bf5fb..fa8a0b1d6f 100644 --- a/compiler/GHC/Unit/Home.hs +++ b/compiler/GHC/Unit/Home.hs @@ -43,9 +43,7 @@ import Data.Maybe -- unit identifier) with `homeUnitMap`. -- -- TODO: this isn't implemented yet. UnitKeys are still converted too early into --- UnitIds in GHC.Unit.State.readUnitDataBase and wiring of home unit --- instantiations is done inplace in DynFlags by --- GHC.Unit.State.upd_wired_in_home_instantiations. +-- UnitIds in GHC.Unit.State.readUnitDataBase data GenHomeUnit u = DefiniteHomeUnit UnitId (Maybe (u, GenInstantiations u)) -- ^ Definite home unit (i.e. that we can compile). diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs index 1f2366f292..d95ea5b442 100644 --- a/compiler/GHC/Unit/Info.hs +++ b/compiler/GHC/Unit/Info.hs @@ -19,23 +19,41 @@ module GHC.Unit.Info , unitPackageNameString , unitPackageIdString , pprUnitInfo + + , collectIncludeDirs + , collectExtraCcOpts + , collectLibraryDirs + , collectFrameworks + , collectFrameworksDirs + , unitHsLibs ) where #include "HsVersions.h" import GHC.Prelude +import GHC.Platform.Ways -import GHC.Unit.Database -import Data.Version -import Data.Bifunctor +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Types.Unique import GHC.Data.FastString import qualified GHC.Data.ShortText as ST -import GHC.Utils.Outputable + import GHC.Unit.Module as Module -import GHC.Types.Unique import GHC.Unit.Ppr +import GHC.Unit.Database + +import GHC.Settings + +import Data.Version +import Data.Bifunctor +import Data.List (isPrefixOf, stripPrefix) +import qualified Data.Set as Set + -- | Information about an installed unit -- @@ -165,3 +183,75 @@ mkUnitPprInfo ufs i = UnitPprInfo (unitPackageNameString i) (unitPackageVersion i) ((unpackFS . unPackageName) <$> unitComponentName i) + +-- | Find all the include directories in the given units +collectIncludeDirs :: [UnitInfo] -> [FilePath] +collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps)) + +-- | Find all the C-compiler options in the given units +collectExtraCcOpts :: [UnitInfo] -> [String] +collectExtraCcOpts ps = map ST.unpack (concatMap unitCcOptions ps) + +-- | Find all the library directories in the given units for the given ways +collectLibraryDirs :: Ways -> [UnitInfo] -> [FilePath] +collectLibraryDirs ws = ordNub . filter notNull . concatMap (libraryDirsForWay ws) + +-- | Find all the frameworks in the given units +collectFrameworks :: [UnitInfo] -> [String] +collectFrameworks ps = map ST.unpack (concatMap unitExtDepFrameworks ps) + +-- | Find all the package framework paths in these and the preload packages +collectFrameworksDirs :: [UnitInfo] -> [String] +collectFrameworksDirs ps = map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps))) + +-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. +libraryDirsForWay :: Ways -> UnitInfo -> [String] +libraryDirsForWay ws + | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs + | otherwise = map ST.unpack . unitLibraryDirs + +unitHsLibs :: GhcNameVersion -> Ways -> UnitInfo -> [String] +unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p) + where + ways1 = Set.filter (/= WayDyn) ways0 + -- the name of a shared library is libHSfoo-ghc<version>.so + -- we leave out the _dyn, because it is superfluous + + -- debug and profiled RTSs include support for -eventlog + ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1 + = Set.filter (/= WayTracing) ways1 + | otherwise + = ways1 + + tag = waysTag (fullWays ways2) + rts_tag = waysTag ways2 + + mkDynName x + | not (ways0 `hasWay` WayDyn) = x + | "HS" `isPrefixOf` x = x ++ dynLibSuffix namever + -- For non-Haskell libraries, we use the name "Cfoo". The .a + -- file is libCfoo.a, and the .so is libfoo.so. That way the + -- linker knows what we mean for the vanilla (-lCfoo) and dyn + -- (-lfoo) ways. We therefore need to strip the 'C' off here. + | Just x' <- stripPrefix "C" x = x' + | otherwise + = panic ("Don't understand library name " ++ x) + + -- Add _thr and other rts suffixes to packages named + -- `rts` or `rts-1.0`. Why both? Traditionally the rts + -- package is called `rts` only. However the tooling + -- usually expects a package name to have a version. + -- As such we will gradually move towards the `rts-1.0` + -- package name, at which point the `rts` package name + -- will eventually be unused. + -- + -- This change elevates the need to add custom hooks + -- and handling specifically for the `rts` package for + -- example in ghc-cabal. + addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) + addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag) + addSuffix other_lib = other_lib ++ (expandTag tag) + + expandTag t | null t = "" + | otherwise = '_':t + diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index 74ba55a702..1aabfb10c2 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -1,6 +1,7 @@ -- (c) The University of Glasgow, 2006 {-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} -- | Unit manipulation module GHC.Unit.State ( @@ -9,6 +10,7 @@ module GHC.Unit.State ( -- * Reading the package config, and processing cmdline args UnitState(..), UnitDatabase (..), + UnitErr (..), emptyUnitState, initUnits, readUnitDatabases, @@ -39,12 +41,9 @@ module GHC.Unit.State ( UnusableUnitReason(..), pprReason, - -- * Inspecting the set of packages in scope - getUnitIncludePath, - getUnitExtraCcOpts, - getPreloadUnitsAnd, - - collectIncludeDirs, + closeUnitDeps, + closeUnitDeps', + mayThrowUnitErr, -- * Module hole substitution ShHoleSubst, @@ -73,19 +72,23 @@ where import GHC.Prelude +import GHC.Driver.Session + import GHC.Platform -import GHC.Unit.Home +import GHC.Platform.Ways + import GHC.Unit.Database import GHC.Unit.Info import GHC.Unit.Ppr import GHC.Unit.Types import GHC.Unit.Module -import GHC.Driver.Session -import GHC.Platform.Ways +import GHC.Unit.Home + import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique.DSet + import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable @@ -94,7 +97,7 @@ import GHC.Data.Maybe import System.Environment ( getEnv ) import GHC.Data.FastString import qualified GHC.Data.ShortText as ST -import GHC.Utils.Error ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, +import GHC.Utils.Error ( debugTraceMsg, dumpIfSet_dyn, withTiming, DumpFormat (..) ) import GHC.Utils.Exception @@ -342,8 +345,8 @@ data UnitConfig = UnitConfig , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units } -initUnitConfig :: DynFlags -> UnitConfig -initUnitConfig dflags = +initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitConfig +initUnitConfig dflags cached_dbs = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags !hu_instantiations = homeUnitInstantiations_ dflags @@ -376,7 +379,7 @@ initUnitConfig dflags = , unitConfigHideAll = gopt Opt_HideAllPackages dflags , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags - , unitConfigDBCache = unitDatabases dflags + , unitConfigDBCache = cached_dbs , unitConfigFlagsDB = packageDBFlags dflags , unitConfigFlagsExposed = packageFlags dflags , unitConfigFlagsIgnored = ignorePackageFlags dflags @@ -573,27 +576,55 @@ 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 :: DynFlags -> IO DynFlags -initUnits dflags = do +initUnits :: DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit) +initUnits dflags cached_dbs = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () let ctx = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages let printer = debugTraceMsg dflags -- printer for trace messages - (state,dbs) <- withTiming dflags (text "initializing unit database") + (unit_state,dbs) <- withTiming dflags (text "initializing unit database") forceUnitInfoMap - (mkUnitState ctx printer (initUnitConfig dflags)) - - dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Module Map" - FormatText (pprModuleMap (moduleNameProvidersMap state)) - - let dflags' = dflags - { unitDatabases = Just dbs -- databases are cached and never read again - , unitState = state - } - dflags'' = upd_wired_in_home_instantiations dflags' - - return dflags'' + $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs) + + dumpIfSet_dyn dflags Opt_D_dump_mod_map "Module Map" + FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) + $ pprModuleMap (moduleNameProvidersMap unit_state)) + + let home_unit = mkHomeUnit unit_state + (homeUnitId_ dflags) + (homeUnitInstanceOf_ dflags) + (homeUnitInstantiations_ dflags) + + return (dbs,unit_state,home_unit) + +mkHomeUnit + :: UnitState + -> UnitId -- ^ Home unit id + -> Maybe UnitId -- ^ Home unit instance of + -> [(ModuleName, Module)] -- ^ Home unit instantiations + -> HomeUnit +mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ = + let + -- Some wired units can be used to instantiate the home unit. We need to + -- replace their unit keys with their wired unit ids. + wmap = wireMap unit_state + hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_ + in case (hu_instanceof, hu_instantiations) of + (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing + (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") + (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with") + (Just u, is) + -- detect fully indefinite units: all their instantiations are hole + -- modules and the home unit id is the same as the instantiating unit + -- id (see Note [About units] in GHC.Unit) + | all (isHoleModule . snd) is && u == hu_id + -> IndefiniteHomeUnit u is + -- otherwise it must be that we (fully) instantiate an indefinite unit + -- to make it definite. + -- TODO: error when the unit is partially instantiated?? + | otherwise + -> DefiniteHomeUnit hu_id (Just (u, is)) -- ----------------------------------------------------------------------------- -- Reading the unit database(s) @@ -759,30 +790,28 @@ mungeDynLibFields pkg = -- -trust and -distrust. applyTrustFlag - :: SDocContext - -> UnitPrecedenceMap + :: UnitPrecedenceMap -> UnusableUnits -> [UnitInfo] -> TrustFlag - -> IO [UnitInfo] -applyTrustFlag ctx prec_map unusable pkgs flag = + -> MaybeErr UnitErr [UnitInfo] +applyTrustFlag prec_map unusable pkgs flag = case flag of -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages prec_map (PackageArg str) pkgs unusable of - Left ps -> trustFlagErr ctx flag ps - Right (ps,qs) -> return (map trust ps ++ qs) + Left ps -> Failed (TrustFlagErr flag ps) + Right (ps,qs) -> Succeeded (map trust ps ++ qs) where trust p = p {unitIsTrusted=True} DistrustPackage str -> case selectPackages prec_map (PackageArg str) pkgs unusable of - Left ps -> trustFlagErr ctx flag ps - Right (ps,qs) -> return (distrustAllUnits ps ++ qs) + Left ps -> Failed (TrustFlagErr flag ps) + Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs) applyPackageFlag - :: SDocContext - -> UnitPrecedenceMap + :: UnitPrecedenceMap -> UnitInfoMap -> PreloadUnitClosure -> UnusableUnits @@ -790,15 +819,15 @@ applyPackageFlag -- any previously exposed packages with the same name -> [UnitInfo] -> VisibilityMap -- Initially exposed - -> PackageFlag -- flag to apply - -> IO VisibilityMap -- Now exposed + -> PackageFlag -- flag to apply + -> MaybeErr UnitErr VisibilityMap -- Now exposed -applyPackageFlag ctx prec_map pkg_map closure unusable no_hide_others pkgs vm flag = +applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag = case flag of ExposePackage _ arg (ModRenaming b rns) -> case findPackages prec_map pkg_map closure arg pkgs unusable of - Left ps -> packageFlagErr ctx flag ps - Right (p:_) -> return vm' + Left ps -> Failed (PackageFlagErr flag ps) + Right (p:_) -> Succeeded vm' where n = fsPackageName p @@ -861,9 +890,8 @@ applyPackageFlag ctx prec_map pkg_map closure unusable no_hide_others pkgs vm fl HidePackage str -> case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of - Left ps -> packageFlagErr ctx flag ps - Right ps -> return vm' - where vm' = foldl' (flip Map.delete) vm (map mkUnit ps) + Left ps -> Failed (PackageFlagErr flag ps) + Right ps -> Succeeded $ foldl' (flip Map.delete) vm (map mkUnit ps) -- | Like 'selectPackages', but doesn't return a list of unmatched -- packages. Furthermore, any packages it returns are *renamed* @@ -970,34 +998,6 @@ compareByPreference prec_map pkg pkg' comparing :: Ord a => (t -> a) -> t -> t -> Ordering comparing f a b = f a `compare` f b -packageFlagErr :: SDocContext - -> PackageFlag - -> [(UnitInfo, UnusableUnitReason)] - -> IO a -packageFlagErr ctx flag reasons - = packageFlagErr' ctx (pprFlag flag) reasons - -trustFlagErr :: SDocContext - -> TrustFlag - -> [(UnitInfo, UnusableUnitReason)] - -> IO a -trustFlagErr ctx flag reasons - = packageFlagErr' ctx (pprTrustFlag flag) reasons - -packageFlagErr' :: SDocContext - -> SDoc - -> [(UnitInfo, UnusableUnitReason)] - -> IO a -packageFlagErr' ctx flag_doc reasons - = throwGhcExceptionIO (CmdLineError (renderWithContext ctx $ err)) - where err = text "cannot satisfy " <> flag_doc <> - (if null reasons then Outputable.empty else text ": ") $$ - nest 4 (ppr_reasons $$ - text "(use -v for more information)") - ppr_reasons = vcat (map ppr_reason reasons) - ppr_reason (p, reason) = - pprReason (ppr (unitId p) <+> text "is") reason - pprFlag :: PackageFlag -> SDoc pprFlag flag = case flag of HidePackage p -> text "-hide-package " <> text p @@ -1117,17 +1117,6 @@ findWiredInUnits printer prec_map pkgs vis_map = do -- For instance, base-4.9.0.0 will be rewritten to just base, to match -- what appears in GHC.Builtin.Names. --- | Some wired units can be used to instantiate the home unit. We need to --- replace their unit keys with their wired unit ids. -upd_wired_in_home_instantiations :: DynFlags -> DynFlags -upd_wired_in_home_instantiations dflags = dflags { homeUnitInstantiations_ = wiredInsts } - where - state = unitState dflags - wiringMap = wireMap state - unwiredInsts = homeUnitInstantiations_ dflags - wiredInsts = map (fmap (upd_wired_in_mod wiringMap)) unwiredInsts - - upd_wired_in_mod :: WiringMap -> Module -> Module upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m @@ -1482,7 +1471,8 @@ mkUnitState ctx printer cfg = do -- Apply trust flags (these flags apply regardless of whether -- or not packages are visible or not) - pkgs1 <- foldM (applyTrustFlag ctx prec_map unusable) + pkgs1 <- mayThrowUnitErr + $ foldM (applyTrustFlag prec_map unusable) (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) let prelim_pkg_db = mkUnitInfoMap pkgs1 @@ -1540,7 +1530,8 @@ mkUnitState ctx printer cfg = do -- -hide-package). This needs to know about the unusable packages, since if a -- user tries to enable an unusable package, we should let them know. -- - vis_map2 <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable + vis_map2 <- mayThrowUnitErr + $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable (unitConfigHideAll cfg) pkgs1) vis_map1 other_flags @@ -1568,7 +1559,8 @@ mkUnitState ctx printer cfg = do -- won't work. | otherwise = vis_map2 plugin_vis_map2 - <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable + <- mayThrowUnitErr + $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable hide_plugin_pkgs pkgs1) plugin_vis_map1 (reverse (unitConfigFlagsPlugins cfg)) @@ -1614,8 +1606,9 @@ mkUnitState ctx printer cfg = do preload3 = ordNub $ (basicLinkedUnits ++ preload1) -- Close the preload packages with their dependencies - let dep_preload_err = closeUnitDeps pkg_db (zip (map toUnitId preload3) (repeat Nothing)) - dep_preload <- throwErr ctx dep_preload_err + dep_preload <- mayThrowUnitErr + $ closeUnitDeps pkg_db + $ zip (map toUnitId preload3) (repeat Nothing) let mod_map1 = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet vis_map mod_map2 = mkUnusableModuleNameProvidersMap unusable @@ -1635,7 +1628,6 @@ mkUnitState ctx printer cfg = do , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } - return (state, raw_dbs) -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' @@ -1775,30 +1767,6 @@ addListTo = foldl' merge mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin mkModMap pkg mod = Map.singleton (mkModule pkg mod) --- ----------------------------------------------------------------------------- --- Extracting information from the packages in scope - --- Many of these functions take a list of packages: in those cases, --- the list is expected to contain the "dependent packages", --- i.e. those packages that were found to be depended on by the --- current module/program. These can be auto or non-auto packages, it --- doesn't really matter. The list is always combined with the list --- of preload (command-line) packages to determine which packages to --- use. - --- | Find all the include directories in these and the preload packages -getUnitIncludePath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] -getUnitIncludePath ctx unit_state home_unit pkgs = - collectIncludeDirs `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs - -collectIncludeDirs :: [UnitInfo] -> [FilePath] -collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps)) - --- | Find all the C-compiler options in these and the preload packages -getUnitExtraCcOpts :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] -getUnitExtraCcOpts ctx unit_state home_unit pkgs = do - ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs - return $ map ST.unpack (concatMap unitCcOptions ps) -- ----------------------------------------------------------------------------- -- Package Utils @@ -1923,39 +1891,15 @@ listVisibleModuleNames state = map fst (filter visible (Map.toList (moduleNameProvidersMap state))) where visible (_, ms) = any originVisible (Map.elems ms) --- | Lookup 'UnitInfo' for every preload unit from the UnitState, for every unit --- used to instantiate the home unit, and for every unit explicitly passed in --- the given list of UnitId. -getPreloadUnitsAnd :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo] -getPreloadUnitsAnd ctx unit_state home_unit ids0 = - let - ids = ids0 ++ inst_ids - inst_ids - -- An indefinite package will have insts to HOLE, - -- which is not a real package. Don't look it up. - -- Fixes #14525 - | isHomeUnitIndefinite home_unit = [] - | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) - pkg_map = unitInfoMap unit_state - preload = preloadUnits unit_state - in do - all_pkgs <- throwErr ctx (closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing)) - return (map (unsafeLookupUnitId unit_state) all_pkgs) - -throwErr :: SDocContext -> MaybeErr MsgDoc a -> IO a -throwErr ctx m = case m of - Failed e -> throwGhcExceptionIO (CmdLineError (renderWithContext ctx e)) - Succeeded r -> return r - -- | Takes a list of UnitIds (and their "parent" dependency, used for error -- messages), and returns the list with dependencies included, in reverse -- dependency order (a units appears before those it depends on). -closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId] +closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps -- | Similar to closeUnitDeps but takes a list of already loaded units as an -- additional argument. -closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId] +closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps -- | Add a UnitId and those it depends on (recursively) to the given list of @@ -1968,16 +1912,11 @@ closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps add_unit :: UnitInfoMap -> [UnitId] -> (UnitId,Maybe UnitId) - -> MaybeErr MsgDoc [UnitId] + -> MaybeErr UnitErr [UnitId] add_unit pkg_map ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this unit | otherwise = case lookupUnitId' pkg_map p of - Nothing -> Failed $ - (ftext (fsLit "unknown package:") <+> ppr p) - <> case mb_parent of - Nothing -> Outputable.empty - Just parent -> space <> parens (text "dependency of" - <+> ftext (unitIdFS parent)) + Nothing -> Failed (CloseUnitErr p mb_parent) Just info -> do -- Add the unit's dependents also ps' <- foldM add_unit_key ps (unitDepends info) @@ -1986,6 +1925,44 @@ add_unit pkg_map ps (p, mb_parent) add_unit_key ps key = add_unit pkg_map ps (key, Just p) +data UnitErr + = CloseUnitErr !UnitId !(Maybe UnitId) + | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] + | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] + +mayThrowUnitErr :: MaybeErr UnitErr a -> IO a +mayThrowUnitErr = \case + Failed e -> throwGhcExceptionIO + $ CmdLineError + $ renderWithContext defaultSDocContext + $ withPprStyle defaultUserStyle + $ ppr e + Succeeded a -> return a + +instance Outputable UnitErr where + ppr = \case + CloseUnitErr p mb_parent + -> (ftext (fsLit "unknown unit:") <+> ppr p) + <> case mb_parent of + Nothing -> Outputable.empty + Just parent -> space <> parens (text "dependency of" + <+> ftext (unitIdFS parent)) + PackageFlagErr flag reasons + -> flag_err (pprFlag flag) reasons + + TrustFlagErr flag reasons + -> flag_err (pprTrustFlag flag) reasons + where + flag_err flag_doc reasons = + text "cannot satisfy " + <> flag_doc + <> (if null reasons then Outputable.empty else text ": ") + $$ nest 4 (vcat (map ppr_reason reasons) $$ + text "(use -v for more information)") + + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + -- ----------------------------------------------------------------------------- -- | Pretty-print a UnitId for the user. diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index ab97f3b0ef..13b877fd44 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -666,6 +666,7 @@ Library GHC.Types.Var.Env GHC.Types.Var.Set GHC.Unit + GHC.Unit.Env GHC.Unit.External GHC.Unit.Finder GHC.Unit.Finder.Types diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 81b0a84fca..152017de38 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -1495,7 +1495,8 @@ info allInfo s = handleSourceError GHC.printException $ do unqual <- GHC.getPrintUnqual dflags <- getDynFlags sdocs <- mapM (infoThing allInfo) (words s) - mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs + unit_state <- hsc_units <$> GHC.getSession + mapM_ (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc infoThing allInfo str = do @@ -1796,7 +1797,8 @@ docCmd s = do let sdocs' = vcat (intersperse (text "") sdocs) unqual <- GHC.getPrintUnqual dflags <- getDynFlags - (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs' + unit_state <- hsc_units <$> GHC.getSession + (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs' pprDocs :: [(Maybe HsDocString, Map Int HsDocString)] -> [SDoc] pprDocs docs @@ -2085,6 +2087,7 @@ keepPackageImports = filterM is_pkg_import modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m () modulesLoadedMsg ok mods = do dflags <- getDynFlags + unit_state <- hsc_units <$> GHC.getSession unqual <- GHC.getPrintUnqual msg <- if gopt Opt_ShowLoadedModules dflags @@ -2099,7 +2102,7 @@ modulesLoadedMsg ok mods = do <+> speakNOf (length mods) (text "module") <+> "loaded." when (verbosity dflags > 0) $ - liftIO $ putStrLn $ showSDocForUser dflags unqual msg + liftIO $ putStrLn $ showSDocForUser dflags unit_state unqual msg where status = case ok of Failed -> text "Failed" @@ -2122,7 +2125,8 @@ runExceptGhcMonad act = handleSourceError GHC.printException $ where handleErr sdoc = do dflags <- getDynFlags - liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc + unit_state <- hsc_units <$> GHC.getSession + liftIO . hPutStrLn stderr . showSDocForUser dflags unit_state alwaysQualify $ sdoc -- | Inverse of 'runExceptT' for \"pure\" computations -- (c.f. 'except' for 'Except') @@ -2186,9 +2190,11 @@ allTypesCmd _ = runExceptGhcMonad $ do where printSpan span' | Just ty <- spaninfoType span' = do - df <- getDynFlags + hsc_env <- GHC.getSession let tyInfo = unwords . words $ - showSDocForUser df alwaysQualify (pprTypeForUser ty) + showSDocForUser (hsc_dflags hsc_env) + (hsc_units hsc_env) + alwaysQualify (pprTypeForUser ty) liftIO . putStrLn $ showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo | otherwise = return () @@ -2357,6 +2363,7 @@ isSafeModule m = do (throwGhcException $ CmdLineError $ "unknown module: " ++ mname) dflags <- getDynFlags + hsc_env <- GHC.getSession let iface = GHC.modInfoIface $ fromJust mb_mod_info when (isNothing iface) (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++ @@ -2364,8 +2371,8 @@ isSafeModule m = do (msafe, pkgs) <- GHC.moduleTrustReqs m let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface - pkg = if packageTrusted dflags m then "trusted" else "untrusted" - (good, bad) = tallyPkgs dflags pkgs + pkg = if packageTrusted hsc_env m then "trusted" else "untrusted" + (good, bad) = tallyPkgs hsc_env pkgs -- print info to user... liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" @@ -2384,14 +2391,15 @@ isSafeModule m = do where mname = GHC.moduleNameString $ GHC.moduleName m - packageTrusted dflags md - | isHomeModule (mkHomeUnitFromFlags dflags) md = True - | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit md) + packageTrusted hsc_env md + | isHomeModule (hsc_home_unit hsc_env) md = True + | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md) - tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty) + tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty) | otherwise = S.partition part deps where part pkg = unitIsTrusted $ unsafeLookupUnitId unit_state pkg - unit_state = unitState dflags + unit_state = hsc_units hsc_env + dflags = hsc_dflags hsc_env ----------------------------------------------------------------------------- -- :browse @@ -2497,7 +2505,8 @@ browseModule bang modl exports_only = do prettyThings = map pretty things prettyThings' | bang = annotate $ zip modNames prettyThings | otherwise = prettyThings - liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings') + unit_state <- hsc_units <$> GHC.getSession + liftIO $ putStrLn $ showSDocForUser dflags unit_state unqual (vcat prettyThings') -- ToDo: modInfoInstances currently throws an exception for -- package modules. When it works, we can do this: -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) @@ -2971,16 +2980,14 @@ newDynFlags interactive_only minus_opts = do -- delete targets and all eventually defined breakpoints. (#1620) clearAllTargets when must_reload $ do - let units = preloadUnits (unitState dflags2) + let units = preloadUnits (hsc_units hsc_env) liftIO $ Loader.loadPackages hsc_env units -- package flags changed, we can't re-use any of the old context setContextAfterLoad False [] - -- and copy the package state to the interactive DynFlags + -- and copy the package flags to the interactive DynFlags idflags <- GHC.getInteractiveDynFlags GHC.setInteractiveDynFlags - idflags{ unitState = unitState dflags2 - , unitDatabases = unitDatabases dflags2 - , packageFlags = packageFlags dflags2 } + idflags{ packageFlags = packageFlags dflags2 } let ld0length = length $ ldInputs dflags0 fmrk0length = length $ cmdlineFrameworks dflags0 @@ -3475,23 +3482,23 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 pure $ map (combineModIdent mod_str) bids completeModule = wrapIdentCompleter $ \w -> do - dflags <- GHC.getSessionDynFlags - let pkg_mods = allVisibleModules dflags + hsc_env <- GHC.getSession + let pkg_mods = allVisibleModules (hsc_units hsc_env) loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ filter (w `isPrefixOf`) - $ map (showPpr dflags) $ loaded_mods ++ pkg_mods + $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do - dflags <- GHC.getSessionDynFlags + hsc_env <- GHC.getSession modules <- case m of Just '-' -> do imports <- GHC.getContext return $ map iiModuleName imports _ -> do - let pkg_mods = allVisibleModules dflags + let pkg_mods = allVisibleModules (hsc_units hsc_env) loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ loaded_mods ++ pkg_mods - return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules + return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules completeHomeModule = wrapIdentCompleter listHomeModules @@ -3549,8 +3556,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor -- | Return a list of visible module names for autocompletion. -- (NB: exposed != visible) -allVisibleModules :: DynFlags -> [ModuleName] -allVisibleModules dflags = listVisibleModuleNames (unitState dflags) +allVisibleModules :: UnitState -> [ModuleName] +allVisibleModules unit_state = listVisibleModuleNames unit_state completeExpression = completeQuotedWord (Just '\\') "\"" listFiles completeIdentifier @@ -4335,7 +4342,7 @@ wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module wantInterpretedModuleName modname = do modl <- lookupModuleName modname let str = moduleNameString modname - home_unit <- mkHomeUnitFromFlags <$> getDynFlags + home_unit <- hsc_home_unit <$> GHC.getSession unless (isHomeModule home_unit modl) $ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) is_interpreted <- GHC.moduleIsInterpreted modl diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 64db8ea219..e6cf0838ca 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -40,6 +40,7 @@ import GHC.Driver.Session (HasDynFlags(..)) import GHC.Data.FastString import GHC import GHC.Driver.Monad +import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Types.Name import GHC.Types.Name.Set @@ -264,6 +265,7 @@ collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName] -> m (Map ModuleName ModInfo) collectInfo ms loaded = do df <- getDynFlags + unit_state <- hsc_units <$> getSession liftIO (filterM cacheInvalid loaded) >>= \case [] -> return ms invalidated -> do @@ -271,13 +273,13 @@ collectInfo ms loaded = do show (length invalidated) ++ " module(s) ... ")) - foldM (go df) ms invalidated + foldM (go df unit_state) ms invalidated where - go df m name = do { info <- getModInfo name; return (M.insert name info m) } + go df unit_state m name = do { info <- getModInfo name; return (M.insert name info m) } `MC.catch` (\(e :: SomeException) -> do liftIO $ putStrLn - $ showSDocForUser df alwaysQualify + $ showSDocForUser df unit_state alwaysQualify $ "Error while getting type info from" <+> ppr name <> ":" <+> text (show e) return m) diff --git a/ghc/GHCi/UI/Tags.hs b/ghc/GHCi/UI/Tags.hs index 53c33ccbfe..7d8331198a 100644 --- a/ghc/GHCi/UI/Tags.hs +++ b/ghc/GHCi/UI/Tags.hs @@ -24,6 +24,8 @@ import GHC.Types.Name (nameOccName) import GHC.Types.Name.Occurrence (pprOccName) import GHC.Core.ConLike import GHC.Utils.Monad +import GHC.Unit.State +import GHC.Driver.Env import Control.Monad import Data.Function @@ -93,12 +95,13 @@ listModuleTags m = do Nothing -> return [] Just mInfo -> do dflags <- getDynFlags + unit_state <- hsc_units <$> getSession mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual let names = fromMaybe [] $ GHC.modInfoTopLevelScope mInfo let localNames = filter ((m==) . nameModule) names mbTyThings <- mapM GHC.lookupName localNames - return $! [ tagInfo dflags unqual exported kind name realLoc + return $! [ tagInfo dflags unit_state unqual exported kind name realLoc | tyThing <- catMaybes mbTyThings , let name = getName tyThing , let exported = GHC.modInfoIsExportedName mInfo name @@ -127,12 +130,13 @@ data TagInfo = TagInfo -- get tag info, for later translation into Vim or Emacs style -tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc +tagInfo :: DynFlags -> UnitState -> PrintUnqualified + -> Bool -> Char -> Name -> RealSrcLoc -> TagInfo -tagInfo dflags unqual exported kind name loc +tagInfo dflags unit_state unqual exported kind name loc = TagInfo exported kind - (showSDocForUser dflags unqual $ pprOccName (nameOccName name)) - (showSDocForUser dflags unqual $ ftext (srcLocFile loc)) + (showSDocForUser dflags unit_state unqual $ pprOccName (nameOccName name)) + (showSDocForUser dflags unit_state unqual $ ftext (srcLocFile loc)) (srcLocLine loc) (srcLocCol loc) Nothing -- throw an exception when someone tries to overwrite existing source file (fix for #10989) diff --git a/ghc/Main.hs b/ghc/Main.hs index db926fb85f..1f9e0bdf2a 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -24,7 +24,6 @@ import GHC.Driver.Env import GHC.Driver.Phases import GHC.Driver.Session hiding (WarnReason(..)) import GHC.Driver.Ppr -import GHC.Driver.Main ( newHscEnv ) import GHC.Driver.Pipeline ( oneShot, compileFile ) import GHC.Driver.MakeFile ( doMkDependHS ) import GHC.Driver.Backpack ( doBackpack ) @@ -43,7 +42,7 @@ import GHC.Runtime.Loader ( loadFrontendPlugin ) import GHC.Unit.Module ( ModuleName, mkModuleName ) import GHC.Unit.Module.ModIface import GHC.Unit.State ( pprUnits, pprUnitsSimple ) -import GHC.Unit.Finder ( findImportedModule, cannotFindModule, FindResult(..) ) +import GHC.Unit.Finder ( findImportedModule, FindResult(..) ) import GHC.Unit.Types ( IsBootInterface(..) ) import GHC.Types.Basic ( failed ) @@ -66,8 +65,7 @@ import GHC.HandleEncoding import GHC.Data.FastString import GHC.SysTools.BaseDir -import GHC.Iface.Load ( showIface ) -import GHC.Iface.Load ( loadUserInterface ) +import GHC.Iface.Load import GHC.Iface.Recomp.Binary ( fingerprintBinMem ) import GHC.Tc.Utils.Monad ( initIfaceCheck ) @@ -229,8 +227,8 @@ main' postLoadMode dflags0 args flagWarnings = do ---------------- Display configuration ----------- case verbosity dflags6 of - v | v == 4 -> liftIO $ dumpUnitsSimple dflags6 - | v >= 5 -> liftIO $ dumpUnits dflags6 + v | v == 4 -> liftIO $ dumpUnitsSimple hsc_env + | v >= 5 -> liftIO $ dumpUnits hsc_env | otherwise -> return () liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) @@ -242,14 +240,14 @@ main' postLoadMode dflags0 args flagWarnings = do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do case postLoadMode of - ShowInterface f -> liftIO $ doShowIface dflags6 f + ShowInterface f -> liftIO $ showIface hsc_env f DoMake -> doMake srcs DoMkDependHS -> doMkDependHS (map fst srcs) StopBefore p -> liftIO (oneShot hsc_env p srcs) DoInteractive -> ghciUI srcs Nothing DoEval exprs -> ghciUI srcs $ Just $ reverse exprs DoAbiHash -> abiHash (map fst srcs) - ShowPackages -> liftIO $ showUnits dflags6 + ShowPackages -> liftIO $ showUnits hsc_env DoFrontend f -> doFrontend f srcs DoBackpack -> doBackpack (map fst srcs) @@ -679,14 +677,6 @@ doMake srcs = do -- --------------------------------------------------------------------------- --- --show-iface mode - -doShowIface :: DynFlags -> FilePath -> IO () -doShowIface dflags file = do - hsc_env <- newHscEnv dflags - showIface hsc_env file - --- --------------------------------------------------------------------------- -- Various banners and verbosity output. showBanner :: PostLoadMode -> DynFlags -> IO () @@ -792,10 +782,10 @@ dumpFastStringStats dflags = do where x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%' -showUnits, dumpUnits, dumpUnitsSimple :: DynFlags -> IO () -showUnits dflags = putStrLn (showSDoc dflags (pprUnits (unitState dflags))) -dumpUnits dflags = putMsg dflags (pprUnits (unitState dflags)) -dumpUnitsSimple dflags = putMsg dflags (pprUnitsSimple (unitState dflags)) +showUnits, dumpUnits, dumpUnitsSimple :: HscEnv -> IO () +showUnits hsc_env = putStrLn (showSDoc (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env))) +dumpUnits hsc_env = putMsg (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env)) +dumpUnitsSimple hsc_env = putMsg (hsc_dflags hsc_env) (pprUnitsSimple (hsc_units hsc_env)) -- ----------------------------------------------------------------------------- -- Frontend plugin support @@ -842,7 +832,7 @@ abiHash strs = do case r of Found _ m -> return m _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ - cannotFindModule dflags modname r + cannotFindModule hsc_env modname r mods <- mapM find_it strs diff --git a/testsuite/tests/ghc-api/T7478/T7478.hs b/testsuite/tests/ghc-api/T7478/T7478.hs index 2fa0f6095e..89fd61a22c 100644 --- a/testsuite/tests/ghc-api/T7478/T7478.hs +++ b/testsuite/tests/ghc-api/T7478/T7478.hs @@ -11,6 +11,7 @@ import qualified GHC.Utils.Outputable as GHC import qualified GHC.Driver.Ppr as GHC import GHC.Driver.Monad (liftIO) import GHC.Utils.Outputable (PprStyle, queryQual) +import GHC.Unit.State compileInGhc :: [FilePath] -- ^ Targets -> (String -> IO ()) -- ^ handler for each SevOutput message @@ -43,7 +44,7 @@ compileInGhc targets handlerOutput = do _ -> error "fileFromTarget: not a known target" collectSrcError handlerOutput flags _ SevOutput _srcspan msg - = handlerOutput $ GHC.showSDocForUser flags alwaysQualify msg + = handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify msg collectSrcError _ _ _ _ _ _ = return () diff --git a/testsuite/tests/ghc-api/T9595.hs b/testsuite/tests/ghc-api/T9595.hs index 468b63a342..9a5450fbd3 100644 --- a/testsuite/tests/ghc-api/T9595.hs +++ b/testsuite/tests/ghc-api/T9595.hs @@ -3,18 +3,18 @@ module Main where import GHC import GHC.Unit.State import GHC.Driver.Monad -import GHC.Utils.Outputable -import System.Environment import GHC.Driver.Session +import GHC.Driver.Env +import GHC.Utils.Outputable import GHC.Unit.Module +import System.Environment main = do [libdir] <- getArgs _ <- runGhc (Just libdir) $ do dflags <- getSessionDynFlags setSessionDynFlags dflags - dflags <- getSessionDynFlags - let state = unitState dflags + state <- hsc_units <$> getSession liftIO $ print (mkModuleName "GHC.Utils.Outputable" `elem` listVisibleModuleNames state) _ <- runGhc (Just libdir) $ do dflags <- getSessionDynFlags @@ -23,7 +23,6 @@ main = (PackageArg "ghc") (ModRenaming True [])] }) - dflags <- getSessionDynFlags - let state = unitState dflags + state <- hsc_units <$> getSession liftIO $ print (mkModuleName "GHC.Utils.Outputable" `elem` listVisibleModuleNames state) return () diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout index 97b7dc743f..9c3db2105a 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.stdout +++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout @@ -1,4 +1,4 @@ -Found 235 parser module dependencies +Found 236 parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -193,6 +193,7 @@ GHC.Types.Var GHC.Types.Var.Env GHC.Types.Var.Set GHC.Unit +GHC.Unit.Env GHC.Unit.External GHC.Unit.Finder.Types GHC.Unit.Home diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index 6bd6864706..d889b90bc7 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -25,6 +25,7 @@ import qualified GHC.CmmToAsm.Reg.Linear.Base as Linear import qualified GHC.CmmToAsm.X86.Instr as X86.Instr import qualified GHC.CmmToAsm.X86 as X86 import GHC.Driver.Main +import GHC.Driver.Env import GHC.StgToCmm.CgUtils import GHC.CmmToAsm import GHC.CmmToAsm.Config @@ -110,7 +111,7 @@ compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do hscEnv <- newHscEnv dflags -- parse the cmm file and output any warnings or errors - (warnings, errors, parsedCmm) <- parseCmmFile dflags cmmFile + (warnings, errors, parsedCmm) <- parseCmmFile dflags (hsc_home_unit hscEnv) cmmFile let warningMsgs = fmap pprWarning warnings errorMsgs = fmap pprError errors diff --git a/testsuite/tests/rts/linker/LinkerUnload.hs b/testsuite/tests/rts/linker/LinkerUnload.hs index 9bdc92fdc2..6529dd654d 100644 --- a/testsuite/tests/rts/linker/LinkerUnload.hs +++ b/testsuite/tests/rts/linker/LinkerUnload.hs @@ -2,6 +2,7 @@ module LinkerUnload (init) where import GHC import GHC.Unit.State +import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Backend import qualified GHC.Linker.Loader as Loader @@ -19,4 +20,4 @@ loadPackages = do , ghcLink = LinkInMemory } setSessionDynFlags dflags' hsc_env <- getSession - liftIO $ Loader.loadPackages hsc_env (preloadUnits (unitState dflags')) + liftIO $ Loader.loadPackages hsc_env (preloadUnits (hsc_units hsc_env)) diff --git a/utils/haddock b/utils/haddock -Subproject acf235d607879eb9542127eb0ddb42a250b5b85 +Subproject 284c9a0c304faf9c186421a62da5d8b4dc73a8a |