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

\section{Code output phase}
-}

{-# LANGUAGE CPP #-}

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

#include "HsVersions.h"

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              ( RawCmmGroup )
import GHC.Cmm.CLabel

import GHC.Driver.Session
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.Unit
import GHC.Unit.State
import GHC.Unit.Finder      ( mkStubPaths )

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

import Control.Exception
import System.Directory
import System.FilePath
import System.IO

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

codeOutput
    :: Logger
    -> TmpFs
    -> DynFlags
    -> UnitState
    -> Module
    -> FilePath
    -> ModLocation
    -> (a -> ForeignStubs)
    -> [(ForeignSrcLang, FilePath)]
    -- ^ additional files to be compiled with the C compiler
    -> [UnitId]
    -> 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)]
-> [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 [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
-> DynFlags
-> SDoc
-> (RawCmmGroup -> ())
-> IO RawCmmGroup
-> IO RawCmmGroup
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent Logger
logger
                  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))
                  (() -> 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 -> LogAction
putLogMsg Logger
logger
                                                   DynFlags
dflags
                                                   WarnReason
NoReason
                                                   Severity
SevDump
                                                   SrcSpan
noSrcSpan
                                                   (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle SDoc
err
                                       ; Logger -> DynFlags -> Int -> IO ()
ghcExit Logger
logger DynFlags
dflags Int
1
                                       }
                        Maybe SDoc
Nothing  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                ; RawCmmGroup -> IO RawCmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return RawCmmGroup
cmm
                }

        ; a
a <- case DynFlags -> Backend
backend DynFlags
dflags of
                 Backend
NCG         -> Logger
-> DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup a
-> IO 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 a
linted_cmm_stream
                 Backend
ViaC        -> Logger
-> DynFlags
-> FilePath
-> Stream IO RawCmmGroup a
-> [UnitId]
-> IO a
forall a.
Logger
-> DynFlags
-> FilePath
-> Stream IO RawCmmGroup a
-> [UnitId]
-> IO a
outputC Logger
logger DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup a
linted_cmm_stream [UnitId]
pkg_deps
                 Backend
LLVM        -> Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
forall a.
Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
outputLlvm Logger
logger DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup a
linted_cmm_stream
                 Backend
Interpreter -> FilePath -> IO a
forall a. FilePath -> a
panic FilePath
"codeOutput: Interpreter"
                 Backend
NoBackend   -> FilePath -> IO a
forall a. FilePath -> a
panic FilePath
"codeOutput: NoBackend"
        ; let stubs :: ForeignStubs
stubs = a -> ForeignStubs
genForeignStubs a
a
        ; (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 (m :: * -> *) a. Monad m => a -> m a
return (FilePath
filenm, (Bool, Maybe FilePath)
stubs_exist, [(ForeignSrcLang, FilePath)]
foreign_fps, a
a)
        }

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
        -> [UnitId]
        -> IO a
outputC :: forall a.
Logger
-> DynFlags
-> FilePath
-> Stream IO RawCmmGroup a
-> [UnitId]
-> IO a
outputC Logger
logger DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup a
cmm_stream [UnitId]
packages =
  Logger -> DynFlags -> SDoc -> (a -> ()) -> IO a -> IO a
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags (FilePath -> SDoc
text FilePath
"C codegen") (\a
a -> a -> () -> ()
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 [UnitId]
packages
    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
-> DynFlags -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_c_backend
                          FilePath
"C backend output"
                          DumpFormat
FormatC
                          SDoc
doc
            DynFlags -> Handle -> SDoc -> IO ()
printForC DynFlags
dflags 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 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 -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
4 (FilePath -> SDoc
text FilePath
"Outputing asm to" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
filenm)
  {-# 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
-> DynFlags
-> Module
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
forall a.
Logger
-> DynFlags
-> Module
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen Logger
logger DynFlags
dflags Module
this_mod 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 =
  {-# 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 -> DynFlags -> Handle -> Stream IO RawCmmGroup a -> IO a
forall a.
Logger -> DynFlags -> Handle -> Stream IO RawCmmGroup a -> IO a
llvmCodeGen Logger
logger DynFlags
dflags 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 = DynFlags -> ModuleName -> ModLocation -> FilePath
mkStubPaths DynFlags
dflags (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) ModLocation
location
   FilePath
stub_c <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs 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 (CHeader SDoc
h_code) (CStub SDoc
c_code) -> 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
-> DynFlags -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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
-> DynFlags -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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 (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 (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

-- -----------------------------------------------------------------------------
-- 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)
 = SDoc -> CStub
CStub (SDoc -> CStub) -> SDoc -> CStub
forall a b. (a -> b) -> a -> b
$ [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]
    [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> SDoc
text FilePath
"static void prof_init_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
            SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"(void) __attribute__((constructor));"
       , FilePath -> SDoc
text FilePath
"static void prof_init_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"(void)"
       , SDoc -> SDoc
braces ([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
                 ])
       ]
 where
   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 :: DynFlags -> Module -> [InfoProvEnt] -> CStub
ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> CStub
ipInitCode DynFlags
dflags Module
this_mod [InfoProvEnt]
ents
 = if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMap DynFlags
dflags)
    then CStub
forall a. Monoid a => a
mempty
    else SDoc -> CStub
CStub (SDoc -> CStub) -> SDoc -> CStub
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
    ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$  (InfoProvEnt -> SDoc) -> [InfoProvEnt] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map InfoProvEnt -> SDoc
emit_ipe_decl [InfoProvEnt]
ents
    [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [[InfoProvEnt] -> SDoc
emit_ipe_list [InfoProvEnt]
ents]
    [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> SDoc
text FilePath
"static void ip_init_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
            SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"(void) __attribute__((constructor));"
       , FilePath -> SDoc
text FilePath
"static void ip_init_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"(void)"
       , SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
                 [ FilePath -> SDoc
text FilePath
"registerInfoProvList" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
local_ipe_list_label SDoc -> SDoc -> SDoc
<> SDoc
semi
                 ])
       ]
 where
   platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
   emit_ipe_decl :: InfoProvEnt -> SDoc
emit_ipe_decl InfoProvEnt
ipe =
       FilePath -> SDoc
text FilePath
"extern InfoProvEnt" SDoc -> SDoc -> SDoc
<+> SDoc
ipe_lbl SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"[];"
     where ipe_lbl :: SDoc
ipe_lbl = Platform -> LabelStyle -> CLabel -> SDoc
pprCLabel Platform
platform LabelStyle
CStyle (InfoProvEnt -> CLabel
mkIPELabel InfoProvEnt
ipe)
   local_ipe_list_label :: SDoc
local_ipe_list_label = FilePath -> SDoc
text FilePath
"local_ipe_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
   emit_ipe_list :: [InfoProvEnt] -> SDoc
emit_ipe_list [InfoProvEnt]
ipes =
      FilePath -> SDoc
text FilePath
"static InfoProvEnt *" SDoc -> SDoc -> SDoc
<> SDoc
local_ipe_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 -> LabelStyle -> CLabel -> SDoc
pprCLabel Platform
platform LabelStyle
CStyle (InfoProvEnt -> CLabel
mkIPELabel InfoProvEnt
ipe) SDoc -> SDoc -> SDoc
<> SDoc
comma
                         | InfoProvEnt
ipe <- [InfoProvEnt]
ipes
                         ] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [FilePath -> SDoc
text FilePath
"NULL"])
      SDoc -> SDoc -> SDoc
<> SDoc
semi