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