-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.1 2000/10/11 15:26:18 simonmar Exp $
+-- $Id: DriverPipeline.hs,v 1.13 2000/10/30 18:13:15 sewardj Exp $
--
-- GHC Driver
--
-----------------------------------------------------------------------------
module DriverPipeline (
+
+ -- interfaces for the batch-mode driver
GhcMode(..), getGhcMode, v_GhcMode,
genPipeline, runPipeline,
- preprocess,
+
+ -- interfaces for the compilation manager (interpreted/batch-mode)
+ preprocess, compile,
+
+ -- batch-mode linking interface
doLink,
) where
#include "HsVersions.h"
-import CmSummarise -- for mkdependHS stuff
+import CmSummarise
+import CmLink
import DriverState
import DriverUtil
import DriverMkDepend
+import DriverPhases
import DriverFlags
+import HscMain
import TmpFiles
+import HscTypes
+import Outputable
+import Module
+import CmdLineOpts
import Config
import Util
-import CmdLineOpts
-import Panic
+import Directory
+import System
import IOExts
-import Posix
import Exception
import IO
"only one of the flags -M, -E, -C, -S, -c, --make, --interactive is allowed")
-----------------------------------------------------------------------------
--- Phases
-
-{-
-Phase of the | Suffix saying | Flag saying | (suffix of)
-compilation system | ``start here''| ``stop after''| output file
-
-literate pre-processor | .lhs | - | -
-C pre-processor (opt.) | - | -E | -
-Haskell compiler | .hs | -C, -S | .hc, .s
-C compiler (opt.) | .hc or .c | -S | .s
-assembler | .s or .S | -c | .o
-linker | other | - | a.out
--}
-
-data Phase
- = MkDependHS -- haskell dependency generation
- | Unlit
- | Cpp
- | Hsc
- | Cc
- | HCc -- Haskellised C (as opposed to vanilla C) compilation
- | Mangle -- assembly mangling, now done by a separate script.
- | SplitMangle -- after mangler if splitting
- | SplitAs
- | As
- | Ln
- deriving (Eq)
-
--- the first compilation phase for a given file is determined
--- by its suffix.
-startPhase "lhs" = Unlit
-startPhase "hs" = Cpp
-startPhase "hc" = HCc
-startPhase "c" = Cc
-startPhase "raw_s" = Mangle
-startPhase "s" = As
-startPhase "S" = As
-startPhase "o" = Ln
-startPhase _ = Ln -- all unknown file types
-
--- the output suffix for a given phase is uniquely determined by
--- the input requirements of the next phase.
-phase_input_ext Unlit = "lhs"
-phase_input_ext Cpp = "lpp" -- intermediate only
-phase_input_ext Hsc = "cpp" -- intermediate only
-phase_input_ext HCc = "hc"
-phase_input_ext Cc = "c"
-phase_input_ext Mangle = "raw_s"
-phase_input_ext SplitMangle = "split_s" -- not really generated
-phase_input_ext As = "s"
-phase_input_ext SplitAs = "split_s" -- not really generated
-phase_input_ext Ln = "o"
-phase_input_ext MkDependHS = "dep"
-
-haskellish_suffix = (`elem` [ "hs", "lhs", "hc" ])
-cish_suffix = (`elem` [ "c", "s", "S" ]) -- maybe .cc et al.??
-
-haskellish_file f = haskellish_suffix suf where (_,suf) = splitFilename f
-cish_file f = cish_suffix suf where (_,suf) = splitFilename f
-
------------------------------------------------------------------------------
-- genPipeline
--
-- Herein is all the magic about which phases to run in which order, whether
genPipeline todo stop_flag filename
= do
- split <- readIORef split_object_files
- mangle <- readIORef do_asm_mangling
- lang <- readIORef hsc_lang
- keep_hc <- readIORef keep_hc_files
- keep_raw_s <- readIORef keep_raw_s_files
- keep_s <- readIORef keep_s_files
+ split <- readIORef v_Split_object_files
+ mangle <- readIORef v_Do_asm_mangling
+ lang <- readIORef v_Hsc_Lang
+ keep_hc <- readIORef v_Keep_hc_files
+ keep_raw_s <- readIORef v_Keep_raw_s_files
+ keep_s <- readIORef v_Keep_s_files
let
----------- ----- ---- --- -- -- - - -
cish = cish_suffix suffix
-- for a .hc file, or if the -C flag is given, we need to force lang to HscC
- real_lang
- | suffix == "hc" = HscC
- | todo == StopBefore HCc && lang /= HscC && haskellish = HscC
- | otherwise = lang
+ real_lang | suffix == "hc" = HscC
+ | otherwise = lang
let
----------- ----- ---- --- -- -- - - -
annotatePipeline [] _ = []
annotatePipeline (Ln:_) _ = []
annotatePipeline (phase:next_phase:ps) stop =
- (phase, keep_this_output, phase_input_ext next_phase)
+ (phase, keep_this_output, phaseInputExt next_phase)
: annotatePipeline (next_phase:ps) stop
where
keep_this_output
where
outputFileName last_phase keep suffix
- = do o_file <- readIORef output_file
+ = do o_file <- readIORef v_Output_file
if last_phase && not do_linking && use_ofile && isJust o_file
then case o_file of
Just s -> return s
-- Unlit phase
run_phase Unlit _basename _suff input_fn output_fn
- = do unlit <- readIORef pgm_L
+ = do unlit <- readIORef v_Pgm_L
unlit_flags <- getOpts opt_L
run_something "Literate pre-processor"
("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
run_phase Cpp _basename _suff input_fn output_fn
= do src_opts <- getOptionsFromSource input_fn
- -- ToDo: this is *wrong* if we're processing more than one file:
- -- the OPTIONS will persist through the subsequent compilations.
_ <- processArgs dynamic_flags src_opts []
do_cpp <- readState cpp_flag
if do_cpp
then do
- cpp <- readIORef pgm_P
+ cpp <- readIORef v_Pgm_P
hscpp_opts <- getOpts opt_P
- hs_src_cpp_opts <- readIORef hs_source_cpp_opts
+ hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
- cmdline_include_paths <- readIORef include_paths
+ cmdline_include_paths <- readIORef v_Include_paths
pkg_include_dirs <- getPackageIncludePath
let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
++ pkg_include_dirs)
deps <- mapM (findDependency basename) imports
- osuf_opt <- readIORef output_suf
+ osuf_opt <- readIORef v_Output_suf
let osuf = case osuf_opt of
Nothing -> "o"
Just s -> s
- extra_suffixes <- readIORef dep_suffixes
+ extra_suffixes <- readIORef v_Dep_suffixes
let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
ofiles = map (\suf -> basename ++ '.':suf) suffixes
objs <- mapM odir_ify ofiles
- hdl <- readIORef dep_tmp_hdl
+ hdl <- readIORef v_Dep_tmp_hdl
-- std dependeny of the object(s) on the source file
hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
let genDep (dep, False {- not an hi file -}) =
hPutStrLn hdl (unwords objs ++ " : " ++ dep)
genDep (dep, True {- is an hi file -}) = do
- hisuf <- readIORef hi_suf
+ hisuf <- readIORef v_Hi_suf
let dep_base = remove_suffix '.' dep
deps = (dep_base ++ hisuf)
: map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
-----------------------------------------------------------------------------
-- Hsc phase
-{-
-run_phase Hsc basename suff input_fn output_fn
- = do hsc <- readIORef pgm_C
+-- Compilation of a single module, in "legacy" mode (_not_ under
+-- the direction of the compilation manager).
+run_phase Hsc basename suff input_fn output_fn
+ = do
-- we add the current directory (i.e. the directory in which
-- the .hs files resides) to the import path, since this is
-- what gcc does, and it's probably what you want.
let current_dir = getdir basename
- paths <- readIORef include_paths
- writeIORef include_paths (current_dir : paths)
-
- -- build the hsc command line
- hsc_opts <- build_hsc_opts
-
- doing_hi <- readIORef produceHi
- tmp_hi_file <- if doing_hi
- then newTempName "hi"
- else return ""
-
- -- tmp files for foreign export stub code
- tmp_stub_h <- newTempName "stub_h"
- tmp_stub_c <- newTempName "stub_c"
+ paths <- readIORef v_Include_paths
+ writeIORef v_Include_paths (current_dir : paths)
-- figure out where to put the .hi file
- ohi <- readIORef output_hi
- hisuf <- readIORef hi_suf
- let hi_flags = case ohi of
- Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
- Just fn -> [ "-hifile="++fn ]
+ ohi <- readIORef v_Output_hi
+ hisuf <- readIORef v_Hi_suf
+ let hifile = case ohi of
+ Nothing -> current_dir ++ "/" ++ basename
+ ++ "." ++ hisuf
+ Just fn -> fn
-- figure out if the source has changed, for recompilation avoidance.
-- only do this if we're eventually going to generate a .o file.
-- (ToDo: do when generating .hc files too?)
--
- -- Setting source_unchanged to "-fsource_unchanged" means that M.o seems
+ -- Setting source_unchanged to "-fsource-unchanged" means that M.o seems
-- to be up to date wrt M.hs; so no need to recompile unless imports have
-- changed (which the compiler itself figures out).
-- Setting source_unchanged to "" tells the compiler that M.o is out of
-- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
- do_recomp <- readIORef recomp
+ do_recomp <- readIORef v_Recomp
todo <- readIORef v_GhcMode
- o_file <- odir_ify (basename ++ '.':phase_input_ext Ln)
+ o_file <- odir_ify (basename ++ '.':phaseInputExt Ln)
source_unchanged <-
if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
then return ""
then return "-fsource-unchanged"
else return ""
+ -- build a bogus ModuleLocation to pass to hscMain.
+ let location = ModuleLocation {
+ ml_hs_file = Nothing,
+ ml_hspp_file = Just input_fn,
+ ml_hi_file = Just hifile,
+ ml_obj_file = Just o_file
+ }
+
+ -- get the DynFlags
+ dyn_flags <- readIORef v_DynFlags
+
-- run the compiler!
- run_something "Haskell Compiler"
- (unwords (hsc : input_fn : (
- hsc_opts
- ++ hi_flags
- ++ [
- source_unchanged,
- "-ofile="++output_fn,
- "-F="++tmp_stub_c,
- "-FH="++tmp_stub_h
- ]
- )))
-
- -- check whether compilation was performed, bail out if not
- b <- doesFileExist output_fn
- if not b && not (null source_unchanged) -- sanity
- then do run_something "Touching object file"
- ("touch " ++ o_file)
- return False
- else do -- carry on...
-
- -- Deal with stubs
- let stub_h = basename ++ "_stub.h"
- let stub_c = basename ++ "_stub.c"
-
- -- copy .h_stub file into current dir if present
- b <- doesFileExist tmp_stub_h
- when b (do
- run_something "Copy stub .h file"
- ("cp " ++ tmp_stub_h ++ ' ':stub_h)
-
- -- #include <..._stub.h> in .hc file
- addCmdlineHCInclude tmp_stub_h -- hack
+ pcs <- initPersistentCompilerState
+ result <- hscMain dyn_flags{ hscOutName = output_fn }
+ (source_unchanged == "-fsource-unchanged")
+ location
+ Nothing -- no iface
+ emptyModuleEnv -- HomeSymbolTable
+ emptyModuleEnv -- HomeIfaceTable
+ pcs
- -- copy the _stub.c file into the current dir
- run_something "Copy stub .c file"
- (unwords [
- "rm -f", stub_c, "&&",
- "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
- "cat", tmp_stub_c, ">> ", stub_c
- ])
+ case result of {
- -- compile the _stub.c file w/ gcc
- pipeline <- genPipeline (StopBefore Ln) "" stub_c
- runPipeline pipeline stub_c False{-no linking-} False{-no -o option-}
+ HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1));
+
+ HscOK details maybe_iface maybe_stub_h maybe_stub_c
+ _maybe_interpreted_code pcs -> do
+
+ -- deal with stubs
+ maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
+ case maybe_stub_o of
+ Nothing -> return ()
+ Just stub_o -> add v_Ld_inputs stub_o
- add ld_inputs (basename++"_stub.o")
- )
return True
--}
+ }
-----------------------------------------------------------------------------
-- Cc phase
run_phase cc_phase _basename _suff input_fn output_fn
| cc_phase == Cc || cc_phase == HCc
- = do cc <- readIORef pgm_c
+ = do cc <- readIORef v_Pgm_c
cc_opts <- (getOpts opt_c)
- cmdline_include_dirs <- readIORef include_paths
+ cmdline_include_dirs <- readIORef v_Include_paths
let hcc = cc_phase == HCc
ccout <- newTempName "ccout"
- mangle <- readIORef do_asm_mangling
+ mangle <- readIORef v_Do_asm_mangling
(md_c_flags, md_regd_c_flags) <- machdepCCOpts
verb <- is_verbose
- o2 <- readIORef opt_minus_o2_for_C
+ o2 <- readIORef v_minus_o2_for_C
let opt_flag | o2 = "-O2"
| otherwise = "-O"
pkg_extra_cc_opts <- getPackageExtraCcOpts
- excessPrecision <- readIORef excess_precision
+ excessPrecision <- readIORef v_Excess_precision
run_something "C Compiler"
(unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
-- Mangle phase
run_phase Mangle _basename _suff input_fn output_fn
- = do mangler <- readIORef pgm_m
+ = do mangler <- readIORef v_Pgm_m
mangler_opts <- getOpts opt_m
machdep_opts <-
if (prefixMatch "i386" cTARGETPLATFORM)
-- Splitting phase
run_phase SplitMangle _basename _suff input_fn _output_fn
- = do splitter <- readIORef pgm_s
+ = do splitter <- readIORef v_Pgm_s
-- this is the prefix used for the split .s files
tmp_pfx <- readIORef v_TmpDir
- x <- getProcessID
+ x <- myGetProcessID
let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
- writeIORef split_prefix split_s_prefix
+ writeIORef v_Split_prefix split_s_prefix
addFilesToClean [split_s_prefix ++ "__*"] -- d:-)
-- allocate a tmp file to put the no. of split .s files in (sigh)
-- save the number of split files for future references
s <- readFile n_files
let n = read s :: Int
- writeIORef n_split_files n
+ writeIORef v_N_split_files n
return True
-----------------------------------------------------------------------------
-- As phase
run_phase As _basename _suff input_fn output_fn
- = do as <- readIORef pgm_a
+ = do as <- readIORef v_Pgm_a
as_opts <- getOpts opt_a
- cmdline_include_paths <- readIORef include_paths
+ cmdline_include_paths <- readIORef v_Include_paths
let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
run_something "Assembler"
(unwords (as : as_opts
return True
run_phase SplitAs basename _suff _input_fn _output_fn
- = do as <- readIORef pgm_a
+ = do as <- readIORef v_Pgm_a
as_opts <- getOpts opt_a
- split_s_prefix <- readIORef split_prefix
- n <- readIORef n_split_files
+ split_s_prefix <- readIORef v_Split_prefix
+ n <- readIORef v_N_split_files
- odir <- readIORef output_dir
+ odir <- readIORef v_Output_dir
let real_odir = case odir of
Nothing -> basename
Just d -> d
doLink :: [String] -> IO ()
doLink o_files = do
- ln <- readIORef pgm_l
+ ln <- readIORef v_Pgm_l
verb <- is_verbose
- o_file <- readIORef output_file
+ o_file <- readIORef v_Output_file
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
pkg_lib_paths <- getPackageLibraryPath
let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
- lib_paths <- readIORef library_paths
+ lib_paths <- readIORef v_Library_paths
let lib_path_opts = map ("-L"++) lib_paths
pkg_libs <- getPackageLibraries
let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
- libs <- readIORef cmdline_libraries
+ libs <- readIORef v_Cmdline_libraries
let lib_opts = map ("-l"++) (reverse libs)
-- reverse because they're added in reverse order from the cmd line
pkg_extra_ld_opts <- getPackageExtraLdOpts
-- probably _stub.o files
- extra_ld_inputs <- readIORef ld_inputs
+ extra_ld_inputs <- readIORef v_Ld_inputs
-- opts from -optl-<blah>
- extra_ld_opts <- getStaticOpts opt_l
+ extra_ld_opts <- getStaticOpts v_Opt_l
run_something "Linker"
(unwords
ASSERT(haskellish_file filename)
do pipeline <- genPipeline (StopBefore Hsc) ("preprocess") filename
runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
+
+
+-----------------------------------------------------------------------------
+-- Compile a single module, under the control of the compilation manager.
+--
+-- This is the interface between the compilation manager and the
+-- compiler proper (hsc), where we deal with tedious details like
+-- reading the OPTIONS pragma from the source file, and passing the
+-- output of hsc through the C compiler.
+
+-- The driver sits between 'compile' and 'hscMain', translating calls
+-- to the former into calls to the latter, and results from the latter
+-- into results from the former. It does things like preprocessing
+-- the .hs file if necessary, and compiling up the .stub_c files to
+-- generate Linkables.
+
+compile :: ModSummary -- summary, including source
+ -> Maybe ModIface -- old interface, if available
+ -> HomeSymbolTable -- for home module ModDetails
+ -> HomeIfaceTable -- for home module Ifaces
+ -> PersistentCompilerState -- persistent compiler state
+ -> IO CompResult
+
+data CompResult
+ = CompOK ModDetails -- new details (HST additions)
+ (Maybe (ModIface, Linkable))
+ -- summary and code; Nothing => compilation not reqd
+ -- (old summary and code are still valid)
+ PersistentCompilerState -- updated PCS
+
+ | CompErrs PersistentCompilerState -- updated PCS
+
+
+compile summary old_iface hst hit pcs = do
+ verb <- readIORef v_Verbose
+ when verb (hPutStrLn stderr
+ (showSDoc (text "compile: compiling"
+ <+> ppr (name_of_summary summary))))
+
+ init_dyn_flags <- readIORef v_InitDynFlags
+ writeIORef v_DynFlags init_dyn_flags
+
+ let location = ms_location summary
+ let input_fn = unJust (ml_hs_file location) "compile:hs"
+
+ when verb (hPutStrLn stderr ("compile: input file " ++ input_fn))
+
+ opts <- getOptionsFromSource input_fn
+ processArgs dynamic_flags opts []
+ dyn_flags <- readIORef v_DynFlags
+
+ hsc_lang <- readIORef v_Hsc_Lang
+ output_fn <- case hsc_lang of
+ HscAsm -> newTempName (phaseInputExt As)
+ HscC -> newTempName (phaseInputExt HCc)
+ HscJava -> newTempName "java" -- ToDo
+ HscInterpreted -> return (error "no output file")
+
+ -- run the compiler
+ hsc_result <- hscMain dyn_flags{ hscOutName = output_fn }
+ (panic "compile:source_unchanged")
+ location old_iface hst hit pcs
+
+ case hsc_result of {
+ HscFail pcs -> return (CompErrs pcs);
+
+ HscOK details maybe_iface
+ maybe_stub_h maybe_stub_c maybe_interpreted_code pcs -> do
+
+ -- if no compilation happened, bail out early
+ case maybe_iface of {
+ Nothing -> return (CompOK details Nothing pcs);
+ Just iface -> do
+
+ let (basename, _) = splitFilename input_fn
+ maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
+ let stub_unlinked = case maybe_stub_o of
+ Nothing -> []
+ Just stub_o -> [ DotO stub_o ]
+
+ hs_unlinked <-
+ case hsc_lang of
+
+ -- in interpreted mode, just return the compiled code
+ -- as our "unlinked" object.
+ HscInterpreted ->
+ case maybe_interpreted_code of
+ Just (code,itbl_env) -> return [Trees code itbl_env]
+ Nothing -> panic "compile: no interpreted code"
+
+ -- we're in batch mode: finish the compilation pipeline.
+ _other -> do pipe <- genPipeline (StopBefore Ln) "" output_fn
+ o_file <- runPipeline pipe output_fn False False
+ return [ DotO o_file ]
+
+ let linkable = LM (moduleName (ms_mod summary))
+ (hs_unlinked ++ stub_unlinked)
+
+ return (CompOK details (Just (iface, linkable)) pcs)
+ }
+ }
+
+-----------------------------------------------------------------------------
+-- stub .h and .c files (for foreign export support)
+
+dealWithStubs basename maybe_stub_h maybe_stub_c
+
+ = do let stub_h = basename ++ "_stub.h"
+ let stub_c = basename ++ "_stub.c"
+
+ -- copy the .stub_h file into the current dir if necessary
+ case maybe_stub_h of
+ Nothing -> return ()
+ Just tmp_stub_h -> do
+ run_something "Copy stub .h file"
+ ("cp " ++ tmp_stub_h ++ ' ':stub_h)
+
+ -- #include <..._stub.h> in .hc file
+ addCmdlineHCInclude tmp_stub_h -- hack
+
+ -- copy the .stub_c file into the current dir, and compile it, if necessary
+ case maybe_stub_c of
+ Nothing -> return Nothing
+ Just tmp_stub_c -> do -- copy the _stub.c file into the current dir
+ run_something "Copy stub .c file"
+ (unwords [
+ "rm -f", stub_c, "&&",
+ "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
+ "cat", tmp_stub_c, ">> ", stub_c
+ ])
+
+ -- compile the _stub.c file w/ gcc
+ pipeline <- genPipeline (StopBefore Ln) "" stub_c
+ stub_o <- runPipeline pipeline stub_c False{-no linking-}
+ False{-no -o option-}
+
+ return (Just stub_o)
projects / ghc-hetmet.git / blobdiff