module DriverPipeline (
oneShot, compileFile,
linkBinary,
preprocess,
compile, compile',
link,
) where
#include "HsVersions.h"
import Packages
import HeaderInfo
import DriverPhases
import SysTools
import HscMain
import Finder
import HscTypes
import Outputable
import Module
import UniqFM ( eltsUFM )
import ErrUtils
import DynFlags
import StaticFlags ( v_Ld_inputs, opt_PIC, opt_Static, WayName(..) )
import Config
import Panic
import Util
import StringBuffer ( hGetStringBuffer )
import BasicTypes ( SuccessFlag(..) )
import Maybes ( expectJust )
import ParserCoreUtils ( getCoreModuleName )
import SrcLoc
import FastString
import LlvmCodeGen ( llvmFixupAsm )
import Exception
import Data.IORef ( readIORef )
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error as IO
import Control.Monad
import Data.List ( isSuffixOf )
import Data.Maybe
import System.Environment
preprocess :: GhcMonad m =>
HscEnv
-> (FilePath, Maybe Phase)
-> m (DynFlags, FilePath)
preprocess hsc_env (filename, mb_phase) =
ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
runPipeline anyHsc hsc_env (filename, mb_phase)
Nothing Temporary Nothing
compile :: GhcMonad m =>
HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> m HomeModInfo
compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch)
type Compiler m a = HscEnv -> ModSummary -> Bool
-> Maybe ModIface -> Maybe (Int, Int)
-> m a
compile' :: GhcMonad m =>
(Compiler m (HscStatus, ModIface, ModDetails),
Compiler m (InteractiveStatus, ModIface, ModDetails),
Compiler m (HscStatus, ModIface, ModDetails))
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> m HomeModInfo
compile' (nothingCompiler, interactiveCompiler, batchCompiler)
hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
= do
let dflags0 = ms_hspp_opts summary
this_mod = ms_mod summary
src_flavour = ms_hsc_src summary
location = ms_location summary
input_fn = expectJust "compile:hs" (ml_hs_file location)
input_fnpp = ms_hspp_file summary
liftIO $ debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
let basename = dropExtension input_fn
let current_dir = case takeDirectory basename of
"" -> "."
d -> d
old_paths = includePaths dflags0
dflags = dflags0 { includePaths = current_dir : old_paths }
hsc_env = hsc_env0 {hsc_dflags = dflags}
let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags)
let next_phase = hscNextPhase dflags src_flavour hsc_lang
output_fn <- liftIO $ getOutputFilename next_phase
Temporary basename dflags next_phase (Just location)
let dflags' = dflags { hscTarget = hsc_lang,
hscOutName = output_fn,
extCoreName = basename ++ ".hcr" }
let hsc_env' = hsc_env { hsc_dflags = dflags' }
let force_recomp = dopt Opt_ForceRecomp dflags
source_unchanged = isJust maybe_old_linkable && not force_recomp
object_filename = ml_obj_file location
let getStubLinkable False = return []
getStubLinkable True
= do stub_o <- compileStub hsc_env' this_mod location
return [ DotO stub_o ]
handleBatch HscNoRecomp
= ASSERT (isJust maybe_old_linkable)
return maybe_old_linkable
handleBatch (HscRecomp hasStub _)
| isHsBoot src_flavour
= do when (isObjectTarget hsc_lang) $
liftIO $ SysTools.touch dflags' "Touching object file"
object_filename
return maybe_old_linkable
| otherwise
= do stub_unlinked <- getStubLinkable hasStub
(hs_unlinked, unlinked_time) <-
case hsc_lang of
HscNothing
-> return ([], ms_hs_date summary)
_other
-> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing)
(Just basename)
Persistent
(Just location)
o_time <- liftIO $ getModificationTime object_filename
return ([DotO object_filename], o_time)
let linkable = LM unlinked_time this_mod
(hs_unlinked ++ stub_unlinked)
return (Just linkable)
handleInterpreted HscNoRecomp
= ASSERT (isJust maybe_old_linkable)
return maybe_old_linkable
handleInterpreted (HscRecomp _hasStub Nothing)
= ASSERT (isHsBoot src_flavour)
return maybe_old_linkable
handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks)))
= do stub_unlinked <- getStubLinkable hasStub
let hs_unlinked = [BCOs comp_bc modBreaks]
unlinked_time = ms_hs_date summary
let linkable = LM unlinked_time this_mod
(hs_unlinked ++ stub_unlinked)
return (Just linkable)
let
runCompiler compiler handle
= do (result, iface, details)
<- compiler hsc_env' summary source_unchanged mb_old_iface
(Just (mod_index, nmods))
linkable <- handle result
return (HomeModInfo{ hm_details = details,
hm_iface = iface,
hm_linkable = linkable })
case hsc_lang of
HscInterpreted ->
runCompiler interactiveCompiler handleInterpreted
HscNothing ->
runCompiler nothingCompiler handleBatch
_other ->
runCompiler batchCompiler handleBatch
compileStub :: GhcMonad m => HscEnv -> Module -> ModLocation
-> m FilePath
compileStub hsc_env mod location = do
let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env)
(moduleName mod) location
_ <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing
(SpecificFile stub_o) Nothing
return stub_o
link :: GhcLink
-> DynFlags
-> Bool
-> HomePackageTable
-> IO SuccessFlag
#ifdef GHCI
link LinkInMemory _ _ _
= do
return Succeeded
#endif
link NoLink _ _ _
= return Succeeded
link LinkBinary dflags batch_attempt_linking hpt
= link' dflags batch_attempt_linking hpt
link LinkDynLib dflags batch_attempt_linking hpt
= link' dflags batch_attempt_linking hpt
#ifndef GHCI
link other _ _ _ = panicBadLink other
#endif
panicBadLink :: GhcLink -> a
panicBadLink other = panic ("link: GHC not built to link this way: " ++
show other)
link' :: DynFlags
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link' dflags batch_attempt_linking hpt
| batch_attempt_linking
= do
let
home_mod_infos = eltsUFM hpt
pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos
linkables = map (expectJust "link".hm_linkable) home_mod_infos
debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
if isNoLink (ghcLink dflags)
then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
return Succeeded
else do
let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
obj_files = concatMap getOfiles linkables
exe_file = exeFileName dflags
linking_needed <- linkingNeeded dflags linkables pkg_deps
if not (dopt Opt_ForceRecomp dflags) && not linking_needed
then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required."))
return Succeeded
else do
debugTraceMsg dflags 1 (ptext (sLit "Linking") <+> text exe_file
<+> text "...")
let link = case ghcLink dflags of
LinkBinary -> linkBinary
LinkDynLib -> linkDynLib
other -> panicBadLink other
link dflags obj_files pkg_deps
debugTraceMsg dflags 3 (text "link: done")
return Succeeded
| otherwise
= do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
text " Main.main not exported; not linking.")
return Succeeded
linkingNeeded :: DynFlags -> [Linkable] -> [PackageId] -> IO Bool
linkingNeeded dflags linkables pkg_deps = do
let exe_file = exeFileName dflags
e_exe_time <- IO.try $ getModificationTime exe_file
case e_exe_time of
Left _ -> return True
Right t -> do
extra_ld_inputs <- readIORef v_Ld_inputs
e_extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs
let (errs,extra_times) = splitEithers e_extra_times
let obj_times = map linkableTime linkables ++ extra_times
if not (null errs) || any (t <) obj_times
then return True
else do
let pkg_map = pkgIdMap (pkgState dflags)
pkg_hslibs = [ (libraryDirs c, lib)
| Just c <- map (lookupPackage pkg_map) pkg_deps,
lib <- packageHsLibs dflags c ]
pkg_libfiles <- mapM (uncurry findHSLib) pkg_hslibs
if any isNothing pkg_libfiles then return True else do
e_lib_times <- mapM (IO.try . getModificationTime)
(catMaybes pkg_libfiles)
let (lib_errs,lib_times) = splitEithers e_lib_times
if not (null lib_errs) || any (t <) lib_times
then return True
else return False
findHSLib :: [String] -> String -> IO (Maybe FilePath)
findHSLib dirs lib = do
let batch_lib_file = "lib" ++ lib <.> "a"
found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
case found of
[] -> return Nothing
(x:_) -> return (Just x)
oneShot :: GhcMonad m =>
HscEnv -> Phase -> [(String, Maybe Phase)] -> m ()
oneShot hsc_env stop_phase srcs = do
o_files <- mapM (compileFile hsc_env stop_phase) srcs
liftIO $ doLink (hsc_dflags hsc_env) stop_phase o_files
compileFile :: GhcMonad m =>
HscEnv -> Phase -> (FilePath, Maybe Phase) -> m FilePath
compileFile hsc_env stop_phase (src, mb_phase) = do
exists <- liftIO $ doesFileExist src
when (not exists) $
ghcError (CmdLineError ("does not exist: " ++ src))
let
dflags = hsc_dflags hsc_env
split = dopt Opt_SplitObjs dflags
mb_o_file = outputFile dflags
ghc_link = ghcLink dflags
output
| StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
| Just o_file <- mb_o_file = SpecificFile o_file
| otherwise = Persistent
stop_phase' = case stop_phase of
As | split -> SplitAs
_ -> stop_phase
( _, out_file) <- runPipeline stop_phase' hsc_env
(src, mb_phase) Nothing output
Nothing
return out_file
doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
doLink dflags stop_phase o_files
| not (isStopLn stop_phase)
= return ()
| otherwise
= case ghcLink dflags of
NoLink -> return ()
LinkBinary -> linkBinary dflags o_files []
LinkDynLib -> linkDynLib dflags o_files []
other -> panicBadLink other
data PipelineOutput
= Temporary
| Persistent
| SpecificFile FilePath
runPipeline
:: GhcMonad m =>
Phase
-> HscEnv
-> (FilePath,Maybe Phase)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> m (DynFlags, FilePath)
runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc
= do
let dflags0 = hsc_dflags hsc_env0
(input_basename, suffix) = splitExtension input_fn
suffix' = drop 1 suffix
basename | Just b <- mb_basename = b
| otherwise = input_basename
dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
hsc_env = hsc_env0 {hsc_dflags = dflags}
start_phase = fromMaybe (startPhase suffix') mb_phase
when (not (start_phase `happensBefore` stop_phase)) $
ghcError (UsageError
("cannot compile this file to desired target: "
++ input_fn))
let get_output_fn = getOutputFilename stop_phase output basename
(dflags', output_fn, maybe_loc) <-
pipeLoop hsc_env start_phase stop_phase input_fn
basename suffix' get_output_fn maybe_loc
case output of
Temporary ->
return (dflags', output_fn)
_other -> liftIO $
do final_fn <- get_output_fn dflags' stop_phase maybe_loc
when (final_fn /= output_fn) $ do
let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
copyWithHeader dflags msg line_prag output_fn final_fn
return (dflags', final_fn)
pipeLoop :: GhcMonad m =>
HscEnv -> Phase -> Phase
-> FilePath -> String -> Suffix
-> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
-> Maybe ModLocation
-> m (DynFlags, FilePath, Maybe ModLocation)
pipeLoop hsc_env phase stop_phase
input_fn orig_basename orig_suff
orig_get_output_fn maybe_loc
| phase `eqPhase` stop_phase
= return (hsc_dflags hsc_env, input_fn, maybe_loc)
| not (phase `happensBefore` stop_phase)
= panic ("pipeLoop: at phase " ++ show phase ++
" but I wanted to stop at phase " ++ show stop_phase)
| otherwise
= do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4
(ptext (sLit "Running phase") <+> ppr phase)
(next_phase, dflags', maybe_loc, output_fn)
<- runPhase phase stop_phase hsc_env orig_basename
orig_suff input_fn orig_get_output_fn maybe_loc
let hsc_env' = hsc_env {hsc_dflags = dflags'}
pipeLoop hsc_env' next_phase stop_phase output_fn
orig_basename orig_suff orig_get_output_fn maybe_loc
getOutputFilename
:: Phase -> PipelineOutput -> String
-> DynFlags -> Phase -> Maybe ModLocation -> IO FilePath
getOutputFilename stop_phase output basename
= func
where
func dflags next_phase maybe_location
| is_last_phase, Persistent <- output = persistent_fn
| is_last_phase, SpecificFile f <- output = return f
| keep_this_output = persistent_fn
| otherwise = newTempName dflags suffix
where
hcsuf = hcSuf dflags
odir = objectDir dflags
osuf = objectSuf dflags
keep_hc = dopt Opt_KeepHcFiles dflags
keep_raw_s = dopt Opt_KeepRawSFiles dflags
keep_s = dopt Opt_KeepSFiles dflags
keep_bc = dopt Opt_KeepLlvmFiles dflags
myPhaseInputExt HCc = hcsuf
myPhaseInputExt StopLn = osuf
myPhaseInputExt other = phaseInputExt other
is_last_phase = next_phase `eqPhase` stop_phase
keep_this_output =
case next_phase of
StopLn -> True
Mangle | keep_raw_s -> True
As | keep_s -> True
LlvmOpt | keep_bc -> True
HCc | keep_hc -> True
_other -> False
suffix = myPhaseInputExt next_phase
persistent_fn
| StopLn <- next_phase = return odir_persistent
| otherwise = return persistent
persistent = basename <.> suffix
odir_persistent
| Just loc <- maybe_location = ml_obj_file loc
| Just d <- odir = d </> persistent
| otherwise = persistent
runPhase :: GhcMonad m =>
Phase
-> Phase
-> HscEnv
-> String
-> String
-> FilePath
-> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
-> Maybe ModLocation
-> m (Phase,
DynFlags,
Maybe ModLocation,
FilePath)
runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do
let dflags = hsc_dflags hsc_env
output_fn <- liftIO $ get_output_fn dflags (Cpp sf) maybe_loc
let unlit_flags = getOpts dflags opt_L
flags = map SysTools.Option unlit_flags ++
[
SysTools.Option "-h"
, SysTools.Option $ reslash Forwards $ normalise input_fn
, SysTools.FileOption "" input_fn
, SysTools.FileOption "" output_fn
]
liftIO $ SysTools.runUnlit dflags flags
return (Cpp sf, dflags, maybe_loc, output_fn)
runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do let dflags0 = hsc_dflags hsc_env
src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
checkProcessArgsResult unhandled_flags
if not (xopt Opt_Cpp dflags1) then do
unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns
return (HsPp sf, dflags1, maybe_loc, input_fn)
else do
output_fn <- liftIO $ get_output_fn dflags1 (HsPp sf) maybe_loc
liftIO $ doCpp dflags1 True False input_fn output_fn
src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
checkProcessArgsResult unhandled_flags
return (HsPp sf, dflags2, maybe_loc, output_fn)
runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
= do let dflags = hsc_dflags hsc_env
if not (dopt Opt_Pp dflags) then
return (Hsc sf, dflags, maybe_loc, input_fn)
else do
let hspp_opts = getOpts dflags opt_F
let orig_fn = basename <.> suff
output_fn <- liftIO $ get_output_fn dflags (Hsc sf) maybe_loc
liftIO $ SysTools.runPp dflags
( [ SysTools.Option orig_fn
, SysTools.Option input_fn
, SysTools.FileOption "" output_fn
] ++
map SysTools.Option hspp_opts
)
src_opts <- liftIO $ getOptionsFromFile dflags output_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags src_opts
handleFlagWarnings dflags1 warns
checkProcessArgsResult unhandled_flags
return (Hsc sf, dflags1, maybe_loc, output_fn)
runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc
= do
let dflags0 = hsc_dflags hsc_env
let current_dir = case takeDirectory basename of
"" -> "."
d -> d
paths = includePaths dflags0
dflags = dflags0 { includePaths = current_dir : paths }
(hspp_buf,mod_name,imps,src_imps) <-
case src_flavour of
ExtCoreFile -> do
m <- liftIO $ getCoreModuleName input_fn
return (Nothing, mkModuleName m, [], [])
_ -> do
buf <- liftIO $ hGetStringBuffer input_fn
(src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
return (Just buf, mod_name, imps, src_imps)
location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
| otherwise = location1
let ohi = outputHi dflags
location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
| otherwise = location2
let expl_o_file = outputFile dflags
location4 | Just ofile <- expl_o_file
, isNoLink (ghcLink dflags)
= location3 { ml_obj_file = ofile }
| otherwise = location3
o_file = ml_obj_file location4
src_timestamp <- liftIO $ getModificationTime (basename <.> suff)
let force_recomp = dopt Opt_ForceRecomp dflags
hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags)
source_unchanged <-
if force_recomp || not (isStopLn stop)
then return False
else do o_file_exists <- liftIO $ doesFileExist o_file
if not o_file_exists
then return False
else do t2 <- liftIO $ getModificationTime o_file
if t2 > src_timestamp
then return True
else return False
let next_phase = hscNextPhase dflags src_flavour hsc_lang
output_fn <- liftIO $ get_output_fn dflags next_phase (Just location4)
let dflags' = dflags { hscTarget = hsc_lang,
hscOutName = output_fn,
extCoreName = basename ++ ".hcr" }
let hsc_env' = hsc_env {hsc_dflags = dflags'}
mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4
let
mod_summary = ModSummary { ms_mod = mod,
ms_hsc_src = src_flavour,
ms_hspp_file = input_fn,
ms_hspp_opts = dflags,
ms_hspp_buf = hspp_buf,
ms_location = location4,
ms_hs_date = src_timestamp,
ms_obj_date = Nothing,
ms_imps = imps,
ms_srcimps = src_imps }
result <- hscCompileOneShot hsc_env'
mod_summary source_unchanged
Nothing
Nothing
case result of
HscNoRecomp
-> do liftIO $ SysTools.touch dflags' "Touching object file" o_file
return (StopLn, dflags', Just location4, o_file)
(HscRecomp hasStub _)
-> do when hasStub $
do stub_o <- compileStub hsc_env' mod location4
liftIO $ consIORef v_Ld_inputs stub_o
when (isHsBoot src_flavour) $
liftIO $ SysTools.touch dflags' "Touching object file" o_file
return (next_phase, dflags', Just location4, output_fn)
runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do
let dflags = hsc_dflags hsc_env
output_fn <- liftIO $ get_output_fn dflags Cmm maybe_loc
liftIO $ doCpp dflags False True input_fn output_fn
return (Cmm, dflags, maybe_loc, output_fn)
runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
= do
let dflags = hsc_dflags hsc_env
let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
let dflags' = dflags { hscTarget = hsc_lang,
hscOutName = output_fn,
extCoreName = basename ++ ".hcr" }
let hsc_env' = hsc_env {hsc_dflags = dflags'}
hscCmmFile hsc_env' input_fn
return (next_phase, dflags, maybe_loc, output_fn)
runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
| cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
= do let dflags = hsc_dflags hsc_env
let cc_opts = getOpts dflags opt_c
hcc = cc_phase `eqPhase` HCc
let cmdline_include_paths = includePaths dflags
pkgs <- if hcc then liftIO (getHCFilePackages input_fn) else return []
pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags
gcc_extra_viac_flags <- liftIO $ getExtraViaCOpts dflags
let pic_c_flags = picCCOpts dflags
let verb = getVerbFlag dflags
pkg_extra_cc_opts <-
if cc_phase `eqPhase` HCc
then return []
else liftIO $ getPackageExtraCcOpts dflags pkgs
#ifdef darwin_TARGET_OS
pkg_framework_paths <- liftIO $ getPackageFrameworkPath dflags pkgs
let cmdline_framework_paths = frameworkPaths dflags
let framework_paths = map ("-F"++)
(cmdline_framework_paths ++ pkg_framework_paths)
#endif
let split_objs = dopt Opt_SplitObjs dflags
split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
| otherwise = [ ]
let cc_opt | optLevel dflags >= 2 = "-O2"
| otherwise = "-O"
let mangle = dopt Opt_DoAsmMangling dflags
next_phase
| hcc && mangle = Mangle
| otherwise = As
output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
let
more_hcc_opts =
#if i386_TARGET_ARCH
(if dopt Opt_ExcessPrecision dflags
then []
else [ "-ffloat-store" ]) ++
#endif
["-fno-strict-aliasing"]
liftIO $ SysTools.runCc dflags (
[ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
then SysTools.Option "c++"
else SysTools.Option "c"] ++
[ SysTools.FileOption "" input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
md_c_flags
++ pic_c_flags
#if defined(mingw32_TARGET_OS)
++ (if thisPackage dflags == basePackageId
then [ "-DCOMPILING_BASE_PACKAGE" ]
else [])
#endif
#ifdef sparc_TARGET_ARCH
++ ["-mcpu=v9"]
#endif
++ (if hcc && mangle
then md_regd_c_flags
else [])
++ (if hcc
then if mangle
then gcc_extra_viac_flags
else filter (=="-fwrapv")
gcc_extra_viac_flags
else [])
++ (if hcc
then more_hcc_opts
else [])
++ [ verb, "-S", "-Wimplicit", cc_opt ]
++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
#ifdef darwin_TARGET_OS
++ framework_paths
#endif
++ cc_opts
++ split_opt
++ include_paths
++ pkg_extra_cc_opts
))
return (next_phase, dflags, maybe_loc, output_fn)
runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do let dflags = hsc_dflags hsc_env
let mangler_opts = getOpts dflags opt_m
#if i386_TARGET_ARCH
machdep_opts <- return [ show (stolen_x86_regs dflags) ]
#else
machdep_opts <- return []
#endif
let split = dopt Opt_SplitObjs dflags
next_phase
| split = SplitMangle
| otherwise = As
output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
liftIO $ SysTools.runMangle dflags (map SysTools.Option mangler_opts
++ [ SysTools.FileOption "" input_fn
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option machdep_opts)
return (next_phase, dflags, maybe_loc, output_fn)
runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc
= liftIO $
do
let dflags = hsc_dflags hsc_env
split_s_prefix <- SysTools.newTempName dflags "split"
let n_files_fn = split_s_prefix
SysTools.runSplit dflags
[ SysTools.FileOption "" input_fn
, SysTools.FileOption "" split_s_prefix
, SysTools.FileOption "" n_files_fn
]
s <- readFile n_files_fn
let n_files = read s :: Int
dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s"
| n <- [1..n_files]]
return (SplitAs, dflags', maybe_loc, "**splitmangle**")
runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= liftIO $
do let dflags = hsc_dflags hsc_env
let as_opts = getOpts dflags opt_a
let cmdline_include_paths = includePaths dflags
output_fn <- get_output_fn dflags StopLn maybe_loc
createDirectoryHierarchy (takeDirectory output_fn)
let (md_c_flags, _) = machdepCCOpts dflags
SysTools.runAs dflags
(map SysTools.Option as_opts
++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
#ifdef sparc_TARGET_ARCH
++ [ SysTools.Option "-mcpu=v9" ]
#endif
++ [ SysTools.Option "-c"
, SysTools.FileOption "" input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option md_c_flags)
return (StopLn, dflags, maybe_loc, output_fn)
runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
= liftIO $ do
let dflags = hsc_dflags hsc_env
output_fn <- get_output_fn dflags StopLn maybe_loc
let base_o = dropExtension output_fn
osuf = objectSuf dflags
split_odir = base_o ++ "_" ++ osuf ++ "_split"
createDirectoryHierarchy split_odir
fs <- getDirectoryContents split_odir
mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
let as_opts = getOpts dflags opt_a
let (split_s_prefix, n) = case splitInfo dflags of
Nothing -> panic "No split info"
Just x -> x
let split_s n = split_s_prefix ++ "__" ++ show n <.> "s"
split_obj n = split_odir </>
takeFileName base_o ++ "__" ++ show n <.> osuf
let (md_c_flags, _) = machdepCCOpts dflags
let assemble_file n
= SysTools.runAs dflags
(map SysTools.Option as_opts ++
#ifdef sparc_TARGET_ARCH
[ SysTools.Option "-mcpu=v9" ] ++
#endif
[ SysTools.Option "-c"
, SysTools.Option "-o"
, SysTools.FileOption "" (split_obj n)
, SysTools.FileOption "" (split_s n)
]
++ map SysTools.Option md_c_flags)
mapM_ assemble_file [1..n]
let ld_r args = SysTools.runLink dflags ([
SysTools.Option "-nostdlib",
SysTools.Option "-nodefaultlibs",
SysTools.Option "-Wl,-r",
SysTools.Option ld_x_flag,
SysTools.Option "-o",
SysTools.FileOption "" output_fn ]
++ map SysTools.Option md_c_flags
++ args)
ld_x_flag | null cLD_X = ""
| otherwise = "-Wl,-x"
if cLdIsGNULd == "YES"
then do
let script = split_odir </> "ld.script"
writeFile script $
"INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
ld_r [SysTools.FileOption "" script]
else do
ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
return (StopLn, dflags, maybe_loc, output_fn)
runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= liftIO $ do
let dflags = hsc_dflags hsc_env
let lo_opts = getOpts dflags opt_lo
let opt_lvl = max 0 (min 2 $ optLevel dflags)
let optFlag = if null lo_opts
then [SysTools.Option (llvmOpts !! opt_lvl)]
else []
output_fn <- get_output_fn dflags LlvmLlc maybe_loc
SysTools.runLlvmOpt dflags
([ SysTools.FileOption "" input_fn,
SysTools.Option "-o",
SysTools.FileOption "" output_fn]
++ optFlag
++ map SysTools.Option lo_opts)
return (LlvmLlc, dflags, maybe_loc, output_fn)
where
llvmOpts = ["-mem2reg", "-O1", "-O2"]
runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= liftIO $ do
let dflags = hsc_dflags hsc_env
let lc_opts = getOpts dflags opt_lc
let opt_lvl = max 0 (min 2 $ optLevel dflags)
#if darwin_TARGET_OS
let nphase = LlvmMangle
#else
let nphase = As
#endif
let rmodel | opt_PIC = "pic"
| not opt_Static = "dynamic-no-pic"
| otherwise = "static"
output_fn <- get_output_fn dflags nphase maybe_loc
SysTools.runLlvmLlc dflags
([ SysTools.Option (llvmOpts !! opt_lvl),
SysTools.Option $ "-relocation-model=" ++ rmodel,
SysTools.FileOption "" input_fn,
SysTools.Option "-o", SysTools.FileOption "" output_fn]
++ map SysTools.Option lc_opts)
return (nphase, dflags, maybe_loc, output_fn)
where
#if darwin_TARGET_OS
llvmOpts = ["-O1", "-O2", "-O2"]
#else
llvmOpts = ["-O1", "-O2", "-O3"]
#endif
runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= liftIO $ do
let dflags = hsc_dflags hsc_env
output_fn <- get_output_fn dflags As maybe_loc
llvmFixupAsm input_fn output_fn
return (As, dflags, maybe_loc, output_fn)
runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc =
panic ("runPhase: don't know how to run phase " ++ show other)
runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
runPhase_MoveBinary dflags input_fn
| WayPar `elem` (wayNames dflags) && not opt_Static =
panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
| WayPar `elem` (wayNames dflags) = do
let sysMan = pgm_sysman dflags
pvm_root <- getEnv "PVM_ROOT"
pvm_arch <- getEnv "PVM_ARCH"
let
pvm_executable_base = "=" ++ input_fn
pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
_ <- tryIO (removeFile pvm_executable)
copy dflags "copying PVM executable" input_fn pvm_executable
writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
return True
| otherwise = return True
mkExtraCObj :: DynFlags -> [String] -> IO FilePath
mkExtraCObj dflags xs
= do cFile <- newTempName dflags "c"
oFile <- newTempName dflags "o"
writeFile cFile $ unlines xs
let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
(md_c_flags, _) = machdepCCOpts dflags
SysTools.runCc dflags
([Option "-c",
FileOption "" cFile,
Option "-o",
FileOption "" oFile] ++
map (FileOption "-I") (includeDirs rtsDetails) ++
map Option md_c_flags)
return oFile
mkRtsOptionsLevelObj :: DynFlags -> IO [FilePath]
mkRtsOptionsLevelObj dflags
= do let mkRtsEnabledObj val
= do fn <- mkExtraCObj dflags
["#include \"Rts.h\"",
"#include \"RtsOpts.h\"",
"const rtsOptsEnabledEnum rtsOptsEnabled = "
++ val ++ ";"]
return [fn]
case rtsOptsEnabled dflags of
RtsOptsNone -> mkRtsEnabledObj "rtsOptsNone"
RtsOptsSafeOnly -> return []
RtsOptsAll -> mkRtsEnabledObj "rtsOptsAll"
mk_pvm_wrapper_script :: String -> String -> String -> String
mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
[
"eval 'exec perl -S $0 ${1+\"$@\"}'",
" if $running_under_some_shell;",
"# =!=!=!=!=!=!=!=!=!=!=!",
"# This script is automatically generated: DO NOT EDIT!!!",
"# Generated by Glasgow Haskell Compiler",
"# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
"#",
"$pvm_executable = '" ++ pvm_executable ++ "';",
"$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
"$SysMan = '" ++ sysMan ++ "';",
"",
"",
"# Now, run the real binary; process the args first",
"$ENV{'PE'} = $pvm_executable_base;",
"$debug = '';",
"$nprocessors = 0; # the default: as many PEs as machines in PVM config",
"@nonPVM_args = ();",
"$in_RTS_args = 0;",
"",
"args: while ($a = shift(@ARGV)) {",
" if ( $a eq '+RTS' ) {",
" $in_RTS_args = 1;",
" } elsif ( $a eq '-RTS' ) {",
" $in_RTS_args = 0;",
" }",
" if ( $a eq '-d' && $in_RTS_args ) {",
" $debug = '-';",
" } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
" $nprocessors = $1;",
" } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
" $nprocessors = $1;",
" } else {",
" push(@nonPVM_args, $a);",
" }",
"}",
"",
"local($return_val) = 0;",
"# Start the parallel execution by calling SysMan",
"system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
"$return_val = $?;",
"# ToDo: fix race condition moving files and flushing them!!",
"system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
"exit($return_val);"
]
getHCFilePackages :: FilePath -> IO [PackageId]
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 stringToPackageId (words rest))
_other ->
return []
linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
linkBinary dflags o_files dep_packages = do
let verb = getVerbFlag dflags
output_fn = exeFileName dflags
pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths)
#ifdef elf_OBJ_FORMAT
get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
| otherwise = ["-L" ++ l]
#else
get_pkg_lib_path_opts l = ["-L" ++ l]
#endif
let lib_paths = libraryPaths dflags
let lib_path_opts = map ("-L"++) lib_paths
let no_hs_main = dopt Opt_NoHsMain dflags
let main_lib | no_hs_main = []
| otherwise = [ "-lHSrtsmain" ]
rtsEnabledObj <- mkRtsOptionsLevelObj dflags
rtsOptsObj <- case rtsOpts dflags of
Just opts ->
do fn <- mkExtraCObj dflags
["char *ghc_rts_opts = " ++ show opts ++ ";"]
return [fn]
Nothing -> return []
pkg_link_opts <- getPackageLinkOpts dflags dep_packages
#ifdef darwin_TARGET_OS
pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
let framework_paths = frameworkPaths dflags
framework_path_opts = map ("-F"++) framework_paths
pkg_frameworks <- getPackageFrameworks dflags dep_packages
let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
let frameworks = cmdlineFrameworks dflags
framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
#endif
extra_ld_inputs <- readIORef v_Ld_inputs
let extra_ld_opts = getOpts dflags opt_l
let ways = wayNames dflags
let
debug_opts | WayDebug `elem` ways = [
#if defined(HAVE_LIBBFD)
"-lbfd", "-liberty"
#endif
]
| otherwise = []
let
thread_opts | WayThreaded `elem` ways = [
#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(openbsd_TARGET_OS) && !defined(haiku_TARGET_OS)
"-lpthread"
#endif
#if defined(osf3_TARGET_OS)
, "-lexc"
#endif
]
| otherwise = []
rc_objs <- maybeCreateManifest dflags output_fn
let (md_c_flags, _) = machdepCCOpts dflags
SysTools.runLink dflags (
[ SysTools.Option verb
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
md_c_flags
#ifdef mingw32_TARGET_OS
++ ["-Wl,--enable-auto-import"]
#endif
++ o_files
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
++ rc_objs
#ifdef darwin_TARGET_OS
++ framework_path_opts
++ framework_opts
#endif
++ pkg_lib_path_opts
++ main_lib
++ rtsEnabledObj
++ rtsOptsObj
++ pkg_link_opts
#ifdef darwin_TARGET_OS
++ pkg_framework_path_opts
++ pkg_framework_opts
#endif
++ debug_opts
++ thread_opts
))
success <- runPhase_MoveBinary dflags output_fn
if success then return ()
else ghcError (InstallationError ("cannot move binary"))
exeFileName :: DynFlags -> FilePath
exeFileName dflags
| Just s <- outputFile dflags =
#if defined(mingw32_HOST_OS)
if null (takeExtension s)
then s <.> "exe"
else s
#else
s
#endif
| otherwise =
#if defined(mingw32_HOST_OS)
"main.exe"
#else
"a.out"
#endif
maybeCreateManifest
:: DynFlags
-> FilePath
-> IO [FilePath]
#ifndef mingw32_TARGET_OS
maybeCreateManifest _ _ = do
return []
#else
maybeCreateManifest dflags exe_filename = do
if not (dopt Opt_GenManifest dflags) then return [] else do
let manifest_filename = exe_filename <.> "manifest"
writeFile manifest_filename $
"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
" <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
" <assemblyIdentity version=\"1.0.0.0\"\n"++
" processorArchitecture=\"X86\"\n"++
" name=\"" ++ dropExtension exe_filename ++ "\"\n"++
" type=\"win32\"/>\n\n"++
" <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
" <security>\n"++
" <requestedPrivileges>\n"++
" <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
" </requestedPrivileges>\n"++
" </security>\n"++
" </trustInfo>\n"++
"</assembly>\n"
if not (dopt Opt_EmbedManifest dflags) then return [] else do
rc_filename <- newTempName dflags "rc"
rc_obj_filename <- newTempName dflags (objectSuf dflags)
writeFile rc_filename $
"1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
let wr_opts = getOpts dflags opt_windres
runWindres dflags $ map SysTools.Option $
["--input="++rc_filename,
"--output="++rc_obj_filename,
"--output-format=coff"]
++ wr_opts
removeFile manifest_filename
return [rc_obj_filename]
#endif
linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
linkDynLib dflags o_files dep_packages = do
let verb = getVerbFlag dflags
let o_file = outputFile dflags
pkgs <- getPreloadPackagesAnd dflags dep_packages
let pkg_lib_paths = collectLibraryPaths pkgs
let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
#ifdef elf_OBJ_FORMAT
get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
| otherwise = ["-L" ++ l]
#else
get_pkg_lib_path_opts l = ["-L" ++ l]
#endif
let lib_paths = libraryPaths dflags
let lib_path_opts = map ("-L"++) lib_paths
#if !defined(mingw32_HOST_OS)
let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs
#else
let pkgs_no_rts = pkgs
#endif
let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
extra_ld_inputs <- readIORef v_Ld_inputs
let (md_c_flags, _) = machdepCCOpts dflags
let extra_ld_opts = getOpts dflags opt_l
rtsEnabledObj <- mkRtsOptionsLevelObj dflags
#if defined(mingw32_HOST_OS)
let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
SysTools.runLink dflags
([ SysTools.Option verb
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
, SysTools.Option "-shared"
] ++
[ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
| dopt Opt_SharedImplib dflags
]
++ map (SysTools.FileOption "") o_files
++ map SysTools.Option (
md_c_flags
++ ["-Wl,--enable-auto-import"]
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ rtsEnabledObj
++ pkg_link_opts
))
#elif defined(darwin_TARGET_OS)
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
instName <- case dylibInstallName dflags of
Just n -> return n
Nothing -> do
pwd <- getCurrentDirectory
return $ pwd `combine` output_fn
SysTools.runLink dflags
([ SysTools.Option verb
, SysTools.Option "-dynamiclib"
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
md_c_flags
++ o_files
++ [ "-undefined", "dynamic_lookup", "-single_module",
#if !defined(x86_64_TARGET_ARCH)
"-Wl,-read_only_relocs,suppress",
#endif
"-install_name", instName ]
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ rtsEnabledObj
++ pkg_link_opts
))
#else
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
let buildingRts = thisPackage dflags == rtsPackageId
let bsymbolicFlag = if buildingRts
then
[]
else
["-Wl,-Bsymbolic"]
SysTools.runLink dflags
([ SysTools.Option verb
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
md_c_flags
++ o_files
++ [ "-shared" ]
++ bsymbolicFlag
++ [ "-Wl,-h," ++ takeFileName output_fn ]
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ rtsEnabledObj
++ pkg_link_opts
))
#endif
doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
doCpp dflags raw include_cc_opts input_fn output_fn = do
let hscpp_opts = getOpts dflags opt_P
let cmdline_include_paths = includePaths dflags
pkg_include_dirs <- getPackageIncludePath dflags []
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
let verb = getVerbFlag dflags
let cc_opts
| not include_cc_opts = []
| otherwise = (optc ++ md_c_flags)
where
optc = getOpts dflags opt_c
(md_c_flags, _) = machdepCCOpts dflags
let cpp_prog args | raw = SysTools.runCpp dflags args
| otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
let target_defs =
[ "-D" ++ HOST_OS ++ "_BUILD_OS=1",
"-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1",
"-D" ++ TARGET_OS ++ "_HOST_OS=1",
"-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
cpp_prog ([SysTools.Option verb]
++ map SysTools.Option include_paths
++ map SysTools.Option hsSourceCppOpts
++ map SysTools.Option target_defs
++ map SysTools.Option hscpp_opts
++ map SysTools.Option cc_opts
++ [ SysTools.Option "-x"
, SysTools.Option "c"
, SysTools.Option input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
])
hsSourceCppOpts :: [String]
hsSourceCppOpts =
[ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
hscNextPhase _ HsBootFile _ = StopLn
hscNextPhase dflags _ hsc_lang =
case hsc_lang of
HscC -> HCc
HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
| otherwise -> As
HscLlvm -> LlvmOpt
HscNothing -> StopLn
HscInterpreted -> StopLn
_other -> StopLn
hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
hscMaybeAdjustTarget dflags stop _ current_hsc_lang
= hsc_lang
where
keep_hc = dopt Opt_KeepHcFiles dflags
hsc_lang
| current_hsc_lang == HscInterpreted = current_hsc_lang
| HCc <- stop = HscC
| keep_hc = HscC
| otherwise = current_hsc_lang