{-
(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.Data.FastString

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.StgToCmm.CgUtils (CgStream)

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

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

import GHC.Utils.TmpFs


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

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

import GHC.Types.SrcLoc
import GHC.Types.CostCentre
import GHC.Types.ForeignStubs
import GHC.Types.Unique.DSM

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
    -> LlvmConfigCache
    -> DynFlags
    -> UnitState
    -> Module
    -> FilePath
    -> ModLocation
    -> (a -> ForeignStubs)
    -> [(ForeignSrcLang, FilePath)]
    -- ^ additional files to be compiled with the C compiler
    -> Set UnitId -- ^ Dependencies
    -> DUniqSupply -- ^ The deterministic unique supply to run the CgStream.
                   -- See Note [Deterministic Uniques in the CG]
    -> CgStream 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
-> LlvmConfigCache
-> DynFlags
-> UnitState
-> Module
-> FilePath
-> ModLocation
-> (a -> ForeignStubs)
-> [(ForeignSrcLang, FilePath)]
-> Set UnitId
-> DUniqSupply
-> CgStream RawCmmGroup a
-> IO
     (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)], a)
codeOutput Logger
logger TmpFs
tmpfs LlvmConfigCache
llvm_config DynFlags
dflags UnitState
unit_state Module
this_mod FilePath
filenm ModLocation
location a -> ForeignStubs
genForeignStubs [(ForeignSrcLang, FilePath)]
foreign_fps Set UnitId
pkg_deps DUniqSupply
dus0
  CgStream RawCmmGroup a
cmm_stream
  =
    do  {
        -- Lint each CmmGroup as it goes past
        ; let linted_cmm_stream :: CgStream RawCmmGroup a
linted_cmm_stream =
                 if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCmmLinting DynFlags
dflags
                    then (RawCmmGroup -> UniqDSMT IO RawCmmGroup)
-> CgStream RawCmmGroup a -> CgStream RawCmmGroup a
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM (IO RawCmmGroup -> UniqDSMT IO RawCmmGroup
forall a. IO a -> UniqDSMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RawCmmGroup -> UniqDSMT IO RawCmmGroup)
-> (RawCmmGroup -> IO RawCmmGroup)
-> RawCmmGroup
-> UniqDSMT IO RawCmmGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawCmmGroup -> IO RawCmmGroup
do_lint) CgStream RawCmmGroup a
cmm_stream
                    else CgStream 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
forall doc. IsLine doc => FilePath -> doc
text FilePath
"CmmLint"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
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
MCInfo -- See Note [MCInfo for Lint] in "GHC.Core.Lint"
                                                   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 :: CgStream RawCmmGroup (ForeignStubs, a)
              final_stream :: CgStream RawCmmGroup (ForeignStubs, a)
final_stream = do
                  { a <- CgStream RawCmmGroup a
linted_cmm_stream
                  ; let stubs = a -> ForeignStubs
genForeignStubs a
a
                  ; emitInitializerDecls this_mod stubs
                  ; return (stubs, a) }

        ; let dus1 :: DUniqSupply
dus1 = Char -> DUniqSupply -> DUniqSupply
newTagDUniqSupply Char
'n' DUniqSupply
dus0
        ; (stubs, a) <- case Backend -> DefunctionalizedCodeOutput
backendCodeOutput (DynFlags -> Backend
backend DynFlags
dflags) of
                 DefunctionalizedCodeOutput
NcgCodeOutput  -> Logger
-> DynFlags
-> Module
-> ModLocation
-> FilePath
-> DUniqSupply
-> CgStream RawCmmGroup (ForeignStubs, a)
-> IO (ForeignStubs, a)
forall a.
Logger
-> DynFlags
-> Module
-> ModLocation
-> FilePath
-> DUniqSupply
-> CgStream RawCmmGroup a
-> IO a
outputAsm Logger
logger DynFlags
dflags Module
this_mod ModLocation
location FilePath
filenm DUniqSupply
dus1
                                             CgStream RawCmmGroup (ForeignStubs, a)
final_stream
                 DefunctionalizedCodeOutput
ViaCCodeOutput -> Logger
-> DynFlags
-> FilePath
-> DUniqSupply
-> CgStream RawCmmGroup (ForeignStubs, a)
-> Set UnitId
-> IO (ForeignStubs, a)
forall a.
Logger
-> DynFlags
-> FilePath
-> DUniqSupply
-> CgStream RawCmmGroup a
-> Set UnitId
-> IO a
outputC Logger
logger DynFlags
dflags FilePath
filenm DUniqSupply
dus1 CgStream RawCmmGroup (ForeignStubs, a)
final_stream Set UnitId
pkg_deps
                 DefunctionalizedCodeOutput
LlvmCodeOutput -> Logger
-> LlvmConfigCache
-> DynFlags
-> FilePath
-> DUniqSupply
-> CgStream RawCmmGroup (ForeignStubs, a)
-> IO (ForeignStubs, a)
forall a.
Logger
-> LlvmConfigCache
-> DynFlags
-> FilePath
-> DUniqSupply
-> CgStream RawCmmGroup a
-> IO a
outputLlvm Logger
logger LlvmConfigCache
llvm_config DynFlags
dflags FilePath
filenm DUniqSupply
dus1 CgStream RawCmmGroup (ForeignStubs, a)
final_stream
                 DefunctionalizedCodeOutput
JSCodeOutput   -> Logger
-> LlvmConfigCache
-> DynFlags
-> FilePath
-> CgStream RawCmmGroup (ForeignStubs, a)
-> IO (ForeignStubs, a)
forall a.
Logger
-> LlvmConfigCache
-> DynFlags
-> FilePath
-> CgStream RawCmmGroup a
-> IO a
outputJS Logger
logger LlvmConfigCache
llvm_config DynFlags
dflags FilePath
filenm CgStream RawCmmGroup (ForeignStubs, a)
final_stream
        ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs
        ; return (filenm, stubs_exist, foreign_fps, a)
        }

-- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.
emitInitializerDecls :: Module -> ForeignStubs -> CgStream RawCmmGroup ()
emitInitializerDecls :: Module -> ForeignStubs -> CgStream 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 -> CgStream RawCmmGroup ()
forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
init_array]
emitInitializerDecls Module
_ ForeignStubs
_ = () -> CgStream RawCmmGroup ()
forall a. a -> Stream (UniqDSMT 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
        -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream
                       -- See Note [Deterministic Uniques in the CG]
        -> CgStream RawCmmGroup a
        -> Set UnitId
        -> IO a
outputC :: forall a.
Logger
-> DynFlags
-> FilePath
-> DUniqSupply
-> CgStream RawCmmGroup a
-> Set UnitId
-> IO a
outputC Logger
logger DynFlags
dflags FilePath
filenm DUniqSupply
dus CgStream 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
forall doc. IsLine doc => FilePath -> doc
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 -> ((a, DUniqSupply) -> a) -> IO (a, DUniqSupply) -> IO a
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, DUniqSupply) -> a
forall a b. (a, b) -> a
fst (IO (a, DUniqSupply) -> IO a) -> IO (a, DUniqSupply) -> IO a
forall a b. (a -> b) -> a -> b
$ DUniqSupply -> UniqDSMT IO a -> IO (a, DUniqSupply)
forall (m :: * -> *) a.
DUniqSupply -> UniqDSMT m a -> m (a, DUniqSupply)
runUDSMT DUniqSupply
dus (UniqDSMT IO a -> IO (a, DUniqSupply))
-> UniqDSMT IO a -> IO (a, DUniqSupply)
forall a b. (a -> b) -> a -> b
$ do
      IO () -> UniqDSMT IO ()
forall a. IO a -> UniqDSMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UniqDSMT IO ()) -> IO () -> UniqDSMT IO ()
forall a b. (a -> b) -> a -> b
$ 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 PprStyle
PprCode
            SDocContext -> Mode -> Handle -> SDoc -> IO ()
printSDocLn SDocContext
ctx Mode
LeftMode Handle
h SDoc
doc
      CgStream RawCmmGroup a
-> (forall a1. UniqDSMT IO a1 -> UniqDSMT IO a1)
-> (RawCmmGroup -> UniqDSMT IO ())
-> UniqDSMT 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 CgStream RawCmmGroup a
cmm_stream UniqDSMT IO a1 -> UniqDSMT IO a1
forall a. a -> a
forall a1. UniqDSMT IO a1 -> UniqDSMT IO a1
id (IO () -> UniqDSMT IO ()
forall a. IO a -> UniqDSMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UniqDSMT IO ())
-> (RawCmmGroup -> IO ()) -> RawCmmGroup -> UniqDSMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawCmmGroup -> IO ()
writeC)

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

outputAsm :: Logger
          -> DynFlags
          -> Module
          -> ModLocation
          -> FilePath
          -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream
                         -- See Note [Deterministic Uniques in the CG]
          -> CgStream RawCmmGroup a
          -> IO a
outputAsm :: forall a.
Logger
-> DynFlags
-> Module
-> ModLocation
-> FilePath
-> DUniqSupply
-> CgStream RawCmmGroup a
-> IO a
outputAsm Logger
logger DynFlags
dflags Module
this_mod ModLocation
location FilePath
filenm DUniqSupply
dus CgStream RawCmmGroup a
cmm_stream = do
  -- Update tag of uniques in Stream
  Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
4 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Outputing asm to" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
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" #-}
      ((a, DUniqSupply) -> a) -> IO (a, DUniqSupply) -> IO a
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, DUniqSupply) -> a
forall a b. (a, b) -> a
fst (IO (a, DUniqSupply) -> IO a) -> IO (a, DUniqSupply) -> IO a
forall a b. (a -> b) -> a -> b
$
      DUniqSupply -> UniqDSMT IO a -> IO (a, DUniqSupply)
forall (m :: * -> *) a.
DUniqSupply -> UniqDSMT m a -> m (a, DUniqSupply)
runUDSMT DUniqSupply
dus (UniqDSMT IO a -> IO (a, DUniqSupply))
-> UniqDSMT IO a -> IO (a, DUniqSupply)
forall a b. (a -> b) -> a -> b
$ Char -> UniqDSMT IO a -> UniqDSMT IO a
forall (m :: * -> *) a.
Monad m =>
Char -> UniqDSMT m a -> UniqDSMT m a
setTagUDSMT Char
'n' (UniqDSMT IO a -> UniqDSMT IO a) -> UniqDSMT IO a -> UniqDSMT IO a
forall a b. (a -> b) -> a -> b
$
      Logger
-> ToolSettings
-> NCGConfig
-> ModLocation
-> Handle
-> CgStream RawCmmGroup a
-> UniqDSMT IO a
forall a.
Logger
-> ToolSettings
-> NCGConfig
-> ModLocation
-> Handle
-> CgStream RawCmmGroup a
-> UniqDSMT IO a
nativeCodeGen Logger
logger (DynFlags -> ToolSettings
toolSettings DynFlags
dflags) NCGConfig
ncg_config ModLocation
location Handle
h CgStream RawCmmGroup a
cmm_stream

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

outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath
           -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream
                          -- See Note [Deterministic Uniques in the CG]
           -> CgStream RawCmmGroup a -> IO a
outputLlvm :: forall a.
Logger
-> LlvmConfigCache
-> DynFlags
-> FilePath
-> DUniqSupply
-> CgStream RawCmmGroup a
-> IO a
outputLlvm Logger
logger LlvmConfigCache
llvm_config DynFlags
dflags FilePath
filenm DUniqSupply
dus CgStream RawCmmGroup a
cmm_stream = do
  lcg_config <- Logger -> LlvmConfigCache -> DynFlags -> IO LlvmCgConfig
initLlvmCgConfig Logger
logger LlvmConfigCache
llvm_config DynFlags
dflags
  {-# SCC "llvm_output" #-} doOutput filenm $
    \Handle
f -> {-# SCC "llvm_CodeGen" #-}
      Logger
-> LlvmCgConfig
-> Handle
-> DUniqSupply
-> CgStream RawCmmGroup a
-> IO a
forall a.
Logger
-> LlvmCgConfig
-> Handle
-> DUniqSupply
-> CgStream RawCmmGroup a
-> IO a
llvmCodeGen Logger
logger LlvmCgConfig
lcg_config Handle
f DUniqSupply
dus CgStream RawCmmGroup a
cmm_stream

{-
************************************************************************
*                                                                      *
\subsection{JavaScript}
*                                                                      *
************************************************************************
-}
outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> CgStream RawCmmGroup a -> IO a
outputJS :: forall a.
Logger
-> LlvmConfigCache
-> DynFlags
-> FilePath
-> CgStream RawCmmGroup a
-> IO a
outputJS Logger
_ LlvmConfigCache
_ DynFlags
_ FilePath
_ CgStream RawCmmGroup a
_ = FilePath -> IO a
forall a. HasCallStack => FilePath -> a
pgmError (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath
"codeOutput: Hit JavaScript case. We should never reach here!"
                              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\nThe JS backend should shortcircuit to StgToJS after Stg."
                              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\nIf you reached this point then you've somehow made it to Cmm!"

{-
************************************************************************
*                                                                      *
\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
   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 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 = SDoc -> SDoc
pprCode 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 = SDoc -> SDoc
pprCode SDoc
h_code
            stub_h_output_w :: FilePath
stub_h_output_w = DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags SDoc
stub_h_output_d

        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 \"rts/ghc_ffi.h\"\n"
              | Bool
otherwise = FilePath
""

        -- The header path is computed from the module source path, which
        -- does not exist when loading interface core bindings for Template
        -- Haskell for non-home modules (e.g. when compiling in separate
        -- invocations of oneshot mode).
        -- Stub headers are only generated for foreign exports.
        -- Since those aren't supported for TH with bytecode at the moment,
        -- it doesn't make much of a difference.
        -- In any case, if a stub dir was specified explicitly by the user, it
        -- would be used nonetheless.
        stub_h_file_exists <-
          case FinderOpts -> ModuleName -> ModLocation -> Maybe OsPath
mkStubPaths (DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) ModLocation
location of
            Maybe OsPath
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            Just OsPath
path -> do
              let stub_h :: FilePath
stub_h = HasCallStack => OsPath -> FilePath
OsPath -> FilePath
unsafeDecodeUtf OsPath
path
              Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
stub_h)
              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

        putDumpFileMaybe logger 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
           -- 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.

        return (stub_h_file_exists, if stub_c_file_exists
                                       then Just stub_c
                                       else 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"


-- 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
   pdocC :: CLabel -> SDoc
pdocC = Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform
   fn_name :: CLabel
fn_name = Module -> FastString -> CLabel
mkInitializerStubLabel Module
this_mod (FilePath -> FastString
fsLit FilePath
"prof_init")
   decls :: SDoc
decls = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsDoc doc => [doc] -> doc
vcat
        [ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"registerCcList" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
local_cc_list_label SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
        , FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"registerCcsList" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
singleton_cc_list_label SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
        ]
   emit_cc_decl :: CostCentre -> SDoc
emit_cc_decl CostCentre
cc =
       FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"extern CostCentre" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cc_lbl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"[];"
     where cc_lbl :: SDoc
cc_lbl = CLabel -> SDoc
pdocC (CostCentre -> CLabel
mkCCLabel CostCentre
cc)
   local_cc_list_label :: SDoc
local_cc_list_label = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"local_cc_" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
   emit_cc_list :: [CostCentre] -> SDoc
emit_cc_list [CostCentre]
ccs =
      FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"static CostCentre *" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
local_cc_list_label SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"[] ="
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ CLabel -> SDoc
pdocC (CostCentre -> CLabel
mkCCLabel CostCentre
cc) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
                         | CostCentre
cc <- [CostCentre]
ccs
                         ] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"NULL"])
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi

   emit_ccs_decl :: CostCentreStack -> SDoc
emit_ccs_decl CostCentreStack
ccs =
       FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"extern CostCentreStack" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
ccs_lbl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"[];"
     where ccs_lbl :: SDoc
ccs_lbl = CLabel -> SDoc
pdocC (CostCentreStack -> CLabel
mkCCSLabel CostCentreStack
ccs)
   singleton_cc_list_label :: SDoc
singleton_cc_list_label = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"singleton_cc_" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
   emit_ccs_list :: [CostCentreStack] -> SDoc
emit_ccs_list [CostCentreStack]
ccs =
      FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"static CostCentreStack *" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
singleton_cc_list_label SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"[] ="
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ CLabel -> SDoc
pdocC (CostCentreStack -> CLabel
mkCCSLabel CostCentreStack
cc) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
                         | CostCentreStack
cc <- [CostCentreStack]
ccs
                         ] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"NULL"])
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
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 -> FastString -> CLabel
mkInitializerStubLabel Module
this_mod (FilePath -> FastString
fsLit FilePath
"ip_init")

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

   ipe_buffer_label :: SDoc
ipe_buffer_label = Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform (Module -> CLabel
mkIPELabel Module
this_mod)

   ipe_buffer_decl :: SDoc
ipe_buffer_decl =
       FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"extern IpeBufferListNode" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
ipe_buffer_label SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
";"