summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/compMan/CompManager.lhs6
-rw-r--r--ghc/compiler/ghci/Linker.lhs7
-rw-r--r--ghc/compiler/main/CodeOutput.lhs89
-rw-r--r--ghc/compiler/main/DriverPipeline.hs170
-rw-r--r--ghc/compiler/main/DriverState.hs175
-rw-r--r--ghc/compiler/main/Finder.lhs4
-rw-r--r--ghc/compiler/main/HscMain.lhs7
-rw-r--r--ghc/compiler/main/Main.hs29
-rw-r--r--ghc/compiler/main/Packages.lhs83
-rw-r--r--ghc/compiler/main/ParsePkgConf.y11
-rw-r--r--ghc/utils/ghc-pkg/Package.hs5
-rw-r--r--ghc/utils/ghc-pkg/ParsePkgConfLite.y10
12 files changed, 310 insertions, 286 deletions
diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 517b82480c..044b1d0c95 100644
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -571,7 +571,7 @@ cmLoadModules cmstate1 dflags mg2unsorted
valid_old_linkables
when (verb >= 2) $
- putStrLn (showSDoc (text "Stable modules:"
+ hPutStrLn stderr (showSDoc (text "Stable modules:"
<+> sep (map (text.moduleNameUserString) stable_mods)))
-- Unload any modules which are going to be re-linked this
@@ -646,7 +646,7 @@ cmLoadModules cmstate1 dflags mg2unsorted
hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module."
-- link everything together
- linkresult <- link ghci_mode dflags a_root_is_Main (hptLinkables hpt3)
+ linkresult <- link ghci_mode dflags a_root_is_Main hpt3
cmLoadFinish Succeeded linkresult
hpt3 modsDone ghci_mode pcs3
@@ -673,7 +673,7 @@ cmLoadModules cmstate1 dflags mg2unsorted
cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep)
-- Link everything together
- linkresult <- link ghci_mode dflags False (hptLinkables hpt4)
+ linkresult <- link ghci_mode dflags False hpt4
cmLoadFinish Failed linkresult
hpt4 mods_to_keep ghci_mode pcs3
diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs
index d71bcd7f1d..f766c421f6 100644
--- a/ghc/compiler/ghci/Linker.lhs
+++ b/ghc/compiler/ghci/Linker.lhs
@@ -30,8 +30,7 @@ import ByteCodeItbls ( ItblEnv )
import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..))
import Packages
-import DriverState ( v_Library_paths, v_Opt_l, getPackageConfigMap,
- getStaticOpts )
+import DriverState ( v_Library_paths, v_Opt_l, getStaticOpts )
import Finder ( findModule, findLinkable )
import HscTypes
import Name ( Name, nameModule, isExternalName )
@@ -224,8 +223,8 @@ getLinkDeps hpt pit mods
} ;
-- 3. For each dependent module, find its linkable
- -- This will either be in the HPT or (in the case of one-shot compilation)
- -- we may need to use maybe_getFileLinkable
+ -- This will either be in the HPT or (in the case of one-shot
+ -- compilation) we may need to use maybe_getFileLinkable
lnks_needed <- mapM get_linkable mods_needed ;
return (lnks_needed, pkgs_needed) }
diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 2b0d745ae3..c5b56f228d 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -24,19 +24,18 @@ import qualified PrintJava
import OccurAnal ( occurAnalyseBinds )
#endif
+import Packages ( PackageConfig(name), packageNameString )
+import DriverState ( getExplicitPackagesAnd, getPackageCIncludes )
import FastString ( unpackFS )
-import DriverState ( v_HCHeader )
-import Id ( Id )
-import StgSyn ( StgBinding )
import AbsCSyn ( AbstractC )
import PprAbsC ( dumpRealC, writeRealC )
-import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), typeEnvTyCons )
+import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..),
+ typeEnvTyCons, Dependencies(..) )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass )
import Outputable
import Pretty ( Mode(..), printDoc )
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
-import DATA_IOREF ( readIORef, writeIORef )
import Monad ( when )
import IO
\end{code}
@@ -51,15 +50,16 @@ import IO
\begin{code}
codeOutput :: DynFlags
-> ModGuts
- -> [(StgBinding,[Id])] -- The STG program with SRTs
-> AbstractC -- Compiled abstract C
-> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
+
codeOutput dflags
(ModGuts {mg_module = mod_name,
mg_types = type_env,
mg_foreign = foreign_stubs,
+ mg_deps = deps,
mg_binds = core_binds})
- stg_binds flat_abstractC
+ flat_abstractC
= let
tycons = typeEnvTyCons type_env
in
@@ -71,27 +71,26 @@ codeOutput dflags
do { showPass dflags "CodeOutput"
; let filenm = dopt_OutName dflags
- ; stub_names <- outputForeignStubs dflags foreign_stubs
- ; case dopt_HscLang dflags of
- HscInterpreted -> return stub_names
- HscAsm -> outputAsm dflags filenm flat_abstractC
- >> return stub_names
- HscC -> outputC dflags filenm flat_abstractC stub_names
- >> return stub_names
+ ; stubs_exist <- outputForeignStubs dflags foreign_stubs
+ ; case dopt_HscLang dflags of {
+ HscInterpreted -> return ();
+ HscAsm -> outputAsm dflags filenm flat_abstractC;
+ HscC -> outputC dflags filenm flat_abstractC stubs_exist
+ deps foreign_stubs;
HscJava ->
#ifdef JAVA
- outputJava dflags filenm mod_name tycons core_binds
- >> return stub_names
+ outputJava dflags filenm mod_name tycons core_binds;
#else
- panic "Java support not compiled into this ghc"
+ panic "Java support not compiled into this ghc";
#endif
HscILX ->
#ifdef ILX
- outputIlx dflags filenm mod_name tycons stg_binds
- >> return stub_names
+ outputIlx dflags filenm mod_name tycons stg_binds;
#else
- panic "ILX support not compiled into this ghc"
+ panic "ILX support not compiled into this ghc";
#endif
+ }
+ ; return stubs_exist
}
doOutput :: String -> (Handle -> IO ()) -> IO ()
@@ -106,11 +105,38 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
%************************************************************************
\begin{code}
-outputC dflags filenm flat_absC (stub_h_exists, _)
+outputC dflags filenm flat_absC
+ (stub_h_exists, _) dependencies (ForeignStubs _ _ ffi_decl_headers _ )
= do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
- header <- readIORef v_HCHeader
+
+ -- figure out which header files to #include in the generated .hc file:
+ --
+ -- * extra_includes from packages
+ -- * -#include options from the cmdline and OPTIONS pragmas
+ -- * the _stub.h file, if there is one.
+ --
+ let packages = dep_pkgs dependencies
+ pkg_configs <- getExplicitPackagesAnd packages
+ let pkg_names = map name pkg_configs
+
+ c_includes <- getPackageCIncludes pkg_configs
+ let cmdline_includes = cmdlineHcIncludes dflags -- -#include options
+
+ all_headers = c_includes
+ ++ reverse cmdline_includes
+ ++ reverse (map unpackFS ffi_decl_headers)
+ -- reverse correct?
+
+ let cc_injects = unlines (map mk_include all_headers)
+ mk_include h_file =
+ case h_file of
+ '"':_{-"-} -> "#include "++h_file
+ '<':_ -> "#include "++h_file
+ _ -> "#include \""++h_file++"\""
+
doOutput filenm $ \ h -> do
- hPutStr h header
+ hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
+ hPutStr h cc_injects
when stub_h_exists $
hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
writeRealC h flat_absC
@@ -189,20 +215,11 @@ outputIlx dflags filename mod tycons stg_binds
%************************************************************************
\begin{code}
- -- Turn the list of headers requested in foreign import
- -- declarations into a string suitable for emission into generated
- -- C code...
-mkForeignHeaders headers
- = unlines
- . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"")
- . reverse
- $ headers
-
outputForeignStubs :: DynFlags -> ForeignStubs
-> IO (Bool, -- Header file created
Bool) -- C file created
outputForeignStubs dflags NoStubs = return (False, False)
-outputForeignStubs dflags (ForeignStubs h_code c_code hdrs _)
+outputForeignStubs dflags (ForeignStubs h_code c_code _ _)
= do
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export header file" stub_h_output_d
@@ -214,15 +231,9 @@ outputForeignStubs dflags (ForeignStubs h_code c_code hdrs _)
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export stubs" stub_c_output_d
- -- Extend the list of foreign headers (used in outputC)
- fhdrs <- readIORef v_HCHeader
- let new_fhdrs = fhdrs ++ mkForeignHeaders hdrs
- writeIORef v_HCHeader new_fhdrs
-
stub_c_file_exists
<- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
("#define IN_STG_CODE 0\n" ++
- new_fhdrs ++
"#include \"RtsAPI.h\"\n" ++
cplusplus_hdr)
cplusplus_ftr
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index 0721c7238b..8b705a175f 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -61,9 +61,8 @@ import Monad
import Maybe
------------------------------------------------------------------------------
--- Pre process
------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------
+-- Pre-process
-- Just preprocess a file, put the result in a temp. file (used by the
-- compilation manager during the summary phase).
@@ -79,9 +78,8 @@ preprocess filename =
False{-no linking-} False{-no -o flag-}
return fn
------------------------------------------------------------------------------
--- Compile
------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------
+-- Compile
-- Compile a single module, under the control of the compilation manager.
--
@@ -124,7 +122,6 @@ compile ghci_mode this_mod location
dyn_flags <- restoreDynFlags -- Restore to the state of the last save
-
showPass dyn_flags
(showSDoc (text "Compiling" <+> ppr this_mod))
@@ -167,20 +164,6 @@ compile ghci_mode this_mod location
hscStubHOutName = basename ++ "_stub.h",
extCoreName = basename ++ ".hcr" }
- -- figure out which header files to #include in a generated .hc file
- c_includes <- getPackageCIncludes
- cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options
-
- let cc_injects = unlines (map mk_include
- (c_includes ++ reverse cmdline_includes))
- mk_include h_file =
- case h_file of
- '"':_{-"-} -> "#include "++h_file
- '<':_ -> "#include "++h_file
- _ -> "#include \""++h_file++"\""
-
- writeIORef v_HCHeader cc_injects
-
-- -no-recomp should also work with --make
do_recomp <- readIORef v_Recomp
let source_unchanged' = source_unchanged && do_recomp
@@ -251,14 +234,13 @@ compileStub dflags stub_c_exists
return (Just stub_o)
------------------------------------------------------------------------------
--- Link
------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------
+-- Link
link :: GhciMode -- interactive or batch
-> DynFlags -- dynamic flags
-> Bool -- attempt linking in batch mode?
- -> [Linkable]
+ -> HomePackageTable -- what to link
-> IO SuccessFlag
-- For the moment, in the batch linker, we don't bother to tell doLink
@@ -268,40 +250,28 @@ link :: GhciMode -- interactive or batch
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.
--- There will be (ToDo: are) two lists passed to link. These
--- correspond to
---
--- 1. The list of all linkables in the current home package. This is
--- used by the batch linker to link the program, and by the interactive
--- linker to decide which modules from the previous link it can
--- throw away.
--- 2. The list of modules on which we just called "compile". This list
--- is used by the interactive linker to decide which modules need
--- to be actually linked this time around (or unlinked and re-linked
--- if the module was recompiled).
-
-link mode dflags batch_attempt_linking linkables
- = do let verb = verbosity dflags
- when (verb >= 3) $ do
- hPutStrLn stderr "link: linkables are ..."
- hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
-
- res <- link' mode dflags batch_attempt_linking linkables
-
- when (verb >= 3) (hPutStrLn stderr "link: done")
-
- return res
-
#ifdef GHCI
-link' Interactive dflags batch_attempt_linking linkables
- = do showPass dflags "Not Linking...(demand linker will do the job)"
- -- linkModules dflags linkables
+link Interactive dflags batch_attempt_linking hpt
+ = do -- Not Linking...(demand linker will do the job)
return Succeeded
#endif
-link' Batch dflags batch_attempt_linking linkables
+link Batch dflags batch_attempt_linking hpt
| batch_attempt_linking
= do
+ let
+ home_mod_infos = moduleEnvElts hpt
+
+ -- the packages we depend on
+ pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos
+
+ -- the linkables to link
+ linkables = map hm_linkable home_mod_infos
+
+ when (verb >= 3) $ do
+ hPutStrLn stderr "link: linkables are ..."
+ hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
+
-- check for the -no-link flag
omit_linking <- readIORef v_NoLink
if omit_linking
@@ -313,8 +283,13 @@ link' Batch dflags batch_attempt_linking linkables
when (verb >= 1) $
hPutStrLn stderr "Linking ..."
+ let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+ obj_files = concatMap getOfiles linkables
+
-- Don't showPass in Batch mode; doLink will do that for us.
- staticLink (concatMap getOfiles linkables)
+ staticLink obj_files pkg_deps
+
+ when (verb >= 3) (hPutStrLn stderr "link: done")
-- staticLink only returns if it succeeds
return Succeeded
@@ -326,13 +301,12 @@ link' Batch dflags batch_attempt_linking linkables
return Succeeded
where
verb = verbosity dflags
- getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+
------------------------------------------------------------------------------
--- genPipeline: Pipeline construction
------------------------------------------------------------------------------
+-- --------------------------------------------------------------------------
+-- genPipeline: Pipeline construction
-- Herein is all the magic about which phases to run in which order, whether
-- the intermediate files should be in TMPDIR or in the current directory,
@@ -635,7 +609,8 @@ run_phase Cpp basename suff input_fn output_fn
hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
cmdline_include_paths <- readIORef v_Include_paths
- pkg_include_dirs <- getPackageIncludePath
+
+ pkg_include_dirs <- getPackageIncludePath []
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
@@ -760,20 +735,6 @@ run_phase Hsc basename suff input_fn output_fn
paths <- readIORef v_Include_paths
writeIORef v_Include_paths (current_dir : paths)
- -- figure out which header files to #include in a generated .hc file
- c_includes <- getPackageCIncludes
- cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options
-
- let cc_injects = unlines (map mk_include
- (c_includes ++ reverse cmdline_includes))
- mk_include h_file =
- case h_file of
- '"':_{-"-} -> "#include "++h_file
- '<':_ -> "#include "++h_file
- _ -> "#include \""++h_file++"\""
-
- writeIORef v_HCHeader cc_injects
-
-- gather the imports and module name
(srcimps,imps,mod_name) <-
if extcoreish_suffix suff
@@ -877,10 +838,13 @@ run_phase cc_phase basename suff input_fn output_fn
let hcc = cc_phase == HCc
- -- 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 <- getPackageIncludePath
+ -- HC files have the dependent packages stamped into them
+ pkgs <- if hcc then getHCFilePackages input_fn else return []
+
+ -- 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 <- getPackageIncludePath pkgs
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
@@ -893,7 +857,7 @@ run_phase cc_phase basename suff input_fn output_fn
let opt_flag | o2 = "-O2"
| otherwise = "-O"
- pkg_extra_cc_opts <- getPackageExtraCcOpts
+ pkg_extra_cc_opts <- getPackageExtraCcOpts pkgs
split_objs <- readIORef v_Split_object_files
let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
@@ -1132,38 +1096,66 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
checkProcessArgsResult flags basename suff
= do when (notNull flags) (throwDyn (ProgramError (
- basename ++ "." ++ suff
- ++ ": static flags are not allowed in {-# OPTIONS #-} pragmas:\n\t"
- ++ unwords flags)) (ExitFailure 1))
+ showSDoc (hang (text basename <> text ('.':suff) <> char ':')
+ 4 (text "unknown flags in {-# OPTIONS #-} pragma:" <+>
+ hsep (map text flags)))
+ )))
+
+-----------------------------------------------------------------------------
+-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
+
+getHCFilePackages :: FilePath -> IO [PackageName]
+getHCFilePackages filename =
+ EXCEPTION.bracket (openFile filename ReadMode) hClose $ \h -> do
+ l <- hGetLine h
+ case l of
+ '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
+ return (map mkPackageName (words rest))
+ _other ->
+ return []
-----------------------------------------------------------------------------
-- Static linking, of .o files
-staticLink :: [String] -> IO ()
-staticLink o_files = do
+-- The list of packages passed to link is the list of packages on
+-- which this program depends, as discovered by the compilation
+-- manager. It is combined with the list of packages that the user
+-- specifies on the command line with -package flags.
+--
+-- In one-shot linking mode, we can't discover the package
+-- dependencies (because we haven't actually done any compilation or
+-- read any interface files), so the user must explicitly specify all
+-- the packages.
+
+staticLink :: [FilePath] -> [PackageName] -> IO ()
+staticLink o_files dep_packages = do
verb <- getVerbFlag
static <- readIORef v_Static
no_hs_main <- readIORef v_NoHsMain
+ -- get the full list of packages to link with, by combining the
+ -- explicit packages with the auto packages and all of their
+ -- dependencies, and eliminating duplicates.
+
o_file <- readIORef v_Output_file
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
- pkg_lib_paths <- getPackageLibraryPath
+ pkg_lib_paths <- getPackageLibraryPath dep_packages
let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
lib_paths <- readIORef v_Library_paths
let lib_path_opts = map ("-L"++) lib_paths
- pkg_link_opts <- getPackageLinkOpts
+ pkg_link_opts <- getPackageLinkOpts dep_packages
#ifdef darwin_TARGET_OS
- pkg_framework_paths <- getPackageFrameworkPath
+ pkg_framework_paths <- getPackageFrameworkPath dep_packages
let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
framework_paths <- readIORef v_Framework_paths
let framework_path_opts = map ("-F"++) framework_paths
- pkg_frameworks <- getPackageFrameworks
+ pkg_frameworks <- getPackageFrameworks dep_packages
let pkg_framework_opts = map ("-framework " ++) pkg_frameworks
frameworks <- readIORef v_Cmdline_frameworks
@@ -1229,13 +1221,13 @@ doMkDLL o_files = do
o_file <- readIORef v_Output_file
let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
- pkg_lib_paths <- getPackageLibraryPath
+ pkg_lib_paths <- getPackageLibraryPath []
let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
lib_paths <- readIORef v_Library_paths
let lib_path_opts = map ("-L"++) lib_paths
- pkg_link_opts <- getPackageLinkOpts
+ pkg_link_opts <- getPackageLinkOpts []
-- probably _stub.o files
extra_ld_inputs <- readIORef v_Ld_inputs
diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs
index fe5ff52e67..acd5e49c29 100644
--- a/ghc/compiler/main/DriverState.hs
+++ b/ghc/compiler/main/DriverState.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.87 2002/12/17 13:50:29 simonmar Exp $
+-- $Id: DriverState.hs,v 1.88 2002/12/18 16:29:28 simonmar Exp $
--
-- Settings for the driver
--
@@ -12,16 +12,13 @@ module DriverState where
#include "../includes/config.h"
#include "HsVersions.h"
-import SysTools ( getTopDir )
import ParsePkgConf ( loadPackageConfig )
-import Packages ( PackageConfig(..), PackageConfigMap,
- PackageName, mkPackageName, packageNameString,
- packageDependents,
- mungePackagePaths, emptyPkgMap, extendPkgMap, lookupPkg,
- basePackage, rtsPackage, haskell98Package )
+import SysTools ( getTopDir )
+import Packages
import CmdLineOpts
import DriverPhases
import DriverUtil
+import UniqFM ( eltsUFM )
import Util
import Config
import Panic
@@ -32,8 +29,8 @@ import EXCEPTION
import List
import Char
import Monad
-import Maybe ( fromJust, isJust )
-import Directory ( doesDirectoryExist )
+import Maybe ( fromJust, isJust )
+import Directory ( doesDirectoryExist )
-----------------------------------------------------------------------------
-- non-configured things
@@ -452,91 +449,102 @@ addToDirList ref path
splitUp xs = return (split split_marker xs)
#endif
-GLOBAL_VAR(v_HCHeader, "", String)
-
------------------------------------------------------------------------------
--- Packages
-
-------------------------
--- The PackageConfigMap is read in from the configuration file
--- It doesn't change during a run
-GLOBAL_VAR(v_Package_details, emptyPkgMap, PackageConfigMap)
+-- ----------------------------------------------------------------------------
+-- Loading the package config file
readPackageConf :: String -> IO ()
readPackageConf conf_file = do
proto_pkg_configs <- loadPackageConfig conf_file
top_dir <- getTopDir
- old_pkg_map <- readIORef v_Package_details
-
let pkg_configs = mungePackagePaths top_dir proto_pkg_configs
- new_pkg_map = extendPkgMap old_pkg_map pkg_configs
-
- writeIORef v_Package_details new_pkg_map
+ extendPackageConfigMap pkg_configs
+
+mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
+-- Replace the string "$libdir" at the beginning of a path
+-- with the current libdir (obtained from the -B option).
+mungePackagePaths top_dir ps = map munge_pkg ps
+ where
+ munge_pkg p = p{ import_dirs = munge_paths (import_dirs p),
+ include_dirs = munge_paths (include_dirs p),
+ library_dirs = munge_paths (library_dirs p),
+ framework_dirs = munge_paths (framework_dirs p) }
-getPackageConfigMap :: IO PackageConfigMap
-getPackageConfigMap = readIORef v_Package_details
+ munge_paths = map munge_path
+ munge_path p
+ | Just p' <- my_prefix_match "$libdir" p = top_dir ++ p'
+ | otherwise = p
-------------------------
--- The package list reflects what was given as command-line options,
--- plus their dependent packages.
--- It is maintained in dependency order;
--- earlier ones depend on later ones, but not vice versa
-GLOBAL_VAR(v_Packages, initPackageList, [PackageName])
-getPackages :: IO [PackageName]
-getPackages = readIORef v_Packages
+-- -----------------------------------------------------------------------------
+-- The list of packages requested on the command line
-initPackageList = [haskell98Package,
- basePackage,
- rtsPackage]
+-- The package list reflects what packages were given as command-line options,
+-- plus their dependent packages. It is maintained in dependency order;
+-- earlier packages may depend on later ones, but not vice versa
+GLOBAL_VAR(v_ExplicitPackages, initPackageList, [PackageName])
+initPackageList = [rtsPackage]
+
+-- add a package requested from the command-line
addPackage :: String -> IO ()
-addPackage package
- = do { pkg_details <- getPackageConfigMap
- ; ps <- readIORef v_Packages
- ; ps' <- add_package pkg_details ps (mkPackageName package)
+addPackage package = do
+ pkg_details <- getPackageConfigMap
+ ps <- readIORef v_ExplicitPackages
+ ps' <- add_package pkg_details ps (mkPackageName package)
-- Throws an exception if it fails
- ; writeIORef v_Packages ps' }
+ writeIORef v_ExplicitPackages ps'
+-- internal helper
add_package :: PackageConfigMap -> [PackageName]
-> PackageName -> IO [PackageName]
add_package pkg_details ps p
| p `elem` ps -- Check if we've already added this package
= return ps
| Just details <- lookupPkg pkg_details p
- = do { -- Add the package's dependents first
- ps' <- foldM (add_package pkg_details) ps
- (packageDependents details)
- ; return (p : ps') }
-
+ -- Add the package's dependents also
+ = do ps' <- foldM (add_package pkg_details) ps (packageDependents details)
+ return (p : ps')
| otherwise
= throwDyn (CmdLineError ("unknown package name: " ++ packageNameString p))
-getPackageImportPath :: IO [String]
+
+-- -----------------------------------------------------------------------------
+-- 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 explicit (command-line) packages to determine which packages to
+-- use.
+
+getPackageImportPath :: IO [String]
getPackageImportPath = do
- ps <- getPackageInfo
+ ps <- getExplicitAndAutoPackageConfigs
+ -- import dirs are always derived from the 'auto'
+ -- packages as well as the explicit ones
return (nub (filter notNull (concatMap import_dirs ps)))
-getPackageIncludePath :: IO [String]
-getPackageIncludePath = do
- ps <- getPackageInfo
+getPackageIncludePath :: [PackageName] -> IO [String]
+getPackageIncludePath pkgs = do
+ ps <- getExplicitPackagesAnd pkgs
return (nub (filter notNull (concatMap include_dirs ps)))
-- includes are in reverse dependency order (i.e. rts first)
-getPackageCIncludes :: IO [String]
-getPackageCIncludes = do
- ps <- getPackageInfo
- return (reverse (nub (filter notNull (concatMap c_includes ps))))
-
-getPackageLibraryPath :: IO [String]
-getPackageLibraryPath = do
- ps <- getPackageInfo
+getPackageCIncludes :: [PackageConfig] -> IO [String]
+getPackageCIncludes pkg_configs = do
+ return (reverse (nub (filter notNull (concatMap c_includes pkg_configs))))
+
+getPackageLibraryPath :: [PackageName] -> IO [String]
+getPackageLibraryPath pkgs = do
+ ps <- getExplicitPackagesAnd pkgs
return (nub (filter notNull (concatMap library_dirs ps)))
-getPackageLinkOpts :: IO [String]
-getPackageLinkOpts = do
- ps <- getPackageInfo
+getPackageLinkOpts :: [PackageName] -> IO [String]
+getPackageLinkOpts pkgs = do
+ ps <- getExplicitPackagesAnd pkgs
tag <- readIORef v_Build_tag
static <- readIORef v_Static
let
@@ -580,35 +588,42 @@ getPackageLinkOpts = do
getPackageExtraGhcOpts :: IO [String]
getPackageExtraGhcOpts = do
- ps <- getPackageInfo
+ ps <- getExplicitAndAutoPackageConfigs
return (concatMap extra_ghc_opts ps)
-getPackageExtraCcOpts :: IO [String]
-getPackageExtraCcOpts = do
- ps <- getPackageInfo
+getPackageExtraCcOpts :: [PackageName] -> IO [String]
+getPackageExtraCcOpts pkgs = do
+ ps <- getExplicitPackagesAnd pkgs
return (concatMap extra_cc_opts ps)
#ifdef darwin_TARGET_OS
-getPackageFrameworkPath :: IO [String]
+getPackageFrameworkPath :: [PackageName] -> IO [String]
getPackageFrameworkPath = do
- ps <- getPackageInfo
+ ps <- getExplicitPackagesAnd pkgs
return (nub (filter notNull (concatMap framework_dirs ps)))
-getPackageFrameworks :: IO [String]
-getPackageFrameworks = do
- ps <- getPackageInfo
+getPackageFrameworks :: [PackageName] -> IO [String]
+getPackageFrameworks pkgs = do
+ ps <- getExplicitPackagesAnd pkgs
return (concatMap extra_frameworks ps)
#endif
-getPackageInfo :: IO [PackageConfig]
-getPackageInfo = do ps <- getPackages
- getPackageDetails ps
-
-getPackageDetails :: [PackageName] -> IO [PackageConfig]
-getPackageDetails ps = do
- pkg_details <- getPackageConfigMap
- return [ pkg | Just pkg <- map (lookupPkg pkg_details) ps ]
-
+-- -----------------------------------------------------------------------------
+-- Package Utils
+
+getExplicitPackagesAnd :: [PackageName] -> IO [PackageConfig]
+getExplicitPackagesAnd pkg_names = do
+ pkg_map <- getPackageConfigMap
+ expl <- readIORef v_ExplicitPackages
+ all_pkgs <- foldM (add_package pkg_map) expl pkg_names
+ getPackageDetails all_pkgs
+
+-- return all packages, including both the auto packages and the explicit ones
+getExplicitAndAutoPackageConfigs :: IO [PackageConfig]
+getExplicitAndAutoPackageConfigs = do
+ pkg_map <- getPackageConfigMap
+ let auto_packages = [ mkPackageName (name p) | p <- eltsUFM pkg_map, auto p ]
+ getExplicitPackagesAnd auto_packages
-----------------------------------------------------------------------------
-- Ways
diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs
index 348eee6410..96720c63db 100644
--- a/ghc/compiler/main/Finder.lhs
+++ b/ghc/compiler/main/Finder.lhs
@@ -5,7 +5,6 @@
\begin{code}
module Finder (
- initFinder, -- :: [PackageConfig] -> IO (),
flushFinderCache, -- :: IO ()
findModule, -- :: ModuleName -> IO (Maybe (Module, ModLocation))
@@ -52,9 +51,6 @@ import Monad
-- It does *not* know which particular package a module lives in, because
-- that information is only contained in the interface file.
-initFinder :: [PackageConfig] -> IO ()
-initFinder pkgs = return ()
-
-- -----------------------------------------------------------------------------
-- The finder's cache
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 05dcfb4993..3c2d652731 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -330,7 +330,7 @@ hscFrontEnd hsc_env pcs_ch location = do {
-- PARSE
-------------------
; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
- (expectJust "hscRecomp:hspp" (ml_hspp_file location))
+ (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
; case maybe_parsed of {
Nothing -> return (Left (HscFail pcs_ch));
@@ -344,7 +344,7 @@ hscFrontEnd hsc_env pcs_ch location = do {
; case maybe_tc_result of {
Nothing -> return (Left (HscFail pcs_ch));
Just tc_result -> do {
-
+
-------------------
-- DESUGAR
-------------------
@@ -393,8 +393,7 @@ hscBackEnd dflags cg_info_ref prepd_result
------------------ Code output -----------------------
(stub_h_exists, stub_c_exists)
- <- codeOutput dflags prepd_result
- stg_binds abstractC
+ <- codeOutput dflags prepd_result abstractC
return (stub_h_exists, stub_c_exists, Nothing)
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 1fcaf02e3d..677c8a3cf6 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,7 +1,7 @@
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.115 2002/12/17 13:50:29 simonmar Exp $
+-- $Id: Main.hs,v 1.116 2002/12/18 16:29:30 simonmar Exp $
--
-- GHC Driver program
--
@@ -23,21 +23,21 @@ import DriverPhases( objish_file )
#endif
-import Finder ( initFinder )
import CompManager ( cmInit, cmLoadModules, cmDepAnal )
import HscTypes ( GhciMode(..) )
import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion )
import SysTools ( getPackageConfigPath, initSysTools, cleanTempFiles )
-import Packages ( showPackages )
+import Packages ( showPackages, getPackageConfigMap )
import DriverPipeline ( staticLink, doMkDLL, genPipeline, pipeLoop )
import DriverState ( buildCoreToDo, buildStgToDo,
- findBuildTag, getPackageInfo, getPackageConfigMap,
+ findBuildTag,
getPackageExtraGhcOpts, unregFlags,
v_GhcMode, v_GhcModeFlag, GhcMode(..),
v_Keep_tmp_files, v_Ld_inputs, v_Ways,
v_OptLevel, v_Output_file, v_Output_hi,
- readPackageConf, verifyOutputFiles, v_NoLink
+ readPackageConf, verifyOutputFiles, v_NoLink,
+ v_Build_tag
)
import DriverFlags ( buildStaticHscOpts,
dynamic_flags, processArgs, static_flags)
@@ -201,9 +201,13 @@ main =
-- by module basis, using only the -fvia-C and -fasm flags. If the global
-- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
dyn_flags <- getDynFlags
+ build_tag <- readIORef v_Build_tag
let lang = case mode of
DoInteractive -> HscInterpreted
- _other -> hscLang dyn_flags
+ _other | build_tag /= "" -> HscC
+ | otherwise -> hscLang dyn_flags
+ -- for ways other that the normal way, we must
+ -- compile via C.
setDynFlags (dyn_flags{ coreToDo = core_todo,
stgToDo = stg_todo,
@@ -246,10 +250,6 @@ main =
when (verb >= 3)
(hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts))
- -- initialise the finder
- pkg_avails <- getPackageInfo
- initFinder pkg_avails
-
-- mkdependHS is special
when (mode == DoMkDependHS) beginMkDependHS
@@ -304,10 +304,15 @@ main =
o_files <- mapM compileFile srcs
+ when (mode == DoMkDependHS) endMkDependHS
+
omit_linking <- readIORef v_NoLink
+ when (mode == DoLink && not omit_linking)
+ (staticLink o_files [basePackage, haskell98Package])
+ -- we always link in the base package in one-shot linking.
+ -- any other packages required must be given using -package
+ -- options on the command-line.
- when (mode == DoMkDependHS) endMkDependHS
- when (mode == DoLink && not omit_linking) (staticLink o_files)
when (mode == DoMkDLL) (doMkDLL o_files)
diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs
index 08e86f4199..ef4a6e4b8e 100644
--- a/ghc/compiler/main/Packages.lhs
+++ b/ghc/compiler/main/Packages.lhs
@@ -7,36 +7,33 @@
module Packages (
PackageConfig(..),
defaultPackageConfig,
- mungePackagePaths, packageDependents,
+ packageDependents,
showPackages,
PackageName, -- Instance of Outputable
mkPackageName, packageNameString,
- basePackage, rtsPackage, haskell98Package, thPackage, -- :: PackageName
+ basePackage, rtsPackage, haskell98Package, thPackage, -- :: PackageName
- PackageConfigMap, emptyPkgMap, extendPkgMap, lookupPkg
+ PackageConfigMap, emptyPkgMap, lookupPkg,
+ extendPackageConfigMap, getPackageDetails, getPackageConfigMap,
)
where
#include "HsVersions.h"
-import Pretty
-
import CmdLineOpts ( dynFlag, verbosity )
-import DriverUtil ( my_prefix_match )
import ErrUtils ( dumpIfSet )
import Outputable ( docToSDoc )
import FastString
import UniqFM
-\end{code}
+import Util
+import Pretty
-%*********************************************************
-%* *
-\subsection{Basic data types}
-%* *
-%*********************************************************
+import DATA_IOREF
+
+-- -----------------------------------------------------------------------------
+-- The PackageConfig type
-\begin{code}
#define WANT_PRETTY
#define INTERNAL_PRETTY
-- Yes, do generate pretty-printing stuff for packages, and use our
@@ -44,14 +41,13 @@ import UniqFM
-- There's a blob of code shared with ghc-pkg,
-- so we just include it from there
--- Primarily it defines
--- PackageConfig (a record)
--- PackageName (FastString)
+-- Primarily it defines PackageConfig (a record)
#include "../utils/ghc-pkg/Package.hs"
-\end{code}
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- Package names
+
type PackageName = FastString -- No encoding at all
mkPackageName :: String -> PackageName
@@ -70,14 +66,14 @@ packageDependents :: PackageConfig -> [PackageName]
-- Impedence matcher, because PackageConfig has Strings
-- not PackageNames at the moment. Sigh.
packageDependents pkg = map mkPackageName (package_deps pkg)
-\end{code}
-A PackageConfigMap maps a PackageName to a PackageConfig
+-- -----------------------------------------------------------------------------
+-- A PackageConfigMap maps a PackageName to a PackageConfig
-\begin{code}
type PackageConfigMap = UniqFM PackageConfig
lookupPkg :: PackageConfigMap -> PackageName -> Maybe PackageConfig
+
emptyPkgMap :: PackageConfigMap
emptyPkgMap = emptyUFM
@@ -88,40 +84,26 @@ extendPkgMap pkg_map new_pkgs
= foldl add pkg_map new_pkgs
where
add pkg_map p = addToUFM pkg_map (mkFastString (name p)) p
-\end{code}
-%*********************************************************
-%* *
-\subsection{Load the config file}
-%* *
-%*********************************************************
+GLOBAL_VAR(v_Package_details, emptyPkgMap, PackageConfigMap)
-\begin{code}
-mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
--- Replace the string "$libdir" at the beginning of a path
--- with the current libdir (obtained from the -B option).
-mungePackagePaths top_dir ps = map munge_pkg ps
- where
- munge_pkg p = p{ import_dirs = munge_paths (import_dirs p),
- include_dirs = munge_paths (include_dirs p),
- library_dirs = munge_paths (library_dirs p),
- framework_dirs = munge_paths (framework_dirs p) }
-
- munge_paths = map munge_path
-
- munge_path p
- | Just p' <- my_prefix_match "$libdir" p = top_dir ++ p'
- | otherwise = p
-\end{code}
+getPackageConfigMap :: IO PackageConfigMap
+getPackageConfigMap = readIORef v_Package_details
+extendPackageConfigMap :: [PackageConfig] -> IO ()
+extendPackageConfigMap pkg_configs = do
+ old_pkg_map <- readIORef v_Package_details
+ writeIORef v_Package_details (extendPkgMap old_pkg_map pkg_configs)
-%*********************************************************
-%* *
-\subsection{Display results}
-%* *
-%*********************************************************
+getPackageDetails :: [PackageName] -> IO [PackageConfig]
+getPackageDetails ps = do
+ pkg_details <- getPackageConfigMap
+ return [ pkg | Just pkg <- map (lookupPkg pkg_details) ps ]
+
+
+-- -----------------------------------------------------------------------------
+-- Displaying packages
-\begin{code}
showPackages :: PackageConfigMap -> IO ()
-- Show package info on console, if verbosity is >= 3
showPackages pkg_map
@@ -131,4 +113,5 @@ showPackages pkg_map
}
where
ps = eltsUFM pkg_map
+
\end{code}
diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y
index e9161113e6..1c94edc43e 100644
--- a/ghc/compiler/main/ParsePkgConf.y
+++ b/ghc/compiler/main/ParsePkgConf.y
@@ -52,6 +52,11 @@ field :: { PackageConfig -> PackageConfig }
"name" -> returnP (\ p -> p{name = unpackFS $3});
_ -> happyError } }
+ | VARID '=' bool
+ {\p -> case unpackFS $1 of {
+ "auto" -> p{auto = $3};
+ _ -> p } }
+
| VARID '=' strlist
{\p -> case unpackFS $1 of
"import_dirs" -> p{import_dirs = $3}
@@ -77,6 +82,12 @@ strs :: { [String] }
: STRING { [ unpackFS $1 ] }
| strs ',' STRING { unpackFS $3 : $1 }
+bool :: { Bool }
+ : CONID {% case unpackFS $1 of {
+ "True" -> returnP True;
+ "False" -> returnP False;
+ _ -> happyError } }
+
{
happyError :: P a
happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
diff --git a/ghc/utils/ghc-pkg/Package.hs b/ghc/utils/ghc-pkg/Package.hs
index 2fb7690754..bd9e226a79 100644
--- a/ghc/utils/ghc-pkg/Package.hs
+++ b/ghc/utils/ghc-pkg/Package.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: Package.hs,v 1.5 2002/09/09 12:10:01 simonmar Exp $
+-- $Id: Package.hs,v 1.6 2002/12/18 16:29:34 simonmar Exp $
--
-- Package configuration defn.
-----------------------------------------------------------------------------
@@ -27,6 +27,7 @@ import Pretty
data PackageConfig
= Package {
name :: String,
+ auto :: Bool,
import_dirs :: [String],
source_dirs :: [String],
library_dirs :: [String],
@@ -45,6 +46,7 @@ data PackageConfig
defaultPackageConfig
= Package {
name = error "defaultPackage",
+ auto = False,
import_dirs = [],
source_dirs = [],
library_dirs = [],
@@ -76,6 +78,7 @@ dumpPkgGuts pkg =
text "Package" $$ nest 3 (braces (
sep (punctuate comma [
text "name = " <> text (show (name pkg)),
+ text "auto = " <> text (show (auto pkg)),
dumpField "import_dirs" (import_dirs pkg),
dumpField "source_dirs" (source_dirs pkg),
dumpField "library_dirs" (library_dirs pkg),
diff --git a/ghc/utils/ghc-pkg/ParsePkgConfLite.y b/ghc/utils/ghc-pkg/ParsePkgConfLite.y
index 152ff9b517..d4d8ddbf6a 100644
--- a/ghc/utils/ghc-pkg/ParsePkgConfLite.y
+++ b/ghc/utils/ghc-pkg/ParsePkgConfLite.y
@@ -48,6 +48,11 @@ field :: { PackageConfig -> PackageConfig }
"name" -> p{name = $3}
_ -> error "unknown key in config file" }
+ | VARID '=' bool
+ {\p -> case $1 of {
+ "auto" -> p{auto = $3};
+ _ -> p } }
+
| VARID '=' strlist
{\p -> case $1 of
"import_dirs" -> p{import_dirs = $3}
@@ -73,6 +78,11 @@ strs :: { [String] }
: STRING { [ $1 ] }
| strs ',' STRING { $3 : $1 }
+bool :: { Bool }
+ : CONID {% case $1 of {
+ "True" -> True;
+ "False" -> False;
+ _ -> error ("unknown constructor in config file: " ++ $1) } }
{
data Token =
ITocurly
View Lorry Controller Status