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, outputForeignStubs ) 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 = bracket (openFile filenm WriteMode) hClose io_action
  97 \end{code}
  98
  99
 100 %************************************************************************
 101 %*                                                                      *
 102 \subsection{C}
 103 %*                                                                      *
 104 %************************************************************************
 105
 106 \begin{code}
 107 outputC dflags filenm flat_absC (stub_h_exists, _)
 108   = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
 109        header <- readIORef v_HCHeader
 110        doOutput filenm $ \ h -> do
 111           hPutStr h header
 112           when stub_h_exists $
 113              hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
 114           writeRealC h flat_absC
 115 \end{code}
 116
 117
 118 %************************************************************************
 119 %*                                                                      *
 120 \subsection{Assembler}
 121 %*                                                                      *
 122 %************************************************************************
 123
 124 \begin{code}
 125 outputAsm dflags filenm flat_absC
 126
 127 #ifndef OMIT_NATIVE_CODEGEN
 128
 129   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 130        let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen"
 131                                         nativeCodeGen flat_absC ncg_uniqs
 132        dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
 133        dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
 134        _scc_ "OutputAsm" doOutput filenm $
 135            \f -> printDoc LeftMode f ncg_output_d
 136   where
 137
 138 #else /* OMIT_NATIVE_CODEGEN */
 139
 140   = pprPanic "This compiler was built without a native code generator"
 141              (text "Use -fvia-C instead")
 142
 143 #endif
 144 \end{code}
 145
 146
 147 %************************************************************************
 148 %*                                                                      *
 149 \subsection{Java}
 150 %*                                                                      *
 151 %************************************************************************
 152
 153 \begin{code}
 154 #ifdef JAVA
 155 outputJava dflags filenm mod tycons core_binds
 156   = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
 157         -- User style printing for now to keep indentation
 158   where
 159     occ_anal_binds = occurAnalyseBinds core_binds
 160         -- Make sure we have up to date dead-var information
 161     java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
 162     pp_java   = PrintJava.compilationUnit java_code
 163 #endif
 164 \end{code}
 165
 166
 167 %************************************************************************
 168 %*                                                                      *
 169 \subsection{Ilx}
 170 %*                                                                      *
 171 %************************************************************************
 172
 173 \begin{code}
 174 #ifdef ILX
 175 outputIlx dflags filename mod tycons stg_binds
 176   =  doOutput filename (\ f -> printForC f pp_ilx)
 177   where
 178     pp_ilx = ilxGen mod tycons stg_binds
 179 #endif
 180 \end{code}
 181
 182
 183 %************************************************************************
 184 %*                                                                      *
 185 \subsection{Foreign import/export}
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 \begin{code}
 190 outputForeignStubs dflags c_code h_code
 191   = do
 192         dumpIfSet_dyn dflags Opt_D_dump_foreign
 193                       "Foreign export header file" stub_h_output_d
 194
 195         stub_h_file_exists
 196            <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
 197                 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
 198
 199         dumpIfSet_dyn dflags Opt_D_dump_foreign
 200                       "Foreign export stubs" stub_c_output_d
 201
 202         hc_header <- readIORef v_HCHeader
 203
 204         stub_c_file_exists
 205            <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
 206                 ("#define IN_STG_CODE 0\n" ++
 207                  hc_header ++
 208                  "#include \"RtsAPI.h\"\n" ++
 209                  cplusplus_hdr)
 210                  cplusplus_ftr
 211            -- we're adding the default hc_header to the stub file, but this
 212            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
 213            -- avoid the register variables etc. being enabled.
 214
 215         return (stub_h_file_exists, stub_c_file_exists)
 216   where
 217     -- C stubs for "foreign export"ed functions.
 218     stub_c_output_d = pprCode CStyle c_code
 219     stub_c_output_w = showSDoc stub_c_output_d
 220
 221     -- Header file protos for "foreign export"ed functions.
 222     stub_h_output_d = pprCode CStyle h_code
 223     stub_h_output_w = showSDoc stub_h_output_d
 224
 225 cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
 226 cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
 227
 228 -- Don't use doOutput for dumping the f. export stubs
 229 -- since it is more than likely that the stubs file will
 230 -- turn out to be empty, in which case no file should be created.
 231 outputForeignStubs_help fname ""      header footer = return False
 232 outputForeignStubs_help fname doc_str header footer
 233    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
 234         return True
 235 \end{code}
 236