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 ) 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 qualified PrintJava
  23 #endif
  24
  25 import DriverState      ( v_HCHeader )
  26 import TyCon            ( TyCon )
  27 import Id               ( Id )
  28 import CoreSyn          ( CoreBind )
  29 import OccurAnal        ( occurAnalyseBinds )
  30 import StgSyn           ( StgBinding )
  31 import AbsCSyn          ( AbstractC )
  32 import PprAbsC          ( dumpRealC, writeRealC )
  33 import Module           ( Module )
  34 import CmdLineOpts
  35 import ErrUtils         ( dumpIfSet_dyn, showPass )
  36 import Outputable
  37 import CmdLineOpts      ( DynFlags, HscLang(..), dopt_OutName )
  38
  39 import IOExts
  40 import Monad            ( when )
  41 import IO
  42 \end{code}
  43
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection{Steering}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 \begin{code}
  52 codeOutput :: DynFlags
  53            -> Module
  54            -> [TyCon]                   -- Local tycons
  55            -> [CoreBind]                -- Core bindings
  56            -> [(StgBinding,[Id])]       -- The STG program with SRTs
  57            -> SDoc              -- C stubs for foreign exported functions
  58            -> SDoc              -- Header file prototype for foreign exported functions
  59            -> AbstractC         -- Compiled abstract C
  60            -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
  61 codeOutput dflags mod_name tycons core_binds stg_binds
  62            c_code h_code flat_abstractC
  63   = -- You can have C (c_output) or assembly-language (ncg_output),
  64     -- but not both.  [Allowing for both gives a space leak on
  65     -- flat_abstractC.  WDP 94/10]
  66
  67     -- Dunno if the above comment is still meaningful now.  JRS 001024.
  68
  69     do  { showPass dflags "CodeOutput"
  70         ; let filenm = dopt_OutName dflags
  71         ; stub_names <- outputForeignStubs dflags c_code h_code
  72         ; case dopt_HscLang dflags of
  73              HscInterpreted -> return stub_names
  74              HscAsm         -> outputAsm dflags filenm flat_abstractC
  75                                >> return stub_names
  76              HscC           -> outputC dflags filenm flat_abstractC stub_names
  77                                >> return stub_names
  78              HscJava        ->
  79 #ifdef JAVA
  80                                outputJava dflags filenm mod_name tycons core_binds
  81                                >> return stub_names
  82 #else
  83                                panic "Java support not compiled into this ghc"
  84 #endif
  85              HscILX         ->
  86 #ifdef ILX
  87                                outputIlx dflags filenm mod_name tycons stg_binds
  88                                >> return stub_names
  89 #else
  90                                panic "ILX support not compiled into this ghc"
  91 #endif
  92         }
  93
  94 doOutput :: String -> (Handle -> IO ()) -> IO ()
  95 doOutput filenm io_action
  96   = (do handle <- openFile filenm WriteMode
  97         io_action handle
  98         hClose handle)
  99     `catch` (\err -> pprPanic "Failed to open or write code output file"
 100                               (text filenm))
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsection{C}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 \begin{code}
 111 outputC dflags filenm flat_absC (stub_h_exists, _)
 112   = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
 113        header <- readIORef v_HCHeader
 114        doOutput filenm $ \ h -> do
 115           hPutStr h header
 116           when stub_h_exists $
 117              hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
 118           writeRealC h flat_absC
 119 \end{code}
 120
 121
 122 %************************************************************************
 123 %*                                                                      *
 124 \subsection{Assembler}
 125 %*                                                                      *
 126 %************************************************************************
 127
 128 \begin{code}
 129 outputAsm dflags filenm flat_absC
 130
 131 #ifndef OMIT_NATIVE_CODEGEN
 132
 133   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 134        let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen"
 135                                         nativeCodeGen flat_absC ncg_uniqs
 136        dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
 137        dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" ncg_output_d
 138        _scc_ "OutputAsm" doOutput filenm ( \f -> printForAsm f ncg_output_d)
 139   where
 140
 141 #else /* OMIT_NATIVE_CODEGEN */
 142
 143   = pprPanic "This compiler was built without a native code generator"
 144              (text "Use -fvia-C instead")
 145
 146 #endif
 147 \end{code}
 148
 149
 150 %************************************************************************
 151 %*                                                                      *
 152 \subsection{Java}
 153 %*                                                                      *
 154 %************************************************************************
 155
 156 \begin{code}
 157 #ifdef JAVA
 158 outputJava dflags filenm mod tycons core_binds
 159   = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
 160         -- User style printing for now to keep indentation
 161   where
 162     occ_anal_binds = occurAnalyseBinds core_binds
 163         -- Make sure we have up to date dead-var information
 164     java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
 165     pp_java   = PrintJava.compilationUnit java_code
 166 #endif
 167 \end{code}
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection{Ilx}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 #ifdef ILX
 178 outputIlx dflags filename mod tycons stg_binds
 179   =  doOutput filename (\ f -> printForC f pp_ilx)
 180   where
 181     pp_ilx = ilxGen mod tycons stg_binds
 182 #endif
 183 \end{code}
 184
 185
 186 %************************************************************************
 187 %*                                                                      *
 188 \subsection{Foreign import/export}
 189 %*                                                                      *
 190 %************************************************************************
 191
 192 \begin{code}
 193 outputForeignStubs dflags c_code h_code
 194   = do
 195         dumpIfSet_dyn dflags Opt_D_dump_foreign
 196                       "Foreign export header file" stub_h_output_d
 197
 198         stub_h_file_exists
 199            <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
 200                 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
 201
 202         dumpIfSet_dyn dflags Opt_D_dump_foreign
 203                       "Foreign export stubs" stub_c_output_d
 204
 205         hc_header <- readIORef v_HCHeader
 206
 207         stub_c_file_exists
 208            <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
 209                 ("#define IN_STG_CODE 0\n" ++
 210                  hc_header ++
 211                  "#include \"RtsAPI.h\"\n" ++
 212                  cplusplus_hdr)
 213                  cplusplus_ftr
 214            -- we're adding the default hc_header to the stub file, but this
 215            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
 216            -- avoid the register variables etc. being enabled.
 217
 218         return (stub_h_file_exists, stub_c_file_exists)
 219   where
 220     -- C stubs for "foreign export"ed functions.
 221     stub_c_output_d = pprCode CStyle c_code
 222     stub_c_output_w = showSDoc stub_c_output_d
 223
 224     -- Header file protos for "foreign export"ed functions.
 225     stub_h_output_d = pprCode CStyle h_code
 226     stub_h_output_w = showSDoc stub_h_output_d
 227
 228 cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
 229 cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
 230
 231 -- Don't use doOutput for dumping the f. export stubs
 232 -- since it is more than likely that the stubs file will
 233 -- turn out to be empty, in which case no file should be created.
 234 outputForeignStubs_help fname ""      header footer = return False
 235 outputForeignStubs_help fname doc_str header footer
 236    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
 237         return True
 238 \end{code}
 239