ghc/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 UniqSupply       ( mkSplitUniqSupply )
  13 import AsmCodeGen       ( nativeCodeGen )
  14 #endif
  15
  16 #ifdef ILX
  17 import IlxGen           ( ilxGen )
  18 #endif
  19
  20 #ifdef JAVA
  21 import JavaGen          ( javaGen )
  22 import OccurAnal        ( occurAnalyseBinds )
  23 import qualified PrintJava
  24 import OccurAnal        ( occurAnalyseBinds )
  25 #endif
  26
  27 import Packages         ( PackageConfig(name), packageNameString )
  28 import DriverState      ( getExplicitPackagesAnd, getPackageCIncludes )
  29 import FastString       ( unpackFS )
  30 import AbsCSyn          ( AbstractC )
  31 import PprAbsC          ( dumpRealC, writeRealC )
  32 import HscTypes         ( ModGuts(..), ModGuts, ForeignStubs(..),
  33                           typeEnvTyCons, Dependencies(..) )
  34 import CmdLineOpts
  35 import ErrUtils         ( dumpIfSet_dyn, showPass )
  36 import Outputable
  37 import Pretty           ( Mode(..), printDoc )
  38 import CmdLineOpts      ( DynFlags, HscLang(..), dopt_OutName )
  39 import Monad            ( when )
  40 import IO
  41 \end{code}
  42
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 \subsection{Steering}
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 \begin{code}
  51 codeOutput :: DynFlags
  52            -> ModGuts
  53            -> AbstractC                 -- Compiled abstract C
  54            -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
  55
  56 codeOutput dflags
  57            (ModGuts {mg_module = mod_name,
  58                      mg_types  = type_env,
  59                      mg_foreign = foreign_stubs,
  60                      mg_deps    = deps,
  61                      mg_binds   = core_binds})
  62            flat_abstractC
  63   = let
  64         tycons = typeEnvTyCons type_env
  65     in
  66     -- You can have C (c_output) or assembly-language (ncg_output),
  67     -- but not both.  [Allowing for both gives a space leak on
  68     -- flat_abstractC.  WDP 94/10]
  69
  70     -- Dunno if the above comment is still meaningful now.  JRS 001024.
  71
  72     do  { showPass dflags "CodeOutput"
  73         ; let filenm = dopt_OutName dflags
  74         ; stubs_exist <- outputForeignStubs dflags foreign_stubs
  75         ; case dopt_HscLang dflags of {
  76              HscInterpreted -> return ();
  77              HscAsm         -> outputAsm dflags filenm flat_abstractC;
  78              HscC           -> outputC dflags filenm flat_abstractC stubs_exist
  79                                         deps foreign_stubs;
  80              HscJava        ->
  81 #ifdef JAVA
  82                                outputJava dflags filenm mod_name tycons core_binds;
  83 #else
  84                                panic "Java support not compiled into this ghc";
  85 #endif
  86              HscILX         ->
  87 #ifdef ILX
  88                                outputIlx dflags filenm mod_name tycons stg_binds;
  89 #else
  90                                panic "ILX support not compiled into this ghc";
  91 #endif
  92           }
  93         ; return stubs_exist
  94         }
  95
  96 doOutput :: String -> (Handle -> IO ()) -> IO ()
  97 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
  98 \end{code}
  99
 100
 101 %************************************************************************
 102 %*                                                                      *
 103 \subsection{C}
 104 %*                                                                      *
 105 %************************************************************************
 106
 107 \begin{code}
 108 outputC dflags filenm flat_absC
 109         (stub_h_exists, _) dependencies (ForeignStubs _ _ ffi_decl_headers _ )
 110   = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
 111
 112        -- figure out which header files to #include in the generated .hc file:
 113        --
 114        --   * extra_includes from packages
 115        --   * -#include options from the cmdline and OPTIONS pragmas
 116        --   * the _stub.h file, if there is one.
 117        --
 118        let packages = dep_pkgs dependencies
 119        pkg_configs <- getExplicitPackagesAnd packages
 120        let pkg_names = map name pkg_configs
 121
 122        c_includes <- getPackageCIncludes pkg_configs
 123        let cmdline_includes = cmdlineHcIncludes dflags -- -#include options
 124
 125            all_headers =  c_includes
 126                        ++ reverse cmdline_includes
 127                        ++ reverse (map unpackFS ffi_decl_headers)
 128                            -- reverse correct?
 129
 130        let cc_injects = unlines (map mk_include all_headers)
 131            mk_include h_file =
 132             case h_file of
 133                '"':_{-"-} -> "#include "++h_file
 134                '<':_      -> "#include "++h_file
 135                _          -> "#include \""++h_file++"\""
 136
 137        doOutput filenm $ \ h -> do
 138           hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
 139           hPutStr h cc_injects
 140           when stub_h_exists $
 141              hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
 142           writeRealC h flat_absC
 143 \end{code}
 144
 145
 146 %************************************************************************
 147 %*                                                                      *
 148 \subsection{Assembler}
 149 %*                                                                      *
 150 %************************************************************************
 151
 152 \begin{code}
 153 outputAsm dflags filenm flat_absC
 154
 155 #ifndef OMIT_NATIVE_CODEGEN
 156
 157   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 158        let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen"
 159                                         nativeCodeGen flat_absC ncg_uniqs
 160        dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
 161        dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
 162        _scc_ "OutputAsm" doOutput filenm $
 163            \f -> printDoc LeftMode f ncg_output_d
 164   where
 165
 166 #else /* OMIT_NATIVE_CODEGEN */
 167
 168   = pprPanic "This compiler was built without a native code generator"
 169              (text "Use -fvia-C instead")
 170
 171 #endif
 172 \end{code}
 173
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsection{Java}
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 \begin{code}
 182 #ifdef JAVA
 183 outputJava dflags filenm mod tycons core_binds
 184   = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
 185         -- User style printing for now to keep indentation
 186   where
 187     occ_anal_binds = occurAnalyseBinds core_binds
 188         -- Make sure we have up to date dead-var information
 189     java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
 190     pp_java   = PrintJava.compilationUnit java_code
 191 #endif
 192 \end{code}
 193
 194
 195 %************************************************************************
 196 %*                                                                      *
 197 \subsection{Ilx}
 198 %*                                                                      *
 199 %************************************************************************
 200
 201 \begin{code}
 202 #ifdef ILX
 203 outputIlx dflags filename mod tycons stg_binds
 204   =  doOutput filename (\ f -> printForC f pp_ilx)
 205   where
 206     pp_ilx = ilxGen mod tycons stg_binds
 207 #endif
 208 \end{code}
 209
 210
 211 %************************************************************************
 212 %*                                                                      *
 213 \subsection{Foreign import/export}
 214 %*                                                                      *
 215 %************************************************************************
 216
 217 \begin{code}
 218 outputForeignStubs :: DynFlags -> ForeignStubs
 219                    -> IO (Bool,         -- Header file created
 220                           Bool)         -- C file created
 221 outputForeignStubs dflags NoStubs = return (False, False)
 222 outputForeignStubs dflags (ForeignStubs h_code c_code _ _)
 223   = do
 224         dumpIfSet_dyn dflags Opt_D_dump_foreign
 225                       "Foreign export header file" stub_h_output_d
 226
 227         stub_h_file_exists
 228            <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
 229                 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
 230
 231         dumpIfSet_dyn dflags Opt_D_dump_foreign
 232                       "Foreign export stubs" stub_c_output_d
 233
 234         stub_c_file_exists
 235            <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
 236                 ("#define IN_STG_CODE 0\n" ++
 237                  "#include \"RtsAPI.h\"\n" ++
 238                  cplusplus_hdr)
 239                  cplusplus_ftr
 240            -- We're adding the default hc_header to the stub file, but this
 241            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
 242            -- avoid the register variables etc. being enabled.
 243
 244         return (stub_h_file_exists, stub_c_file_exists)
 245   where
 246     -- C stubs for "foreign export"ed functions.
 247     stub_c_output_d = pprCode CStyle c_code
 248     stub_c_output_w = showSDoc stub_c_output_d
 249
 250     -- Header file protos for "foreign export"ed functions.
 251     stub_h_output_d = pprCode CStyle h_code
 252     stub_h_output_w = showSDoc stub_h_output_d
 253
 254 cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
 255 cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
 256
 257 -- Don't use doOutput for dumping the f. export stubs
 258 -- since it is more than likely that the stubs file will
 259 -- turn out to be empty, in which case no file should be created.
 260 outputForeignStubs_help fname ""      header footer = return False
 261 outputForeignStubs_help fname doc_str header footer
 262    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
 263         return True
 264 \end{code}
 265