{-# LANGUAGE CPP #-}
module CodeOutput( codeOutput, outputForeignStubs ) where
#include "GhclibHsVersions.h"
import GhcPrelude
import AsmCodeGen ( nativeCodeGen )
import LlvmCodeGen ( llvmCodeGen )
import UniqSupply ( mkSplitUniqSupply )
import Finder ( mkStubPaths )
import PprC ( writeCs )
import CmmLint ( cmmLint )
import Packages
import Cmm ( RawCmmGroup )
import HscTypes
import DynFlags
import Config
import Stream (Stream)
import qualified Stream
import FileCleanup
import ErrUtils
import Outputable
import Module
import SrcLoc
import Control.Exception
import System.Directory
import System.FilePath
import System.IO
codeOutput :: DynFlags
-> Module
-> FilePath
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, FilePath)]
-> [InstalledUnitId]
-> Stream IO RawCmmGroup ()
-> IO (FilePath,
(Bool, Maybe FilePath),
[(ForeignSrcLang, FilePath)])
codeOutput :: DynFlags
-> Module
-> FilePath
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, FilePath)]
-> [InstalledUnitId]
-> Stream IO RawCmmGroup ()
-> IO
(FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)])
codeOutput DynFlags
dflags Module
this_mod FilePath
filenm ModLocation
location ForeignStubs
foreign_stubs [(ForeignSrcLang, FilePath)]
foreign_fps [InstalledUnitId]
pkg_deps
Stream IO RawCmmGroup ()
cmm_stream
=
do {
; let linted_cmm_stream :: Stream IO RawCmmGroup ()
linted_cmm_stream =
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCmmLinting DynFlags
dflags
then (RawCmmGroup -> IO RawCmmGroup)
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM RawCmmGroup -> IO RawCmmGroup
forall d h.
(Outputable d, Outputable h) =>
GenCmmGroup d h CmmGraph -> IO (GenCmmGroup d h CmmGraph)
do_lint Stream IO RawCmmGroup ()
cmm_stream
else Stream IO RawCmmGroup ()
cmm_stream
do_lint :: GenCmmGroup d h CmmGraph -> IO (GenCmmGroup d h CmmGraph)
do_lint GenCmmGroup d h CmmGraph
cmm = IO DynFlags
-> SDoc
-> (GenCmmGroup d h CmmGraph -> ())
-> IO (GenCmmGroup d h CmmGraph)
-> IO (GenCmmGroup d h CmmGraph)
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags)
(FilePath -> SDoc
text FilePath
"CmmLint"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(() -> GenCmmGroup d h CmmGraph -> ()
forall a b. a -> b -> a
const ()) (IO (GenCmmGroup d h CmmGraph) -> IO (GenCmmGroup d h CmmGraph))
-> IO (GenCmmGroup d h CmmGraph) -> IO (GenCmmGroup d h CmmGraph)
forall a b. (a -> b) -> a -> b
$ do
{ case DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
forall d h.
(Outputable d, Outputable h) =>
DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint DynFlags
dflags GenCmmGroup d h CmmGraph
cmm of
Just SDoc
err -> do { DynFlags -> LogAction
log_action DynFlags
dflags
DynFlags
dflags
WarnReason
NoReason
Severity
SevDump
SrcSpan
noSrcSpan
(DynFlags -> PprStyle
defaultDumpStyle DynFlags
dflags)
SDoc
err
; DynFlags -> Int -> IO ()
ghcExit DynFlags
dflags Int
1
}
Maybe SDoc
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; GenCmmGroup d h CmmGraph -> IO (GenCmmGroup d h CmmGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return GenCmmGroup d h CmmGraph
cmm
}
; (Bool, Maybe FilePath)
stubs_exist <- DynFlags
-> Module
-> ModLocation
-> ForeignStubs
-> IO (Bool, Maybe FilePath)
outputForeignStubs DynFlags
dflags Module
this_mod ModLocation
location ForeignStubs
foreign_stubs
; case DynFlags -> HscTarget
hscTarget DynFlags
dflags of {
HscTarget
HscAsm -> DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup ()
-> IO ()
outputAsm DynFlags
dflags Module
this_mod ModLocation
location FilePath
filenm
Stream IO RawCmmGroup ()
linted_cmm_stream;
HscTarget
HscC -> DynFlags
-> FilePath
-> Stream IO RawCmmGroup ()
-> [InstalledUnitId]
-> IO ()
outputC DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup ()
linted_cmm_stream [InstalledUnitId]
pkg_deps;
HscTarget
HscLlvm -> DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
outputLlvm DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup ()
linted_cmm_stream;
HscTarget
HscInterpreted -> FilePath -> IO ()
forall a. FilePath -> a
panic FilePath
"codeOutput: HscInterpreted";
HscTarget
HscNothing -> FilePath -> IO ()
forall a. FilePath -> a
panic FilePath
"codeOutput: HscNothing"
}
; (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)])
-> IO
(FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
filenm, (Bool, Maybe FilePath)
stubs_exist, [(ForeignSrcLang, FilePath)]
foreign_fps)
}
doOutput :: String -> (Handle -> IO a) -> IO a
doOutput :: FilePath -> (Handle -> IO a) -> IO a
doOutput FilePath
filenm Handle -> IO a
io_action = IO Handle -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IOMode -> IO Handle
openFile FilePath
filenm IOMode
WriteMode) Handle -> IO ()
hClose Handle -> IO a
io_action
outputC :: DynFlags
-> FilePath
-> Stream IO RawCmmGroup ()
-> [InstalledUnitId]
-> IO ()
outputC :: DynFlags
-> FilePath
-> Stream IO RawCmmGroup ()
-> [InstalledUnitId]
-> IO ()
outputC DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup ()
cmm_stream [InstalledUnitId]
packages
= do
[RawCmmGroup]
rawcmms <- Stream IO RawCmmGroup () -> IO [RawCmmGroup]
forall (m :: * -> *) a. Monad m => Stream m a () -> m [a]
Stream.collect Stream IO RawCmmGroup ()
cmm_stream
let rts :: PackageConfig
rts = DynFlags -> UnitId -> PackageConfig
getPackageDetails DynFlags
dflags UnitId
rtsUnitId
let cc_injects :: FilePath
cc_injects = [FilePath] -> FilePath
unlines ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
mk_include (PackageConfig -> [FilePath]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [FilePath]
includes PackageConfig
rts))
mk_include :: FilePath -> FilePath
mk_include FilePath
h_file =
case FilePath
h_file of
Char
'"':FilePath
_ -> FilePath
"#include "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
h_file
Char
'<':FilePath
_ -> FilePath
"#include "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
h_file
FilePath
_ -> FilePath
"#include \""FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
h_fileFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"\""
let pkg_names :: [FilePath]
pkg_names = (InstalledUnitId -> FilePath) -> [InstalledUnitId] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map InstalledUnitId -> FilePath
installedUnitIdString [InstalledUnitId]
packages
FilePath -> (Handle -> IO ()) -> IO ()
forall a. FilePath -> (Handle -> IO a) -> IO a
doOutput FilePath
filenm ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Handle
h -> do
Handle -> FilePath -> IO ()
hPutStr Handle
h (FilePath
"/* GHC_PACKAGES " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
pkg_names FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n*/\n")
Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
cc_injects
DynFlags -> Handle -> [RawCmmGroup] -> IO ()
writeCs DynFlags
dflags Handle
h [RawCmmGroup]
rawcmms
outputAsm :: DynFlags -> Module -> ModLocation -> FilePath
-> Stream IO RawCmmGroup ()
-> IO ()
outputAsm :: DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup ()
-> IO ()
outputAsm DynFlags
dflags Module
this_mod ModLocation
location FilePath
filenm Stream IO RawCmmGroup ()
cmm_stream
| FilePath
cGhcWithNativeCodeGen FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"YES"
= do UniqSupply
ncg_uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'n'
DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
4 (FilePath -> SDoc
text FilePath
"Outputing asm to" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
filenm)
UniqSupply
_ <- {-# SCC "OutputAsm" #-} FilePath -> (Handle -> IO UniqSupply) -> IO UniqSupply
forall a. FilePath -> (Handle -> IO a) -> IO a
doOutput FilePath
filenm ((Handle -> IO UniqSupply) -> IO UniqSupply)
-> (Handle -> IO UniqSupply) -> IO UniqSupply
forall a b. (a -> b) -> a -> b
$
\Handle
h -> {-# SCC "NativeCodeGen" #-}
DynFlags
-> Module
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> IO UniqSupply
nativeCodeGen DynFlags
dflags Module
this_mod ModLocation
location Handle
h UniqSupply
ncg_uniqs Stream IO RawCmmGroup ()
cmm_stream
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= FilePath -> IO ()
forall a. FilePath -> a
panic FilePath
"This compiler was built without a native code generator"
outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
outputLlvm DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup ()
cmm_stream
= do UniqSupply
ncg_uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'n'
{-# SCC "llvm_output" #-} FilePath -> (Handle -> IO ()) -> IO ()
forall a. FilePath -> (Handle -> IO a) -> IO a
doOutput FilePath
filenm ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
\Handle
f -> {-# SCC "llvm_CodeGen" #-}
DynFlags
-> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
llvmCodeGen DynFlags
dflags Handle
f UniqSupply
ncg_uniqs Stream IO RawCmmGroup ()
cmm_stream
outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
-> IO (Bool,
Maybe FilePath)
outputForeignStubs :: DynFlags
-> Module
-> ModLocation
-> ForeignStubs
-> IO (Bool, Maybe FilePath)
outputForeignStubs DynFlags
dflags Module
mod ModLocation
location ForeignStubs
stubs
= do
let stub_h :: FilePath
stub_h = DynFlags -> ModuleName -> ModLocation -> FilePath
mkStubPaths DynFlags
dflags (Module -> ModuleName
moduleName Module
mod) ModLocation
location
FilePath
stub_c <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
"c"
case ForeignStubs
stubs of
ForeignStubs
NoStubs ->
(Bool, Maybe FilePath) -> IO (Bool, Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Maybe FilePath
forall a. Maybe a
Nothing)
ForeignStubs SDoc
h_code SDoc
c_code -> do
let
stub_c_output_d :: SDoc
stub_c_output_d = CodeStyle -> SDoc -> SDoc
pprCode CodeStyle
CStyle SDoc
c_code
stub_c_output_w :: FilePath
stub_c_output_w = DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags SDoc
stub_c_output_d
stub_h_output_d :: SDoc
stub_h_output_d = CodeStyle -> SDoc -> SDoc
pprCode CodeStyle
CStyle SDoc
h_code
stub_h_output_w :: FilePath
stub_h_output_w = DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags SDoc
stub_h_output_d
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
stub_h)
DynFlags -> DumpFlag -> FilePath -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_foreign
FilePath
"Foreign export header file" SDoc
stub_h_output_d
let rts_includes :: FilePath
rts_includes =
let rts_pkg :: PackageConfig
rts_pkg = DynFlags -> UnitId -> PackageConfig
getPackageDetails DynFlags
dflags UnitId
rtsUnitId in
(FilePath -> FilePath) -> [FilePath] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FilePath -> FilePath
mk_include (PackageConfig -> [FilePath]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [FilePath]
includes PackageConfig
rts_pkg)
mk_include :: FilePath -> FilePath
mk_include FilePath
i = FilePath
"#include \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
i FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"\n"
ffi_includes :: FilePath
ffi_includes | Bool
cLibFFI = FilePath
"#include \"ffi.h\"\n"
| Bool
otherwise = FilePath
""
Bool
stub_h_file_exists
<- FilePath -> FilePath -> FilePath -> FilePath -> IO Bool
outputForeignStubs_help FilePath
stub_h FilePath
stub_h_output_w
(FilePath
"#include \"HsFFI.h\"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cplusplus_hdr) FilePath
cplusplus_ftr
DynFlags -> DumpFlag -> FilePath -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_foreign
FilePath
"Foreign export stubs" SDoc
stub_c_output_d
Bool
stub_c_file_exists
<- FilePath -> FilePath -> FilePath -> FilePath -> IO Bool
outputForeignStubs_help FilePath
stub_c FilePath
stub_c_output_w
(FilePath
"#define IN_STG_CODE 0\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
"#include \"Rts.h\"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
rts_includes FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
ffi_includes FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
cplusplus_hdr)
FilePath
cplusplus_ftr
(Bool, Maybe FilePath) -> IO (Bool, Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
stub_h_file_exists, if Bool
stub_c_file_exists
then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
stub_c
else Maybe FilePath
forall a. Maybe a
Nothing )
where
cplusplus_hdr :: FilePath
cplusplus_hdr = FilePath
"#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
cplusplus_ftr :: FilePath
cplusplus_ftr = FilePath
"#ifdef __cplusplus\n}\n#endif\n"
outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
outputForeignStubs_help :: FilePath -> FilePath -> FilePath -> FilePath -> IO Bool
outputForeignStubs_help FilePath
_fname FilePath
"" FilePath
_header FilePath
_footer = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
outputForeignStubs_help FilePath
fname FilePath
doc_str FilePath
header FilePath
footer
= do FilePath -> FilePath -> IO ()
writeFile FilePath
fname (FilePath
header FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
doc_str FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
'\n'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
footer FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n")
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True