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 #ifndef OMIT_NATIVE_CODEGEN
  12 import AsmCodeGen       ( nativeCodeGen )
  13 #endif
  14
  15 import UniqSupply       ( mkSplitUniqSupply )
  16 #ifndef GHCI_TABLES_NEXT_TO_CODE
  17 import qualified LlvmCodeGen ( llvmCodeGen )
  18 #endif
  19
  20 #ifdef JAVA
  21 import JavaGen          ( javaGen )
  22 import qualified PrintJava
  23 import OccurAnal        ( occurAnalyseBinds )
  24 #endif
  25
  26 import Finder           ( mkStubPaths )
  27 import PprC             ( writeCs )
  28 import CmmLint          ( cmmLint )
  29 import Packages
  30 import Util
  31 import Cmm              ( RawCmm )
  32 import HscTypes
  33 import DynFlags
  34 import Config
  35
  36 import ErrUtils         ( dumpIfSet_dyn, showPass, ghcExit )
  37 import Outputable
  38 import Module
  39 import Maybes           ( firstJust )
  40
  41 import Control.Exception
  42 import Control.Monad
  43 import System.Directory
  44 import System.FilePath
  45 import System.IO
  46 \end{code}
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 \subsection{Steering}
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 \begin{code}
  55 codeOutput :: DynFlags
  56            -> Module
  57            -> ModLocation
  58            -> ForeignStubs
  59            -> [PackageId]
  60            -> [RawCmm]                  -- Compiled C--
  61            -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
  62
  63 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
  64   =
  65     -- You can have C (c_output) or assembly-language (ncg_output),
  66     -- but not both.  [Allowing for both gives a space leak on
  67     -- flat_abstractC.  WDP 94/10]
  68
  69     -- Dunno if the above comment is still meaningful now.  JRS 001024.
  70
  71     do  { when (dopt Opt_DoCmmLinting dflags) $ do
  72                 { showPass dflags "CmmLint"
  73                 ; let lints = map cmmLint flat_abstractC
  74                 ; case firstJust lints of
  75                         Just err -> do { printDump err
  76                                        ; ghcExit dflags 1
  77                                        }
  78                         Nothing  -> return ()
  79                 }
  80
  81         ; showPass dflags "CodeOutput"
  82         ; let filenm = hscOutName dflags
  83         ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
  84         ; case hscTarget dflags of {
  85              HscInterpreted -> return ();
  86              HscAsm         -> outputAsm dflags filenm flat_abstractC;
  87              HscC           -> outputC dflags filenm flat_abstractC pkg_deps;
  88              HscLlvm        -> outputLlvm dflags filenm flat_abstractC;
  89              HscJava        ->
  90 #ifdef JAVA
  91                                outputJava dflags filenm mod_name tycons core_binds;
  92 #else
  93                                panic "Java support not compiled into this ghc";
  94 #endif
  95              HscNothing     -> panic "codeOutput: HscNothing"
  96           }
  97         ; return stubs_exist
  98         }
  99
 100 doOutput :: String -> (Handle -> IO ()) -> IO ()
 101 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
 102 \end{code}
 103
 104
 105 %************************************************************************
 106 %*                                                                      *
 107 \subsection{C}
 108 %*                                                                      *
 109 %************************************************************************
 110
 111 \begin{code}
 112 outputC :: DynFlags
 113         -> FilePath
 114         -> [RawCmm]
 115         -> [PackageId]
 116         -> IO ()
 117
 118 outputC dflags filenm flat_absC packages
 119   = do
 120        -- figure out which header files to #include in the generated .hc file:
 121        --
 122        --   * extra_includes from packages
 123        --   * -#include options from the cmdline and OPTIONS pragmas
 124        --   * the _stub.h file, if there is one.
 125        --
 126        let rts = getPackageDetails (pkgState dflags) rtsPackageId
 127
 128        let cc_injects = unlines (map mk_include (includes rts))
 129            mk_include h_file =
 130             case h_file of
 131                '"':_{-"-} -> "#include "++h_file
 132                '<':_      -> "#include "++h_file
 133                _          -> "#include \""++h_file++"\""
 134
 135        pkg_configs <- getPreloadPackagesAnd dflags packages
 136        let pkg_names = map (display.sourcePackageId) pkg_configs
 137
 138        doOutput filenm $ \ h -> do
 139           hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
 140           hPutStr h cc_injects
 141           writeCs dflags h flat_absC
 142 \end{code}
 143
 144
 145 %************************************************************************
 146 %*                                                                      *
 147 \subsection{Assembler}
 148 %*                                                                      *
 149 %************************************************************************
 150
 151 \begin{code}
 152 outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
 153
 154 #ifndef OMIT_NATIVE_CODEGEN
 155
 156 outputAsm dflags filenm flat_absC
 157   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 158
 159        {-# SCC "OutputAsm" #-} doOutput filenm $
 160            \f -> {-# SCC "NativeCodeGen" #-}
 161                  nativeCodeGen dflags f ncg_uniqs flat_absC
 162   where
 163
 164 #else /* OMIT_NATIVE_CODEGEN */
 165
 166 outputAsm _ _ _
 167   = pprPanic "This compiler was built without a native code generator"
 168              (text "Use -fvia-C instead")
 169
 170 #endif
 171 \end{code}
 172
 173
 174 %************************************************************************
 175 %*                                                                      *
 176 \subsection{LLVM}
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 \begin{code}
 181 outputLlvm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
 182
 183 #ifndef GHCI_TABLES_NEXT_TO_CODE
 184 outputLlvm dflags filenm flat_absC
 185   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 186        doOutput filenm $ \f ->
 187                  LlvmCodeGen.llvmCodeGen dflags f ncg_uniqs flat_absC
 188 #else
 189 outputLlvm _ _ _
 190   = pprPanic "This compiler was built with the LLVM backend disabled"
 191              (text ("This is because the TABLES_NEXT_TO_CODE optimisation is"
 192          ++ " enabled, which the LLVM backend doesn't support right now.")
 193          $+$ text "Use -fasm instead")
 194 #endif
 195 \end{code}
 196
 197
 198 %************************************************************************
 199 %*                                                                      *
 200 \subsection{Java}
 201 %*                                                                      *
 202 %************************************************************************
 203
 204 \begin{code}
 205 #ifdef JAVA
 206 outputJava dflags filenm mod tycons core_binds
 207   = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
 208         -- User style printing for now to keep indentation
 209   where
 210     occ_anal_binds = occurAnalyseBinds core_binds
 211         -- Make sure we have up to date dead-var information
 212     java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
 213     pp_java   = PrintJava.compilationUnit java_code
 214 #endif
 215 \end{code}
 216
 217
 218 %************************************************************************
 219 %*                                                                      *
 220 \subsection{Foreign import/export}
 221 %*                                                                      *
 222 %************************************************************************
 223
 224 \begin{code}
 225 outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
 226                    -> IO (Bool,         -- Header file created
 227                           Bool)         -- C file created
 228 outputForeignStubs dflags mod location stubs
 229  = case stubs of
 230    NoStubs -> do
 231         -- When compiling External Core files, may need to use stub
 232         -- files from a previous compilation
 233         stub_c_exists <- doesFileExist stub_c
 234         stub_h_exists <- doesFileExist stub_h
 235         return (stub_h_exists, stub_c_exists)
 236
 237    ForeignStubs h_code c_code -> do
 238         let
 239             stub_c_output_d = pprCode CStyle c_code
 240             stub_c_output_w = showSDoc stub_c_output_d
 241
 242             -- Header file protos for "foreign export"ed functions.
 243             stub_h_output_d = pprCode CStyle h_code
 244             stub_h_output_w = showSDoc stub_h_output_d
 245         -- in
 246
 247         createDirectoryHierarchy (takeDirectory stub_c)
 248
 249         dumpIfSet_dyn dflags Opt_D_dump_foreign
 250                       "Foreign export header file" stub_h_output_d
 251
 252         -- we need the #includes from the rts package for the stub files
 253         let rts_includes =
 254                let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in
 255                concatMap mk_include (includes rts_pkg)
 256             mk_include i = "#include \"" ++ i ++ "\"\n"
 257
 258             -- wrapper code mentions the ffi_arg type, which comes from ffi.h
 259             ffi_includes | cLibFFI   = "#include \"ffi.h\"\n"
 260                          | otherwise = ""
 261
 262         stub_h_file_exists
 263            <- outputForeignStubs_help stub_h stub_h_output_w
 264                 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
 265
 266         dumpIfSet_dyn dflags Opt_D_dump_foreign
 267                       "Foreign export stubs" stub_c_output_d
 268
 269         stub_c_file_exists
 270            <- outputForeignStubs_help stub_c stub_c_output_w
 271                 ("#define IN_STG_CODE 0\n" ++
 272                  "#include \"Rts.h\"\n" ++
 273                  rts_includes ++
 274                  ffi_includes ++
 275                  cplusplus_hdr)
 276                  cplusplus_ftr
 277            -- We're adding the default hc_header to the stub file, but this
 278            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
 279            -- avoid the register variables etc. being enabled.
 280
 281         return (stub_h_file_exists, stub_c_file_exists)
 282   where
 283    (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location
 284
 285    cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
 286    cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
 287
 288
 289 -- Don't use doOutput for dumping the f. export stubs
 290 -- since it is more than likely that the stubs file will
 291 -- turn out to be empty, in which case no file should be created.
 292 outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
 293 outputForeignStubs_help _fname ""      _header _footer = return False
 294 outputForeignStubs_help fname doc_str header footer
 295    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
 296         return True
 297 \end{code}
 298