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