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.

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 5a54af2..f7ff7ae 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -25,7 +25,8 @@ import NameEnv          ( delListFromNameEnv )
 import TcType           ( tidyTopType )
 import qualified Id     ( setIdType )
 import IdInfo           ( GlobalIdDetails(..) )
 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
 
 import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
 #endif
 

@@ -1198,21 +1199,28 @@ setOptions wds =
 
       -- then, dynamic flags
       dflags <- getDynFlags
 
       -- then, dynamic flags
       dflags <- getDynFlags

+      let pkg_flags = packageFlags dflags

       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
       (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 ()
 
 
       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
 
 unsetOptions :: String -> GHCi ()
 unsetOptions str

@@ -1259,16 +1267,6 @@ optToStr ShowTiming = "s"
 optToStr ShowType   = "t"
 optToStr RevertCAFs = "r"
 
 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'
 
 -- ---------------------------------------------------------------------------
 -- code for `:show'
 

diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 2cbe755..8c6ef62 100644 (file)
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -224,7 +224,7 @@ reallyInitDynLinker dflags
        ; initObjLinker 
 
                -- (b) Load packages from the command-line
        ; 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
 
                -- (c) Link libraries from the command-line
        ; let optl = getOpts dflags opt_l

diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index 30f273e..06e1ee7 100644 (file)
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -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.
        --
        --   * -#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
        let pkg_names = map (showPackageId.package) pkg_configs
 
        c_includes <- getPackageCIncludes pkg_configs

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 58cc49e..d66f147 100644 (file)
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -29,7 +29,7 @@ module DriverPipeline (
 import Packages
 import HeaderInfo
 import DriverPhases
 import Packages
 import HeaderInfo
 import DriverPhases

-import SysTools                ( newTempName, addFilesToClean, getSysMan, copy )
+import SysTools                ( newTempName, addFilesToClean, copy )

 import qualified SysTools      
 import HscMain
 import Finder
 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
 
 -- 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 
   = do 

-        sysMan   <- getSysMan
+        let sysMan = pgm_sysman dflags

         pvm_root <- getEnv "PVM_ROOT"
         pvm_arch <- getEnv "PVM_ARCH"
         let 
         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)
 
     -- 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")))
 
              if success then return ()
                         else throwDyn (InstallationError ("cannot move binary to PVM dir")))
 

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 9f1f532..0a361a4 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -fno-warn-missing-fields #-}

 -----------------------------------------------------------------------------
 --
 -- Dynamic flags
 -----------------------------------------------------------------------------
 --
 -- Dynamic flags

@@ -63,6 +64,7 @@ import Config
 import CmdLineParser
 import Constants       ( mAX_CONTEXT_REDUCTION_DEPTH )
 import Panic           ( panic, GhcException(..) )
 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 )
 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 '/'
   
   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],
   -- 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_a                        :: (String,[Option]),
   pgm_l                        :: (String,[Option]),
   pgm_dll              :: (String,[Option]),

+  pgm_T                 :: String,
+  pgm_sysman            :: String,

 
 

-  --  ** Package flags
+  --  Package flags

   extraPkgConfs                :: [FilePath],
   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
 
        -- 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
   pkgState             :: PackageState,
 
   -- hsc dynamic flags

@@ -322,6 +334,7 @@ data PackageFlag
   = ExposePackage  String
   | HidePackage    String
   | IgnorePackage  String
   = ExposePackage  String
   | HidePackage    String
   | IgnorePackage  String

+  deriving Eq

 
 defaultHscTarget
   | cGhcWithNativeCodeGen == "YES"     =  HscAsm
 
 defaultHscTarget
   | cGhcWithNativeCodeGen == "YES"     =  HscAsm

@@ -359,10 +372,6 @@ defaultDynFlags =
        ctxtStkDepth            = mAX_CONTEXT_REDUCTION_DEPTH,
 
        thisPackage             = mainPackageId,
        ctxtStkDepth            = mAX_CONTEXT_REDUCTION_DEPTH,
 
        thisPackage             = mainPackageId,

-       
-       wayNames                = panic "ways",
-       buildTag                = panic "buildTag",
-       rtsBuildTag             = panic "rtsBuildTag",

 
        objectDir               = Nothing,
        hiDir                   = Nothing,
 
        objectDir               = Nothing,
        hiDir                   = Nothing,

@@ -390,19 +399,10 @@ defaultDynFlags =
        opt_dll                 = [],
        opt_dep                 = [],
        
        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            = [],
        extraPkgConfs           = [],
        packageFlags            = [],

-       pkgState                = panic "pkgState",
+        pkgDatabase             = Nothing,
+        pkgState                = panic "no package state yet: call GHC.setSessionDynFlags",

        
        flags = [ 
            Opt_RecompChecking,
        
        flags = [ 
            Opt_RecompChecking,

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 5e75793..be47c76 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -11,13 +11,11 @@ module GHC (
        Session,
        defaultErrorHandler,
        defaultCleanupHandler,
        Session,
        defaultErrorHandler,
        defaultCleanupHandler,

-       init, initFromArgs,

        newSession,
 
        -- * Flags and settings
        DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
        parseDynamicFlags,
        newSession,
 
        -- * Flags and settings
        DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
        parseDynamicFlags,

-       initPackages,

        getSessionDynFlags,
        setSessionDynFlags,
 
        getSessionDynFlags,
        setSessionDynFlags,
 

@@ -166,8 +164,6 @@ module GHC (
  ToDo:
 
   * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
  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?
 -}
 
   * what StaticFlags should we expose, if any?
 -}
 

@@ -322,46 +318,19 @@ defaultCleanupHandler dflags inner =
     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".
 -- | 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)
   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)
 
 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.
 
 -- | If there is no -o option, guess the name of target executable
 -- by using top-level source file name as a base.

diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs
index ec5a116..971eb35 100644 (file)
--- a/compiler/main/Main.hs
+++ b/compiler/main/Main.hs
@@ -21,7 +21,6 @@ import CmdLineParser
 import MkIface         ( showIface )
 import DriverPipeline  ( oneShot, compileFile )
 import DriverMkDepend  ( doMkDependHS )
 import MkIface         ( showIface )
 import DriverPipeline  ( oneShot, compileFile )
 import DriverMkDepend  ( doMkDependHS )

-import SysTools                ( getTopDir, getUsageMsgPaths )

 #ifdef GHCI
 import InteractiveUI   ( ghciWelcomeMsg, interactiveUI )
 #endif
 #ifdef GHCI
 import InteractiveUI   ( ghciWelcomeMsg, interactiveUI )
 #endif

@@ -64,11 +63,18 @@ import Maybe
 main =
   GHC.defaultErrorHandler defaultDynFlags $ do
   
 main =
   GHC.defaultErrorHandler defaultDynFlags $ do
   

+  -- 1. extract the -B flag from the args

   argv0 <- getArgs
   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.)
 
   -- 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
 
   let mode = case cli_mode of
                DoInteractive   -> Interactive

@@ -78,7 +84,7 @@ main =
                _               -> OneShot
 
   -- start our GHC session
                _               -> OneShot
 
   -- start our GHC session

-  session <- GHC.newSession mode
+  session <- GHC.newSession mode mbMinusB

 
   dflags0 <- GHC.getSessionDynFlags session
 
 
   dflags0 <- GHC.getSessionDynFlags session
 

@@ -102,20 +108,17 @@ main =
 
        -- The rest of the arguments are "dynamic"
        -- Leftover ones are presumably files
 
        -- 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
 
        -- make sure we clean up after ourselves

-  GHC.defaultCleanupHandler dflags2 $ do
+  GHC.defaultCleanupHandler dflags $ do

 
        -- Display banner
 
        -- 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
 
   -- 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 
 
   let
      -- To simplify the handling of filepaths, we normalise all filepaths right 

@@ -140,8 +143,8 @@ main =
 
        ---------------- Do the business -----------
   case cli_mode of
 
        ---------------- 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
        ShowVersion     -> showVersion
         ShowNumVersion  -> putStrLn cProjectVersion
         ShowInterface f -> showIface f

@@ -421,11 +424,10 @@ showVersion = do
   putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
   exitWith ExitSuccess
 
   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 
   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
   usage <- readFile usage_path
   dump usage
   exitWith ExitSuccess

diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 7458659..bbaf846 100644 (file)
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -1,8 +1,8 @@
+ %
+% (c) The University of Glasgow, 2006

 %
 %

-% (c) The University of Glasgow, 2000
+% Package manipulation

 %
 %

-\section{Package manipulation}
-

 \begin{code}
 module Packages (
        module PackageConfig,
 \begin{code}
 module Packages (
        module PackageConfig,

@@ -25,7 +25,7 @@ module Packages (
        getPackageExtraCcOpts,
        getPackageFrameworkPath,
        getPackageFrameworks,
        getPackageExtraCcOpts,
        getPackageFrameworkPath,
        getPackageFrameworks,

-       getExplicitPackagesAnd,
+       getPreloadPackagesAnd,

 
        -- * Utils
        isDllName
 
        -- * Utils
        isDllName

@@ -35,7 +35,6 @@ where
 #include "HsVersions.h"
 
 import PackageConfig   
 #include "HsVersions.h"
 
 import PackageConfig   

-import SysTools                ( getTopDir, getPackageConfigPath )

 import ParsePkgConf    ( loadPackageConfig )
 import DynFlags                ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) )
 import StaticFlags     ( opt_Static )
 import ParsePkgConf    ( loadPackageConfig )
 import DynFlags                ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) )
 import StaticFlags     ( opt_Static )

@@ -86,7 +85,7 @@ import ErrUtils         ( debugTraceMsg, putMsg, Message )
 --     Let depExposedPackages be the transitive closure from exposedPackages of
 --     their dependencies.
 --
 --     Let depExposedPackages be the transitive closure from exposedPackages of
 --     their dependencies.
 --

---   * When searching for a module from an explicit import declaration,
+--   * When searching for a module from an preload import declaration,

 --     only the exposed modules in exposedPackages are valid.
 --
 --   * When searching for a module from an implicit import, all modules
 --     only the exposed modules in exposedPackages are valid.
 --
 --   * When searching for a module from an implicit import, all modules

@@ -95,7 +94,7 @@ import ErrUtils         ( debugTraceMsg, putMsg, Message )
 --   * When linking in a comp manager mode, we link in packages the
 --     program depends on (the compiler knows this list by the
 --     time it gets to the link step).  Also, we link in all packages
 --   * When linking in a comp manager mode, we link in packages the
 --     program depends on (the compiler knows this list by the
 --     time it gets to the link step).  Also, we link in all packages

---     which were mentioned with explicit -package flags on the command-line,
+--     which were mentioned with preload -package flags on the command-line,

 --     or are a transitive dependency of same, or are "base"/"rts".
 --     The reason for (b) is that we might need packages which don't
 --     contain any Haskell modules, and therefore won't be discovered
 --     or are a transitive dependency of same, or are "base"/"rts".
 --     The reason for (b) is that we might need packages which don't
 --     contain any Haskell modules, and therefore won't be discovered

@@ -111,20 +110,18 @@ import ErrUtils         ( debugTraceMsg, putMsg, Message )
 -- in a different DLL, by setting the DLL flag.
 
 data PackageState = PackageState {
 -- in a different DLL, by setting the DLL flag.
 
 data PackageState = PackageState {

-
-  explicitPackages      :: [PackageId],
-       -- The packages we're going to link in eagerly.  This list
-       -- should be in reverse dependency order; that is, a package
-       -- is always mentioned before the packages it depends on.
-
-  origPkgIdMap         :: PackageConfigMap, -- PackageId   -> PackageConfig
-       -- the full package database
+  origPkgIdMap         :: PackageConfigMap, -- PackageId   -> PackageConfig
+        -- The on-disk package database

 
   pkgIdMap             :: PackageConfigMap, -- PackageId   -> PackageConfig
 
   pkgIdMap             :: PackageConfigMap, -- PackageId   -> PackageConfig

-       -- Derived from origPkgIdMap.

        -- The exposed flags are adjusted according to -package and
        -- -hide-package flags, and -ignore-package removes packages.
 
        -- The exposed flags are adjusted according to -package and
        -- -hide-package flags, and -ignore-package removes packages.
 

+  preloadPackages      :: [PackageId],
+       -- The packages we're going to link in eagerly.  This list
+       -- should be in reverse dependency order; that is, a package
+       -- is always mentioned before the packages it depends on.
+

   moduleToPkgConfAll   :: UniqFM [(PackageConfig,Bool)] -- ModuleEnv mapping
        -- Derived from pkgIdMap.       
        -- Maps Module to (pkgconf,exposed), where pkgconf is the
   moduleToPkgConfAll   :: UniqFM [(PackageConfig,Bool)] -- ModuleEnv mapping
        -- Derived from pkgIdMap.       
        -- Maps Module to (pkgconf,exposed), where pkgconf is the

@@ -153,14 +150,29 @@ getPackageDetails dflags ps = expectJust "getPackageDetails" (lookupPackage (pkg
 -- ----------------------------------------------------------------------------
 -- Loading the package config files and building up the package state
 
 -- ----------------------------------------------------------------------------
 -- Loading the package config files and building up the package state
 

--- | Call this after parsing the DynFlags.  It reads the package
+-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package

 -- configuration files, and sets up various internal tables of package
 -- information, according to the package-related flags on the
 -- command-line (@-package@, @-hide-package@ etc.)
 -- configuration files, and sets up various internal tables of package
 -- information, according to the package-related flags on the
 -- command-line (@-package@, @-hide-package@ etc.)

-initPackages :: DynFlags -> IO DynFlags
+--
+-- Returns a list of packages to link in if we're doing dynamic linking.
+-- This list contains the packages that the user explicitly mentioned with
+-- -package flags.
+--
+-- 'initPackages' can be called again subsequently after updating the
+-- 'packageFlags' field of the 'DynFlags', and it will update the
+-- 'packageState' in 'DynFlags' and return a list of packages to
+-- link in.
+initPackages :: DynFlags -> IO (DynFlags, [PackageId])

 initPackages dflags = do 
 initPackages dflags = do 

-  pkg_map <- readPackageConfigs dflags; 
-  mkPackageState dflags pkg_map
+  pkg_db <- case pkgDatabase dflags of
+                Nothing -> readPackageConfigs dflags
+                Just db -> return db
+  (pkg_state, preload, this_pkg)       
+        <- mkPackageState dflags pkg_db [] (thisPackage dflags)
+  return (dflags{ pkgState = pkg_state,
+                  thisPackage = this_pkg },
+          preload)

 
 -- -----------------------------------------------------------------------------
 -- Reading the package database(s)
 
 -- -----------------------------------------------------------------------------
 -- Reading the package database(s)

@@ -189,7 +201,7 @@ readPackageConfigs dflags = do
 getSystemPackageConfigs :: DynFlags -> IO [FilePath]
 getSystemPackageConfigs dflags = do
        -- System one always comes first
 getSystemPackageConfigs :: DynFlags -> IO [FilePath]
 getSystemPackageConfigs dflags = do
        -- System one always comes first

-   system_pkgconf <- getPackageConfigPath
+   let system_pkgconf = systemPackageConfig dflags

 
        -- allow package.conf.d to contain a bunch of .conf files
        -- containing package specifications.  This is an easier way
 
        -- allow package.conf.d to contain a bunch of .conf files
        -- containing package specifications.  This is an easier way

@@ -229,8 +241,8 @@ readPackageConfig
 readPackageConfig dflags pkg_map conf_file = do
   debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
   proto_pkg_configs <- loadPackageConfig conf_file
 readPackageConfig dflags pkg_map conf_file = do
   debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
   proto_pkg_configs <- loadPackageConfig conf_file

-  top_dir          <- getTopDir
-  let pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
+  let top_dir = topDir dflags
+      pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs

       pkg_configs2 = maybeHidePackages dflags pkg_configs1
   return (extendPackageConfigMap pkg_map pkg_configs2)
 
       pkg_configs2 = maybeHidePackages dflags pkg_configs1
   return (extendPackageConfigMap pkg_map pkg_configs2)
 

@@ -259,91 +271,105 @@ mungePackagePaths top_dir ps = map munge_pkg ps
 
 
 -- -----------------------------------------------------------------------------
 
 
 -- -----------------------------------------------------------------------------

--- When all the command-line options are in, we can process our package
--- settings and populate the package state.
-
-mkPackageState :: DynFlags -> PackageConfigMap -> IO DynFlags
-mkPackageState dflags orig_pkg_db = do
-  --
-  -- Modify the package database according to the command-line flags
-  -- (-package, -hide-package, -ignore-package, -hide-all-packages).
-  --
-  -- Also, here we build up a set of the packages mentioned in -package
-  -- flags on the command line; these are called the "explicit" packages.
-  -- we link these packages in eagerly.  The explicit set should contain
-  -- at least rts & base, which is why we pretend that the command line
-  -- contains -package rts & -package base.
-  --
-  let
-       flags = reverse (packageFlags dflags)
-
-       procflags pkgs expl [] = return (pkgs,expl)
-       procflags pkgs expl (ExposePackage str : flags) = do
-          case pick str pkgs of
+-- Modify our copy of the package database based on a package flag
+-- (-package, -hide-package, -ignore-package).
+
+applyPackageFlag
+   :: [PackageConfig]           -- Initial database
+   -> PackageFlag               -- flag to apply
+   -> IO [PackageConfig]        -- new database
+
+applyPackageFlag pkgs flag = 
+  case flag of
+        ExposePackage str ->
+          case matchingPackages str pkgs of

                Nothing -> missingPackageErr str
                Nothing -> missingPackageErr str

-               Just (p,ps) -> procflags (p':ps') expl' flags
+               Just (p:ps,qs) -> return (p':ps')

                  where p' = p {exposed=True}
                  where p' = p {exposed=True}

-                       ps' = hideAll (pkgName (package p)) ps
-                       expl' = package p : expl
-       procflags pkgs expl (HidePackage str : flags) = do
-          case partition (matches str) pkgs of
-               ([],_)   -> missingPackageErr str
-               (ps,qs) -> procflags (map hide ps ++ qs) expl flags
+                       ps' = hideAll (pkgName (package p)) (ps++qs)
+
+       HidePackage str ->
+           case matchingPackages str pkgs of
+                Nothing -> missingPackageErr str
+                Just (ps,qs) -> return (map hide ps ++ qs)

                  where hide p = p {exposed=False}
                  where hide p = p {exposed=False}

-       procflags pkgs expl (IgnorePackage str : flags) = do
-          case partition (matches str) pkgs of
-               (ps,qs) -> procflags qs expl flags
+
+       IgnorePackage str ->
+           case matchingPackages str pkgs of
+                Nothing -> return pkgs
+                Just (ps,qs) -> return qs

                -- missing package is not an error for -ignore-package,
                -- because a common usage is to -ignore-package P as
                -- a preventative measure just in case P exists.
                -- missing package is not an error for -ignore-package,
                -- because a common usage is to -ignore-package P as
                -- a preventative measure just in case P exists.

+   where
+       -- When a package is requested to be exposed, we hide all other
+       -- packages with the same name.
+       hideAll name ps = map maybe_hide ps
+         where maybe_hide p | pkgName (package p) == name = p {exposed=False}
+                            | otherwise                   = p

 
 

-       pick str pkgs
-         = case partition (matches str) pkgs of
-               ([],_) -> Nothing
-               (ps,rest) -> 
-                  case sortByVersion ps of
-                       (p:ps) -> Just (p, ps ++ rest)
-                       _ -> panic "Packages.pick"
-
-        sortByVersion = sortBy (flip (comparing (pkgVersion.package)))
-        comparing f a b = f a `compare` f b

 
 

-       -- A package named on the command line can either include the
+matchingPackages :: String -> [PackageConfig]
+         -> Maybe ([PackageConfig], [PackageConfig])
+matchingPackages str pkgs
+  = case partition (matches str) pkgs of
+       ([],_)    -> Nothing
+       (ps,rest) -> Just (sortByVersion ps, rest)
+  where
+        -- A package named on the command line can either include the

        -- version, or just the name if it is unambiguous.
        matches str p
                =  str == showPackageId (package p)
                || str == pkgName (package p)
 
        -- version, or just the name if it is unambiguous.
        matches str p
                =  str == showPackageId (package p)
                || str == pkgName (package p)
 

-       -- When a package is requested to be exposed, we hide all other
-       -- packages with the same name.
-       hideAll name ps = map maybe_hide ps
-         where maybe_hide p | pkgName (package p) == name = p {exposed=False}
-                            | otherwise                   = p
-  --
-  (pkgs1,explicit) <- procflags (eltsUFM orig_pkg_db) [] flags
-  --
-  -- hide all packages for which there is also a later version
-  -- that is already exposed.  This just makes it non-fatal to have two
-  -- versions of a package exposed, which can happen if you install a
-  -- later version of a package in the user database, for example.
-  --
-  let maybe_hide p
+
+pickPackages pkgs strs = 
+  [ p | p <- strs, Just (p:ps,_) <- [matchingPackages p pkgs] ]
+
+sortByVersion = sortBy (flip (comparing (pkgVersion.package)))
+comparing f a b = f a `compare` f b
+
+-- -----------------------------------------------------------------------------
+-- Hide old versions of packages
+
+--
+-- hide all packages for which there is also a later version
+-- that is already exposed.  This just makes it non-fatal to have two
+-- versions of a package exposed, which can happen if you install a
+-- later version of a package in the user database, for example.
+--
+hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig]
+hideOldPackages dflags pkgs = mapM maybe_hide pkgs
+  where maybe_hide p

           | not (exposed p) = return p
           | (p' : _) <- later_versions = do
                debugTraceMsg dflags 2 $
           | not (exposed p) = return p
           | (p' : _) <- later_versions = do
                debugTraceMsg dflags 2 $

-                  (ptext SLIT("hiding package") <+> text (showPackageId (package p)) <+>
+                  (ptext SLIT("hiding package") <+> 
+                    text (showPackageId (package p)) <+>

                    ptext SLIT("to avoid conflict with later version") <+>
                    text (showPackageId (package p')))
                return (p {exposed=False})
           | otherwise = return p
          where myname = pkgName (package p)
                myversion = pkgVersion (package p)
                    ptext SLIT("to avoid conflict with later version") <+>
                    text (showPackageId (package p')))
                return (p {exposed=False})
           | otherwise = return p
          where myname = pkgName (package p)
                myversion = pkgVersion (package p)

-               later_versions = [ p | p <- pkgs1, exposed p,
+               later_versions = [ p | p <- pkgs, exposed p,

                                    let pkg = package p,
                                    pkgName pkg == myname,
                                    pkgVersion pkg > myversion ]
 
                                    let pkg = package p,
                                    pkgName pkg == myname,
                                    pkgVersion pkg > myversion ]
 

-  pkgs2 <- mapM maybe_hide pkgs1
+-- -----------------------------------------------------------------------------
+-- Wired-in packages
+
+findWiredInPackages
+   :: DynFlags
+   -> [PackageConfig]           -- database
+   -> [PackageIdentifier]       -- preload packages
+   -> PackageId                -- this package
+   -> IO ([PackageConfig],
+          [PackageIdentifier],
+          PackageId)
+
+findWiredInPackages dflags pkgs preload this_package = do

   --
   -- Now we must find our wired-in packages, and rename them to
   -- their canonical names (eg. base-1.0 ==> base).
   --
   -- Now we must find our wired-in packages, and rename them to
   -- their canonical names (eg. base-1.0 ==> base).

@@ -391,7 +417,7 @@ mkPackageState dflags orig_pkg_db = do
                        return (Just (package pkg))
 
 
                        return (Just (package pkg))
 
 

-  mb_wired_in_ids <- mapM (findWiredInPackage pkgs2) wired_in_names
+  mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_names

   let 
         wired_in_ids = catMaybes mb_wired_in_ids
 
   let 
         wired_in_ids = catMaybes mb_wired_in_ids
 

@@ -407,79 +433,122 @@ mkPackageState dflags orig_pkg_db = do
                                [] -> pid
                                (x:_) -> x{ pkgVersion = Version [] [] }
 
                                [] -> pid
                                (x:_) -> x{ pkgVersion = Version [] [] }
 

-        pkgs3 = deleteOtherWiredInPackages pkgs2
+        pkgs1 = deleteOtherWiredInPackages pkgs

 
 

-        pkgs4 = updateWiredInDependencies pkgs3
+        pkgs2 = updateWiredInDependencies pkgs1

 
 

-        explicit1 = map upd_pid explicit
+        preload1 = map upd_pid preload

 
         -- we must return an updated thisPackage, just in case we
         -- are actually compiling one of the wired-in packages
 
         -- we must return an updated thisPackage, just in case we
         -- are actually compiling one of the wired-in packages

-        Just old_this_pkg = unpackPackageId (thisPackage dflags)
+        Just old_this_pkg = unpackPackageId this_package

         new_this_pkg = mkPackageId (upd_pid old_this_pkg)
 
         new_this_pkg = mkPackageId (upd_pid old_this_pkg)
 

-  --
-  -- Eliminate any packages which have dangling dependencies (perhaps
-  -- because the package was removed by -ignore-package).
-  --
-  let
-       elimDanglingDeps pkgs = 
-          case partition (not.null.snd) (map (getDanglingDeps pkgs) pkgs) of
-             ([],ps) -> return (map fst ps)
-             (ps,qs) -> do
-                mapM_ reportElim ps
-                elimDanglingDeps (map fst qs)
-
-       reportElim (p, deps) = 
-               debugTraceMsg dflags 2 $
-                  (ptext SLIT("package") <+> pprPkg p <+> 
-                       ptext SLIT("will be ignored due to missing dependencies:") $$ 
-                   nest 2 (hsep (map (text.showPackageId) deps)))
+  return (pkgs2, preload1, new_this_pkg)
+
+-- -----------------------------------------------------------------------------
+--
+-- Eliminate any packages which have dangling dependencies (
+-- because the dependency was removed by -ignore-package).
+--
+elimDanglingDeps
+   :: DynFlags
+   -> [PackageConfig]
+   -> [PackageId]       -- ignored packages
+   -> IO [PackageConfig]
+
+elimDanglingDeps dflags pkgs ignored = 
+   case partition (not.null.snd) (map (getDanglingDeps pkgs ignored) pkgs) of
+        ([],ps) -> return (map fst ps)
+        (ps,qs) -> do
+            mapM_ reportElim ps
+            elimDanglingDeps dflags (map fst qs)
+                (ignored ++ map packageConfigId (map fst ps))
+ where
+   reportElim (p, deps) = 
+        debugTraceMsg dflags 2 $
+             (ptext SLIT("package") <+> pprPkg p <+> 
+                  ptext SLIT("will be ignored due to missing dependencies:") $$ 
+             nest 2 (hsep (map (text.showPackageId) deps)))
+
+   getDanglingDeps pkgs ignored p = (p, filter dangling (depends p))
+        where dangling pid = mkPackageId pid `elem` ignored
+
+-- -----------------------------------------------------------------------------
+-- When all the command-line options are in, we can process our package
+-- settings and populate the package state.
+
+mkPackageState
+    :: DynFlags
+    -> PackageConfigMap         -- initial database
+    -> [PackageId]              -- preloaded packages
+    -> PackageId                -- this package
+    -> IO (PackageState,
+           [PackageId],         -- new packages to preload
+           PackageId) -- this package, might be modified if the current

 
 

-       getDanglingDeps pkgs p = (p, filter dangling (depends p))
-         where dangling pid = pid `notElem` all_pids
-               all_pids = map package pkgs
+                      -- package is a wired-in package.
+
+mkPackageState dflags orig_pkg_db preload0 this_package = do

   --
   --

-  pkgs <- elimDanglingDeps pkgs4
-  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
+  -- Modify the package database according to the command-line flags
+  -- (-package, -hide-package, -ignore-package, -hide-all-packages).

   --
   --

-  -- Find the transitive closure of dependencies of exposed
+  let flags = reverse (packageFlags dflags)
+  let pkgs0 = eltsUFM orig_pkg_db
+  pkgs1 <- foldM applyPackageFlag pkgs0 flags
+
+  -- Here we build up a set of the packages mentioned in -package
+  -- flags on the command line; these are called the "preload"
+  -- packages.  we link these packages in eagerly.  The preload set
+  -- should contain at least rts & base, which is why we pretend that
+  -- the command line contains -package rts & -package base.

   --
   --

-  let exposed_pkgids = [ packageConfigId p | p <- pkgs, exposed p ]
-  dep_exposed <- closeDeps pkg_db exposed_pkgids
-  let
-       -- add base & rts to the explicit packages
-       basicLinkedPackages = filter (flip elemUFM pkg_db)
+  let new_preload_packages = 
+        map package (pickPackages pkgs0 [ p | ExposePackage p <- flags ])
+
+  -- hide packages that are subsumed by later versions
+  pkgs2 <- hideOldPackages dflags pkgs1
+
+  -- sort out which packages are wired in
+  (pkgs3, preload1, new_this_pkg)
+        <- findWiredInPackages dflags pkgs2 new_preload_packages this_package
+
+  let ignored = map packageConfigId $
+                   pickPackages pkgs0 [ p | IgnorePackage p <- flags ]
+  pkgs <- elimDanglingDeps dflags pkgs3 ignored
+
+  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
+      pkgids = map packageConfigId pkgs
+
+      -- add base & rts to the preload packages
+      basicLinkedPackages = filter (flip elemUFM pkg_db)

                                 [basePackageId,rtsPackageId]
                                 [basePackageId,rtsPackageId]

-       explicit2 = addListToUniqSet (mkUniqSet (map mkPackageId explicit1))
-                                     basicLinkedPackages
-  --
-  -- Close the explicit packages with their dependencies
-  --
-  dep_explicit <- closeDeps pkg_db (uniqSetToList explicit2)
-  --
-  -- Build up a mapping from Module -> PackageConfig for all modules.
-  -- Discover any conflicts at the same time, and factor in the new exposed
-  -- status of each package.
-  --
-  let mod_map = mkModuleMap pkg_db dep_exposed
+      preload2 = nub (basicLinkedPackages ++ map mkPackageId preload1)

 
 

-      pstate = PackageState{ explicitPackages     = dep_explicit,
-                            origPkgIdMap           = orig_pkg_db,
-                            pkgIdMap               = pkg_db,
-                            moduleToPkgConfAll   = mod_map
+  -- Close the preload packages with their dependencies
+  dep_preload <- closeDeps pkg_db (zip preload2 (repeat Nothing))
+  let new_dep_preload = filter (`notElem` preload0) dep_preload
+
+  let pstate = PackageState{ preloadPackages     = dep_preload,
+                             origPkgIdMap        = orig_pkg_db,
+                            pkgIdMap            = pkg_db,
+                            moduleToPkgConfAll  = mkModuleMap pkg_db

                           }
 
                           }
 

-  return dflags{ pkgState = pstate, thisPackage = new_this_pkg }
-  -- done!
+  return (pstate, new_dep_preload, new_this_pkg)
+

 
 

+-- -----------------------------------------------------------------------------
+-- Make the mapping from module to package info

 
 mkModuleMap
   :: PackageConfigMap
 
 mkModuleMap
   :: PackageConfigMap

-  -> [PackageId]

   -> UniqFM [(PackageConfig, Bool)]
   -> UniqFM [(PackageConfig, Bool)]

-mkModuleMap pkg_db pkgs = foldr extend_modmap emptyUFM pkgs
+mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids

   where
   where

+        pkgids = map packageConfigId (eltsUFM pkg_db)
+        

        extend_modmap pkgid modmap =
                addListToUFM_C (++) modmap 
                    [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods]
        extend_modmap pkgid modmap =
                addListToUFM_C (++) modmap 
                    [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods]

@@ -500,12 +569,12 @@ pprPkg p = text (showPackageId (package p))
 -- 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
 -- 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 explicit (command-line) packages to determine which packages to
+-- of preload (command-line) packages to determine which packages to

 -- use.
 
 getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String]
 getPackageIncludePath dflags pkgs = do
 -- use.
 
 getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String]
 getPackageIncludePath dflags pkgs = do

-  ps <- getExplicitPackagesAnd dflags pkgs
+  ps <- getPreloadPackagesAnd dflags pkgs

   return (nub (filter notNull (concatMap includeDirs ps)))
 
        -- includes are in reverse dependency order (i.e. rts first)
   return (nub (filter notNull (concatMap includeDirs ps)))
 
        -- includes are in reverse dependency order (i.e. rts first)

@@ -515,12 +584,12 @@ getPackageCIncludes pkg_configs = do
 
 getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
 getPackageLibraryPath dflags pkgs = do 
 
 getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
 getPackageLibraryPath dflags pkgs = do 

-  ps <- getExplicitPackagesAnd dflags pkgs
+  ps <- getPreloadPackagesAnd dflags pkgs

   return (nub (filter notNull (concatMap libraryDirs ps)))
 
 getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String]
 getPackageLinkOpts dflags pkgs = do
   return (nub (filter notNull (concatMap libraryDirs ps)))
 
 getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String]
 getPackageLinkOpts dflags pkgs = do

-  ps <- getExplicitPackagesAnd dflags pkgs
+  ps <- getPreloadPackagesAnd dflags pkgs

   let tag = buildTag dflags
       rts_tag = rtsBuildTag dflags
   let 
   let tag = buildTag dflags
       rts_tag = rtsBuildTag dflags
   let 

@@ -549,17 +618,17 @@ getPackageLinkOpts dflags pkgs = do
 
 getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
 getPackageExtraCcOpts dflags pkgs = do
 
 getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
 getPackageExtraCcOpts dflags pkgs = do

-  ps <- getExplicitPackagesAnd dflags pkgs
+  ps <- getPreloadPackagesAnd dflags pkgs

   return (concatMap ccOptions ps)
 
 getPackageFrameworkPath  :: DynFlags -> [PackageId] -> IO [String]
 getPackageFrameworkPath dflags pkgs = do
   return (concatMap ccOptions ps)
 
 getPackageFrameworkPath  :: DynFlags -> [PackageId] -> IO [String]
 getPackageFrameworkPath dflags pkgs = do

-  ps <- getExplicitPackagesAnd dflags pkgs
+  ps <- getPreloadPackagesAnd dflags pkgs

   return (nub (filter notNull (concatMap frameworkDirs ps)))
 
 getPackageFrameworks  :: DynFlags -> [PackageId] -> IO [String]
 getPackageFrameworks dflags pkgs = do
   return (nub (filter notNull (concatMap frameworkDirs ps)))
 
 getPackageFrameworks  :: DynFlags -> [PackageId] -> IO [String]
 getPackageFrameworks dflags pkgs = do

-  ps <- getExplicitPackagesAnd dflags pkgs
+  ps <- getPreloadPackagesAnd dflags pkgs

   return (concatMap frameworks ps)
 
 -- -----------------------------------------------------------------------------
   return (concatMap frameworks ps)
 
 -- -----------------------------------------------------------------------------

@@ -574,19 +643,21 @@ lookupModuleInAllPackages dflags m =
        Nothing -> []
        Just ps -> ps
 
        Nothing -> []
        Just ps -> ps
 

-getExplicitPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig]
-getExplicitPackagesAnd dflags pkgids =
+getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig]
+getPreloadPackagesAnd dflags pkgids =

   let 
       state   = pkgState dflags
       pkg_map = pkgIdMap state
   let 
       state   = pkgState dflags
       pkg_map = pkgIdMap state

-      expl    = explicitPackages state
+      preload = preloadPackages state
+      pairs = zip pkgids (repeat Nothing)

   in do
   in do

-  all_pkgs <- throwErr (foldM (add_package pkg_map) expl pkgids)
+  all_pkgs <- throwErr (foldM (add_package pkg_map) preload pairs)

   return (map (getPackageDetails state) all_pkgs)
 
 -- Takes a list of packages, and returns the list with dependencies included,
 -- in reverse dependency order (a package appears before those it depends on).
   return (map (getPackageDetails state) all_pkgs)
 
 -- Takes a list of packages, and returns the list with dependencies included,
 -- in reverse dependency order (a package appears before those it depends on).

-closeDeps :: PackageConfigMap -> [PackageId] -> IO [PackageId]
+closeDeps :: PackageConfigMap -> [(PackageId, Maybe PackageId)]
+        -> IO [PackageId]

 closeDeps pkg_map ps = throwErr (closeDepsErr pkg_map ps)
 
 throwErr :: MaybeErr Message a -> IO a
 closeDeps pkg_map ps = throwErr (closeDepsErr pkg_map ps)
 
 throwErr :: MaybeErr Message a -> IO a

@@ -594,27 +665,32 @@ throwErr m = case m of
                Failed e    -> throwDyn (CmdLineError (showSDoc e))
                Succeeded r -> return r
 
                Failed e    -> throwDyn (CmdLineError (showSDoc e))
                Succeeded r -> return r
 

-closeDepsErr :: PackageConfigMap -> [PackageId]
+closeDepsErr :: PackageConfigMap -> [(PackageId,Maybe PackageId)]

        -> MaybeErr Message [PackageId]
 closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
 
 -- internal helper
        -> MaybeErr Message [PackageId]
 closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
 
 -- internal helper

-add_package :: PackageConfigMap -> [PackageId] -> PackageId 
+add_package :: PackageConfigMap -> [PackageId] -> (PackageId,Maybe PackageId)

        -> MaybeErr Message [PackageId]
        -> MaybeErr Message [PackageId]

-add_package pkg_db ps p
+add_package pkg_db ps (p, mb_parent)

   | p `elem` ps = return ps    -- Check if we've already added this package
   | otherwise =
       case lookupPackage pkg_db p of
   | p `elem` ps = return ps    -- Check if we've already added this package
   | otherwise =
       case lookupPackage pkg_db p of

-        Nothing -> Failed (missingPackageMsg (packageIdString p))
+        Nothing -> Failed (missingPackageMsg (packageIdString p) <> 
+                           missingDependencyMsg mb_parent)

         Just pkg -> do
           -- Add the package's dependents also
           let deps = map mkPackageId (depends pkg)
         Just pkg -> do
           -- Add the package's dependents also
           let deps = map mkPackageId (depends pkg)

-          ps' <- foldM (add_package pkg_db) ps deps
+          ps' <- foldM (add_package pkg_db) ps (zip deps (repeat (Just p)))

           return (p : ps')
 
 missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p)))
 missingPackageMsg p = ptext SLIT("unknown package:") <+> text p
 
           return (p : ps')
 
 missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p)))
 missingPackageMsg p = ptext SLIT("unknown package:") <+> text p
 

+missingDependencyMsg Nothing = empty
+missingDependencyMsg (Just parent)
+  = space <> parens (ptext SLIT("dependency of") <+> ftext (packageIdFS parent))
+

 -- -----------------------------------------------------------------------------
 
 isDllName :: PackageId -> Name -> Bool
 -- -----------------------------------------------------------------------------
 
 isDllName :: PackageId -> Name -> Bool

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index fb9cf37..594407e 100644 (file)
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -11,10 +11,6 @@ module SysTools (
        -- Initialisation
        initSysTools,
 
        -- 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 ()
        -- Interface to system tools
        runUnlit, runCpp, runCc, -- [Option] -> IO ()
        runPp,                   -- [Option] -> IO ()

@@ -35,9 +31,6 @@ module SysTools (
        -- System interface
        system,                 -- String -> IO ExitCode
 
        -- System interface
        system,                 -- String -> IO ExitCode
 

-       -- Misc
-       getSysMan,              -- IO String    Parallel system only
-       

        Option(..)
 
  ) where
        Option(..)
 
  ) where

@@ -168,34 +161,6 @@ stuff.
                End of NOTES
 ---------------------------------------------
 
                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}
 %************************************************************************
 %*                                                                     *
 \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
 
 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
                -- 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
 
        ; 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)
 
        ; 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{
        ; 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   = "",
                        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_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)
        }
 
 #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 ()
   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
 
 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
                      -- ToDo: speed up via slurping.
   hPutStr h ls
   hClose h

-

 \end{code}
 
 \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
 %************************************************************************
 %*                                                                     *
 \subsection{Managing temporary files