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 AsmCodeGen       ( nativeCodeGen )
  13 #endif
  14 #ifdef ILX
  15 import IlxGen           ( ilxGen )
  16 #endif
  17
  18 import TyCon            ( TyCon )
  19 import Id               ( Id )
  20 import Class            ( Class )
  21 import StgSyn           ( StgBinding )
  22 import AbsCSyn          ( AbstractC, absCNop )
  23 import PprAbsC          ( dumpRealC, writeRealC )
  24 import UniqSupply       ( UniqSupply )
  25 import Module           ( Module, moduleString )
  26 import CmdLineOpts
  27 import Maybes           ( maybeToBool )
  28 import ErrUtils         ( doIfSet, dumpIfSet )
  29 import Outputable
  30 import IO               ( IOMode(..), hPutStr, hClose, openFile )
  31 \end{code}
  32
  33
  34 \begin{code}
  35 codeOutput :: Module
  36            -> [TyCon] -> [Class]        -- Local tycons and classes
  37            -> [(StgBinding,[Id])]       -- The STG program with SRTs
  38            -> SDoc              -- C stubs for foreign exported functions
  39            -> SDoc              -- Header file prototype for foreign exported functions
  40            -> AbstractC         -- Compiled abstract C
  41            -> UniqSupply
  42            -> IO ()
  43 codeOutput mod_name tycons classes stg_binds c_code h_code flat_abstractC ncg_uniqs
  44   = -- You can have C (c_output) or assembly-language (ncg_output),
  45     -- but not both.  [Allowing for both gives a space leak on
  46     -- flat_abstractC.  WDP 94/10]
  47
  48 #ifndef OMIT_NATIVE_CODEGEN
  49     let
  50         (stix_final, ncg_output_d) = nativeCodeGen flat_absC_ncg ncg_uniqs
  51         ncg_output_w = (\ f -> printForAsm f ncg_output_d)
  52     in
  53     dumpIfSet opt_D_dump_stix "Final stix code" stix_final      >>
  54     dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d            >>
  55     doOutput opt_ProduceS ncg_output_w                          >>
  56 #else
  57 #ifdef ILX
  58     doOutput opt_ProduceS (\f -> printForUser f (ilxGen tycons stg_binds))              >>
  59 #endif
  60 #endif
  61
  62     dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d           >>
  63     outputForeignStubs True{-.h output-} opt_ProduceExportHStubs stub_h_output_w        >>
  64
  65     dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d >>
  66     outputForeignStubs False{-not .h-}   opt_ProduceExportCStubs stub_c_output_w        >>
  67
  68     dumpIfSet opt_D_dump_realC "Real C" c_output_d      >>
  69     doOutput opt_ProduceC c_output_w
  70
  71   where
  72     (flat_absC_c, flat_absC_ncg) =
  73          case (maybeToBool opt_ProduceC || opt_D_dump_realC,
  74                maybeToBool opt_ProduceS || opt_D_dump_asm) of
  75              (True,  False) -> (flat_abstractC, absCNop)
  76              (False, True)  -> (absCNop, flat_abstractC)
  77              (False, False) -> (absCNop, absCNop)
  78              (True,  True)  -> error "ERROR: Can't do both .hc and .s at the same time"
  79
  80     -- C stubs for "foreign export"ed functions.
  81     stub_c_output_d = pprCode CStyle c_code
  82     stub_c_output_w = showSDoc stub_c_output_d
  83
  84     -- Header file protos for "foreign export"ed functions.
  85     stub_h_output_d = pprCode CStyle h_code
  86     stub_h_output_w = showSDoc stub_h_output_d
  87
  88     c_output_d = dumpRealC flat_absC_c
  89     c_output_w = (\ f -> writeRealC f flat_absC_c)
  90
  91
  92     -- don't use doOutput for dumping the f. export stubs
  93     -- since it is more than likely that the stubs file will
  94     -- turn out to be empty, in which case no file should be created.
  95 outputForeignStubs is_header switch ""      = return ()
  96 outputForeignStubs is_header switch doc_str =
  97   case switch of
  98     Nothing    -> return ()
  99     Just fname -> writeFile fname (include_prefix ++ doc_str)
 100  where
 101   include_prefix
 102    | is_header   = "#include \"Rts.h\"\n"
 103    | otherwise   = "#include \"RtsAPI.h\"\n"
 104
 105 doOutput switch io_action
 106   = case switch of
 107           Nothing    -> return ()
 108           Just fname ->
 109             openFile fname WriteMode    >>= \ handle ->
 110             io_action handle            >>
 111             hClose handle
 112 \end{code}
 113