module GHC.Driver.CodeOutput
( codeOutput
, outputForeignStubs
, profilingInitCode
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.CmmToAsm ( nativeCodeGen )
import GHC.CmmToLlvm ( llvmCodeGen )
import GHC.Types.Unique.Supply ( mkSplitUniqSupply )
import GHC.Driver.Finder ( mkStubPaths )
import GHC.CmmToC ( writeC )
import GHC.Cmm.Lint ( cmmLint )
import GHC.Cmm ( RawCmmGroup )
import GHC.Cmm.CLabel
import GHC.Driver.Types
import GHC.Driver.Session
import GHC.Data.Stream ( Stream )
import qualified GHC.Data.Stream as Stream
import GHC.SysTools.FileCleanup
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Unit
import GHC.Types.SrcLoc
import GHC.Types.CostCentre
import Control.Exception
import System.Directory
import System.FilePath
import System.IO
codeOutput :: DynFlags
-> Module
-> FilePath
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, FilePath)]
-> [UnitId]
-> Stream IO RawCmmGroup a
-> IO (FilePath,
(Bool, Maybe FilePath),
[(ForeignSrcLang, FilePath)],
a)
codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
cmm_stream
=
do {
; let linted_cmm_stream =
if gopt Opt_DoCmmLinting dflags
then Stream.mapM do_lint cmm_stream
else cmm_stream
do_lint cmm = withTimingSilent
dflags
(text "CmmLint"<+>brackets (ppr this_mod))
(const ()) $ do
{ case cmmLint dflags cmm of
Just err -> do { log_action dflags
dflags
NoReason
SevDump
noSrcSpan
$ withPprStyle defaultDumpStyle err
; ghcExit dflags 1
}
Nothing -> return ()
; return cmm
}
; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
; a <- case hscTarget dflags of
HscAsm -> outputAsm dflags this_mod location filenm
linted_cmm_stream
HscC -> outputC dflags filenm linted_cmm_stream pkg_deps
HscLlvm -> outputLlvm dflags filenm linted_cmm_stream
HscInterpreted -> panic "codeOutput: HscInterpreted"
HscNothing -> panic "codeOutput: HscNothing"
; return (filenm, stubs_exist, foreign_fps, a)
}
doOutput :: String -> (Handle -> IO a) -> IO a
doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
outputC :: DynFlags
-> FilePath
-> Stream IO RawCmmGroup a
-> [UnitId]
-> IO a
outputC dflags filenm cmm_stream packages
= do
withTiming dflags (text "C codegen") (\a -> seq a () ) $ do
let pkg_names = map unitIdString packages
doOutput filenm $ \ h -> do
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
hPutStr h "#include \"Stg.h\"\n"
Stream.consume cmm_stream (writeC dflags h)
outputAsm :: DynFlags -> Module -> ModLocation -> FilePath
-> Stream IO RawCmmGroup a
-> IO a
outputAsm dflags this_mod location filenm cmm_stream
= do ncg_uniqs <- mkSplitUniqSupply 'n'
debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)
doOutput filenm $
\h ->
nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream
outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
outputLlvm dflags filenm cmm_stream
= do doOutput filenm $
\f ->
llvmCodeGen dflags f cmm_stream
outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
-> IO (Bool,
Maybe FilePath)
outputForeignStubs dflags mod location stubs
= do
let stub_h = mkStubPaths dflags (moduleName mod) location
stub_c <- newTempName dflags TFL_CurrentModule "c"
case stubs of
NoStubs ->
return (False, Nothing)
ForeignStubs h_code c_code -> do
let
stub_c_output_d = pprCode CStyle c_code
stub_c_output_w = showSDoc dflags stub_c_output_d
stub_h_output_d = pprCode CStyle h_code
stub_h_output_w = showSDoc dflags stub_h_output_d
createDirectoryIfMissing True (takeDirectory stub_h)
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export header file"
FormatC
stub_h_output_d
let rts_includes =
let rts_pkg = unsafeLookupUnitId (unitState dflags) rtsUnitId in
concatMap mk_include (unitIncludes rts_pkg)
mk_include i = "#include \"" ++ i ++ "\"\n"
ffi_includes
| platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n"
| otherwise = ""
stub_h_file_exists
<- outputForeignStubs_help stub_h stub_h_output_w
("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export stubs" FormatC stub_c_output_d
stub_c_file_exists
<- outputForeignStubs_help stub_c stub_c_output_w
("#define IN_STG_CODE 0\n" ++
"#include <Rts.h>\n" ++
rts_includes ++
ffi_includes ++
cplusplus_hdr)
cplusplus_ftr
return (stub_h_file_exists, if stub_c_file_exists
then Just stub_c
else Nothing )
where
cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n"
cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n"
outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
outputForeignStubs_help _fname "" _header _footer = return False
outputForeignStubs_help fname doc_str header footer
= do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
return True
profilingInitCode :: Module -> CollectedCCs -> SDoc
profilingInitCode this_mod (local_CCs, singleton_CCSs)
= vcat
$ map emit_cc_decl local_CCs
++ map emit_ccs_decl singleton_CCSs
++ [emit_cc_list local_CCs]
++ [emit_ccs_list singleton_CCSs]
++ [ text "static void prof_init_" <> ppr this_mod
<> text "(void) __attribute__((constructor));"
, text "static void prof_init_" <> ppr this_mod <> text "(void)"
, braces (vcat
[ text "registerCcList" <> parens local_cc_list_label <> semi
, text "registerCcsList" <> parens singleton_cc_list_label <> semi
])
]
where
emit_cc_decl cc =
text "extern CostCentre" <+> cc_lbl <> text "[];"
where cc_lbl = ppr (mkCCLabel cc)
local_cc_list_label = text "local_cc_" <> ppr this_mod
emit_cc_list ccs =
text "static CostCentre *" <> local_cc_list_label <> text "[] ="
<+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma
| cc <- ccs
] ++ [text "NULL"])
<> semi
emit_ccs_decl ccs =
text "extern CostCentreStack" <+> ccs_lbl <> text "[];"
where ccs_lbl = ppr (mkCCSLabel ccs)
singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod
emit_ccs_list ccs =
text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="
<+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma
| cc <- ccs
] ++ [text "NULL"])
<> semi