compiler/main/CodeOutput.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section{Code output phase}
   5
   6 \begin{code}
   7 module CodeOutput( codeOutput, outputForeignStubs ) where
   8
   9 #include "HsVersions.h"
  10
  11 import AsmCodeGen ( nativeCodeGen )
  12 import LlvmCodeGen ( llvmCodeGen )
  13
  14 import UniqSupply       ( mkSplitUniqSupply )
  15
  16 import Finder           ( mkStubPaths )
  17 import PprC             ( writeCs )
  18 import CmmLint          ( cmmLint )
  19 import Packages
  20 import Util
  21 import OldCmm           ( RawCmm )
  22 import HscTypes
  23 import DynFlags
  24 import Config
  25 import SysTools
  26
  27 import ErrUtils         ( dumpIfSet_dyn, showPass, ghcExit )
  28 import Outputable
  29 import Module
  30 import Maybes           ( firstJusts )
  31
  32 import Control.Exception
  33 import Control.Monad
  34 import System.Directory
  35 import System.FilePath
  36 import System.IO
  37 \end{code}
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \subsection{Steering}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 \begin{code}
  46 codeOutput :: DynFlags
  47            -> Module
  48            -> ModLocation
  49            -> ForeignStubs
  50            -> [PackageId]
  51            -> [RawCmm]                  -- Compiled C--
  52            -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})
  53
  54 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
  55   =
  56     -- You can have C (c_output) or assembly-language (ncg_output),
  57     -- but not both.  [Allowing for both gives a space leak on
  58     -- flat_abstractC.  WDP 94/10]
  59
  60     -- Dunno if the above comment is still meaningful now.  JRS 001024.
  61
  62     do  { when (dopt Opt_DoCmmLinting dflags) $ do
  63                 { showPass dflags "CmmLint"
  64                 ; let lints = map cmmLint flat_abstractC
  65                 ; case firstJusts lints of
  66                         Just err -> do { printDump err
  67                                        ; ghcExit dflags 1
  68                                        }
  69                         Nothing  -> return ()
  70                 }
  71
  72         ; showPass dflags "CodeOutput"
  73         ; let filenm = hscOutName dflags
  74         ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
  75         ; case hscTarget dflags of {
  76              HscInterpreted -> return ();
  77              HscAsm         -> outputAsm dflags filenm flat_abstractC;
  78              HscC           -> outputC dflags filenm flat_abstractC pkg_deps;
  79              HscLlvm        -> outputLlvm dflags filenm flat_abstractC;
  80              HscNothing     -> panic "codeOutput: HscNothing"
  81           }
  82         ; return stubs_exist
  83         }
  84
  85 doOutput :: String -> (Handle -> IO ()) -> IO ()
  86 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
  87 \end{code}
  88
  89
  90 %************************************************************************
  91 %*                                                                      *
  92 \subsection{C}
  93 %*                                                                      *
  94 %************************************************************************
  95
  96 \begin{code}
  97 outputC :: DynFlags
  98         -> FilePath
  99         -> [RawCmm]
 100         -> [PackageId]
 101         -> IO ()
 102
 103 outputC dflags filenm flat_absC packages
 104   = do
 105        -- figure out which header files to #include in the generated .hc file:
 106        --
 107        --   * extra_includes from packages
 108        --   * -#include options from the cmdline and OPTIONS pragmas
 109        --   * the _stub.h file, if there is one.
 110        --
 111        let rts = getPackageDetails (pkgState dflags) rtsPackageId
 112
 113        let cc_injects = unlines (map mk_include (includes rts))
 114            mk_include h_file =
 115             case h_file of
 116                '"':_{-"-} -> "#include "++h_file
 117                '<':_      -> "#include "++h_file
 118                _          -> "#include \""++h_file++"\""
 119
 120        pkg_configs <- getPreloadPackagesAnd dflags packages
 121        let pkg_names = map (display.sourcePackageId) pkg_configs
 122
 123        doOutput filenm $ \ h -> do
 124           hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
 125           hPutStr h cc_injects
 126           writeCs dflags h flat_absC
 127 \end{code}
 128
 129
 130 %************************************************************************
 131 %*                                                                      *
 132 \subsection{Assembler}
 133 %*                                                                      *
 134 %************************************************************************
 135
 136 \begin{code}
 137 outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
 138 outputAsm dflags filenm flat_absC
 139  | cGhcWithNativeCodeGen == "YES"
 140   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 141
 142        {-# SCC "OutputAsm" #-} doOutput filenm $
 143            \f -> {-# SCC "NativeCodeGen" #-}
 144                  nativeCodeGen dflags f ncg_uniqs flat_absC
 145
 146  | otherwise
 147   = panic "This compiler was built without a native code generator"
 148 \end{code}
 149
 150
 151 %************************************************************************
 152 %*                                                                      *
 153 \subsection{LLVM}
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 \begin{code}
 158 outputLlvm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
 159 outputLlvm dflags filenm flat_absC
 160   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 161        doOutput filenm $ \f -> llvmCodeGen dflags f ncg_uniqs flat_absC
 162 \end{code}
 163
 164
 165 %************************************************************************
 166 %*                                                                      *
 167 \subsection{Foreign import/export}
 168 %*                                                                      *
 169 %************************************************************************
 170
 171 \begin{code}
 172 outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
 173                    -> IO (Bool,         -- Header file created
 174                           Maybe FilePath) -- C file created
 175 outputForeignStubs dflags mod location stubs
 176  = do
 177    let stub_h = mkStubPaths dflags (moduleName mod) location
 178    stub_c <- newTempName dflags "c"
 179
 180    case stubs of
 181      NoStubs -> do
 182         -- When compiling External Core files, may need to use stub
 183         -- files from a previous compilation
 184         stub_h_exists <- doesFileExist stub_h
 185         return (stub_h_exists, Nothing)
 186
 187      ForeignStubs h_code c_code -> do
 188         let
 189             stub_c_output_d = pprCode CStyle c_code
 190             stub_c_output_w = showSDoc stub_c_output_d
 191
 192             -- Header file protos for "foreign export"ed functions.
 193             stub_h_output_d = pprCode CStyle h_code
 194             stub_h_output_w = showSDoc stub_h_output_d
 195         -- in
 196
 197         createDirectoryHierarchy (takeDirectory stub_h)
 198
 199         dumpIfSet_dyn dflags Opt_D_dump_foreign
 200                       "Foreign export header file" stub_h_output_d
 201
 202         -- we need the #includes from the rts package for the stub files
 203         let rts_includes =
 204                let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in
 205                concatMap mk_include (includes rts_pkg)
 206             mk_include i = "#include \"" ++ i ++ "\"\n"
 207
 208             -- wrapper code mentions the ffi_arg type, which comes from ffi.h
 209             ffi_includes | cLibFFI   = "#include \"ffi.h\"\n"
 210                          | otherwise = ""
 211
 212         stub_h_file_exists
 213            <- outputForeignStubs_help stub_h stub_h_output_w
 214                 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
 215
 216         dumpIfSet_dyn dflags Opt_D_dump_foreign
 217                       "Foreign export stubs" stub_c_output_d
 218
 219         stub_c_file_exists
 220            <- outputForeignStubs_help stub_c stub_c_output_w
 221                 ("#define IN_STG_CODE 0\n" ++
 222                  "#include \"Rts.h\"\n" ++
 223                  rts_includes ++
 224                  ffi_includes ++
 225                  cplusplus_hdr)
 226                  cplusplus_ftr
 227            -- We're adding the default hc_header to the stub file, but this
 228            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
 229            -- avoid the register variables etc. being enabled.
 230
 231         return (stub_h_file_exists, if stub_c_file_exists
 232                                        then Just stub_c
 233                                        else Nothing )
 234  where
 235    cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
 236    cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
 237
 238
 239 -- Don't use doOutput for dumping the f. export stubs
 240 -- since it is more than likely that the stubs file will
 241 -- turn out to be empty, in which case no file should be created.
 242 outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
 243 outputForeignStubs_help _fname ""      _header _footer = return False
 244 outputForeignStubs_help fname doc_str header footer
 245    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
 246         return True
 247 \end{code}
 248