module GHC.Driver.Pipeline (
oneShot, compileFile,
preprocess,
compileOne, compileOne',
compileForeign, compileEmptyStub,
link, linkingNeeded, checkLinkInfo,
PipeEnv(..), mkPipeEnv, phaseOutputFilenameNew,
TPhase(..), runPhase,
hscPostBackendPhase,
TPipelineClass, MonadUse(..),
preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline,
hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline,
llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart,
runPipeline
) where
import GHC.Prelude
import GHC.Platform
import GHC.Utils.Monad ( MonadIO(liftIO), mapMaybeM )
import GHC.Driver.Main
import GHC.Driver.Env hiding ( Hsc )
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.Pipeline.Monad
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Phases
import GHC.Driver.Pipeline.Execute
import GHC.Driver.Pipeline.Phases
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Ppr
import GHC.Driver.Hooks
import GHC.Platform.Ways
import GHC.SysTools
import GHC.Utils.TmpFs
import GHC.Linker.ExtraObj
import GHC.Linker.Static
import GHC.Linker.Static.Utils
import GHC.Linker.Types
import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Exception as Exception
import GHC.Utils.Logger
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString ( mkFastString )
import GHC.Data.StringBuffer ( hPutStringBuffer )
import GHC.Data.Maybe ( expectJust )
import GHC.Iface.Make ( mkFullIface )
import GHC.Runtime.Loader ( initializePlugins )
import GHC.Types.Basic ( SuccessFlag(..), ForeignSrcLang(..) )
import GHC.Types.Error ( singleMessage, getMessages )
import GHC.Types.Target
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
import GHC.Unit.Home.ModInfo
import System.Directory
import System.FilePath
import System.IO
import Control.Monad
import qualified Control.Monad.Catch as MC (handle)
import Data.Maybe
import Data.Either ( partitionEithers )
import qualified Data.Set as Set
import Data.Time ( getCurrentTime )
import GHC.Iface.Recomp
type P m = TPipelineClass TPhase m
preprocess :: HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either DriverMessages (DynFlags, FilePath))
preprocess hsc_env input_fn mb_input_buf mb_phase =
handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $
MC.handle handler $
fmap Right $ do
massertPpr (isJust mb_phase || isHaskellSrcFilename input_fn) (text input_fn)
input_fn_final <- mkInputFn
let preprocess_pipeline = preprocessPipeline pipe_env (setDumpPrefix pipe_env hsc_env) input_fn_final
runPipeline (hsc_hooks hsc_env) preprocess_pipeline
where
srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
handler (ProgramError msg) =
return $ Left $ singleMessage $
mkPlainErrorMsgEnvelope srcspan $
DriverUnknownMessage $ mkPlainError noHints $ text msg
handler ex = throwGhcExceptionIO ex
to_driver_messages :: Messages GhcMessage -> Messages DriverMessage
to_driver_messages msgs = case traverse to_driver_message msgs of
Nothing -> pprPanic "non-driver message in preprocess"
(vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))
Just msgs' -> msgs'
to_driver_message = \case
GhcDriverMessage msg
-> Just msg
GhcPsMessage (PsHeaderMessage msg)
-> Just (DriverPsHeaderMessage (PsHeaderMessage msg))
_ -> Nothing
pipe_env = mkPipeEnv StopPreprocess input_fn mb_phase (Temporary TFL_GhcSession)
mkInputFn =
case mb_input_buf of
Just input_buf -> do
fn <- newTempName (hsc_logger hsc_env)
(hsc_tmpfs hsc_env)
(tmpDir (hsc_dflags hsc_env))
TFL_CurrentModule
("buf_" ++ src_suffix pipe_env)
hdl <- openBinaryFile fn WriteMode
hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"
hPutStringBuffer hdl input_buf
hClose hdl
return fn
Nothing -> return input_fn
compileOne :: HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> IO HomeModInfo
compileOne = compileOne' (Just batchMsg)
compileOne' :: Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> IO HomeModInfo
compileOne' mHscMessage
hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable
= do
debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp)
let flags = hsc_dflags hsc_env0
in do unless (gopt Opt_KeepHiFiles flags) $
addFilesToClean tmpfs TFL_CurrentModule $
[ml_hi_file $ ms_location summary]
unless (gopt Opt_KeepOFiles flags) $
addFilesToClean tmpfs TFL_GhcSession $
[ml_obj_file $ ms_location summary]
plugin_hsc_env <- initializePlugins hsc_env
let pipe_env = mkPipeEnv NoStop input_fn Nothing pipelineOutput
status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary
mb_old_iface mb_old_linkable (mod_index, nmods)
let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)
(iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline
details <- initModDetails plugin_hsc_env upd_summary iface
return $! HomeModInfo iface details linkable
where lcl_dflags = ms_hspp_opts summary
location = ms_location summary
input_fn = expectJust "compile:hs" (ml_hs_file location)
input_fnpp = ms_hspp_file summary
pipelineOutput = case bcknd of
Interpreter -> NoOutputFile
NoBackend -> NoOutputFile
_ -> Persistent
logger = hsc_logger hsc_env0
tmpfs = hsc_tmpfs hsc_env0
basename = dropExtension input_fn
current_dir = takeDirectory basename
old_paths = includePaths lcl_dflags
loadAsByteCode
| Just Target { targetAllowObjCode = obj } <- findTarget summary (hsc_targets hsc_env0)
, not obj
= True
| otherwise = False
(bcknd, dflags3)
| loadAsByteCode
= (Interpreter, gopt_set (lcl_dflags { backend = Interpreter }) Opt_ForceRecomp)
| otherwise
= (backend dflags, lcl_dflags)
dflags = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] }
upd_summary = summary { ms_hspp_opts = dflags }
hsc_env = hscSetFlags dflags hsc_env0
link :: GhcLink
-> Logger
-> TmpFs
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt =
case linkHook hooks of
Nothing -> case ghcLink of
NoLink -> return Succeeded
LinkBinary -> normal_link
LinkStaticLib -> normal_link
LinkDynLib -> normal_link
LinkMergedObj -> normal_link
LinkInMemory
| platformMisc_ghcWithInterpreter $ platformMisc dflags
->
return Succeeded
| otherwise
-> panicBadLink LinkInMemory
Just h -> h ghcLink dflags batch_attempt_linking hpt
where
normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt
panicBadLink :: GhcLink -> a
panicBadLink other = panic ("link: GHC not built to link this way: " ++
show other)
link' :: Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt
| batch_attempt_linking
= do
let
staticLink = case ghcLink dflags of
LinkStaticLib -> True
_ -> False
home_mod_infos = eltsHpt hpt
pkg_deps = Set.toList
$ Set.unions
$ fmap (dep_direct_pkgs . mi_deps . hm_iface)
$ home_mod_infos
linkables = map (expectJust "link".hm_linkable) home_mod_infos
debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
if isNoLink (ghcLink dflags)
then do debugTraceMsg logger 3 (text "link(batch): linking omitted (-c flag given).")
return Succeeded
else do
let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)
obj_files = concatMap getOfiles linkables
platform = targetPlatform dflags
exe_file = exeFileName platform staticLink (outputFile_ dflags)
linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps
forM_ mHscMessager $ \hscMessage -> hscMessage linking_needed
if not (gopt Opt_ForceRecomp dflags) && (linking_needed == UpToDate)
then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.")
return Succeeded
else do
let link = case ghcLink dflags of
LinkBinary -> linkBinary logger tmpfs
LinkStaticLib -> linkStaticLib logger
LinkDynLib -> linkDynLibCheck logger tmpfs
other -> panicBadLink other
link dflags unit_env obj_files pkg_deps
debugTraceMsg logger 3 (text "link: done")
return Succeeded
| otherwise
= do debugTraceMsg logger 3 (text "link(batch): upsweep (partially) failed OR" $$
text " Main.main not exported; not linking.")
return Succeeded
linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired
linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
let platform = ue_platform unit_env
unit_state = ue_units unit_env
exe_file = exeFileName platform staticLink (outputFile_ dflags)
e_exe_time <- tryIO $ getModificationUTCTime exe_file
case e_exe_time of
Left _ -> return $ NeedsRecompile MustCompile
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 $ needsRecompileBecause ObjectsChanged
else do
let pkg_hslibs = [ (collectLibraryDirs (ways dflags) [c], lib)
| Just c <- map (lookupUnitId unit_state) pkg_deps,
lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]
pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs
if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged 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 $ needsRecompileBecause LibraryChanged
else do
res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file
if res
then return $ needsRecompileBecause FlagsChanged
else return UpToDate
findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)
findHSLib platform ws dirs lib = do
let batch_lib_file = if ws `hasNotWay` WayDyn
then "lib" ++ lib <.> "a"
else platformSOName platform lib
found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
case found of
[] -> return Nothing
(x:_) -> return (Just x)
oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO ()
oneShot hsc_env stop_phase srcs = do
o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs
case stop_phase of
StopPreprocess -> return ()
StopC -> return ()
StopAs -> return ()
NoStop -> doLink hsc_env o_files
compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe 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
mb_o_file = outputFile dflags
ghc_link = ghcLink dflags
notStopPreprocess | StopPreprocess <- stop_phase = False
| _ <- stop_phase = True
output
| NoBackend <- backend dflags, notStopPreprocess = NoOutputFile
| NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent
| isJust mb_o_file = SpecificFile
| otherwise = Persistent
pipe_env = mkPipeEnv stop_phase src mb_phase output
pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src mb_phase
runPipeline (hsc_hooks hsc_env) pipeline
doLink :: HscEnv -> [FilePath] -> IO ()
doLink hsc_env o_files =
let
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
unit_env = hsc_unit_env hsc_env
tmpfs = hsc_tmpfs hsc_env
in case ghcLink dflags of
NoLink -> return ()
LinkBinary -> linkBinary logger tmpfs dflags unit_env o_files []
LinkStaticLib -> linkStaticLib logger dflags unit_env o_files []
LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files []
LinkMergedObj
| Just out <- outputFile dflags
, let objs = [ f | FileOption _ f <- ldInputs dflags ]
-> joinObjectFiles hsc_env (o_files ++ objs) out
| otherwise -> panic "Output path must be specified for LinkMergedObj"
other -> panicBadLink other
compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign _ RawObject object_file = return object_file
compileForeign hsc_env lang stub_c = do
let pipeline = case lang of
LangC -> viaCPipeline Cc
LangCxx -> viaCPipeline Ccxx
LangObjc -> viaCPipeline Cobjc
LangObjcxx -> viaCPipeline Cobjcxx
LangAsm -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp
#if __GLASGOW_HASKELL__ < 811
RawObject -> panic "compileForeign: should be unreachable"
#endif
pipe_env = mkPipeEnv NoStop stub_c Nothing (Temporary TFL_GhcSession)
res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c)
case res of
Nothing -> pprPanic "compileForeign" (ppr stub_c)
Just fp -> return fp
compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub dflags hsc_env basename location mod_name = do
let logger = hsc_logger hsc_env
let tmpfs = hsc_tmpfs hsc_env
empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
let home_unit = hsc_home_unit hsc_env
src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
_ <- runPipeline (hsc_hooks hsc_env) pipeline
return ()
mkPipeEnv :: StopPhase
-> FilePath
-> Maybe Phase
-> PipelineOutput
-> PipeEnv
mkPipeEnv stop_phase input_fn start_phase output =
let (basename, suffix) = splitExtension input_fn
suffix' = drop 1 suffix
env = PipeEnv{ stop_phase,
src_filename = input_fn,
src_basename = basename,
src_suffix = suffix',
start_phase = fromMaybe (startPhase suffix') start_phase,
output_spec = output }
in env
setDumpPrefix :: PipeEnv -> HscEnv -> HscEnv
setDumpPrefix pipe_env hsc_env =
hscUpdateFlags (\dflags -> dflags { dumpPrefix = src_basename pipe_env ++ "."}) hsc_env
phaseIfFlag :: Monad m
=> HscEnv
-> (DynFlags -> Bool)
-> a
-> m a
-> m a
phaseIfFlag hsc_env flag def action =
if flag (hsc_dflags hsc_env)
then action
else return def
phaseIfAfter :: P m => Platform -> Phase -> Phase -> a -> m a -> m a
phaseIfAfter platform start_phase cur_phase def action =
if start_phase `eqPhase` cur_phase
|| happensBefore platform start_phase cur_phase
then action
else return def
preprocessPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)
preprocessPipeline pipe_env hsc_env input_fn = do
unlit_fn <-
runAfter (Unlit HsSrcFile) input_fn $ do
use (T_Unlit pipe_env hsc_env input_fn)
(dflags1, p_warns1, warns1) <- use (T_FileArgs hsc_env unlit_fn)
let hsc_env1 = hscSetFlags dflags1 hsc_env
(cpp_fn, hsc_env2)
<- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do
cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn)
(dflags2, _, _) <- use (T_FileArgs hsc_env1 cpp_fn)
let hsc_env2 = hscSetFlags dflags2 hsc_env1
return (cpp_fn, hsc_env2)
pp_fn <- runAfterFlag hsc_env2 (HsPp HsSrcFile) (gopt Opt_Pp) cpp_fn $
use (T_HsPp pipe_env hsc_env2 input_fn cpp_fn)
(dflags3, p_warns3, warns3)
<- if pp_fn == unlit_fn
then return (dflags1, p_warns1, warns1)
else do
use (T_FileArgs hsc_env pp_fn)
liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))
liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3)
return (dflags3, pp_fn)
where platform = targetPlatform (hsc_dflags hsc_env)
runAfter :: P p => Phase
-> a -> p a -> p a
runAfter = phaseIfAfter platform (start_phase pipe_env)
runAfterFlag :: P p
=> HscEnv
-> Phase
-> (DynFlags -> Bool)
-> a
-> p a
-> p a
runAfterFlag hsc_env phase flag def action =
runAfter phase def
$ phaseIfFlag hsc_env flag def action
fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable)
fullPipeline pipe_env hsc_env pp_fn src_flavour = do
(dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn
let hsc_env' = hscSetFlags dflags hsc_env
(hsc_env_with_plugins, mod_sum, hsc_recomp_status)
<- use (T_HscRecomp pipe_env hsc_env' input_fn src_flavour)
hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status)
hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable)
hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do
case hsc_recomp_status of
HscUpToDate iface mb_linkable -> return (iface, mb_linkable)
HscRecompNeeded mb_old_hash -> do
(tc_result, warnings) <- use (T_Hsc hsc_env_with_plugins mod_sum)
hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash )
hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction
hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable)
hscBackendPipeline pipe_env hsc_env mod_sum result =
case backend (hsc_dflags hsc_env) of
NoBackend ->
case result of
HscUpdate iface -> return (iface, Nothing)
HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure Nothing
_ -> do
res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result
when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do
let dflags' = setDynamicNow (hsc_dflags hsc_env)
() <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result
return res
hscGenBackendPipeline :: P m
=> PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, Maybe Linkable)
hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
let mod_name = moduleName (ms_mod mod_sum)
src_flavour = (ms_hsc_src mod_sum)
let location = ms_location mod_sum
(fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result)
final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file
final_linkable <-
case final_fp of
Nothing -> return mlinkable
Just o_fp -> do
unlinked_time <- liftIO (liftIO getCurrentTime)
final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)
let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]
return (Just linkable)
return (miface, final_linkable)
asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile)
asPipeline use_cpp pipe_env hsc_env location input_fn =
case stop_phase pipe_env of
StopAs -> return Nothing
_ -> Just <$> use (T_As use_cpp pipe_env hsc_env location input_fn)
viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
viaCPipeline c_phase pipe_env hsc_env location input_fn = do
out_fn <- use (T_Cc c_phase pipe_env hsc_env input_fn)
case stop_phase pipe_env of
StopC -> return Nothing
_ -> asPipeline False pipe_env hsc_env location out_fn
llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmPipeline pipe_env hsc_env location fp = do
opt_fn <- use (T_LlvmOpt pipe_env hsc_env fp)
llvmLlcPipeline pipe_env hsc_env location opt_fn
llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmLlcPipeline pipe_env hsc_env location opt_fn = do
llc_fn <- use (T_LlvmLlc pipe_env hsc_env opt_fn)
llvmManglePipeline pipe_env hsc_env location llc_fn
llvmManglePipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmManglePipeline pipe_env hsc_env location llc_fn = do
mangled_fn <-
if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env)
then return llc_fn
else use (T_LlvmMangle pipe_env hsc_env llc_fn)
asPipeline False pipe_env hsc_env location mangled_fn
cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath
cmmCppPipeline pipe_env hsc_env input_fn = do
output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn)
cmmPipeline pipe_env hsc_env output_fn
cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath
cmmPipeline pipe_env hsc_env input_fn = do
(fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn)
mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn
case mo_fn of
Nothing -> panic "CMM pipeline - produced no .o file"
Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos)
hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing
hscPostBackendPipeline _ _ HsigFile _ _ _ = return Nothing
hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn =
case bcknd of
ViaC -> viaCPipeline HCc pipe_env hsc_env ml input_fn
NCG -> asPipeline False pipe_env hsc_env ml input_fn
LLVM -> llvmPipeline pipe_env hsc_env ml input_fn
NoBackend -> return Nothing
Interpreter -> return Nothing
pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath)
pipelineStart pipe_env hsc_env input_fn mb_phase =
fromPhase (fromMaybe (startPhase $ src_suffix pipe_env) mb_phase)
where
stop_after = stop_phase pipe_env
frontend :: P m => HscSource -> m (Maybe FilePath)
frontend sf = case stop_after of
StopPreprocess -> do
(_, out_fn) <- preprocessPipeline pipe_env hsc_env input_fn
let logger = hsc_logger hsc_env
final_fn <- liftIO $ phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing
when (final_fn /= out_fn) $ do
let msg = "Copying `" ++ out_fn ++"' to `" ++ final_fn ++ "'"
line_prag = "{-# LINE 1 \"" ++ src_filename pipe_env ++ "\" #-}\n"
liftIO (showPass logger msg)
liftIO (copyWithHeader line_prag out_fn final_fn)
return Nothing
_ -> objFromLinkable <$> fullPipeline pipe_env hsc_env input_fn sf
c :: P m => Phase -> m (Maybe FilePath)
c phase = viaCPipeline phase pipe_env hsc_env Nothing input_fn
as :: P m => Bool -> m (Maybe FilePath)
as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn
objFromLinkable (_, Just (LM _ _ [DotO lnk])) = Just lnk
objFromLinkable _ = Nothing
fromPhase :: P m => Phase -> m (Maybe FilePath)
fromPhase (Unlit p) = frontend p
fromPhase (Cpp p) = frontend p
fromPhase (HsPp p) = frontend p
fromPhase (Hsc p) = frontend p
fromPhase HCc = c HCc
fromPhase Cc = c Cc
fromPhase Ccxx = c Ccxx
fromPhase Cobjc = c Cobjc
fromPhase Cobjcxx = c Cobjcxx
fromPhase (As p) = as p
fromPhase LlvmOpt = llvmPipeline pipe_env hsc_env Nothing input_fn
fromPhase LlvmLlc = llvmLlcPipeline pipe_env hsc_env Nothing input_fn
fromPhase LlvmMangle = llvmManglePipeline pipe_env hsc_env Nothing input_fn
fromPhase StopLn = return (Just input_fn)
fromPhase CmmCpp = Just <$> cmmCppPipeline pipe_env hsc_env input_fn
fromPhase Cmm = Just <$> cmmPipeline pipe_env hsc_env input_fn
fromPhase MergeForeign = panic "fromPhase: MergeForeign"