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

\section{Code output phase}
-}

{-# LANGUAGE CPP #-}

module CodeOutput( codeOutput, outputForeignStubs ) where

#include "HsVersions.h"

import GhcPrelude

import AsmCodeGen       ( nativeCodeGen )
import LlvmCodeGen      ( llvmCodeGen )

import UniqSupply       ( mkSplitUniqSupply )

import Finder           ( mkStubPaths )
import PprC             ( writeC )
import CmmLint          ( cmmLint )
import Packages
import Cmm              ( RawCmmGroup )
import HscTypes
import DynFlags
import Stream           ( Stream )
import qualified Stream
import FileCleanup

import ErrUtils
import Outputable
import Module
import SrcLoc

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

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

codeOutput :: DynFlags
           -> Module
           -> FilePath
           -> ModLocation
           -> ForeignStubs
           -> [(ForeignSrcLang, FilePath)]
           -- ^ additional files to be compiled with with the C compiler
           -> [InstalledUnitId]
           -> Stream IO RawCmmGroup a                       -- Compiled C--
           -> IO (FilePath,
                  (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
                  [(ForeignSrcLang, FilePath)]{-foreign_fps-},
                  a)

codeOutput :: DynFlags
-> Module
-> FilePath
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, FilePath)]
-> [InstalledUnitId]
-> Stream IO RawCmmGroup a
-> IO
     (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)], a)
codeOutput DynFlags
dflags Module
this_mod FilePath
filenm ModLocation
location ForeignStubs
foreign_stubs [(ForeignSrcLang, FilePath)]
foreign_fps [InstalledUnitId]
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
forall d h.
(Outputable d, Outputable h) =>
GenCmmGroup d h CmmGraph -> IO (GenCmmGroup d h CmmGraph)
do_lint Stream IO RawCmmGroup a
cmm_stream
                    else Stream IO RawCmmGroup a
cmm_stream

              do_lint :: GenCmmGroup d h CmmGraph -> IO (GenCmmGroup d h CmmGraph)
do_lint GenCmmGroup d h CmmGraph
cmm = DynFlags
-> SDoc
-> (GenCmmGroup d h CmmGraph -> ())
-> IO (GenCmmGroup d h CmmGraph)
-> IO (GenCmmGroup d h CmmGraph)
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTimingSilent
                  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))
                  (() -> GenCmmGroup d h CmmGraph -> ()
forall a b. a -> b -> a
const ()) (IO (GenCmmGroup d h CmmGraph) -> IO (GenCmmGroup d h CmmGraph))
-> IO (GenCmmGroup d h CmmGraph) -> IO (GenCmmGroup d h CmmGraph)
forall a b. (a -> b) -> a -> b
$ do
                { case DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
forall d h.
(Outputable d, Outputable h) =>
DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
cmmLint DynFlags
dflags GenCmmGroup d h CmmGraph
cmm of
                        Just SDoc
err -> do { DynFlags -> LogAction
log_action DynFlags
dflags
                                                   DynFlags
dflags
                                                   WarnReason
NoReason
                                                   Severity
SevDump
                                                   SrcSpan
noSrcSpan
                                                   (DynFlags -> PprStyle
defaultDumpStyle DynFlags
dflags)
                                                   SDoc
err
                                       ; DynFlags -> Int -> IO ()
ghcExit DynFlags
dflags Int
1
                                       }
                        Maybe SDoc
Nothing  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                ; GenCmmGroup d h CmmGraph -> IO (GenCmmGroup d h CmmGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return GenCmmGroup d h CmmGraph
cmm
                }

        ; (Bool, Maybe FilePath)
stubs_exist <- DynFlags
-> Module
-> ModLocation
-> ForeignStubs
-> IO (Bool, Maybe FilePath)
outputForeignStubs DynFlags
dflags Module
this_mod ModLocation
location ForeignStubs
foreign_stubs
        ; a
a <- case DynFlags -> HscTarget
hscTarget DynFlags
dflags of
                 HscTarget
HscAsm         -> DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup a
-> IO a
forall a.
DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup a
-> IO a
outputAsm DynFlags
dflags Module
this_mod ModLocation
location FilePath
filenm
                                             Stream IO RawCmmGroup a
linted_cmm_stream
                 HscTarget
HscC           -> DynFlags
-> FilePath -> Stream IO RawCmmGroup a -> [InstalledUnitId] -> IO a
forall a.
DynFlags
-> FilePath -> Stream IO RawCmmGroup a -> [InstalledUnitId] -> IO a
outputC DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup a
linted_cmm_stream [InstalledUnitId]
pkg_deps
                 HscTarget
HscLlvm        -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
forall a. DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
outputLlvm DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup a
linted_cmm_stream
                 HscTarget
HscInterpreted -> FilePath -> IO a
forall a. FilePath -> a
panic FilePath
"codeOutput: HscInterpreted"
                 HscTarget
HscNothing     -> FilePath -> IO a
forall a. FilePath -> a
panic FilePath
"codeOutput: HscNothing"
        ; (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 :: 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 :: DynFlags
        -> FilePath
        -> Stream IO RawCmmGroup a
        -> [InstalledUnitId]
        -> IO a

outputC :: DynFlags
-> FilePath -> Stream IO RawCmmGroup a -> [InstalledUnitId] -> IO a
outputC DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup a
cmm_stream [InstalledUnitId]
packages
  = do
       DynFlags -> SDoc -> (a -> ()) -> IO a -> IO a
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming 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

         -- figure out which header files to #include in the generated .hc file:
         --
         --   * extra_includes from packages
         --   * -#include options from the cmdline and OPTIONS pragmas
         --   * the _stub.h file, if there is one.
         --
         let rts :: PackageConfig
rts = DynFlags -> UnitId -> PackageConfig
getPackageDetails DynFlags
dflags UnitId
rtsUnitId

         let cc_injects :: FilePath
cc_injects = [FilePath] -> FilePath
unlines ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
mk_include (PackageConfig -> [FilePath]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [FilePath]
includes PackageConfig
rts))
             mk_include :: FilePath -> FilePath
mk_include FilePath
h_file =
              case FilePath
h_file of
                 Char
'"':FilePath
_{-"-} -> FilePath
"#include "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
h_file
                 Char
'<':FilePath
_      -> FilePath
"#include "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
h_file
                 FilePath
_          -> FilePath
"#include \""FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
h_fileFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"\""

         let pkg_names :: [FilePath]
pkg_names = (InstalledUnitId -> FilePath) -> [InstalledUnitId] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map InstalledUnitId -> FilePath
installedUnitIdString [InstalledUnitId]
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
cc_injects
            Stream IO RawCmmGroup a -> (RawCmmGroup -> IO ()) -> IO a
forall (m :: * -> *) a b.
Monad m =>
Stream m a b -> (a -> m ()) -> m b
Stream.consume Stream IO RawCmmGroup a
cmm_stream (DynFlags -> Handle -> RawCmmGroup -> IO ()
writeC DynFlags
dflags Handle
h)

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

outputAsm :: DynFlags -> Module -> ModLocation -> FilePath
          -> Stream IO RawCmmGroup a
          -> IO a
outputAsm :: DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup a
-> IO a
outputAsm DynFlags
dflags Module
this_mod ModLocation
location FilePath
filenm Stream IO RawCmmGroup a
cmm_stream
 | PlatformMisc -> Bool
platformMisc_ghcWithNativeCodeGen (PlatformMisc -> Bool) -> PlatformMisc -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags
  = do UniqSupply
ncg_uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'n'

       DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg 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" #-}
                 DynFlags
-> Module
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
forall a.
DynFlags
-> Module
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen DynFlags
dflags Module
this_mod ModLocation
location Handle
h UniqSupply
ncg_uniqs Stream IO RawCmmGroup a
cmm_stream

 | Bool
otherwise
  = FilePath -> IO a
forall a. FilePath -> a
panic FilePath
"This compiler was built without a native code generator"

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

outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
outputLlvm DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup a
cmm_stream
  = do {-# 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" #-}
                 DynFlags -> Handle -> Stream IO RawCmmGroup a -> IO a
forall a. DynFlags -> Handle -> Stream IO RawCmmGroup a -> IO a
llvmCodeGen DynFlags
dflags Handle
f Stream IO RawCmmGroup a
cmm_stream

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

outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
                   -> IO (Bool,         -- Header file created
                          Maybe FilePath) -- C file created
outputForeignStubs :: DynFlags
-> Module
-> ModLocation
-> ForeignStubs
-> IO (Bool, Maybe FilePath)
outputForeignStubs DynFlags
dflags Module
mod ModLocation
location ForeignStubs
stubs
 = do
   let stub_h :: FilePath
stub_h = DynFlags -> ModuleName -> ModLocation -> FilePath
mkStubPaths DynFlags
dflags (Module -> ModuleName
moduleName Module
mod) ModLocation
location
   FilePath
stub_c <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName 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 SDoc
h_code SDoc
c_code -> do
        let
            stub_c_output_d :: SDoc
stub_c_output_d = CodeStyle -> SDoc -> SDoc
pprCode CodeStyle
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 = CodeStyle -> SDoc -> SDoc
pprCode CodeStyle
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)

        DynFlags -> DumpFlag -> FilePath -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_foreign
                      FilePath
"Foreign export header file" SDoc
stub_h_output_d

        -- we need the #includes from the rts package for the stub files
        let rts_includes :: FilePath
rts_includes =
               let rts_pkg :: PackageConfig
rts_pkg = DynFlags -> UnitId -> PackageConfig
getPackageDetails DynFlags
dflags UnitId
rtsUnitId in
               (FilePath -> FilePath) -> [FilePath] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FilePath -> FilePath
mk_include (PackageConfig -> [FilePath]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [FilePath]
includes PackageConfig
rts_pkg)
            mk_include :: FilePath -> FilePath
mk_include FilePath
i = FilePath
"#include \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
i FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"\n"

            -- 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

        DynFlags -> DumpFlag -> FilePath -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_foreign
                      FilePath
"Foreign export stubs" 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