Commit ee565d46 authored by Simon Marlow's avatar Simon Marlow

Packages cleanup, and allow new packages to be loaded with :set again

This cleans up the package subsystem a little.  There are some
changes to the GHC API as a result.

  - GHC.init and GHC.initFromArgs are no longer necessary.

  - GHC.newSession takes the root of the GHC tree as an argument
    (previously passed to GHC.init).

  - You *must* do GHC.setSessionDynFlags after GHC.newSession,
    this is what loads the package database.

  - Several global vars removed from SysTools

  - The :set command in GHCi can now cause new packages to be loaded,
    or can hide/ignore existing packages.
parent 891cd303
......@@ -25,7 +25,8 @@ import NameEnv ( delListFromNameEnv )
import TcType ( tidyTopType )
import qualified Id ( setIdType )
import IdInfo ( GlobalIdDetails(..) )
import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker )
import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,
initDynLinker, linkPackages )
import PrelNames ( breakpointJumpName, breakpointCondJumpName )
#endif
......@@ -1198,21 +1199,28 @@ setOptions wds =
-- then, dynamic flags
dflags <- getDynFlags
let pkg_flags = packageFlags dflags
(dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
setDynFlags dflags'
-- update things if the users wants more packages
{- TODO:
let new_packages = pkgs_after \\ pkgs_before
when (not (null new_packages)) $
newPackages new_packages
-}
if (not (null leftovers))
then throwDyn (CmdLineError ("unrecognised flags: " ++
unwords leftovers))
else return ()
new_pkgs <- setDynFlags dflags'
-- if the package flags changed, we should reset the context
-- and link the new packages.
dflags <- getDynFlags
when (packageFlags dflags /= pkg_flags) $ do
io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
session <- getSession
io (GHC.setTargets session [])
io (GHC.load session LoadAllTargets)
io (linkPackages dflags new_pkgs)
setContextAfterLoad session []
return ()
unsetOptions :: String -> GHCi ()
unsetOptions str
......@@ -1259,16 +1267,6 @@ optToStr ShowTiming = "s"
optToStr ShowType = "t"
optToStr RevertCAFs = "r"
{- ToDo
newPackages new_pkgs = do -- The new packages are already in v_Packages
session <- getSession
io (GHC.setTargets session [])
io (GHC.load session Nothing)
dflags <- getDynFlags
io (linkPackages dflags new_pkgs)
setContextAfterLoad []
-}
-- ---------------------------------------------------------------------------
-- code for `:show'
......
......@@ -224,7 +224,7 @@ reallyInitDynLinker dflags
; initObjLinker
-- (b) Load packages from the command-line
; linkPackages dflags (explicitPackages (pkgState dflags))
; linkPackages dflags (preloadPackages (pkgState dflags))
-- (c) Link libraries from the command-line
; let optl = getOpts dflags opt_l
......
......@@ -126,7 +126,7 @@ outputC dflags filenm mod location flat_absC
-- * -#include options from the cmdline and OPTIONS pragmas
-- * the _stub.h file, if there is one.
--
pkg_configs <- getExplicitPackagesAnd dflags packages
pkg_configs <- getPreloadPackagesAnd dflags packages
let pkg_names = map (showPackageId.package) pkg_configs
c_includes <- getPackageCIncludes pkg_configs
......
......@@ -29,7 +29,7 @@ module DriverPipeline (
import Packages
import HeaderInfo
import DriverPhases
import SysTools ( newTempName, addFilesToClean, getSysMan, copy )
import SysTools ( newTempName, addFilesToClean, copy )
import qualified SysTools
import HscMain
import Finder
......@@ -1044,9 +1044,9 @@ runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc
-- we don't need the generality of a phase (MoveBinary is always
-- done after linking and makes only sense in a parallel setup) -- HWL
runPhase_MoveBinary input_fn
runPhase_MoveBinary dflags input_fn
= do
sysMan <- getSysMan
let sysMan = pgm_sysman dflags
pvm_root <- getEnv "PVM_ROOT"
pvm_arch <- getEnv "PVM_ARCH"
let
......@@ -1243,7 +1243,7 @@ staticLink dflags o_files dep_packages = do
-- parallel only: move binary to another dir -- HWL
when (WayPar `elem` ways)
(do success <- runPhase_MoveBinary output_fn
(do success <- runPhase_MoveBinary dflags output_fn
if success then return ()
else throwDyn (InstallationError ("cannot move binary to PVM dir")))
......
{-# OPTIONS -fno-warn-missing-fields #-}
-----------------------------------------------------------------------------
--
-- Dynamic flags
......@@ -63,6 +64,7 @@ import Config
import CmdLineParser
import Constants ( mAX_CONTEXT_REDUCTION_DEPTH )
import Panic ( panic, GhcException(..) )
import UniqFM ( UniqFM )
import Util ( notNull, splitLongestPrefix, normalisePath )
import Maybes ( fromJust, orElse )
import SrcLoc ( SrcSpan )
......@@ -246,6 +248,9 @@ data DynFlags = DynFlags {
cmdlineFrameworks :: [String], -- ditto
tmpDir :: String, -- no trailing '/'
ghcUsagePath :: FilePath, -- Filled in by SysTools
ghciUsagePath :: FilePath, -- ditto
-- options for particular phases
opt_L :: [String],
opt_P :: [String],
......@@ -267,16 +272,23 @@ data DynFlags = DynFlags {
pgm_a :: (String,[Option]),
pgm_l :: (String,[Option]),
pgm_dll :: (String,[Option]),
pgm_T :: String,
pgm_sysman :: String,
-- ** Package flags
-- Package flags
extraPkgConfs :: [FilePath],
topDir :: FilePath, -- filled in by SysTools
systemPackageConfig :: FilePath, -- ditto
-- The -package-conf flags given on the command line, in the order
-- they appeared.
packageFlags :: [PackageFlag],
-- The -package and -hide-package flags from the command-line
-- ** Package state
-- Package state
-- NB. do not modify this field, it is calculated by
-- Packages.initPackages and Packages.updatePackages.
pkgDatabase :: Maybe (UniqFM InstalledPackageInfo),
pkgState :: PackageState,
-- hsc dynamic flags
......@@ -322,6 +334,7 @@ data PackageFlag
= ExposePackage String
| HidePackage String
| IgnorePackage String
deriving Eq
defaultHscTarget
| cGhcWithNativeCodeGen == "YES" = HscAsm
......@@ -359,10 +372,6 @@ defaultDynFlags =
ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH,
thisPackage = mainPackageId,
wayNames = panic "ways",
buildTag = panic "buildTag",
rtsBuildTag = panic "rtsBuildTag",
objectDir = Nothing,
hiDir = Nothing,
......@@ -390,19 +399,10 @@ defaultDynFlags =
opt_dll = [],
opt_dep = [],
pgm_L = panic "pgm_L",
pgm_P = panic "pgm_P",
pgm_F = panic "pgm_F",
pgm_c = panic "pgm_c",
pgm_m = panic "pgm_m",
pgm_s = panic "pgm_s",
pgm_a = panic "pgm_a",
pgm_l = panic "pgm_l",
pgm_dll = panic "pgm_mkdll",
extraPkgConfs = [],
packageFlags = [],
pkgState = panic "pkgState",
pkgDatabase = Nothing,
pkgState = panic "no package state yet: call GHC.setSessionDynFlags",
flags = [
Opt_RecompChecking,
......
......@@ -11,13 +11,11 @@ module GHC (
Session,
defaultErrorHandler,
defaultCleanupHandler,
init, initFromArgs,
newSession,
-- * Flags and settings
DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
parseDynamicFlags,
initPackages,
getSessionDynFlags,
setSessionDynFlags,
......@@ -166,8 +164,6 @@ module GHC (
ToDo:
* inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
* we need to expose DynFlags, so should parseDynamicFlags really be
part of this interface?
* what StaticFlags should we expose, if any?
-}
......@@ -322,46 +318,19 @@ defaultCleanupHandler dflags inner =
inner
-- | Initialises GHC. This must be done /once/ only. Takes the
-- TopDir path without the '-B' prefix.
init :: Maybe String -> IO ()
init mbMinusB = do
-- catch ^C
main_thread <- myThreadId
putMVar interruptTargetThread [main_thread]
installSignalHandlers
dflags0 <- initSysTools mbMinusB defaultDynFlags
writeIORef v_initDynFlags dflags0
-- | Initialises GHC. This must be done /once/ only. Takes the
-- command-line arguments. All command-line arguments which aren't
-- understood by GHC will be returned.
initFromArgs :: [String] -> IO [String]
initFromArgs args
= do init mbMinusB
return argv1
where -- Grab the -B option if there is one
(minusB_args, argv1) = partition (prefixMatch "-B") args
mbMinusB | null minusB_args
= Nothing
| otherwise
= Just (drop 2 (last minusB_args))
GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
-- stores the DynFlags between the call to init and subsequent
-- calls to newSession.
-- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
-- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
-- code".
newSession :: GhcMode -> IO Session
newSession mode = do
dflags0 <- readIORef v_initDynFlags
dflags <- initDynFlags dflags0
newSession :: GhcMode -> Maybe FilePath -> IO Session
newSession mode mb_top_dir = do
-- catch ^C
main_thread <- myThreadId
putMVar interruptTargetThread [main_thread]
installSignalHandlers
dflags0 <- initSysTools mb_top_dir defaultDynFlags
dflags <- initDynFlags dflags0
env <- newHscEnv dflags{ ghcMode=mode }
ref <- newIORef env
return (Session ref)
......@@ -384,9 +353,23 @@ modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
getSessionDynFlags :: Session -> IO DynFlags
getSessionDynFlags s = withSession s (return . hsc_dflags)
-- | Updates the DynFlags in a Session
setSessionDynFlags :: Session -> DynFlags -> IO ()
setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
-- | Updates the DynFlags in a Session. This also reads
-- the package database (unless it has already been read),
-- and prepares the compilers knowledge about packages. It
-- can be called again to load new packages: just add new
-- package flags to (packageFlags dflags).
--
-- Returns a list of new packages that may need to be linked in using
-- the dynamic linker (see 'linkPackages') as a result of new package
-- flags. If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
setSessionDynFlags (Session ref) dflags = do
hsc_env <- readIORef ref
(dflags', preload) <- initPackages dflags
writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
return preload
-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
......
......@@ -21,7 +21,6 @@ import CmdLineParser
import MkIface ( showIface )
import DriverPipeline ( oneShot, compileFile )
import DriverMkDepend ( doMkDependHS )
import SysTools ( getTopDir, getUsageMsgPaths )
#ifdef GHCI
import InteractiveUI ( ghciWelcomeMsg, interactiveUI )
#endif
......@@ -64,11 +63,18 @@ import Maybe
main =
GHC.defaultErrorHandler defaultDynFlags $ do
-- 1. extract the -B flag from the args
argv0 <- getArgs
argv1 <- parseStaticFlags =<< GHC.initFromArgs argv0
let
(minusB_args, argv1) = partition (prefixMatch "-B") argv0
mbMinusB | null minusB_args = Nothing
| otherwise = Just (drop 2 (last minusB_args))
argv2 <- parseStaticFlags argv1
-- 2. Parse the "mode" flags (--make, --interactive etc.)
(cli_mode, argv2) <- parseModeFlags argv1
(cli_mode, argv3) <- parseModeFlags argv2
let mode = case cli_mode of
DoInteractive -> Interactive
......@@ -78,7 +84,7 @@ main =
_ -> OneShot
-- start our GHC session
session <- GHC.newSession mode
session <- GHC.newSession mode mbMinusB
dflags0 <- GHC.getSessionDynFlags session
......@@ -102,20 +108,17 @@ main =
-- The rest of the arguments are "dynamic"
-- Leftover ones are presumably files
(dflags2, fileish_args) <- GHC.parseDynamicFlags dflags1 argv2
(dflags, fileish_args) <- GHC.parseDynamicFlags dflags1 argv3
-- make sure we clean up after ourselves
GHC.defaultCleanupHandler dflags2 $ do
GHC.defaultCleanupHandler dflags $ do
-- Display banner
showBanner cli_mode dflags2
-- Read the package config(s), and process the package-related
-- command-line flags
dflags <- initPackages dflags2
showBanner cli_mode dflags
-- we've finished manipulating the DynFlags, update the session
GHC.setSessionDynFlags session dflags
dflags <- GHC.getSessionDynFlags session
let
-- To simplify the handling of filepaths, we normalise all filepaths right
......@@ -140,8 +143,8 @@ main =
---------------- Do the business -----------
case cli_mode of
ShowUsage -> showGhcUsage cli_mode
PrintLibdir -> do d <- getTopDir; putStrLn d
ShowUsage -> showGhcUsage dflags cli_mode
PrintLibdir -> putStrLn (topDir dflags)
ShowVersion -> showVersion
ShowNumVersion -> putStrLn cProjectVersion
ShowInterface f -> showIface f
......@@ -421,11 +424,10 @@ showVersion = do
putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
exitWith ExitSuccess
showGhcUsage cli_mode = do
(ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths
showGhcUsage dflags cli_mode = do
let usage_path
| DoInteractive <- cli_mode = ghci_usage_path
| otherwise = ghc_usage_path
| DoInteractive <- cli_mode = ghcUsagePath dflags
| otherwise = ghciUsagePath dflags
usage <- readFile usage_path
dump usage
exitWith ExitSuccess
......
This diff is collapsed.
......@@ -11,10 +11,6 @@ module SysTools (
-- Initialisation
initSysTools,
getTopDir, -- IO String -- The value of $topdir
getPackageConfigPath, -- IO String -- Where package.conf is
getUsageMsgPaths, -- IO (String,String)
-- Interface to system tools
runUnlit, runCpp, runCc, -- [Option] -> IO ()
runPp, -- [Option] -> IO ()
......@@ -35,9 +31,6 @@ module SysTools (
-- System interface
system, -- String -> IO ExitCode
-- Misc
getSysMan, -- IO String Parallel system only
Option(..)
) where
......@@ -168,34 +161,6 @@ stuff.
End of NOTES
---------------------------------------------
%************************************************************************
%* *
\subsection{Global variables to contain system programs}
%* *
%************************************************************************
All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
(See remarks under pathnames below)
\begin{code}
GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String))
GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
-- Parallel system only
GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
-- ways to get at some of these variables from outside this module
getPackageConfigPath = readIORef v_Path_package_config
getTopDir = readIORef v_TopDir
\end{code}
%************************************************************************
%* *
\subsection{Initialisation}
......@@ -214,11 +179,11 @@ initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
initSysTools mbMinusB dflags
= do { (am_installed, top_dir) <- findTopDir mbMinusB
; writeIORef v_TopDir top_dir
-- top_dir
-- for "installed" this is the root of GHC's support files
-- for "in-place" it is the root of the build tree
-- NB: top_dir is assumed to be in standard Unix format '/' separated
-- NB: top_dir is assumed to be in standard Unix
-- format, '/' separated
; let installed, installed_bin :: FilePath -> FilePath
installed_bin pgm = pgmPath top_dir pgm
......@@ -368,19 +333,11 @@ initSysTools mbMinusB dflags
; let (as_prog,as_args) = (gcc_prog,gcc_args)
(ld_prog,ld_args) = (gcc_prog,gcc_args)
-- Initialise the global vars
; writeIORef v_Path_package_config pkgconfig_path
; writeIORef v_Path_usages (ghc_usage_msg_path,
ghci_usage_msg_path)
; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
-- Hans: this isn't right in general, but you can
-- elaborate it in the same way as the others
; writeIORef v_Pgm_T touch_path
; writeIORef v_Pgm_CP cp_path
; return dflags1{
ghcUsagePath = ghc_usage_msg_path,
ghciUsagePath = ghci_usage_msg_path,
topDir = top_dir,
systemPackageConfig = pkgconfig_path,
pgm_L = unlit_path,
pgm_P = cpp_path,
pgm_F = "",
......@@ -389,7 +346,12 @@ initSysTools mbMinusB dflags
pgm_s = (split_prog,split_args),
pgm_a = (as_prog,as_args),
pgm_l = (ld_prog,ld_args),
pgm_dll = (mkdll_prog,mkdll_args) }
pgm_dll = (mkdll_prog,mkdll_args),
pgm_T = touch_path,
pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan"
-- Hans: this isn't right in general, but you can
-- elaborate it in the same way as the others
}
}
#if defined(mingw32_HOST_OS)
......@@ -509,9 +471,8 @@ runMkDLL dflags args = do
runSomething dflags "Make DLL" p (args0++args)
touch :: DynFlags -> String -> String -> IO ()
touch dflags purpose arg = do
p <- readIORef v_Pgm_T
runSomething dflags purpose p [FileOption "" arg]
touch dflags purpose arg =
runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
copy :: DynFlags -> String -> String -> String -> IO ()
copy dflags purpose from to = do
......@@ -522,22 +483,8 @@ copy dflags purpose from to = do
-- ToDo: speed up via slurping.
hPutStr h ls
hClose h
\end{code}
\begin{code}
getSysMan :: IO String -- How to invoke the system manager
-- (parallel system only)
getSysMan = readIORef v_Pgm_sysman
\end{code}
\begin{code}
getUsageMsgPaths :: IO (FilePath,FilePath)
-- the filenames of the usage messages (ghc, ghci)
getUsageMsgPaths = readIORef v_Path_usages
\end{code}
%************************************************************************
%* *
\subsection{Managing temporary files
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment