CodeOutput.lhs 3.37 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section{Code output phase}

\begin{code}
module CodeOutput( codeOutput ) where

#include "HsVersions.h"

#if ! OMIT_NATIVE_CODEGEN
import AsmCodeGen	( nativeCodeGen )
#endif

import AbsCSyn		( AbstractC, absCNop )
import PprAbsC		( dumpRealC, writeRealC )
import UniqSupply	( UniqSupply )
import Module		( Module, moduleString )
import CmdLineOpts
import Maybes		( maybeToBool )
import ErrUtils		( doIfSet, dumpIfSet )
import Outputable
import IO		( IOMode(..), hPutStr, hClose, openFile, stderr	)
\end{code}


\begin{code}
codeOutput :: Module
	   -> SDoc 		-- C stubs for foreign exported functions
	   -> SDoc		-- Header file prototype for foreign exported functions
	   -> AbstractC		-- Compiled abstract C
	   -> UniqSupply
	   -> IO ()
codeOutput mod_name c_code h_code flat_abstractC ncg_uniqs
  = -- You can have C (c_output) or assembly-language (ncg_output),
    -- but not both.  [Allowing for both gives a space leak on
    -- flat_abstractC.  WDP 94/10]

    dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d 	>>
    doOutput opt_ProduceS ncg_output_w 			>>

    dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d >>
    outputHStub opt_ProduceExportHStubs stub_h_output_w	>>

    dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d >>
    outputCStub mod_name opt_ProduceExportCStubs stub_c_output_w	>>

    dumpIfSet opt_D_dump_realC "Real C" c_output_d 	>>
    doOutput opt_ProduceC c_output_w

  where
    (flat_absC_c, flat_absC_ncg) =
	 case (maybeToBool opt_ProduceC || opt_D_dump_realC,
	       maybeToBool opt_ProduceS || opt_D_dump_asm) of
	     (True,  False) -> (flat_abstractC, absCNop)
	     (False, True)  -> (absCNop, flat_abstractC)
	     (False, False) -> (absCNop, absCNop)
	     (True,  True)  -> error "ERROR: Can't do both .hc and .s at the same time"

    -- C stubs for "foreign export"ed functions.
    stub_c_output_d = pprCode CStyle c_code
    stub_c_output_w = showSDoc stub_c_output_d

    -- Header file protos for "foreign export"ed functions.
    stub_h_output_d = pprCode CStyle h_code
    stub_h_output_w = showSDoc stub_h_output_d

    c_output_d = dumpRealC flat_absC_c
    c_output_w = (\ f -> writeRealC f flat_absC_c)

	-- Native code generation done here!
#if OMIT_NATIVE_CODEGEN
    ncg_output_d = error "*** GHC not built with a native-code generator ***"
    ncg_output_w = ncg_output_d
#else
    ncg_output_d = nativeCodeGen flat_absC_ncg ncg_uniqs
    ncg_output_w = (\ f -> printForAsm f ncg_output_d)
#endif


    -- don't use doOutput for dumping the f. export stubs
    -- since it is more than likely that the stubs file will
    -- turn out to be empty, in which case no file should be created.
outputCStub mod_name switch ""
  = return ()
outputCStub mod_name switch doc_str
  = case switch of
	  Nothing    -> return ()
	  Just fname -> writeFile fname ("#include \"Rts.h\"\n#include \"RtsAPI.h\"\n"++rest)
	    where
	     rest = "#include "++show (moduleString mod_name ++ "_stub.h") ++ '\n':doc_str
	      
outputHStub switch ""
  = return ()
outputHStub switch doc_str
  = case switch of
	  Nothing    -> return ()
	  Just fname -> writeFile fname ("#include \"Rts.h\"\n"++doc_str)

doOutput switch io_action
  = case switch of
	  Nothing    -> return ()
	  Just fname ->
	    openFile fname WriteMode	>>= \ handle ->
	    io_action handle		>>
	    hClose handle
\end{code}