#include <ghcplatform.h>
module GHC.Driver.Pipeline.Execute where
import GHC.Prelude
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Catch
import GHC.Driver.Hooks
import Control.Monad.Trans.Reader
import GHC.Driver.Pipeline.Monad
import GHC.Driver.Pipeline.Phases
import GHC.Driver.Env hiding (Hsc)
import GHC.Unit.Module.Location
import GHC.Driver.Phases
import GHC.Unit.Module.Name ( ModuleName )
import GHC.Unit.Types
import GHC.Types.SourceFile
import GHC.Unit.Module.Status
import GHC.Unit.Module.ModIface
import GHC.Linker.Types
import GHC.Driver.Backend
import GHC.Driver.Session
import GHC.Driver.CmdLine
import GHC.Unit.Module.ModSummary
import qualified GHC.LanguageExtensions as LangExt
import GHC.Types.SrcLoc
import GHC.Driver.Main
import GHC.Tc.Types
import GHC.Types.Error
import GHC.Driver.Errors.Types
import GHC.Fingerprint
import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Platform
import Data.List (intercalate, isInfixOf)
import GHC.Unit.Env
import GHC.SysTools.Info
import GHC.Utils.Error
import Data.Maybe
import GHC.CmmToLlvm.Mangler
import GHC.SysTools
import GHC.Utils.Panic.Plain
import System.Directory
import System.FilePath
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Unit.Info
import GHC.Unit.State
import GHC.Unit.Home
import GHC.Data.Maybe
import GHC.Iface.Make
import Data.Time
import GHC.Driver.Config.Parser
import GHC.Parser.Header
import GHC.Data.StringBuffer
import GHC.Types.SourceError
import GHC.Unit.Finder
import GHC.Runtime.Loader
import Data.IORef
import GHC.Types.Name.Env
import GHC.Platform.Ways
import GHC.Platform.ArchOS
import GHC.CmmToLlvm.Base ( llvmVersionList )
import GHC.Driver.Pipeline (compileForeign, compileEmptyStub)
import GHC.Settings
import System.IO
import GHC.Linker.ExtraObj
import GHC.Linker.Dynamic
import Data.Version
import GHC.Utils.Panic
import GHC.Unit.Module.Env
import GHC.Driver.Env.KnotVars
import GHC.Driver.Config.Finder
import GHC.Rename.Names
newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a }
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO)
instance MonadUse TPhase HookedUse where
use fa = HookedUse $ \(hooks, (PhaseHook k)) ->
case runPhaseHook hooks of
Nothing -> k fa
Just (PhaseHook h) -> h fa
runPipeline :: Hooks -> HookedUse a -> IO a
runPipeline hooks pipeline = runHookedUse pipeline (hooks, PhaseHook runPhase)
runPhase :: TPhase out -> IO out
runPhase (T_Unlit pipe_env hsc_env inp_path) = do
out_path <- phaseOutputFilenameNew (Cpp HsSrcFile) pipe_env hsc_env Nothing
runUnlitPhase hsc_env inp_path out_path
runPhase (T_FileArgs hsc_env inp_path) = getFileArgs hsc_env inp_path
runPhase (T_Cpp pipe_env hsc_env inp_path) = do
out_path <- phaseOutputFilenameNew (HsPp HsSrcFile) pipe_env hsc_env Nothing
runCppPhase hsc_env inp_path out_path
runPhase (T_HsPp pipe_env hsc_env origin_path inp_path) = do
out_path <- phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing
runHsPpPhase hsc_env origin_path inp_path out_path
runPhase (T_HscRecomp pipe_env hsc_env fp hsc_src) = do
runHscPhase pipe_env hsc_env fp hsc_src
runPhase (T_Hsc hsc_env mod_sum) = runHscTcPhase hsc_env mod_sum
runPhase (T_HscPostTc hsc_env ms fer m mfi) =
runHscPostTcPhase hsc_env ms fer m mfi
runPhase (T_HscBackend pipe_env hsc_env mod_name hsc_src location x) = do
runHscBackendPhase pipe_env hsc_env mod_name hsc_src location x
runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do
output_fn <- phaseOutputFilenameNew Cmm pipe_env hsc_env Nothing
doCpp (hsc_logger hsc_env)
(hsc_tmpfs hsc_env)
(hsc_dflags hsc_env)
(hsc_unit_env hsc_env)
False
input_fn output_fn
return output_fn
runPhase (T_Cmm pipe_env hsc_env input_fn) = do
let dflags = hsc_dflags hsc_env
let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)
output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
mstub <- hscCompileCmmFile hsc_env (src_filename pipe_env) input_fn output_fn
stub_o <- mapM (compileStub hsc_env) mstub
let foreign_os = maybeToList stub_o
return (foreign_os, output_fn)
runPhase (T_Cc phase pipe_env hsc_env input_fn) = runCcPhase phase pipe_env hsc_env input_fn
runPhase (T_As cpp pipe_env hsc_env location input_fn) = do
runAsPhase cpp pipe_env hsc_env location input_fn
runPhase (T_LlvmOpt pipe_env hsc_env input_fn) =
runLlvmOptPhase pipe_env hsc_env input_fn
runPhase (T_LlvmLlc pipe_env hsc_env input_fn) =
runLlvmLlcPhase pipe_env hsc_env input_fn
runPhase (T_LlvmMangle pipe_env hsc_env input_fn) =
runLlvmManglePhase pipe_env hsc_env input_fn
runPhase (T_MergeForeign pipe_env hsc_env input_fn fos) =
runMergeForeign pipe_env hsc_env input_fn fos
runLlvmManglePhase :: PipeEnv -> HscEnv -> FilePath -> IO [Char]
runLlvmManglePhase pipe_env hsc_env input_fn = do
let next_phase = As False
output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
let dflags = hsc_dflags hsc_env
llvmFixupAsm (targetPlatform dflags) input_fn output_fn
return output_fn
runMergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> IO FilePath
runMergeForeign _pipe_env hsc_env input_fn foreign_os = do
if null foreign_os
then return input_fn
else do
new_o <- newTempName (hsc_logger hsc_env)
(hsc_tmpfs hsc_env)
(tmpDir (hsc_dflags hsc_env))
TFL_CurrentModule "o"
copyFile input_fn new_o
joinObjectFiles hsc_env (new_o : foreign_os) input_fn
return input_fn
runLlvmLlcPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
runLlvmLlcPhase pipe_env hsc_env input_fn = do
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
llvmOpts = case llvmOptLevel dflags of
0 -> "-O1"
1 -> "-O1"
_ -> "-O2"
defaultOptions = map GHC.SysTools.Option . concatMap words . snd
$ unzip (llvmOptions dflags)
optFlag = if null (getOpts dflags opt_lc)
then map GHC.SysTools.Option $ words llvmOpts
else []
next_phase <- if
| gopt Opt_NoLlvmMangler dflags -> return (As False)
| otherwise -> return LlvmMangle
output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
GHC.SysTools.runLlvmLlc logger dflags
( optFlag
++ defaultOptions
++ [ GHC.SysTools.FileOption "" input_fn
, GHC.SysTools.Option "-o"
, GHC.SysTools.FileOption "" output_fn
]
)
return output_fn
runLlvmOptPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
runLlvmOptPhase pipe_env hsc_env input_fn = do
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
let
optIdx = max 0 $ min 2 $ llvmOptLevel dflags
llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of
Just passes -> passes
Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "
++ "is missing passes for level "
++ show optIdx)
defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst
$ unzip (llvmOptions dflags)
optFlag = if null (getOpts dflags opt_lo)
then map GHC.SysTools.Option $ words llvmOpts
else []
output_fn <- phaseOutputFilenameNew LlvmLlc pipe_env hsc_env Nothing
GHC.SysTools.runLlvmOpt logger dflags
( optFlag
++ defaultOptions ++
[ GHC.SysTools.FileOption "" input_fn
, GHC.SysTools.Option "-o"
, GHC.SysTools.FileOption "" output_fn]
)
return output_fn
runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
runAsPhase with_cpp pipe_env hsc_env location input_fn = do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
let unit_env = hsc_unit_env hsc_env
let platform = ue_platform unit_env
let (as_prog, get_asm_info) | backend dflags == LLVM
, platformOS platform == OSDarwin
= (GHC.SysTools.runClang, pure Clang)
| otherwise
= (GHC.SysTools.runAs, getAssemblerInfo logger dflags)
asmInfo <- get_asm_info
let cmdline_include_paths = includePaths dflags
let pic_c_flags = picCCOpts dflags
output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location
createDirectoryIfMissing True (takeDirectory output_fn)
let global_includes = [ GHC.SysTools.Option ("-I" ++ p)
| p <- includePathsGlobal cmdline_include_paths ]
let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)
| p <- includePathsQuote cmdline_include_paths ++
includePathsQuoteImplicit cmdline_include_paths]
let runAssembler inputFilename outputFilename
= withAtomicRename outputFilename $ \temp_outputFilename ->
as_prog
logger dflags
(local_includes ++ global_includes
++ map GHC.SysTools.Option pic_c_flags
++ [ GHC.SysTools.Option "-Wa,-mbig-obj"
| platformOS (targetPlatform dflags) == OSMinGW32
, not $ target32Bit (targetPlatform dflags)
]
++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51]
then [GHC.SysTools.Option "-Qunused-arguments"]
else [])
++ [ GHC.SysTools.Option "-x"
, if with_cpp
then GHC.SysTools.Option "assembler-with-cpp"
else GHC.SysTools.Option "assembler"
, GHC.SysTools.Option "-c"
, GHC.SysTools.FileOption "" inputFilename
, GHC.SysTools.Option "-o"
, GHC.SysTools.FileOption "" temp_outputFilename
])
debugTraceMsg logger 4 (text "Running the assembler")
runAssembler input_fn output_fn
return output_fn
runCcPhase :: Phase -> PipeEnv -> HscEnv -> FilePath -> IO FilePath
runCcPhase cc_phase pipe_env hsc_env input_fn = do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
let unit_env = hsc_unit_env hsc_env
let home_unit = hsc_home_unit hsc_env
let tmpfs = hsc_tmpfs hsc_env
let platform = ue_platform unit_env
let hcc = cc_phase `eqPhase` HCc
let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)
pkgs <- if hcc then getHCFilePackages input_fn else return []
ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs)
let pkg_include_dirs = collectIncludeDirs ps
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 ++
includePathsQuoteImplicit cmdline_include_paths)
let include_paths = include_paths_quote ++ include_paths_global
let opts = getOpts dflags opt_P
aug_imports = augmentImports dflags opts
more_preprocessor_opts = concat
[ ["-Xpreprocessor", i]
| not hcc
, i <- aug_imports
]
let gcc_extra_viac_flags = extraGccViaCFlags dflags
let pic_c_flags = picCCOpts dflags
let verbFlags = getVerbFlags dflags
let pkg_extra_cc_opts
| hcc = []
| otherwise = collectExtraCcOpts ps
let framework_paths
| platformUsesFrameworks platform
= let pkgFrameworkPaths = collectFrameworksDirs ps
cmdlineFrameworkPaths = frameworkPaths dflags
in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
| otherwise
= []
let cc_opt | llvmOptLevel dflags >= 2 = [ "-O2" ]
| llvmOptLevel dflags >= 1 = [ "-O" ]
| otherwise = []
let next_phase = As False
output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
let
more_hcc_opts =
(if platformArch platform == ArchX86 &&
not (gopt Opt_ExcessPrecision dflags)
then [ "-ffloat-store" ]
else []) ++
["-fno-strict-aliasing"]
ghcVersionH <- getGhcVersionPathName dflags unit_env
GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (
[ GHC.SysTools.FileOption "" input_fn
, GHC.SysTools.Option "-o"
, GHC.SysTools.FileOption "" output_fn
]
++ map GHC.SysTools.Option (
pic_c_flags
++ (if platformOS platform == OSMinGW32 &&
isHomeUnitId home_unit baseUnitId
then [ "-DCOMPILING_BASE_PACKAGE" ]
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 output_fn
runHscBackendPhase :: PipeEnv
-> HscEnv
-> ModuleName
-> HscSource
-> ModLocation
-> HscBackendAction
-> IO ([FilePath], ModIface, Maybe Linkable, FilePath)
runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
o_file = if dynamicNow dflags then ml_dyn_obj_file location else ml_obj_file location
next_phase = hscPostBackendPhase src_flavour (backend dflags)
case result of
HscUpdate iface ->
if | NoBackend <- backend dflags ->
panic "HscUpdate not relevant for NoBackend"
| Interpreter <- backend dflags -> do
return ([], iface, Nothing, o_file)
| otherwise -> do
case src_flavour of
HsigFile -> do
let input_fn = expectJust "runPhase" (ml_hs_file location)
basename = dropExtension input_fn
compileEmptyStub dflags hsc_env basename location mod_name
HsBootFile -> touchObjectFile logger dflags o_file
HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile"
return ([], iface, Nothing, o_file)
HscRecomp { hscs_guts = cgguts,
hscs_mod_location = mod_location,
hscs_partial_iface = partial_iface,
hscs_old_iface_hash = mb_old_iface_hash
}
-> case backend dflags of
NoBackend -> panic "HscRecomp not relevant for NoBackend"
Interpreter -> do
final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing
hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location
(hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location
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 <- getCurrentTime
let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name)
(hs_unlinked ++ stub_o)
return ([], final_iface, Just linkable, panic "interpreter")
_ -> do
output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)
(outputFilename, mStub, foreign_files, mb_stg_infos, mb_cg_infos) <-
hscGenHardCode hsc_env cgguts mod_location output_fn
final_iface <- mkFullIface hsc_env partial_iface mb_stg_infos mb_cg_infos
hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
stub_o <- mapM (compileStub hsc_env) mStub
foreign_os <-
mapM (uncurry (compileForeign hsc_env)) foreign_files
let fos = (maybe [] return stub_o ++ foreign_os)
return (fos, final_iface, Nothing, outputFilename)
runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath
runUnlitPhase hsc_env input_fn output_fn = do
let
escape ('\\':cs) = '\\':'\\': escape cs
escape ('\"':cs) = '\\':'\"': escape cs
escape ('\'':cs) = '\\':'\'': escape cs
escape (c:cs) = c : escape cs
escape [] = []
let flags = [
GHC.SysTools.Option "-h"
, GHC.SysTools.Option $ escape input_fn
, GHC.SysTools.FileOption "" input_fn
, GHC.SysTools.FileOption "" output_fn
]
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
GHC.SysTools.runUnlit logger dflags flags
return output_fn
getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, [Warn]))
getFileArgs hsc_env input_fn = do
let dflags0 = hsc_dflags hsc_env
parser_opts = initParserOpts dflags0
(warns0, src_opts) <- getOptionsFromFile parser_opts input_fn
(dflags1, unhandled_flags, warns)
<- parseDynamicFilePragma dflags0 src_opts
checkProcessArgsResult unhandled_flags
return (dflags1, warns0, warns)
runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath
runCppPhase hsc_env input_fn output_fn = do
doCpp (hsc_logger hsc_env)
(hsc_tmpfs hsc_env)
(hsc_dflags hsc_env)
(hsc_unit_env hsc_env)
True
input_fn output_fn
return output_fn
runHscPhase :: PipeEnv
-> HscEnv
-> FilePath
-> HscSource
-> IO (HscEnv, ModSummary, HscRecompStatus)
runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
let dflags0 = hsc_dflags hsc_env0
PipeEnv{ src_basename=basename,
src_suffix=suff } = pipe_env
let current_dir = takeDirectory basename
new_includes = addImplicitQuoteInclude paths [current_dir]
paths = includePaths dflags0
dflags = dflags0 { includePaths = new_includes }
hsc_env = hscSetFlags dflags hsc_env0
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
Left errs -> throwErrors (GhcPsMessage <$> errs)
Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return
(Just buf, mod_name, rn_imps imps, rn_imps src_imps, ghc_prim_imp)
location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name
let o_file = ml_obj_file location
hi_file = ml_hi_file location
hie_file = ml_hie_file location
dyn_o_file = ml_dyn_obj_file location
src_hash <- getFileHash (basename <.> suff)
hi_date <- modificationTimeIfExists hi_file
hie_date <- modificationTimeIfExists hie_file
o_mod <- modificationTimeIfExists o_file
dyn_o_mod <- modificationTimeIfExists dyn_o_file
mod <- do
let home_unit = hsc_home_unit hsc_env
let fc = hsc_FC hsc_env
addHomeModuleToFinder fc home_unit 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_hash = src_hash,
ms_obj_date = o_mod,
ms_dyn_obj_date = dyn_o_mod,
ms_parsed_mod = Nothing,
ms_iface_date = hi_date,
ms_hie_date = hie_date,
ms_ghc_prim_import = ghc_prim_imp,
ms_textual_imps = imps,
ms_srcimps = src_imps }
let msg :: Messager
msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what
plugin_hsc_env' <- initializePlugins hsc_env
type_env_var <- newIORef emptyNameEnv
let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }
status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary
Nothing Nothing (1, 1)
return (plugin_hsc_env, mod_summary, status)
mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO ModLocation
mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
let PipeEnv{ src_basename=basename,
src_suffix=suff } = pipe_env
let location1 = mkHomeModLocation2 fopts 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 dynohi = dynOutputHi dflags
location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }
| otherwise = location3
let expl_o_file = outputFile_ dflags
expl_dyn_o_file = dynOutputFile_ dflags
location5 | Just ofile <- expl_o_file
, let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file
, isNoLink (ghcLink dflags)
= location4 { ml_obj_file = ofile
, ml_dyn_obj_file = dyn_ofile }
| Just dyn_ofile <- expl_dyn_o_file
= location4 { ml_dyn_obj_file = dyn_ofile }
| otherwise = location4
return location5
where
fopts = initFinderOpts dflags
runHscTcPhase :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage)
runHscTcPhase = hscTypecheckAndGetWarnings
runHscPostTcPhase ::
HscEnv
-> ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
-> IO HscBackendAction
runHscPostTcPhase hsc_env mod_summary tc_result tc_warnings mb_old_hash = do
runHsc hsc_env $ do
hscDesugarAndSimplify mod_summary tc_result tc_warnings mb_old_hash
runHsPpPhase :: HscEnv -> FilePath -> FilePath -> FilePath -> IO FilePath
runHsPpPhase hsc_env orig_fn input_fn output_fn = do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
GHC.SysTools.runPp logger dflags
( [ GHC.SysTools.Option orig_fn
, GHC.SysTools.Option input_fn
, GHC.SysTools.FileOption "" output_fn
] )
return output_fn
phaseOutputFilenameNew :: Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> IO FilePath
phaseOutputFilenameNew next_phase pipe_env hsc_env maybe_loc = do
let PipeEnv{stop_phase, src_basename, output_spec} = pipe_env
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
tmpfs = hsc_tmpfs hsc_env
getOutputFilename logger tmpfs (stopPhaseToPhase stop_phase) output_spec
src_basename dflags next_phase maybe_loc
getOutputFilename
:: Logger
-> TmpFs
-> Phase
-> PipelineOutput
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location
| StopLn <- next_phase, Just loc <- maybe_location =
return $ if dynamicNow dflags then ml_dyn_obj_file loc
else ml_obj_file loc
| is_last_phase, Persistent <- output = persistent_fn
| is_last_phase, SpecificFile <- output =
return $
if dynamicNow dflags
then case dynOutputFile_ dflags of
Nothing -> let ofile = getOutputFile_ dflags
new_ext = case takeExtension ofile of
"" -> "dyn"
ext -> "dyn_" ++ tail ext
in replaceExtension ofile new_ext
Just fn -> fn
else getOutputFile_ dflags
| keep_this_output = persistent_fn
| Temporary lifetime <- output = newTempName logger tmpfs (tmpDir dflags) lifetime suffix
| otherwise = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule
suffix
where
getOutputFile_ dflags = case outputFile_ dflags of
Nothing -> pprPanic "SpecificFile: No filename" (ppr $ (dynamicNow dflags, outputFile_ dflags, dynOutputFile_ dflags))
Just fn -> fn
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 d <- odir = (d </> persistent)
| otherwise = persistent
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 ]
++ [("", "-mcpu=" ++ mcpu) | not (null mcpu)
, not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]
++ [("", "-mattr=" ++ attrs) | not (null attrs) ]
++ [("", "-target-abi=" ++ abi) | not (null abi) ]
where target = platformMisc_llvmTarget $ platformMisc dflags
Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)
rmodel | gopt Opt_PIC dflags = "pic"
| positionIndependent dflags = "pic"
| ways dflags `hasWay` WayDyn = "dynamic-no-pic"
| otherwise = "static"
platform = targetPlatform dflags
align :: Int
align = case platformArch platform of
ArchX86_64 | isAvxEnabled dflags -> 32
_ -> 0
attrs :: String
attrs = intercalate "," $ mattr
++ ["+sse42" | isSse4_2Enabled dflags ]
++ ["+sse2" | isSse2Enabled platform ]
++ ["+sse" | isSseEnabled platform ]
++ ["+avx512f" | isAvx512fEnabled dflags ]
++ ["+avx2" | isAvx2Enabled dflags ]
++ ["+avx" | isAvxEnabled dflags ]
++ ["+avx512cd"| isAvx512cdEnabled dflags ]
++ ["+avx512er"| isAvx512erEnabled dflags ]
++ ["+avx512pf"| isAvx512pfEnabled dflags ]
++ ["+bmi" | isBmiEnabled dflags ]
++ ["+bmi2" | isBmi2Enabled dflags ]
abi :: String
abi = case platformArch (targetPlatform dflags) of
ArchRISCV64 -> "lp64d"
_ -> ""
offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs
offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =
let go = map (augmentByWorkingDirectory dflags)
in IncludeSpecs (go incs) (go quotes) (go impl)
doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()
doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do
let hscpp_opts = picPOpts dflags
let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)
let unit_state = ue_units unit_env
pkg_include_dirs <- mayThrowUnitErr
(collectIncludeDirs <$> preloadUnitsInfo unit_env)
let home_pkg_deps =
[homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]
dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]
let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
(includePathsGlobal cmdline_include_paths ++ pkg_include_dirs
++ concatMap includePathsGlobal dep_pkg_extra_inputs)
let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
(includePathsQuote cmdline_include_paths ++
includePathsQuoteImplicit cmdline_include_paths)
let include_paths = include_paths_quote ++ include_paths_global
let verbFlags = getVerbFlags dflags
let cpp_prog args | raw = GHC.SysTools.runCpp logger dflags args
| otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags
(GHC.SysTools.Option "-E" : args)
let platform = targetPlatform dflags
targetArch = stringEncodeArch $ platformArch platform
targetOS = stringEncodeOS $ platformOS platform
isWindows = platformOS platform == OSMinGW32
let target_defs =
[ "-D" ++ HOST_OS ++ "_BUILD_OS",
"-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
"-D" ++ targetOS ++ "_HOST_OS",
"-D" ++ targetArch ++ "_HOST_ARCH" ]
let io_manager_defs =
[ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++
[ "-D__IO_MANAGER_MIO__=1" ]
let sse_defs =
[ "-D__SSE__" | isSseEnabled platform ] ++
[ "-D__SSE2__" | isSse2Enabled platform ] ++
[ "-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 logger dflags
let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
ghcVersionH <- getGhcVersionPathName dflags unit_env
let hsSourceCppOpts = [ "-include", ghcVersionH ]
let uids = explicitUnits unit_state
pkgs = mapMaybe (lookupUnit unit_state . fst) uids
mb_macro_include <-
if not (null pkgs) && gopt Opt_VersionMacros dflags
then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"
writeFile macro_stub (generatePackageVersionMacros pkgs)
return [GHC.SysTools.FileOption "-include" macro_stub]
else return []
cpp_prog ( map GHC.SysTools.Option verbFlags
++ map GHC.SysTools.Option include_paths
++ map GHC.SysTools.Option hsSourceCppOpts
++ map GHC.SysTools.Option target_defs
++ map GHC.SysTools.Option backend_defs
++ map GHC.SysTools.Option th_defs
++ map GHC.SysTools.Option hscpp_opts
++ map GHC.SysTools.Option sse_defs
++ map GHC.SysTools.Option avx_defs
++ map GHC.SysTools.Option io_manager_defs
++ mb_macro_include
++ [ GHC.SysTools.Option "-x"
, GHC.SysTools.Option "assembler-with-cpp"
, GHC.SysTools.Option input_fn
, GHC.SysTools.Option "-o"
, GHC.SysTools.FileOption "" output_fn
])
getBackendDefs :: Logger -> DynFlags -> IO [String]
getBackendDefs logger dflags | backend dflags == LLVM = do
llvmVer <- figureLlvmVersion logger 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 []
hscPostBackendPhase :: HscSource -> Backend -> Phase
hscPostBackendPhase HsBootFile _ = StopLn
hscPostBackendPhase HsigFile _ = StopLn
hscPostBackendPhase _ bcknd =
case bcknd of
ViaC -> HCc
NCG -> As False
LLVM -> LlvmOpt
NoBackend -> StopLn
Interpreter -> StopLn
compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c
joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()
joinObjectFiles hsc_env o_files output_fn
| can_merge_objs = do
let toolSettings' = toolSettings dflags
ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (
map GHC.SysTools.Option ld_build_id
++ [ GHC.SysTools.Option "-o",
GHC.SysTools.FileOption "" output_fn ]
++ args)
ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]
| otherwise = []
if ldIsGnuLd
then do
script <- newTempName logger tmpfs (tmpDir 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 [GHC.SysTools.FileOption "" script]
else if toolSettings_ldSupportsFilelist toolSettings'
then do
filelist <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "filelist"
writeFile filelist $ unlines o_files
ld_r [GHC.SysTools.Option "-filelist",
GHC.SysTools.FileOption "" filelist]
else
ld_r (map (GHC.SysTools.FileOption "") o_files)
| otherwise = do
withAtomicRename output_fn $ \tmp_ar ->
liftIO $ runAr logger dflags Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files
where
dashLSupported = sArSupportsDashL (settings dflags)
dashL = if dashLSupported then "L" else ""
can_merge_objs = isJust (pgm_lm (hsc_dflags hsc_env))
dflags = hsc_dflags hsc_env
tmpfs = hsc_tmpfs hsc_env
logger = hsc_logger hsc_env
getHCFilePackages :: FilePath -> IO [UnitId]
getHCFilePackages filename =
withFile filename ReadMode $ \h -> do
l <- hGetLine h
case l of
'/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
return (map stringToUnitId (words rest))
_other ->
return []
linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do
when (haveRtsOptsFlags dflags) $
logMsg logger MCInfo noSrcSpan
$ withPprStyle defaultUserStyle
(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 logger tmpfs dflags unit_env o_files dep_units
generatePackageVersionMacros :: [UnitInfo] -> String
generatePackageVersionMacros pkgs = concat
[ generateMacros "" pkgname version
| pkg <- pkgs
, let version = unitPackageVersion pkg
pkgname = map fixchar (unitPackageNameString 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)
touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()
touchObjectFile logger dflags path = do
createDirectoryIfMissing True $ takeDirectory path
GHC.SysTools.touch logger dflags "Touching object file" path
getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
getGhcVersionPathName dflags unit_env = do
candidates <- case ghcVersionFile dflags of
Just path -> return [path]
Nothing -> do
ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])
return ((</> "ghcversion.h") <$> collectIncludeDirs ps)
found <- filterM doesFileExist candidates
case found of
[] -> throwGhcExceptionIO (InstallationError
("ghcversion.h missing; tried: "
++ intercalate ", " candidates))
(x:_) -> return x