module DriverPipeline (
oneShot, compileFile,
linkBinary,
preprocess,
compileOne, compileOne',
link,
PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,
hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
runPhase, exeFileName,
maybeCreateManifest,
linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
) where
#include "HsVersions.h"
import GhcPrelude
import PipelineMonad
import Packages
import HeaderInfo
import DriverPhases
import SysTools
import SysTools.ExtraObj
import HscMain
import Finder
import HscTypes hiding ( Hsc )
import Outputable
import Module
import ErrUtils
import DynFlags
import Config
import Panic
import Util
import StringBuffer ( hGetStringBuffer, hPutStringBuffer )
import BasicTypes ( SuccessFlag(..) )
import Maybes ( expectJust )
import SrcLoc
import LlvmCodeGen ( llvmFixupAsm, llvmVersionList )
import MonadUtils
import Platform
import TcRnTypes
import Hooks
import qualified GHC.LanguageExtensions as LangExt
import FileCleanup
import Ar
import Bag ( unitBag )
import FastString ( mkFastString )
import Exception
import System.Directory
import System.FilePath
import System.IO
import Control.Monad
import Data.List ( isInfixOf, isSuffixOf, intercalate )
import Data.Maybe
import Data.Version
import Data.Either ( partitionEithers )
import Data.Time ( UTCTime )
preprocess :: HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess hsc_env input_fn mb_input_buf mb_phase =
handleSourceError (\err -> return (Left (srcErrorMessages err))) $
ghandle handler $
fmap Right $
ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)
Nothing
(Temporary TFL_GhcSession)
Nothing
[]
where
srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
handler (ProgramError msg) = return $ Left $ unitBag $
mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg
handler ex = throwGhcExceptionIO ex
compileOne :: HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne = compileOne' Nothing (Just batchMsg)
compileOne' :: Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' m_tc_result mHscMessage
hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
source_modified0
= do
debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
(status, hmi0) <- hscIncrementalCompile
always_do_basic_recompilation_check
m_tc_result mHscMessage
hsc_env summary source_modified mb_old_iface (mod_index, nmods)
let flags = hsc_dflags hsc_env0
in do unless (gopt Opt_KeepHiFiles flags) $
addFilesToClean flags TFL_CurrentModule $
[ml_hi_file $ ms_location summary]
unless (gopt Opt_KeepOFiles flags) $
addFilesToClean flags TFL_GhcSession $
[ml_obj_file $ ms_location summary]
case (status, hsc_lang) of
(HscUpToDate, _) ->
return hmi0 { hm_linkable = maybe_old_linkable }
(HscNotGeneratingCode, HscNothing) ->
let mb_linkable = if isHsBootOrSig src_flavour
then Nothing
else Just (LM (ms_hs_date summary) this_mod [])
in return hmi0 { hm_linkable = mb_linkable }
(HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"
(_, HscNothing) -> panic "compileOne HscNothing"
(HscUpdateBoot, HscInterpreted) -> do
return hmi0
(HscUpdateBoot, _) -> do
touchObjectFile dflags object_filename
return hmi0
(HscUpdateSig, HscInterpreted) ->
let linkable = LM (ms_hs_date summary) this_mod []
in return hmi0 { hm_linkable = Just linkable }
(HscUpdateSig, _) -> do
output_fn <- getOutputFilename next_phase
(Temporary TFL_CurrentModule) basename dflags
next_phase (Just location)
_ <- runPipeline StopLn hsc_env
(output_fn,
Nothing,
Just (HscOut src_flavour
mod_name HscUpdateSig))
(Just basename)
Persistent
(Just location)
[]
o_time <- getModificationUTCTime object_filename
let linkable = LM o_time this_mod [DotO object_filename]
return hmi0 { hm_linkable = Just linkable }
(HscRecomp cgguts summary, HscInterpreted) -> do
(hasStub, comp_bc, spt_entries) <-
hscInteractive hsc_env cgguts summary
stub_o <- case hasStub of
Nothing -> return []
Just stub_c -> do
stub_o <- compileStub hsc_env stub_c
return [DotO stub_o]
let hs_unlinked = [BCOs comp_bc spt_entries]
unlinked_time = ms_hs_date summary
let linkable = LM unlinked_time (ms_mod summary)
(hs_unlinked ++ stub_o)
return hmi0 { hm_linkable = Just linkable }
(HscRecomp cgguts summary, _) -> do
output_fn <- getOutputFilename next_phase
(Temporary TFL_CurrentModule)
basename dflags next_phase (Just location)
_ <- runPipeline StopLn hsc_env
(output_fn,
Nothing,
Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
(Just basename)
Persistent
(Just location)
[]
o_time <- getModificationUTCTime object_filename
let linkable = LM o_time this_mod [DotO object_filename]
return hmi0 { hm_linkable = Just linkable }
where dflags0 = ms_hspp_opts summary
this_mod = ms_mod summary
location = ms_location summary
input_fn = expectJust "compile:hs" (ml_hs_file location)
input_fnpp = ms_hspp_file summary
mod_graph = hsc_mod_graph hsc_env0
needsLinker = needsTemplateHaskellOrQQ mod_graph
isDynWay = any (== WayDyn) (ways dflags0)
isProfWay = any (== WayProf) (ways dflags0)
internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)
src_flavour = ms_hsc_src summary
mod_name = ms_mod_name summary
next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
object_filename = ml_obj_file location
dflags1 = if dynamicGhc && internalInterpreter &&
not isDynWay && not isProfWay && needsLinker
then gopt_set dflags0 Opt_BuildDynamicToo
else dflags0
dflags2 = if not internalInterpreter && needsLinker
then gopt_set dflags1 Opt_ExternalInterpreter
else dflags1
basename = dropExtension input_fn
current_dir = takeDirectory basename
old_paths = includePaths dflags2
!prevailing_dflags = hsc_dflags hsc_env0
dflags =
dflags2 { includePaths = addQuoteInclude old_paths [current_dir]
, log_action = log_action prevailing_dflags }
hsc_env = hsc_env0 {hsc_dflags = dflags}
hsc_lang = hscTarget dflags
force_recomp = gopt Opt_ForceRecomp dflags
source_modified
| force_recomp = SourceModified
| otherwise = source_modified0
always_do_basic_recompilation_check = case hsc_lang of
HscInterpreted -> True
_ -> False
compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign _ RawObject object_file = return object_file
compileForeign hsc_env lang stub_c = do
let phase = case lang of
LangC -> Cc
LangCxx -> Ccxx
LangObjc -> Cobjc
LangObjcxx -> Cobjcxx
LangAsm -> As True
RawObject -> panic "compileForeign: should be unreachable"
(_, stub_o) <- runPipeline StopLn hsc_env
(stub_c, Nothing, Just (RealPhase phase))
Nothing (Temporary TFL_GhcSession)
Nothing
[]
return stub_o
compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c
compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub dflags hsc_env basename location mod_name = do
empty_stub <- newTempName dflags TFL_CurrentModule "c"
let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"
writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
_ <- runPipeline StopLn hsc_env
(empty_stub, Nothing, Nothing)
(Just basename)
Persistent
(Just location)
[]
return ()
link :: GhcLink
-> DynFlags
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link ghcLink dflags
= lookupHook linkHook l dflags ghcLink dflags
where
l LinkInMemory _ _ _
= if cGhcWithInterpreter == "YES"
then
return Succeeded
else panicBadLink LinkInMemory
l NoLink _ _ _
= return Succeeded
l LinkBinary dflags batch_attempt_linking hpt
= link' dflags batch_attempt_linking hpt
l LinkStaticLib dflags batch_attempt_linking hpt
= link' dflags batch_attempt_linking hpt
l LinkDynLib dflags batch_attempt_linking hpt
= link' dflags batch_attempt_linking hpt
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
staticLink = case ghcLink dflags of
LinkStaticLib -> True
_ -> False
home_mod_infos = eltsHpt hpt
pkg_deps = concatMap (map fst . 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 staticLink dflags
linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps
if not (gopt Opt_ForceRecomp dflags) && not linking_needed
then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.")
return Succeeded
else do
compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")
let link = case ghcLink dflags of
LinkBinary -> linkBinary
LinkStaticLib -> linkStaticLib
LinkDynLib -> linkDynLibCheck
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 -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
linkingNeeded dflags staticLink linkables pkg_deps = do
let exe_file = exeFileName staticLink dflags
e_exe_time <- tryIO $ getModificationUTCTime exe_file
case e_exe_time of
Left _ -> return True
Right t -> do
let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
let (errs,extra_times) = partitionEithers 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_hslibs = [ (collectLibraryPaths dflags [c], lib)
| Just c <- map (lookupInstalledPackage dflags) pkg_deps,
lib <- packageHsLibs dflags c ]
pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
if any isNothing pkg_libfiles then return True else do
e_lib_times <- mapM (tryIO . getModificationUTCTime)
(catMaybes pkg_libfiles)
let (lib_errs,lib_times) = partitionEithers e_lib_times
if not (null lib_errs) || any (t <) lib_times
then return True
else checkLinkInfo dflags pkg_deps exe_file
findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
findHSLib dflags dirs lib = do
let batch_lib_file = if WayDyn `notElem` ways dflags
then "lib" ++ lib <.> "a"
else mkSOName (targetPlatform dflags) lib
found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
case found of
[] -> return Nothing
(x:_) -> return (Just x)
oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
oneShot hsc_env stop_phase srcs = do
o_files <- mapM (compileFile hsc_env stop_phase) srcs
doLink (hsc_dflags hsc_env) stop_phase o_files
compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile hsc_env stop_phase (src, mb_phase) = do
exists <- doesFileExist src
when (not exists) $
throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
let
dflags = hsc_dflags hsc_env
split = gopt Opt_SplitObjs dflags
mb_o_file = outputFile dflags
ghc_link = ghcLink dflags
output
| HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule
| StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
| isJust mb_o_file = SpecificFile
| otherwise = Persistent
stop_phase' = case stop_phase of
As _ | split -> SplitAs
_ -> stop_phase
( _, out_file) <- runPipeline stop_phase' hsc_env
(src, Nothing, fmap RealPhase 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 []
LinkStaticLib -> linkStaticLib dflags o_files []
LinkDynLib -> linkDynLibCheck dflags o_files []
other -> panicBadLink other
runPipeline
:: Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)
mb_basename output maybe_loc foreign_os
= do let
dflags0 = hsc_dflags hsc_env0
dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
hsc_env = hsc_env0 {hsc_dflags = dflags}
(input_basename, suffix) = splitExtension input_fn
suffix' = drop 1 suffix
basename | Just b <- mb_basename = b
| otherwise = input_basename
start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase
isHaskell (RealPhase (Unlit _)) = True
isHaskell (RealPhase (Cpp _)) = True
isHaskell (RealPhase (HsPp _)) = True
isHaskell (RealPhase (Hsc _)) = True
isHaskell (HscOut {}) = True
isHaskell _ = False
isHaskellishFile = isHaskell start_phase
env = PipeEnv{ stop_phase,
src_filename = input_fn,
src_basename = basename,
src_suffix = suffix',
output_spec = output }
when (isBackpackishSuffix suffix') $
throwGhcExceptionIO (UsageError
("use --backpack to process " ++ input_fn))
let happensBefore' = happensBefore dflags
case start_phase of
RealPhase start_phase' ->
when (not (start_phase' `happensBefore'` stop_phase ||
start_phase' `eqPhase` stop_phase)) $
throwGhcExceptionIO (UsageError
("cannot compile this file to desired target: "
++ input_fn))
HscOut {} -> return ()
input_fn' <- case (start_phase, mb_input_buf) of
(RealPhase real_start_phase, Just input_buf) -> do
let suffix = phaseInputExt real_start_phase
fn <- newTempName dflags TFL_CurrentModule suffix
hdl <- openBinaryFile fn WriteMode
hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"
hPutStringBuffer hdl input_buf
hClose hdl
return fn
(_, _) -> return input_fn
debugTraceMsg dflags 4 (text "Running the pipeline")
r <- runPipeline' start_phase hsc_env env input_fn'
maybe_loc foreign_os
let dflags = hsc_dflags hsc_env
when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do
when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
debugTraceMsg dflags 4
(text "Running the pipeline again for -dynamic-too")
let dflags' = dynamicTooMkDynamicDynFlags dflags
hsc_env' <- newHscEnv dflags'
_ <- runPipeline' start_phase hsc_env' env input_fn'
maybe_loc foreign_os
return ()
return r
runPipeline'
:: PhasePlus
-> HscEnv
-> PipeEnv
-> FilePath
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline' start_phase hsc_env env input_fn
maybe_loc foreign_os
= do
let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }
evalP (pipeLoop start_phase input_fn) env state
pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
pipeLoop phase input_fn = do
env <- getPipeEnv
dflags <- getDynFlags
let happensBefore' = happensBefore dflags
stopPhase = stop_phase env
case phase of
RealPhase realPhase | realPhase `eqPhase` stopPhase
->
case output_spec env of
Temporary _ ->
return (dflags, input_fn)
output ->
do pst <- getPipeState
final_fn <- liftIO $ getOutputFilename
stopPhase output (src_basename env)
dflags stopPhase (maybe_loc pst)
when (final_fn /= input_fn) $ do
let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
return (dflags, final_fn)
| not (realPhase `happensBefore'` stopPhase)
-> panic ("pipeLoop: at phase " ++ show realPhase ++
" but I wanted to stop at phase " ++ show stopPhase)
_
-> do liftIO $ debugTraceMsg dflags 4
(text "Running phase" <+> ppr phase)
(next_phase, output_fn) <- runHookedPhase phase input_fn dflags
r <- pipeLoop next_phase output_fn
case phase of
HscOut {} ->
whenGeneratingDynamicToo dflags $ do
setDynFlags $ dynamicTooMkDynamicDynFlags dflags
_ <- pipeLoop phase input_fn
return ()
_ ->
return ()
return r
runHookedPhase :: PhasePlus -> FilePath -> DynFlags
-> CompPipeline (PhasePlus, FilePath)
runHookedPhase pp input dflags =
lookupHook runPhaseHook runPhase dflags pp input dflags
phaseOutputFilename :: Phase -> CompPipeline FilePath
phaseOutputFilename next_phase = do
PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
PipeState{maybe_loc, hsc_env} <- getPipeState
let dflags = hsc_dflags hsc_env
liftIO $ getOutputFilename stop_phase output_spec
src_basename dflags next_phase maybe_loc
getOutputFilename
:: Phase -> PipelineOutput -> String
-> DynFlags -> Phase -> Maybe ModLocation -> IO FilePath
getOutputFilename stop_phase output basename dflags next_phase maybe_location
| is_last_phase, Persistent <- output = persistent_fn
| is_last_phase, SpecificFile <- output = case outputFile dflags of
Just f -> return f
Nothing ->
panic "SpecificFile: No filename"
| keep_this_output = persistent_fn
| Temporary lifetime <- output = newTempName dflags lifetime suffix
| otherwise = newTempName dflags TFL_CurrentModule
suffix
where
hcsuf = hcSuf dflags
odir = objectDir dflags
osuf = objectSuf dflags
keep_hc = gopt Opt_KeepHcFiles dflags
keep_hscpp = gopt Opt_KeepHscppFiles dflags
keep_s = gopt Opt_KeepSFiles dflags
keep_bc = gopt Opt_KeepLlvmFiles dflags
myPhaseInputExt HCc = hcsuf
myPhaseInputExt MergeForeign = osuf
myPhaseInputExt StopLn = osuf
myPhaseInputExt other = phaseInputExt other
is_last_phase = next_phase `eqPhase` stop_phase
keep_this_output =
case next_phase of
As _ | keep_s -> True
LlvmOpt | keep_bc -> True
HCc | keep_hc -> True
HsPp _ | keep_hscpp -> 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
fastLlvmPipeline :: DynFlags -> Bool
fastLlvmPipeline dflags
= not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags
llvmOptions :: DynFlags
-> [(String, String)]
llvmOptions dflags =
[("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
++ [("-relocation-model=" ++ rmodel
,"-relocation-model=" ++ rmodel) | not (null rmodel)]
++ [("-stack-alignment=" ++ (show align)
,"-stack-alignment=" ++ (show align)) | align > 0 ]
++ [("", "-filetype=obj") | fastLlvmPipeline dflags ]
++ [("", "-mcpu=" ++ mcpu) | not (null mcpu)
, not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]
++ [("", "-mattr=" ++ attrs) | not (null attrs) ]
where target = LLVM_TARGET
Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags)
rmodel | gopt Opt_PIC dflags = "pic"
| positionIndependent dflags = "pic"
| WayDyn `elem` ways dflags = "dynamic-no-pic"
| otherwise = "static"
align :: Int
align = case platformArch (targetPlatform dflags) of
ArchX86_64 | isAvxEnabled dflags -> 32
_ -> 0
attrs :: String
attrs = intercalate "," $ mattr
++ ["+sse42" | isSse4_2Enabled dflags ]
++ ["+sse2" | isSse2Enabled dflags ]
++ ["+sse" | isSseEnabled dflags ]
++ ["+avx512f" | isAvx512fEnabled dflags ]
++ ["+avx2" | isAvx2Enabled dflags ]
++ ["+avx" | isAvxEnabled dflags ]
++ ["+avx512cd"| isAvx512cdEnabled dflags ]
++ ["+avx512er"| isAvx512erEnabled dflags ]
++ ["+avx512pf"| isAvx512pfEnabled dflags ]
++ ["+bmi" | isBmiEnabled dflags ]
++ ["+bmi2" | isBmi2Enabled dflags ]
runPhase :: PhasePlus
-> FilePath
-> DynFlags
-> CompPipeline (PhasePlus,
FilePath)
runPhase (RealPhase (Unlit sf)) input_fn dflags
= do
output_fn <- phaseOutputFilename (Cpp sf)
let flags = [
SysTools.Option "-h"
, SysTools.Option $ escape input_fn
, SysTools.FileOption "" input_fn
, SysTools.FileOption "" output_fn
]
liftIO $ SysTools.runUnlit dflags flags
return (RealPhase (Cpp sf), output_fn)
where
escape ('\\':cs) = '\\':'\\': escape cs
escape ('\"':cs) = '\\':'\"': escape cs
escape ('\'':cs) = '\\':'\'': escape cs
escape (c:cs) = c : escape cs
escape [] = []
runPhase (RealPhase (Cpp sf)) input_fn dflags0
= do
src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicFilePragma dflags0 src_opts
setDynFlags dflags1
liftIO $ checkProcessArgsResult dflags1 unhandled_flags
if not (xopt LangExt.Cpp dflags1) then do
unless (gopt Opt_Pp dflags1) $
liftIO $ handleFlagWarnings dflags1 warns
return (RealPhase (HsPp sf), input_fn)
else do
output_fn <- phaseOutputFilename (HsPp sf)
liftIO $ doCpp dflags1 True
input_fn output_fn
src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- liftIO $ parseDynamicFilePragma dflags0 src_opts
liftIO $ checkProcessArgsResult dflags2 unhandled_flags
unless (gopt Opt_Pp dflags2) $
liftIO $ handleFlagWarnings dflags2 warns
setDynFlags dflags2
return (RealPhase (HsPp sf), output_fn)
runPhase (RealPhase (HsPp sf)) input_fn dflags
= do
if not (gopt Opt_Pp dflags) then
return (RealPhase (Hsc sf), input_fn)
else do
PipeEnv{src_basename, src_suffix} <- getPipeEnv
let orig_fn = src_basename <.> src_suffix
output_fn <- phaseOutputFilename (Hsc sf)
liftIO $ SysTools.runPp dflags
( [ SysTools.Option orig_fn
, SysTools.Option input_fn
, SysTools.FileOption "" output_fn
]
)
src_opts <- liftIO $ getOptionsFromFile dflags output_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicFilePragma dflags src_opts
setDynFlags dflags1
liftIO $ checkProcessArgsResult dflags1 unhandled_flags
liftIO $ handleFlagWarnings dflags1 warns
return (RealPhase (Hsc sf), output_fn)
runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
= do
PipeEnv{ stop_phase=stop,
src_basename=basename,
src_suffix=suff } <- getPipeEnv
let current_dir = takeDirectory basename
new_includes = addQuoteInclude paths [current_dir]
paths = includePaths dflags0
dflags = dflags0 { includePaths = new_includes }
setDynFlags dflags
(hspp_buf,mod_name,imps,src_imps) <- liftIO $ do
do
buf <- hGetStringBuffer input_fn
eimps <- getImports dflags buf input_fn (basename <.> suff)
case eimps of
Left errs -> throwErrors errs
Right (src_imps,imps,L _ mod_name) -> return
(Just buf, mod_name, imps, src_imps)
location <- getLocation src_flavour mod_name
let o_file = ml_obj_file location
hi_file = ml_hi_file location
hie_file = ml_hie_file location
dest_file | writeInterfaceOnlyMode dflags
= hi_file
| otherwise
= o_file
src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
source_unchanged <- liftIO $
if not (isStopLn stop)
then return SourceModified
else do dest_file_mod <- sourceModified dest_file src_timestamp
hie_file_mod <- if gopt Opt_WriteHie dflags
then sourceModified hie_file
src_timestamp
else pure False
if dest_file_mod || hie_file_mod
then return SourceModified
else return SourceUnmodified
PipeState{hsc_env=hsc_env'} <- getPipeState
mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location
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 = location,
ms_hs_date = src_timestamp,
ms_obj_date = Nothing,
ms_parsed_mod = Nothing,
ms_iface_date = Nothing,
ms_hie_date = Nothing,
ms_textual_imps = imps,
ms_srcimps = src_imps }
let msg hsc_env _ what _ = oneShotMsg hsc_env what
(result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
mod_summary source_unchanged Nothing (1,1)
return (HscOut src_flavour mod_name result,
panic "HscOut doesn't have an input filename")
runPhase (HscOut src_flavour mod_name result) _ dflags = do
location <- getLocation src_flavour mod_name
setModLocation location
let o_file = ml_obj_file location
hsc_lang = hscTarget dflags
next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
case result of
HscNotGeneratingCode ->
return (RealPhase StopLn,
panic "No output filename from Hsc when no-code")
HscUpToDate ->
do liftIO $ touchObjectFile dflags o_file
return (RealPhase StopLn, o_file)
HscUpdateBoot ->
do
liftIO $ touchObjectFile dflags o_file
return (RealPhase StopLn, o_file)
HscUpdateSig ->
do
PipeState{hsc_env=hsc_env'} <- getPipeState
let input_fn = expectJust "runPhase" (ml_hs_file location)
basename = dropExtension input_fn
liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name
return (RealPhase StopLn, o_file)
HscRecomp cgguts mod_summary
-> do output_fn <- phaseOutputFilename next_phase
PipeState{hsc_env=hsc_env'} <- getPipeState
(outputFilename, mStub, foreign_files) <- liftIO $
hscGenHardCode hsc_env' cgguts mod_summary output_fn
stub_o <- liftIO (mapM (compileStub hsc_env') mStub)
foreign_os <- liftIO $
mapM (uncurry (compileForeign hsc_env')) foreign_files
setForeignOs (maybe [] return stub_o ++ foreign_os)
return (RealPhase next_phase, outputFilename)
runPhase (RealPhase CmmCpp) input_fn dflags
= do
output_fn <- phaseOutputFilename Cmm
liftIO $ doCpp dflags False
input_fn output_fn
return (RealPhase Cmm, output_fn)
runPhase (RealPhase Cmm) input_fn dflags
= do
let hsc_lang = hscTarget dflags
let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang
output_fn <- phaseOutputFilename next_phase
PipeState{hsc_env} <- getPipeState
liftIO $ hscCompileCmmFile hsc_env input_fn output_fn
return (RealPhase next_phase, output_fn)
runPhase (RealPhase cc_phase) input_fn dflags
| any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]
= do
let platform = targetPlatform dflags
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_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
(includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
(includePathsQuote cmdline_include_paths)
let include_paths = include_paths_quote ++ include_paths_global
let more_preprocessor_opts = concat
[ ["-Xpreprocessor", i]
| not hcc
, i <- getOpts dflags opt_P
]
let gcc_extra_viac_flags = extraGccViaCFlags dflags
let pic_c_flags = picCCOpts dflags
let verbFlags = getVerbFlags dflags
pkg_extra_cc_opts <- liftIO $
if hcc
then return []
else getPackageExtraCcOpts dflags pkgs
framework_paths <-
if platformUsesFrameworks platform
then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs
let cmdlineFrameworkPaths = frameworkPaths dflags
return $ map ("-F"++)
(cmdlineFrameworkPaths ++ pkgFrameworkPaths)
else return []
let cc_opt | optLevel dflags >= 2 = [ "-O2" ]
| optLevel dflags >= 1 = [ "-O" ]
| otherwise = []
let next_phase = As False
output_fn <- phaseOutputFilename next_phase
let
more_hcc_opts =
(if platformArch platform == ArchX86 &&
not (gopt Opt_ExcessPrecision dflags)
then [ "-ffloat-store" ]
else []) ++
["-fno-strict-aliasing"]
ghcVersionH <- liftIO $ getGhcVersionPathName dflags
let gcc_lang_opt | cc_phase `eqPhase` Ccxx = "c++"
| cc_phase `eqPhase` Cobjc = "objective-c"
| cc_phase `eqPhase` Cobjcxx = "objective-c++"
| otherwise = "c"
liftIO $ SysTools.runCc dflags (
[ SysTools.Option "-x", SysTools.Option gcc_lang_opt
, SysTools.FileOption "" input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
pic_c_flags
++ (if platformOS platform == OSMinGW32 &&
thisPackage dflags == baseUnitId
then [ "-DCOMPILING_BASE_PACKAGE" ]
else [])
++ (if platformArch platform == ArchSPARC
then ["-mcpu=v9"]
else [])
++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
then ["-Wimplicit"]
else [])
++ (if hcc
then gcc_extra_viac_flags ++ more_hcc_opts
else [])
++ verbFlags
++ [ "-S" ]
++ cc_opt
++ [ "-include", ghcVersionH ]
++ framework_paths
++ include_paths
++ more_preprocessor_opts
++ pkg_extra_cc_opts
))
return (RealPhase next_phase, output_fn)
runPhase (RealPhase Splitter) input_fn dflags
= do
split_s_prefix <-
liftIO $ newTempName dflags TFL_CurrentModule "split"
let n_files_fn = split_s_prefix
liftIO $ SysTools.runSplit dflags
[ SysTools.FileOption "" input_fn
, SysTools.FileOption "" split_s_prefix
, SysTools.FileOption "" n_files_fn
]
s <- liftIO $ readFile n_files_fn
let n_files = read s :: Int
dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
setDynFlags dflags'
liftIO $ addFilesToClean dflags' TFL_CurrentModule $
[ split_s_prefix ++ "__" ++ show n ++ ".s"
| n <- [1..n_files]]
return (RealPhase SplitAs,
"**splitter**")
runPhase (RealPhase (As with_cpp)) input_fn dflags
= do
let whichAsProg | hscTarget dflags == HscLlvm &&
platformOS (targetPlatform dflags) == OSDarwin
= return SysTools.runClang
| otherwise = return SysTools.runAs
as_prog <- whichAsProg
let cmdline_include_paths = includePaths dflags
let pic_c_flags = picCCOpts dflags
next_phase <- maybeMergeForeign
output_fn <- phaseOutputFilename next_phase
liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
ccInfo <- liftIO $ getCompilerInfo dflags
let global_includes = [ SysTools.Option ("-I" ++ p)
| p <- includePathsGlobal cmdline_include_paths ]
let local_includes = [ SysTools.Option ("-iquote" ++ p)
| p <- includePathsQuote cmdline_include_paths ]
let runAssembler inputFilename outputFilename
= liftIO $ as_prog dflags
(local_includes ++ global_includes
++ map SysTools.Option pic_c_flags
++ [ SysTools.Option "-Wa,-mbig-obj"
| platformOS (targetPlatform dflags) == OSMinGW32
, not $ target32Bit (targetPlatform dflags)
]
++ (if platformArch (targetPlatform dflags) == ArchSPARC
then [SysTools.Option "-mcpu=v9"]
else [])
++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
then [SysTools.Option "-Qunused-arguments"]
else [])
++ [ SysTools.Option "-x"
, if with_cpp
then SysTools.Option "assembler-with-cpp"
else SysTools.Option "assembler"
, SysTools.Option "-c"
, SysTools.FileOption "" inputFilename
, SysTools.Option "-o"
, SysTools.FileOption "" outputFilename
])
liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
runAssembler input_fn output_fn
return (RealPhase next_phase, output_fn)
runPhase (RealPhase SplitAs) _input_fn dflags
= do
let next_phase = StopLn
output_fn <- phaseOutputFilename next_phase
let base_o = dropExtension output_fn
osuf = objectSuf dflags
split_odir = base_o ++ "_" ++ osuf ++ "_split"
let pic_c_flags = picCCOpts dflags
liftIO $ createDirectoryIfMissing True split_odir
fs <- liftIO $ getDirectoryContents split_odir
liftIO $ mapM_ removeFile $
map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
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 :: Int -> FilePath
split_obj n = split_odir </>
takeFileName base_o ++ "__" ++ show n <.> osuf
let assemble_file n
= SysTools.runAs dflags (
(if platformArch (targetPlatform dflags) == ArchSPARC
then [SysTools.Option "-mcpu=v9"]
else []) ++
map SysTools.Option pic_c_flags ++
[ SysTools.Option "-c"
, SysTools.Option "-o"
, SysTools.FileOption "" (split_obj n)
, SysTools.FileOption "" (split_s n)
])
liftIO $ mapM_ assemble_file [1..n]
PipeState{foreign_os} <- getPipeState
if null foreign_os
then return ()
else liftIO $ do
tmp_split_1 <- newTempName dflags TFL_CurrentModule osuf
let split_1 = split_obj 1
copyFile split_1 tmp_split_1
removeFile split_1
joinObjectFiles dflags (tmp_split_1 : foreign_os) split_1
liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
return (RealPhase next_phase, output_fn)
runPhase (RealPhase LlvmOpt) input_fn dflags
= do
output_fn <- phaseOutputFilename LlvmLlc
liftIO $ SysTools.runLlvmOpt dflags
( optFlag
++ defaultOptions ++
[ SysTools.FileOption "" input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn]
)
return (RealPhase LlvmLlc, output_fn)
where
optIdx = max 0 $ min 2 $ optLevel dflags
llvmOpts = case lookup optIdx $ llvmPasses dflags of
Just passes -> passes
Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "
++ "is missing passes for level "
++ show optIdx)
optFlag = if null (getOpts dflags opt_lo)
then map SysTools.Option $ words llvmOpts
else []
defaultOptions = map SysTools.Option . concat . fmap words . fst
$ unzip (llvmOptions dflags)
runPhase (RealPhase LlvmLlc) input_fn dflags
= do
next_phase <- if fastLlvmPipeline dflags
then maybeMergeForeign
else case gopt Opt_NoLlvmMangler dflags of
False -> return LlvmMangle
True | gopt Opt_SplitObjs dflags -> return Splitter
True -> return (As False)
output_fn <- phaseOutputFilename next_phase
liftIO $ SysTools.runLlvmLlc dflags
( optFlag
++ defaultOptions
++ [ SysTools.FileOption "" input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
)
return (RealPhase next_phase, output_fn)
where
llvmOpts = case optLevel dflags of
0 -> "-O1"
1 -> "-O1"
_ -> "-O2"
optFlag = if null (getOpts dflags opt_lc)
then map SysTools.Option $ words llvmOpts
else []
defaultOptions = map SysTools.Option . concat . fmap words . snd
$ unzip (llvmOptions dflags)
runPhase (RealPhase LlvmMangle) input_fn dflags
= do
let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False
output_fn <- phaseOutputFilename next_phase
liftIO $ llvmFixupAsm dflags input_fn output_fn
return (RealPhase next_phase, output_fn)
runPhase (RealPhase MergeForeign) input_fn dflags
= do
PipeState{foreign_os} <- getPipeState
output_fn <- phaseOutputFilename StopLn
liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
if null foreign_os
then panic "runPhase(MergeForeign): no foreign objects"
else do
liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn
return (RealPhase StopLn, output_fn)
runPhase (RealPhase other) _input_fn _dflags =
panic ("runPhase: don't know how to run phase " ++ show other)
maybeMergeForeign :: CompPipeline Phase
maybeMergeForeign
= do
PipeState{foreign_os} <- getPipeState
if null foreign_os then return StopLn else return MergeForeign
getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
getLocation src_flavour mod_name = do
dflags <- getDynFlags
PipeEnv{ src_basename=basename,
src_suffix=suff } <- getPipeEnv
PipeState { maybe_loc=maybe_loc} <- getPipeState
case maybe_loc of
Just l -> return $ l
{ ml_hs_file = Just $ basename <.> suff
, ml_hi_file = ml_hi_file l -<.> hiSuf dflags
, ml_obj_file = ml_obj_file l -<.> objectSuf dflags
}
_ -> do
location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
let location2
| HsBootFile <- src_flavour = addBootSuffixLocnOut 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
return location4
getHCFilePackages :: FilePath -> IO [InstalledUnitId]
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 stringToInstalledUnitId (words rest))
_other ->
return []
linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary = linkBinary' False
linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary' staticLink dflags o_files dep_packages = do
let platform = targetPlatform dflags
mySettings = settings dflags
verbFlags = getVerbFlags dflags
output_fn = exeFileName staticLink dflags
full_output_fn <- if isAbsolute output_fn
then return output_fn
else do d <- getCurrentDirectory
return $ normalise (d </> output_fn)
pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
get_pkg_lib_path_opts l
| osElfTarget (platformOS platform) &&
dynLibLoader dflags == SystemDependent &&
WayDyn `elem` ways dflags
= let libpath = if gopt Opt_RelativeDynlibPaths dflags
then "$ORIGIN" </>
(l `makeRelativeTo` full_output_fn)
else l
rpath = if gopt Opt_RPath dflags
then ["-Xlinker", "-rpath", "-Xlinker", libpath]
else []
rpathlink = if (platformOS platform) == OSSolaris2
then []
else ["-Xlinker", "-rpath-link", "-Xlinker", l]
in ["-L" ++ l] ++ rpathlink ++ rpath
| osMachOTarget (platformOS platform) &&
dynLibLoader dflags == SystemDependent &&
WayDyn `elem` ways dflags &&
gopt Opt_RPath dflags
= let libpath = if gopt Opt_RelativeDynlibPaths dflags
then "@loader_path" </>
(l `makeRelativeTo` full_output_fn)
else l
in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
| otherwise = ["-L" ++ l]
pkg_lib_path_opts <-
if gopt Opt_SingleLibFolder dflags
then do
libs <- getLibs dflags dep_packages
tmpDir <- newTempDir dflags
sequence_ [ copyFile lib (tmpDir </> basename)
| (lib, basename) <- libs]
return [ "-L" ++ tmpDir ]
else pure pkg_lib_path_opts
let
dead_strip
| gopt Opt_WholeArchiveHsLibs dflags = []
| otherwise = if osSubsectionsViaSymbols (platformOS platform)
then ["-Wl,-dead_strip"]
else []
let lib_paths = libraryPaths dflags
let lib_path_opts = map ("-L"++) lib_paths
extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
let
(pre_hs_libs, post_hs_libs)
| gopt Opt_WholeArchiveHsLibs dflags
= if platformOS platform == OSDarwin
then (["-Wl,-all_load"], [])
else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
| otherwise
= ([],[])
pkg_link_opts <- do
(package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages
return $ if staticLink
then package_hs_libs
else other_flags ++ dead_strip
++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
++ extra_libs
pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages
let framework_opts = getFrameworkOpts dflags platform
let extra_ld_inputs = ldInputs dflags
let debug_opts | WayDebug `elem` ways dflags = [
#if defined(HAVE_LIBBFD)
"-lbfd", "-liberty"
#endif
]
| otherwise = []
thread_opts | WayThreaded `elem` ways dflags = [
#if NEED_PTHREAD_LIB
"-lpthread"
#endif
]
| otherwise = []
rc_objs <- maybeCreateManifest dflags output_fn
let link = if staticLink
then SysTools.runLibtool
else SysTools.runLink
link dflags (
map SysTools.Option verbFlags
++ [ SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ libmLinkOpts
++ map SysTools.Option (
[]
++ picCCOpts dflags
++ (if platformOS platform == OSMinGW32
then ["-Wl,--enable-auto-import"]
else [])
++ (if sLdSupportsCompactUnwind mySettings &&
not staticLink &&
(platformOS platform == OSDarwin) &&
case platformArch platform of
ArchX86 -> True
ArchX86_64 -> True
ArchARM {} -> True
ArchARM64 -> True
_ -> False
then ["-Wl,-no_compact_unwind"]
else [])
++ (if platformOS platform == OSDarwin &&
platformArch platform == ArchX86 &&
not staticLink
then ["-Wl,-read_only_relocs,suppress"]
else [])
++ (if sLdIsGnuLd mySettings &&
not (gopt Opt_WholeArchiveHsLibs dflags)
then ["-Wl,--gc-sections"]
else [])
++ o_files
++ lib_path_opts)
++ extra_ld_inputs
++ map SysTools.Option (
rc_objs
++ framework_opts
++ pkg_lib_path_opts
++ extraLinkObj:noteLinkObjs
++ pkg_link_opts
++ pkg_framework_opts
++ debug_opts
++ thread_opts
++ (if platformOS platform == OSDarwin
then [ "-Wl,-dead_strip_dylibs" ]
else [])
))
exeFileName :: Bool -> DynFlags -> FilePath
exeFileName staticLink dflags
| Just s <- outputFile dflags =
case platformOS (targetPlatform dflags) of
OSMinGW32 -> s <?.> "exe"
_ -> if staticLink
then s <?.> "a"
else s
| otherwise =
if platformOS (targetPlatform dflags) == OSMinGW32
then "main.exe"
else if staticLink
then "liba.a"
else "a.out"
where s <?.> ext | null (takeExtension s) = s <.> ext
| otherwise = s
maybeCreateManifest
:: DynFlags
-> FilePath
-> IO [FilePath]
maybeCreateManifest dflags exe_filename
| platformOS (targetPlatform dflags) == OSMinGW32 &&
gopt Opt_GenManifest dflags
= 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 (gopt Opt_EmbedManifest dflags) then return [] else do
rc_filename <- newTempName dflags TFL_CurrentModule "rc"
rc_obj_filename <-
newTempName dflags TFL_GhcSession (objectSuf dflags)
writeFile rc_filename $
"1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
runWindres dflags $ map SysTools.Option $
["--input="++rc_filename,
"--output="++rc_obj_filename,
"--output-format=coff"]
removeFile manifest_filename
return [rc_obj_filename]
| otherwise = return []
linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
putLogMsg dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags)
(text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
text " Call hs_init_ghc() from your main() function to set these options.")
linkDynLib dflags o_files dep_packages
linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkStaticLib dflags o_files dep_packages = do
let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
modules = o_files ++ extra_ld_inputs
output_fn = exeFileName True dflags
full_output_fn <- if isAbsolute output_fn
then return output_fn
else do d <- getCurrentDirectory
return $ normalise (d </> output_fn)
output_exists <- doesFileExist full_output_fn
(when output_exists) $ removeFile full_output_fn
pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages
archives <- concat <$> mapM (collectArchives dflags) pkg_cfgs
ar <- foldl mappend
<$> (Archive <$> mapM loadObj modules)
<*> mapM loadAr archives
if sLdIsGnuLd (settings dflags)
then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
runRanlib dflags [SysTools.FileOption "" output_fn]
doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp dflags raw input_fn output_fn = do
let hscpp_opts = picPOpts dflags
let cmdline_include_paths = includePaths dflags
pkg_include_dirs <- getPackageIncludePath dflags []
let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
(includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
(includePathsQuote cmdline_include_paths)
let include_paths = include_paths_quote ++ include_paths_global
let verbFlags = getVerbFlags 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",
"-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
"-D" ++ TARGET_OS ++ "_HOST_OS",
"-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ]
let sse_defs =
[ "-D__SSE__" | isSseEnabled dflags ] ++
[ "-D__SSE2__" | isSse2Enabled dflags ] ++
[ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
let avx_defs =
[ "-D__AVX__" | isAvxEnabled dflags ] ++
[ "-D__AVX2__" | isAvx2Enabled dflags ] ++
[ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
[ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
[ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
[ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
backend_defs <- getBackendDefs dflags
let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
ghcVersionH <- getGhcVersionPathName dflags
let hsSourceCppOpts = [ "-include", ghcVersionH ]
let uids = explicitPackages (pkgState dflags)
pkgs = catMaybes (map (lookupPackage dflags) uids)
mb_macro_include <-
if not (null pkgs) && gopt Opt_VersionMacros dflags
then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
writeFile macro_stub (generatePackageVersionMacros pkgs)
return [SysTools.FileOption "-include" macro_stub]
else return []
cpp_prog ( map SysTools.Option verbFlags
++ map SysTools.Option include_paths
++ map SysTools.Option hsSourceCppOpts
++ map SysTools.Option target_defs
++ map SysTools.Option backend_defs
++ map SysTools.Option th_defs
++ map SysTools.Option hscpp_opts
++ map SysTools.Option sse_defs
++ map SysTools.Option avx_defs
++ mb_macro_include
++ [ SysTools.Option "-x"
, SysTools.Option "assembler-with-cpp"
, SysTools.Option input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
])
getBackendDefs :: DynFlags -> IO [String]
getBackendDefs dflags | hscTarget dflags == HscLlvm = do
llvmVer <- figureLlvmVersion dflags
return $ case fmap llvmVersionList llvmVer of
Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]
Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
_ -> []
where
format (major, minor)
| minor >= 100 = error "getBackendDefs: Unsupported minor version"
| otherwise = show $ (100 * major + minor :: Int)
getBackendDefs _ =
return []
generatePackageVersionMacros :: [PackageConfig] -> String
generatePackageVersionMacros pkgs = concat
[ generateMacros "" pkgname version
| pkg <- pkgs
, let version = packageVersion pkg
pkgname = map fixchar (packageNameString pkg)
]
fixchar :: Char -> Char
fixchar '-' = '_'
fixchar c = c
generateMacros :: String -> String -> Version -> String
generateMacros prefix name version =
concat
["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
," (major1) < ",major1," || \\\n"
," (major1) == ",major1," && (major2) < ",major2," || \\\n"
," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
,"\n\n"
]
where
(major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles dflags o_files output_fn = do
let mySettings = settings dflags
ldIsGnuLd = sLdIsGnuLd mySettings
osInfo = platformOS (targetPlatform dflags)
ld_r args cc = SysTools.runLink dflags ([
SysTools.Option "-nostdlib",
SysTools.Option "-Wl,-r"
]
++ (if sGccSupportsNoPie mySettings
then [SysTools.Option "-no-pie"]
else [])
++ (if any (cc ==) [Clang, AppleClang, AppleClang51]
then []
else [SysTools.Option "-nodefaultlibs"])
++ (if osInfo == OSFreeBSD
then [SysTools.Option "-L/usr/lib"]
else [])
++ (if platformArch (targetPlatform dflags)
`elem` [ArchSPARC, ArchSPARC64]
&& ldIsGnuLd
then [SysTools.Option "-Wl,-no-relax"]
else [])
++ [ SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64"
| OSMinGW32 == osInfo
, not $ target32Bit (targetPlatform dflags)
]
++ map SysTools.Option ld_build_id
++ [ SysTools.Option "-o",
SysTools.FileOption "" output_fn ]
++ args)
ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"]
| otherwise = []
ccInfo <- getCompilerInfo dflags
if ldIsGnuLd
then do
script <- newTempName dflags TFL_CurrentModule "ldscript"
cwd <- getCurrentDirectory
let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
ld_r [SysTools.FileOption "" script] ccInfo
else if sLdSupportsFilelist mySettings
then do
filelist <- newTempName dflags TFL_CurrentModule "filelist"
writeFile filelist $ unlines o_files
ld_r [SysTools.Option "-Wl,-filelist",
SysTools.FileOption "-Wl," filelist] ccInfo
else do
ld_r (map (SysTools.FileOption "") o_files) ccInfo
writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode dflags =
gopt Opt_WriteInterface dflags &&
HscNothing == hscTarget dflags
sourceModified :: FilePath
-> UTCTime
-> IO Bool
sourceModified dest_file src_timestamp = do
dest_file_exists <- doesFileExist dest_file
if not dest_file_exists
then return True
else do t2 <- getModificationUTCTime dest_file
return (t2 <= src_timestamp)
hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
hscPostBackendPhase _ HsBootFile _ = StopLn
hscPostBackendPhase _ HsigFile _ = StopLn
hscPostBackendPhase dflags _ hsc_lang =
case hsc_lang of
HscC -> HCc
HscAsm | gopt Opt_SplitObjs dflags -> Splitter
| otherwise -> As False
HscLlvm -> LlvmOpt
HscNothing -> StopLn
HscInterpreted -> StopLn
touchObjectFile :: DynFlags -> FilePath -> IO ()
touchObjectFile dflags path = do
createDirectoryIfMissing True $ takeDirectory path
SysTools.touch dflags "Touching object file" path
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName dflags = do
candidates <- case ghcVersionFile dflags of
Just path -> return [path]
Nothing -> (map (</> "ghcversion.h")) <$>
(getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
found <- filterM doesFileExist candidates
case found of
[] -> throwGhcExceptionIO (InstallationError
("ghcversion.h missing; tried: "
++ intercalate ", " candidates))
(x:_) -> return x