diff options
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 |