{-
(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             ( writeCs )
import CmmLint          ( cmmLint )
import Packages
import Cmm              ( RawCmmGroup )
import HscTypes
import DynFlags
import Config
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 ()                       -- Compiled C--
           -> IO (FilePath,
                  (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
                  [(ForeignSrcLang, FilePath)]{-foreign_fps-})

codeOutput :: DynFlags
-> Module
-> FilePath
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, FilePath)]
-> [InstalledUnitId]
-> Stream IO RawCmmGroup ()
-> IO
     (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)])
codeOutput dflags :: DynFlags
dflags this_mod :: Module
this_mod filenm :: FilePath
filenm location :: ModLocation
location foreign_stubs :: ForeignStubs
foreign_stubs foreign_fps :: [(ForeignSrcLang, FilePath)]
foreign_fps pkg_deps :: [InstalledUnitId]
pkg_deps
  cmm_stream :: Stream IO RawCmmGroup ()
cmm_stream
  =
    do  {
        -- Lint each CmmGroup as it goes past
        ; let linted_cmm_stream :: Stream IO RawCmmGroup ()
linted_cmm_stream =
                 if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCmmLinting DynFlags
dflags
                    then (RawCmmGroup -> IO RawCmmGroup)
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
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 ()
cmm_stream
                    else Stream IO RawCmmGroup ()
cmm_stream

              do_lint :: GenCmmGroup d h CmmGraph -> IO (GenCmmGroup d h CmmGraph)
do_lint cmm :: GenCmmGroup d h CmmGraph
cmm = IO DynFlags
-> SDoc
-> (GenCmmGroup d h CmmGraph -> ())
-> IO (GenCmmGroup d h CmmGraph)
-> IO (GenCmmGroup d h CmmGraph)
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags)
                                       (FilePath -> SDoc
text "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 err :: 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 1
                                       }
                        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
        ; case DynFlags -> HscTarget
hscTarget DynFlags
dflags of {
             HscAsm         -> DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup ()
-> IO ()
outputAsm DynFlags
dflags Module
this_mod ModLocation
location FilePath
filenm
                                         Stream IO RawCmmGroup ()
linted_cmm_stream;
             HscC           -> DynFlags
-> FilePath
-> Stream IO RawCmmGroup ()
-> [InstalledUnitId]
-> IO ()
outputC DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup ()
linted_cmm_stream [InstalledUnitId]
pkg_deps;
             HscLlvm        -> DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
outputLlvm DynFlags
dflags FilePath
filenm Stream IO RawCmmGroup ()
linted_cmm_stream;
             HscInterpreted -> FilePath -> IO ()
forall a. FilePath -> a
panic "codeOutput: HscInterpreted";
             HscNothing     -> FilePath -> IO ()
forall a. FilePath -> a
panic "codeOutput: HscNothing"
          }
        ; (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)])
-> IO
     (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
filenm, (Bool, Maybe FilePath)
stubs_exist, [(ForeignSrcLang, FilePath)]
foreign_fps)
        }

doOutput :: String -> (Handle -> IO a) -> IO a
doOutput :: FilePath -> (Handle -> IO a) -> IO a
doOutput filenm :: FilePath
filenm io_action :: 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 ()
        -> [InstalledUnitId]
        -> IO ()

outputC :: DynFlags
-> FilePath
-> Stream IO RawCmmGroup ()
-> [InstalledUnitId]
-> IO ()
outputC dflags :: DynFlags
dflags filenm :: FilePath
filenm cmm_stream :: Stream IO RawCmmGroup ()
cmm_stream packages :: [InstalledUnitId]
packages
  = do
       -- ToDo: make the C backend consume the C-- incrementally, by
       -- pushing the cmm_stream inside (c.f. nativeCodeGen)
       [RawCmmGroup]
rawcmms <- Stream IO RawCmmGroup () -> IO [RawCmmGroup]
forall (m :: * -> *) a. Monad m => Stream m a () -> m [a]
Stream.collect Stream IO RawCmmGroup ()
cmm_stream

       -- 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 h_file :: FilePath
h_file =
            case FilePath
h_file of
               '"':_{-"-} -> "#include "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
h_file
               '<':_      -> "#include "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
h_file
               _          -> "#include \""FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
h_fileFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++"\""

       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 ()) -> IO ()
forall a. FilePath -> (Handle -> IO a) -> IO a
doOutput FilePath
filenm ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ h :: Handle
h -> do
          Handle -> FilePath -> IO ()
hPutStr Handle
h ("/* GHC_PACKAGES " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
pkg_names FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\n*/\n")
          Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
cc_injects
          DynFlags -> Handle -> [RawCmmGroup] -> IO ()
writeCs DynFlags
dflags Handle
h [RawCmmGroup]
rawcmms

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

outputAsm :: DynFlags -> Module -> ModLocation -> FilePath
          -> Stream IO RawCmmGroup ()
          -> IO ()
outputAsm :: DynFlags
-> Module
-> ModLocation
-> FilePath
-> Stream IO RawCmmGroup ()
-> IO ()
outputAsm dflags :: DynFlags
dflags this_mod :: Module
this_mod location :: ModLocation
location filenm :: FilePath
filenm cmm_stream :: Stream IO RawCmmGroup ()
cmm_stream
 | FilePath
cGhcWithNativeCodeGen FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "YES"
  = do UniqSupply
ncg_uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply 'n'

       DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 4 (FilePath -> SDoc
text "Outputing asm to" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
filenm)

       UniqSupply
_ <- {-# SCC "OutputAsm" #-} FilePath -> (Handle -> IO UniqSupply) -> IO UniqSupply
forall a. FilePath -> (Handle -> IO a) -> IO a
doOutput FilePath
filenm ((Handle -> IO UniqSupply) -> IO UniqSupply)
-> (Handle -> IO UniqSupply) -> IO UniqSupply
forall a b. (a -> b) -> a -> b
$
           \h :: Handle
h -> {-# SCC "NativeCodeGen" #-}
                 DynFlags
-> Module
-> ModLocation
-> Handle
-> UniqSupply
-> Stream IO RawCmmGroup ()
-> IO UniqSupply
nativeCodeGen DynFlags
dflags Module
this_mod ModLocation
location Handle
h UniqSupply
ncg_uniqs Stream IO RawCmmGroup ()
cmm_stream
       () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
outputLlvm dflags :: DynFlags
dflags filenm :: FilePath
filenm cmm_stream :: Stream IO RawCmmGroup ()
cmm_stream
  = do UniqSupply
ncg_uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply 'n'

       {-# SCC "llvm_output" #-} FilePath -> (Handle -> IO ()) -> IO ()
forall a. FilePath -> (Handle -> IO a) -> IO a
doOutput FilePath
filenm ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
           \f :: Handle
f -> {-# SCC "llvm_CodeGen" #-}
                 DynFlags
-> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
llvmCodeGen DynFlags
dflags Handle
f UniqSupply
ncg_uniqs Stream IO RawCmmGroup ()
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 dflags :: DynFlags
dflags mod :: Module
mod location :: ModLocation
location stubs :: 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 "c"

   case ForeignStubs
stubs of
     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 h_code :: SDoc
h_code c_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
                      "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 i :: FilePath
i = "#include \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
i FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\"\n"

            -- wrapper code mentions the ffi_arg type, which comes from ffi.h
            ffi_includes :: FilePath
ffi_includes | Bool
cLibFFI   = "#include \"ffi.h\"\n"
                         | Bool
otherwise = ""

        Bool
stub_h_file_exists
           <- FilePath -> FilePath -> FilePath -> FilePath -> IO Bool
outputForeignStubs_help FilePath
stub_h FilePath
stub_h_output_w
                ("#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
                      "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
                ("#define IN_STG_CODE 0\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                 "#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 = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
   cplusplus_ftr :: FilePath
cplusplus_ftr = "#ifdef __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 _fname :: FilePath
_fname ""      _header :: FilePath
_header _footer :: FilePath
_footer = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
outputForeignStubs_help fname :: FilePath
fname doc_str :: FilePath
doc_str header :: FilePath
header footer :: 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]
++ '\n'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
footer FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\n")
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True