    {-
    (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}
    *                                                                      *
    ************************************************************************
    -}

    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