"Auto" packages.
The big change here is that it is no longer necessary to explicitly
say '-package X' on the command line if X is a package containing
hierarchical Haskell modules. All packages marked "auto" contribute
to the import path, so their modules are always available. At link
time, the compiler knows which packages are actually used by the
program, and it links in only those libraries needed.
There's one exception: one-shot linking. If you link a program using
ghc -o prog A.o B.o ...
then you need to explicitly add -package flags for each package
required (except base & haskell98) because the compiler has no
information about the package dependencies in this case.
Package configs have a new field: auto, which is either True or False.
Non-auto packages must be mentioned on the command-line as usual.
Non-auto packages are still required for:
- non-hierarchical libraries (to avoid polluting the module namespace)
- packages with no Haskell content
- if you want more than one version of a package, or packages
providing overlapping functionality where the user must decide
which one to use.
Doc changes to follow...
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
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
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
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 )
} ;
-- 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) }
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}
\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
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 ()
%************************************************************************
\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
%************************************************************************
\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
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
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).
False{-no linking-} False{-no -o flag-}
return fn
------------------------------------------------------------------------------
--- Compile
------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------
+-- Compile
-- Compile a single module, under the control of the compilation manager.
--
dyn_flags <- restoreDynFlags -- Restore to the state of the last save
-
showPass dyn_flags
(showSDoc (text "Compiling" <+> ppr this_mod))
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
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
-- 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
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
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,
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)
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
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)
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" ]
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
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
-----------------------------------------------------------------------------
--- $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
--
#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
import List
import Char
import Monad
-import Maybe ( fromJust, isJust )
-import Directory ( doesDirectoryExist )
+import Maybe ( fromJust, isJust )
+import Directory ( doesDirectoryExist )
-----------------------------------------------------------------------------
-- non-configured things
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
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
\begin{code}
module Finder (
- initFinder, -- :: [PackageConfig] -> IO (),
flushFinderCache, -- :: IO ()
findModule, -- :: ModuleName -> IO (Maybe (Module, ModLocation))
-- 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
-- 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));
; case maybe_tc_result of {
Nothing -> return (Left (HscFail pcs_ch));
Just tc_result -> do {
-
+
-------------------
-- DESUGAR
-------------------
------------------ 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)
{-# 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
--
#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)
-- 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,
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
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)
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
-- 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
-- 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
= 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
}
where
ps = eltsUFM pkg_map
+
\end{code}
"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}
: 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)
-----------------------------------------------------------------------------
--- $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.
-----------------------------------------------------------------------------
data PackageConfig
= Package {
name :: String,
+ auto :: Bool,
import_dirs :: [String],
source_dirs :: [String],
library_dirs :: [String],
defaultPackageConfig
= Package {
name = error "defaultPackage",
+ auto = False,
import_dirs = [],
source_dirs = [],
library_dirs = [],
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),
"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}
: 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
projects / ghc-hetmet.git / commitdiff