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