-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.7 2000/10/26 14:38:42 simonmar Exp $
+-- $Id: DriverPipeline.hs,v 1.25 2000/11/14 17:41:04 sewardj Exp $
--
-- GHC Driver
--
genPipeline, runPipeline,
-- interfaces for the compilation manager (interpreted/batch-mode)
- preprocess, compile,
+ preprocess, compile, CompResult(..),
-- batch-mode linking interface
- doLink,
+ doLink
) where
#include "HsVersions.h"
import DriverPhases
import DriverFlags
import HscMain
-import Finder
import TmpFiles
import HscTypes
import Outputable
import Config
import Util
-import Posix
import Directory
import System
import IOExts
--- import Posix commented out temp by SLPJ to get going on windows
import Exception
import IO
genPipeline
:: GhcMode -- when to stop
-> String -- "stop after" flag (for error messages)
+ -> Bool -- True => output is persistent
+ -> HscLang -- preferred output language for hsc
-> String -- original filename
-> IO [ -- list of phases to run for this file
(Phase,
String) -- output file suffix
]
-genPipeline todo stop_flag filename
+genPipeline todo stop_flag persistent_output lang 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
+ keep_hc <- readIORef v_Keep_hc_files
+ keep_raw_s <- readIORef v_Keep_raw_s_files
+ keep_s <- readIORef v_Keep_s_files
+ osuf <- readIORef v_Object_suf
let
----------- ----- ---- --- -- -- - - -
haskellish = haskellish_suffix suffix
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
- | otherwise = lang
+ -- for a .hc file we need to force lang to HscC
+ real_lang | start_phase == HCc = HscC
+ | otherwise = lang
let
----------- ----- ---- --- -- -- - - -
let
----------- ----- ---- --- -- -- - - -
+ myPhaseInputExt Ln = case osuf of Nothing -> phaseInputExt Ln
+ Just s -> s
+ myPhaseInputExt other = phaseInputExt other
+
annotatePipeline
:: [Phase] -- raw pipeline
-> Phase -- phase to stop before
annotatePipeline [] _ = []
annotatePipeline (Ln:_) _ = []
annotatePipeline (phase:next_phase:ps) stop =
- (phase, keep_this_output, phaseInputExt next_phase)
+ (phase, keep_this_output, myPhaseInputExt next_phase)
: annotatePipeline (next_phase:ps) stop
where
keep_this_output
- | next_phase == stop = Persistent
- | otherwise =
- case next_phase of
+ | next_phase == stop
+ = if persistent_output then Persistent else Temporary
+ | otherwise
+ = case next_phase of
Ln -> Persistent
Mangle | keep_raw_s -> Persistent
As | keep_s -> Persistent
return ofile
else do -- carry on ...
- -- sadly, ghc -E is supposed to write the file to stdout. We
- -- generate <file>.cpp, so we also have to cat the file here.
- when (null phases && phase == Cpp) $
- run_something "Dump pre-processed file to stdout"
- ("cat " ++ output_fn)
-
pipeLoop phases output_fn do_linking use_ofile orig_basename orig_suffix
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
Nothing -> error "outputFileName"
else if keep == Persistent
- then do f <- odir_ify (orig_basename ++ '.':suffix)
- osuf_ify f
+ then odir_ify (orig_basename ++ '.':suffix)
else newTempName suffix
-------------------------------------------------------------------------------
-- 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++" && "
-------------------------------------------------------------------------------
-- Cpp phase
-run_phase Cpp _basename _suff input_fn output_fn
+run_phase Cpp basename suff input_fn output_fn
= do src_opts <- getOptionsFromSource input_fn
- _ <- processArgs dynamic_flags src_opts []
+ unhandled_flags <- processArgs dynamic_flags src_opts []
+
+ when (not (null unhandled_flags))
+ (throwDyn (OtherError (
+ basename ++ "." ++ suff
+ ++ ": static flags are not allowed in {-# OPTIONS #-} pragmas:\n\t"
+ ++ unwords unhandled_flags)) (ExitFailure 1))
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_Object_suf
let osuf = case osuf_opt of
- Nothing -> "o"
+ Nothing -> phaseInputExt Ln
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
+ -- std dependency 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
+-- 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
-- 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)
+ 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
+ ohi <- readIORef v_Output_hi
+ hisuf <- readIORef v_Hi_suf
let hifile = case ohi of
- Nothing -> current_dir ++ {-ToDo: modname!!-}basename
- ++ hisuf
+ Nothing -> 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 True 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
+ -- Setting source_unchanged to False 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 ++ '.':phaseInputExt Ln)
source_unchanged <-
if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
- then return ""
+ then return False
else do t1 <- getModificationTime (basename ++ '.':suff)
o_file_exists <- doesFileExist o_file
if not o_file_exists
- then return "" -- Need to recompile
+ then return False -- Need to recompile
else do t2 <- getModificationTime o_file
if t2 > t1
- then return "-fsource-unchanged"
- else return ""
+ then return True
+ else return False
- -- build a bogus ModSummary to pass to hscMain.
- let summary = ModSummary {
- ms_location = error "no loc",
- ms_ppsource = Just (input_fn, error "no fingerprint"),
- ms_imports = error "no imports"
- }
+ -- build a 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!
pcs <- initPersistentCompilerState
result <- hscMain dyn_flags{ hscOutName = output_fn }
- (error "no Finder!")
- summary
+ source_unchanged
+ location
Nothing -- no iface
emptyModuleEnv -- HomeSymbolTable
emptyModuleEnv -- HomeIfaceTable
- emptyModuleEnv -- PackageIfaceTable
pcs
case result of {
HscOK details maybe_iface maybe_stub_h maybe_stub_c
_maybe_interpreted_code pcs -> do
- -- generate the interface file
- case maybe_iface of
- Nothing -> -- compilation not required
- do run_something "Touching object file" ("touch " ++ o_file)
- return False
-
- Just iface -> do
- -- discover the filename for the .hi file in a roundabout way
- let mod = moduleString (mi_module iface)
- ohi <- readIORef output_hi
- hifile <- case ohi of
- Just fn -> fn
- Nothing -> do hisuf <- readIORef hi_suf
- return (current_dir ++
- '/'mod ++ '.':hisuf)
- -- write out the interface...
- if_hdl <- openFile hifile WriteMode
- printForIface if_hdl (pprIface iface)
- hClose if_hdl
-
- -- deal with stubs
+ -- 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 ld_inputs stub_o
+ Just stub_o -> add v_Ld_inputs stub_o
- return True
+ let keep_going = case maybe_iface of Just _ -> True; Nothing -> False
+ return keep_going
}
-----------------------------------------------------------------------------
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
pkg_extra_cc_opts <- getPackageExtraCcOpts
- excessPrecision <- readIORef excess_precision
+ split_objs <- readIORef v_Split_object_files
+ let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
+ | otherwise = [ ]
+
+ excessPrecision <- readIORef v_Excess_precision
run_something "C Compiler"
(unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
++ [ verb, "-S", "-Wimplicit", opt_flag ]
++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
++ cc_opts
+ ++ split_opt
#ifdef mingw32_TARGET_OS
++ [" -mno-cygwin"]
#endif
-- 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
+ static <- readIORef v_Static
+ let imp = if static then "" else "_imp"
+ no_hs_main <- readIORef v_NoHsMain
+
+ 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
+ let pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) 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
+ rts_pkg <- getPackageDetails ["rts"]
+ std_pkg <- getPackageDetails ["std"]
+#ifdef mingw32_TARGET_OS
+ let extra_os = if static || no_hs_main
+ then []
+-- else [ head (lib_paths (head rts_pkg)) ++ "/Main.dll_o",
+-- head (lib_paths (head std_pkg)) ++ "/PrelMain.dll_o" ]
+ else []
+#endif
+ (md_c_flags, _) <- machdepCCOpts
run_something "Linker"
- (unwords
+ (unwords
([ ln, verb, "-o", output_fn ]
+ ++ md_c_flags
++ o_files
+#ifdef mingw32_TARGET_OS
+ ++ extra_os
+#endif
++ extra_ld_inputs
++ lib_path_opts
++ lib_opts
++ pkg_lib_opts
++ pkg_extra_ld_opts
++ extra_ld_opts
+#ifdef mingw32_TARGET_OS
+ ++ if static then [ "-u _PrelMain_mainIO_closure" , "-u ___init_PrelMain"] else []
+#else
+ ++ [ "-u PrelMain_mainIO_closure" , "-u __init_PrelMain"]
+#endif
)
)
preprocess :: FilePath -> IO FilePath
preprocess filename =
ASSERT(haskellish_file filename)
- do pipeline <- genPipeline (StopBefore Hsc) ("preprocess") filename
+ do pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False
+ defaultHscLang filename
runPipeline pipeline filename False{-no linking-} False{-no -o flag-}
+
-----------------------------------------------------------------------------
--- Compile a single module.
+-- 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
-- the .hs file if necessary, and compiling up the .stub_c files to
-- generate Linkables.
-compile :: Finder -- to find modules
- -> ModSummary -- summary, including source
+compile :: ModSummary -- summary, including source
-> Maybe ModIface -- old interface, if available
- -> HomeSymbolTable -- for home module ModDetails
+ -> HomeSymbolTable -- for home module ModDetails
+ -> HomeIfaceTable -- for home module Ifaces
-> PersistentCompilerState -- persistent compiler state
-> IO CompResult
| CompErrs PersistentCompilerState -- updated PCS
-compile finder summary old_iface hst pcs = do
- verb <- readIORef verbose
- when verb (hPutStrLn stderr ("compile: compiling " ++
- name_of_summary summary))
+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 input_fn = case ms_ppsource summary of
- Just (ppsource, fingerprint) -> ppsource
- Nothing -> hs_file (ms_location summary)
- when verb (hPutStrLn stderr ("compile: input file " ++ input_fn))
+ let location = ms_location summary
+ let input_fn = unJust (ml_hs_file location) "compile:hs"
+ let input_fnpp = unJust (ml_hspp_file location) "compile:hspp"
+
+ when verb (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
- opts <- getOptionsFromSource input_fn
+ opts <- getOptionsFromSource input_fnpp
processArgs dynamic_flags opts []
dyn_flags <- readIORef v_DynFlags
+ let hsc_lang = hscLang dyn_flags
output_fn <- case hsc_lang of
HscAsm -> newTempName (phaseInputExt As)
HscC -> newTempName (phaseInputExt HCc)
HscInterpreted -> return (error "no output file")
-- run the compiler
- hsc_result <- hscMain dyn_flags summary old_iface output_fn hst pcs
+ hsc_result <- hscMain dyn_flags{ hscOutName = output_fn }
+ False -- (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 warns -> do
+ 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 warns);
+ Nothing -> return (CompOK details Nothing pcs);
Just iface -> do
- let (basename, _) = splitFilename (hs_file (ms_location summary))
+ let (basename, _) = splitFilename input_fn
maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
- stub_unlinked <- case maybe_stub_o of
- Nothing -> []
- Just stub_o -> [ DotO stub_o ]
+ let stub_unlinked = case maybe_stub_o of
+ Nothing -> []
+ Just stub_o -> [ DotO stub_o ]
hs_unlinked <-
case hsc_lang of
-- as our "unlinked" object.
HscInterpreted ->
case maybe_interpreted_code of
- Just code -> return (Trees code)
- Nothing -> panic "compile: no interpreted code"
+ 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
+ _other -> do pipe <- genPipeline (StopBefore Ln) "" True
+ hsc_lang 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 warns)
+ return (CompOK details (Just (iface, linkable)) pcs)
}
}
])
-- compile the _stub.c file w/ gcc
- pipeline <- genPipeline (StopBefore Ln) "" stub_c
+ pipeline <- genPipeline (StopBefore Ln) "" True
+ defaultHscLang stub_c
stub_o <- runPipeline pipeline stub_c False{-no linking-}
False{-no -o option-}
projects / ghc-hetmet.git / blobdiff