{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998

\section{Code output phase}
-}

{-# LANGUAGE ScopedTypeVariables #-}

module GHC.Driver.CodeOutput
   ( codeOutput
   , outputForeignStubs
   , profilingInitCode
   , ipInitCode
   )
where

import GHC.Prelude
import GHC.Platform
import GHC.ForeignSrcLang

import GHC.CmmToAsm     ( nativeCodeGen )
import GHC.CmmToLlvm    ( llvmCodeGen )

import GHC.CmmToC           ( cmmToC )
import GHC.Cmm.Lint         ( cmmLint )
import GHC.Cmm
import GHC.Cmm.CLabel

import GHC.Driver.Session
import GHC.Driver.Config.Finder    (initFinderOpts)
import GHC.Driver.Config.CmmToAsm  (initNCGConfig)
import GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig)
import GHC.Driver.Ppr
import GHC.Driver.Backend

import qualified GHC.Data.ShortText as ST
import GHC.Data.Stream           ( Stream )
import qualified GHC.Data.Stream as Stream

import GHC.Utils.TmpFs


import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
import GHC.Utils.Exception (bracket)
import GHC.Utils.Ppr (Mode(..))

import GHC.Unit
import GHC.Unit.Finder      ( mkStubPaths )

import GHC.Types.SrcLoc
import GHC.Types.CostCentre
import GHC.Types.ForeignStubs
import GHC.Types.Unique.Supply ( mkSplitUniqSupply )

import System.Directory
import System.FilePath
import System.IO
import Data.Set (Set)
import qualified Data.Set as Set

{-
************************************************************************
*                                                                      *
\subsection{Steering}
*                                                                      *
************************************************************************
-}

codeOutput
    :: forall a.
       Logger
    -> TmpFs
    -> DynFlags
    -> UnitState
    -> Module
    -> FilePath
    -> ModLocation
    -> (a -> ForeignStubs)
    -> [(ForeignSrcLang, FilePath)]
    -- ^ additional files to be compiled with the C compiler
    -> Set UnitId -- ^ Dependencies
    -> Stream IO RawCmmGroup a                       -- Compiled C--
    -> IO (FilePath,
           (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
           [(ForeignSrcLang, FilePath)]{-foreign_fps-},
           a)
codeOutput :: forall a.
Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> FilePath
-> ModLocation
-> (a -> ForeignStubs)
-> [(ForeignSrcLang, FilePath)]
-> Set UnitId
-> Stream IO RawCmmGroup a
-> IO
     (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)], a)
codeOutput Logger
logger TmpFs
tmpfs DynFlags
dflags UnitState
unit_state Module
this_mod FilePath
filenm ModLocation
location a -> ForeignStubs
genForeignStubs [(ForeignSrcLang, FilePath)]
foreign_fps Set UnitId
pkg_deps
  Stream IO RawCmmGroup a
cmm_stream
  =
    do  {
        -- Lint each CmmGroup as it goes past
        ; let linted_cmm_stream :: Stream IO RawCmmGroup a
linted_cmm_stream =
                 if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCmmLinting DynFlags
dflags
                    then (RawCmmGroup -> IO RawCmmGroup)
-> Stream IO RawCmmGroup a -> Stream IO RawCmmGroup a
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM RawCmmGroup -> IO RawCmmGroup
do_lint Stream IO RawCmmGroup a
cmm_stream
                    else Stream IO RawCmmGroup a
cmm_stream

              do_lint :: RawCmmGroup -> IO RawCmmGroup
do_lint RawCmmGroup
cmm = Logger
-> SDoc -> (RawCmmGroup -> ()) -> IO RawCmmGroup -> IO RawCmmGroup
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger
                  (FilePath -> SDoc
text FilePath
"CmmLint"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
                  (() -> RawCmmGroup -> ()
forall a b. a -> b -> a
const ()) (IO RawCmmGroup -> IO RawCmmGroup)
-> IO RawCmmGroup -> IO RawCmmGroup
forall a b. (a -> b) -> a -> b
$ do
                { case Platform -> RawCmmGroup -> Maybe SDoc
forall d h.
(OutputableP Platform d, OutputableP Platform h) =>
Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint (DynFlags -> Platform
targetPlatform DynFlags
dflags) RawCmmGroup
cmm of
                        Just SDoc
err -> do { Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger
                                                   MessageClass
MCDump
                                                   SrcSpan
noSrcSpan
                                                   (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle SDoc
err
                                       ; Logger -> Int -> IO ()
ghcExit Logger
logger Int
1
                                       }
                        Maybe SDoc
Nothing  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                ; RawCmmGroup -> IO RawCmmGroup
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RawCmmGroup
cmm
                }

        ; let final_stream :: Stream IO RawCmmGroup (ForeignStubs, a)
              final_stream :: Stream IO RawCmmGroup (ForeignStubs, a)
final_stream = do
                  { a
a <- Stream IO RawCmmGroup a
linted_cmm_stream
                  ; let stubs :: ForeignStubs
stubs = a -> ForeignStubs
genForeignStubs a
a
                  ; Module -> ForeignStubs -> Stream IO RawCmmGroup ()
emitInitializerDecls Module
this_mod ForeignStubs
stubs
                  ; (ForeignStubs, a) -> Stream IO RawCmmGroup (ForeignStubs, a)
forall a. a -> Stream IO RawCmmGroup a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignStubs
stubs, a
a) }

        ; (ForeignStubs
stubs, a
a) <- case DynFlags -> Backend
backend DynFlags
dflags of
                 Backend
NCG         -> Logger
-> DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup (ForeignStubs, a)
-> IO (ForeignStubs, a)
forall a.
Logger
-> DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup a
-> IO a
outputAsm Logger
logger DynFlags
dflags Module
this_mod ModLocation
location FilePath
filenm
                                          Stream IO RawCmmGroup (ForeignStubs, a)
final_stream
                 Backend
ViaC        -> Logger
-> DynFlags
-> FilePath
-> Stream IO RawCmmGroup (ForeignStubs, a)
-> Set UnitId
-> IO (ForeignStubs, a)
forall a.
Logger
-> DynFlags
-> FilePath
-> Stream IO RawCmmGroup a
-> Set UnitId
-> IO a
outputC Logger
logger DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup (ForeignStubs, a)
final_stream Set UnitId
pkg_deps
                 Backend
LLVM        -> Logger
-> DynFlags
-> FilePath
-> Stream IO RawCmmGroup (ForeignStubs, a)
-> IO (ForeignStubs, a)
forall a.
Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
outputLlvm Logger
logger DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup (ForeignStubs, a)
final_stream
                 Backend
Interpreter -> FilePath -> IO (ForeignStubs, a)
forall a. FilePath -> a
panic FilePath
"codeOutput: Interpreter"
                 Backend
NoBackend   -> FilePath -> IO (ForeignStubs, a)
forall a. FilePath -> a
panic FilePath
"codeOutput: NoBackend"
        ; (Bool, Maybe FilePath)
stubs_exist <- Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> ModLocation
-> ForeignStubs
-> IO (Bool, Maybe FilePath)
outputForeignStubs Logger
logger TmpFs
tmpfs DynFlags
dflags UnitState
unit_state Module
this_mod ModLocation
location ForeignStubs
stubs
        ; (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)], a)
-> IO
     (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)], a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
filenm, (Bool, Maybe FilePath)
stubs_exist, [(ForeignSrcLang, FilePath)]
foreign_fps, a
a)
        }

-- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.
emitInitializerDecls :: Module -> ForeignStubs -> Stream IO RawCmmGroup ()
emitInitializerDecls :: Module -> ForeignStubs -> Stream IO RawCmmGroup ()
emitInitializerDecls Module
this_mod (ForeignStubs CHeader
_ CStub
cstub)
  | [CLabel]
initializers <- CStub -> [CLabel]
getInitializers CStub
cstub
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [CLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CLabel]
initializers =
      let init_array :: GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
init_array = Section
-> RawCmmStatics
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sect RawCmmStatics
statics
          lbl :: CLabel
lbl = Module -> CLabel
mkInitializerArrayLabel Module
this_mod
          sect :: Section
sect = SectionType -> CLabel -> Section
Section SectionType
InitArray CLabel
lbl
          statics :: RawCmmStatics
statics = CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl
            [ CmmLit -> CmmStatic
CmmStaticLit (CmmLit -> CmmStatic) -> CmmLit -> CmmStatic
forall a b. (a -> b) -> a -> b
$ CLabel -> CmmLit
CmmLabel CLabel
fn_name
            | CLabel
fn_name <- [CLabel]
initializers
            ]
    in RawCmmGroup -> Stream IO RawCmmGroup ()
forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
init_array]
emitInitializerDecls Module
_ ForeignStubs
_ = () -> Stream IO RawCmmGroup ()
forall a. a -> Stream IO RawCmmGroup a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

doOutput :: String -> (Handle -> IO a) -> IO a
doOutput :: forall a. 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

{-
************************************************************************
*                                                                      *
\subsection{C}
*                                                                      *
************************************************************************
-}

outputC :: Logger
        -> DynFlags
        -> FilePath
        -> Stream IO RawCmmGroup a
        -> Set UnitId
        -> IO a
outputC :: forall a.
Logger
-> DynFlags
-> FilePath
-> Stream IO RawCmmGroup a
-> Set UnitId
-> IO a
outputC Logger
logger DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup a
cmm_stream Set UnitId
unit_deps =
  Logger -> SDoc -> (a -> ()) -> IO a -> IO a
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (FilePath -> SDoc
text FilePath
"C codegen") (\a
a -> a -> () -> ()
forall a b. a -> b -> b
seq a
a () {- FIXME -}) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    let pkg_names :: [FilePath]
pkg_names = (UnitId -> FilePath) -> [UnitId] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> FilePath
unitIdString (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toAscList Set UnitId
unit_deps)
    FilePath -> (Handle -> IO a) -> IO a
forall a. FilePath -> (Handle -> IO a) -> IO a
doOutput FilePath
filenm ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
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
"#include \"Stg.h\"\n"
      let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
          writeC :: RawCmmGroup -> IO ()
writeC RawCmmGroup
cmm = do
            let doc :: SDoc
doc = Platform -> RawCmmGroup -> SDoc
cmmToC Platform
platform RawCmmGroup
cmm
            Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_c_backend
                          FilePath
"C backend output"
                          DumpFormat
FormatC
                          SDoc
doc
            let ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags (LabelStyle -> PprStyle
PprCode LabelStyle
CStyle)
            SDocContext -> Mode -> Handle -> SDoc -> IO ()
printSDocLn SDocContext
ctx Mode
LeftMode Handle
h SDoc
doc
      Stream IO RawCmmGroup a
-> (forall a1. IO a1 -> IO a1) -> (RawCmmGroup -> IO ()) -> IO a
forall (m :: * -> *) (n :: * -> *) a b.
(Monad m, Monad n) =>
Stream m a b -> (forall a1. m a1 -> n a1) -> (a -> n ()) -> n b
Stream.consume Stream IO RawCmmGroup a
cmm_stream IO a1 -> IO a1
forall a. a -> a
forall a1. IO a1 -> IO a1
id RawCmmGroup -> IO ()
writeC

{-
************************************************************************
*                                                                      *
\subsection{Assembler}
*                                                                      *
************************************************************************
-}

outputAsm :: Logger
          -> DynFlags
          -> Module
          -> ModLocation
          -> FilePath
          -> Stream IO RawCmmGroup a
          -> IO a
outputAsm :: forall a.
Logger
-> DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup a
-> IO a
outputAsm Logger
logger DynFlags
dflags Module
this_mod ModLocation
location FilePath
filenm Stream IO RawCmmGroup a
cmm_stream = do
  UniqSupply
ncg_uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'n'
  Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
4 (FilePath -> SDoc
text FilePath
"Outputing asm to" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
filenm)
  let ncg_config :: NCGConfig
ncg_config = DynFlags -> Module -> NCGConfig
initNCGConfig DynFlags
dflags Module
this_mod
  {-# SCC "OutputAsm" #-} FilePath -> (Handle -> IO a) -> IO a
forall a. FilePath -> (Handle -> IO a) -> IO a
doOutput FilePath
filenm ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
    \Handle
h -> {-# SCC "NativeCodeGen" #-}
      Logger
-> NCGConfig
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
forall a.
Logger
-> NCGConfig
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen Logger
logger NCGConfig
ncg_config ModLocation
location Handle
h UniqSupply
ncg_uniqs Stream IO RawCmmGroup a
cmm_stream

{-
************************************************************************
*                                                                      *
\subsection{LLVM}
*                                                                      *
************************************************************************
-}

outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
outputLlvm :: forall a.
Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
outputLlvm Logger
logger DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup a
cmm_stream = do
  LlvmCgConfig
lcg_config <- Logger -> DynFlags -> IO LlvmCgConfig
initLlvmCgConfig Logger
logger DynFlags
dflags
  {-# SCC "llvm_output" #-} FilePath -> (Handle -> IO a) -> IO a
forall a. FilePath -> (Handle -> IO a) -> IO a
doOutput FilePath
filenm ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
    \Handle
f -> {-# SCC "llvm_CodeGen" #-}
      Logger -> LlvmCgConfig -> Handle -> Stream IO RawCmmGroup a -> IO a
forall a.
Logger -> LlvmCgConfig -> Handle -> Stream IO RawCmmGroup a -> IO a
llvmCodeGen Logger
logger LlvmCgConfig
lcg_config Handle
f Stream IO RawCmmGroup a
cmm_stream

{-
************************************************************************
*                                                                      *
\subsection{Foreign import/export}
*                                                                      *
************************************************************************
-}

{-
Note [Packaging libffi headers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The C code emitted by GHC for libffi adjustors must depend upon the ffi_arg type,
defined in <ffi.h>. For this reason, we must ensure that <ffi.h> is available
in binary distributions. To do so, we install these headers as part of the
`rts` package.
-}

outputForeignStubs
    :: Logger
    -> TmpFs
    -> DynFlags
    -> UnitState
    -> Module
    -> ModLocation
    -> ForeignStubs
    -> IO (Bool,         -- Header file created
           Maybe FilePath) -- C file created
outputForeignStubs :: Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> ModLocation
-> ForeignStubs
-> IO (Bool, Maybe FilePath)
outputForeignStubs Logger
logger TmpFs
tmpfs DynFlags
dflags UnitState
unit_state Module
mod ModLocation
location ForeignStubs
stubs
 = do
   let stub_h :: FilePath
stub_h = FinderOpts -> ModuleName -> ModLocation -> FilePath
mkStubPaths (DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) ModLocation
location
   FilePath
stub_c <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule FilePath
"c"

   case ForeignStubs
stubs of
     ForeignStubs
NoStubs ->
        (Bool, Maybe FilePath) -> IO (Bool, Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Maybe FilePath
forall a. Maybe a
Nothing)

     ForeignStubs (CHeader SDoc
h_code) (CStub SDoc
c_code [CLabel]
_ [CLabel]
_) -> do
        let
            stub_c_output_d :: SDoc
stub_c_output_d = LabelStyle -> SDoc -> SDoc
pprCode LabelStyle
CStyle SDoc
c_code
            stub_c_output_w :: FilePath
stub_c_output_w = DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags SDoc
stub_c_output_d

            -- Header file protos for "foreign export"ed functions.
            stub_h_output_d :: SDoc
stub_h_output_d = LabelStyle -> SDoc -> SDoc
pprCode LabelStyle
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)

        Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_foreign
                      FilePath
"Foreign export header file"
                      DumpFormat
FormatC
                      SDoc
stub_h_output_d

        -- we need the #includes from the rts package for the stub files
        let rts_includes :: FilePath
rts_includes =
               let mrts_pkg :: Maybe UnitInfo
mrts_pkg = UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
unit_state UnitId
rtsUnitId
                   mk_include :: ShortText -> FilePath
mk_include ShortText
i = FilePath
"#include \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ShortText -> FilePath
ST.unpack ShortText
i FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"\n"
               in case Maybe UnitInfo
mrts_pkg of
                    Just UnitInfo
rts_pkg -> (ShortText -> FilePath) -> [ShortText] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ShortText -> FilePath
mk_include (UnitInfo -> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitIncludes UnitInfo
rts_pkg)
                    -- This case only happens when compiling foreign stub for the rts
                    -- library itself. The only time we do this at the moment is for
                    -- IPE information for the RTS info tables
                    Maybe UnitInfo
Nothing -> FilePath
""

            -- wrapper code mentions the ffi_arg type, which comes from ffi.h
            ffi_includes :: FilePath
ffi_includes
              | PlatformMisc -> Bool
platformMisc_libFFI (PlatformMisc -> Bool) -> PlatformMisc -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags = 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

        Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_foreign
                      FilePath
"Foreign export stubs" DumpFormat
FormatC 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
           -- We're adding the default hc_header to the stub file, but this
           -- isn't really HC code, so we need to define IN_STG_CODE==0 to
           -- avoid the register variables etc. being enabled.

        (Bool, Maybe FilePath) -> IO (Bool, Maybe FilePath)
forall a. a -> IO a
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
"#if defined(__cplusplus)\nextern \"C\" {\n#endif\n"
   cplusplus_ftr :: FilePath
cplusplus_ftr = FilePath
"#if defined(__cplusplus)\n}\n#endif\n"


-- Don't use doOutput for dumping the f. export stubs
-- since it is more than likely that the stubs file will
-- turn out to be empty, in which case no file should be created.
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- -----------------------------------------------------------------------------
-- Initialising cost centres

-- We must produce declarations for the cost-centres defined in this
-- module;

-- | Generate code to initialise cost centres
profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub
profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub
profilingInitCode Platform
platform Module
this_mod ([CostCentre]
local_CCs, [CostCentreStack]
singleton_CCSs)
 = {-# SCC profilingInitCode #-}
   Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub Platform
platform CLabel
fn_name SDoc
decls SDoc
body
 where
   fn_name :: CLabel
fn_name = Module -> FilePath -> CLabel
mkInitializerStubLabel Module
this_mod FilePath
"prof_init"
   decls :: SDoc
decls = [SDoc] -> SDoc
vcat
        ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$  (CostCentre -> SDoc) -> [CostCentre] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CostCentre -> SDoc
emit_cc_decl [CostCentre]
local_CCs
        [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ (CostCentreStack -> SDoc) -> [CostCentreStack] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CostCentreStack -> SDoc
emit_ccs_decl [CostCentreStack]
singleton_CCSs
        [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [[CostCentre] -> SDoc
emit_cc_list [CostCentre]
local_CCs]
        [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [[CostCentreStack] -> SDoc
emit_ccs_list [CostCentreStack]
singleton_CCSs]
   body :: SDoc
body = [SDoc] -> SDoc
vcat
        [ FilePath -> SDoc
text FilePath
"registerCcList" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
local_cc_list_label SDoc -> SDoc -> SDoc
<> SDoc
semi
        , FilePath -> SDoc
text FilePath
"registerCcsList" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
singleton_cc_list_label SDoc -> SDoc -> SDoc
<> SDoc
semi
        ]
   emit_cc_decl :: CostCentre -> SDoc
emit_cc_decl CostCentre
cc =
       FilePath -> SDoc
text FilePath
"extern CostCentre" SDoc -> SDoc -> SDoc
<+> SDoc
cc_lbl SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"[];"
     where cc_lbl :: SDoc
cc_lbl = Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform (CostCentre -> CLabel
mkCCLabel CostCentre
cc)
   local_cc_list_label :: SDoc
local_cc_list_label = FilePath -> SDoc
text FilePath
"local_cc_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
   emit_cc_list :: [CostCentre] -> SDoc
emit_cc_list [CostCentre]
ccs =
      FilePath -> SDoc
text FilePath
"static CostCentre *" SDoc -> SDoc -> SDoc
<> SDoc
local_cc_list_label SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"[] ="
      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform (CostCentre -> CLabel
mkCCLabel CostCentre
cc) SDoc -> SDoc -> SDoc
<> SDoc
comma
                         | CostCentre
cc <- [CostCentre]
ccs
                         ] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [FilePath -> SDoc
text FilePath
"NULL"])
      SDoc -> SDoc -> SDoc
<> SDoc
semi

   emit_ccs_decl :: CostCentreStack -> SDoc
emit_ccs_decl CostCentreStack
ccs =
       FilePath -> SDoc
text FilePath
"extern CostCentreStack" SDoc -> SDoc -> SDoc
<+> SDoc
ccs_lbl SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"[];"
     where ccs_lbl :: SDoc
ccs_lbl = Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform (CostCentreStack -> CLabel
mkCCSLabel CostCentreStack
ccs)
   singleton_cc_list_label :: SDoc
singleton_cc_list_label = FilePath -> SDoc
text FilePath
"singleton_cc_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
   emit_ccs_list :: [CostCentreStack] -> SDoc
emit_ccs_list [CostCentreStack]
ccs =
      FilePath -> SDoc
text FilePath
"static CostCentreStack *" SDoc -> SDoc -> SDoc
<> SDoc
singleton_cc_list_label SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"[] ="
      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform (CostCentreStack -> CLabel
mkCCSLabel CostCentreStack
cc) SDoc -> SDoc -> SDoc
<> SDoc
comma
                         | CostCentreStack
cc <- [CostCentreStack]
ccs
                         ] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [FilePath -> SDoc
text FilePath
"NULL"])
      SDoc -> SDoc -> SDoc
<> SDoc
semi

-- | Generate code to initialise info pointer origin
-- See Note [Mapping Info Tables to Source Positions]
ipInitCode
  :: Bool            -- is Opt_InfoTableMap enabled or not
  -> Platform
  -> Module
  -> CStub
ipInitCode :: Bool -> Platform -> Module -> CStub
ipInitCode Bool
do_info_table Platform
platform Module
this_mod
  | Bool -> Bool
not Bool
do_info_table = CStub
forall a. Monoid a => a
mempty
  | Bool
otherwise = Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub Platform
platform CLabel
fn_nm SDoc
ipe_buffer_decl SDoc
body
 where
   fn_nm :: CLabel
fn_nm = Module -> FilePath -> CLabel
mkInitializerStubLabel Module
this_mod FilePath
"ip_init"

   body :: SDoc
body = FilePath -> SDoc
text FilePath
"registerInfoProvList" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (FilePath -> SDoc
text FilePath
"&" SDoc -> SDoc -> SDoc
<> SDoc
ipe_buffer_label) SDoc -> SDoc -> SDoc
<> SDoc
semi

   ipe_buffer_label :: SDoc
ipe_buffer_label = Platform -> LabelStyle -> CLabel -> SDoc
pprCLabel Platform
platform LabelStyle
CStyle (Module -> CLabel
mkIPELabel Module
this_mod)

   ipe_buffer_decl :: SDoc
ipe_buffer_decl =
       FilePath -> SDoc
text FilePath
"extern IpeBufferListNode" SDoc -> SDoc -> SDoc
<+> SDoc
ipe_buffer_label SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
";"