CodeOutput.lhs 3.54 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section{Code output phase}

\begin{code}
module CodeOutput( codeOutput ) where

#include "HsVersions.h"

11
#ifndef OMIT_NATIVE_CODEGEN
12 13
import AsmCodeGen	( nativeCodeGen )
#endif
14 15 16
#ifdef ILX
import IlxGen		( ilxGen )
#endif
17

18 19 20 21
import TyCon		( TyCon )
import Id		( Id )
import Class		( Class )
import StgSyn		( StgBinding )
22 23 24 25 26 27 28 29
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
30
import IO		( IOMode(..), hPutStr, hClose, openFile	)
31 32 33 34 35
\end{code}


\begin{code}
codeOutput :: Module
36 37
	   -> [TyCon] -> [Class]	-- Local tycons and classes
	   -> [(StgBinding,[Id])]	-- The STG program with SRTs
38 39 40 41 42
	   -> SDoc 		-- C stubs for foreign exported functions
	   -> SDoc		-- Header file prototype for foreign exported functions
	   -> AbstractC		-- Compiled abstract C
	   -> UniqSupply
	   -> IO ()
43
codeOutput mod_name tycons classes stg_binds c_code h_code flat_abstractC ncg_uniqs
44 45 46 47
  = -- 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]

48 49 50 51 52 53 54 55 56 57 58 59 60
#ifndef OMIT_NATIVE_CODEGEN
    let
	(stix_final, ncg_output_d) = nativeCodeGen flat_absC_ncg ncg_uniqs
	ncg_output_w = (\ f -> printForUser f ncg_output_d)
    in
    dumpIfSet opt_D_dump_stix "Final stix code" stix_final	>>
    dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d 		>>
    doOutput opt_ProduceS ncg_output_w 				>>
#else
#ifdef ILX
    doOutput opt_ProduceS (\f -> printForUser f (ilxGen tycons stg_binds))		>>
#endif
#endif
61

62
    dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d		>>
sof's avatar
sof committed
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 >>
sof's avatar
sof committed
66
    outputForeignStubs False{-not .h-}   opt_ProduceExportCStubs stub_c_output_w	>>
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

    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)


    -- 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.
sof's avatar
sof committed
95 96 97 98 99 100 101 102 103
outputForeignStubs is_header switch ""      = return ()
outputForeignStubs is_header switch doc_str =
  case switch of
    Nothing    -> return ()
    Just fname -> writeFile fname (include_prefix ++ doc_str)
 where
  include_prefix
   | is_header   = "#include \"Rts.h\"\n"
   | otherwise   = "#include \"RtsAPI.h\"\n"
104 105 106 107 108 109 110 111 112 113

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