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 import OccurAnal        ( occurAnalyseBinds )
  24 #endif
  25
  26 import DriverState      ( v_HCHeader )
  27 import TyCon            ( TyCon )
  28 import Id               ( Id )
  29 import CoreSyn          ( CoreBind )
  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 DATA_IOREF       ( readIORef )
  41
  42 import Monad            ( when )
  43 import IO
  44 \end{code}
  45
  46
  47 %************************************************************************
  48 %*                                                                      *
  49 \subsection{Steering}
  50 %*                                                                      *
  51 %************************************************************************
  52
  53 \begin{code}
  54 codeOutput :: DynFlags
  55            -> Module
  56            -> [TyCon]                   -- Local tycons
  57            -> [CoreBind]                -- Core bindings
  58            -> [(StgBinding,[Id])]       -- The STG program with SRTs
  59            -> SDoc              -- C stubs for foreign exported functions
  60            -> SDoc              -- Header file prototype for foreign exported functions
  61            -> AbstractC         -- Compiled abstract C
  62            -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
  63 codeOutput dflags mod_name tycons core_binds stg_binds
  64            c_code h_code flat_abstractC
  65   = -- You can have C (c_output) or assembly-language (ncg_output),
  66     -- but not both.  [Allowing for both gives a space leak on
  67     -- flat_abstractC.  WDP 94/10]
  68
  69     -- Dunno if the above comment is still meaningful now.  JRS 001024.
  70
  71     do  { showPass dflags "CodeOutput"
  72         ; let filenm = dopt_OutName dflags
  73         ; stub_names <- outputForeignStubs dflags c_code h_code
  74         ; case dopt_HscLang dflags of
  75              HscInterpreted -> return stub_names
  76              HscAsm         -> outputAsm dflags filenm flat_abstractC
  77                                >> return stub_names
  78              HscC           -> outputC dflags filenm flat_abstractC stub_names
  79                                >> return stub_names
  80              HscJava        ->
  81 #ifdef JAVA
  82                                outputJava dflags filenm mod_name tycons core_binds
  83                                >> return stub_names
  84 #else
  85                                panic "Java support not compiled into this ghc"
  86 #endif
  87              HscILX         ->
  88 #ifdef ILX
  89                                outputIlx dflags filenm mod_name tycons stg_binds
  90                                >> return stub_names
  91 #else
  92                                panic "ILX support not compiled into this ghc"
  93 #endif
  94         }
  95
  96 doOutput :: String -> (Handle -> IO ()) -> IO ()
  97 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
  98 \end{code}
  99
 100
 101 %************************************************************************
 102 %*                                                                      *
 103 \subsection{C}
 104 %*                                                                      *
 105 %************************************************************************
 106
 107 \begin{code}
 108 outputC dflags filenm flat_absC (stub_h_exists, _)
 109   = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
 110        header <- readIORef v_HCHeader
 111        doOutput filenm $ \ h -> do
 112           hPutStr h header
 113           when stub_h_exists $
 114              hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
 115           writeRealC h flat_absC
 116 \end{code}
 117
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection{Assembler}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125 \begin{code}
 126 outputAsm dflags filenm flat_absC
 127
 128 #ifndef OMIT_NATIVE_CODEGEN
 129
 130   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 131        let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen"
 132                                         nativeCodeGen flat_absC ncg_uniqs
 133        dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
 134        dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
 135        _scc_ "OutputAsm" doOutput filenm $
 136            \f -> printDoc LeftMode f ncg_output_d
 137   where
 138
 139 #else /* OMIT_NATIVE_CODEGEN */
 140
 141   = pprPanic "This compiler was built without a native code generator"
 142              (text "Use -fvia-C instead")
 143
 144 #endif
 145 \end{code}
 146
 147
 148 %************************************************************************
 149 %*                                                                      *
 150 \subsection{Java}
 151 %*                                                                      *
 152 %************************************************************************
 153
 154 \begin{code}
 155 #ifdef JAVA
 156 outputJava dflags filenm mod tycons core_binds
 157   = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
 158         -- User style printing for now to keep indentation
 159   where
 160     occ_anal_binds = occurAnalyseBinds core_binds
 161         -- Make sure we have up to date dead-var information
 162     java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
 163     pp_java   = PrintJava.compilationUnit java_code
 164 #endif
 165 \end{code}
 166
 167
 168 %************************************************************************
 169 %*                                                                      *
 170 \subsection{Ilx}
 171 %*                                                                      *
 172 %************************************************************************
 173
 174 \begin{code}
 175 #ifdef ILX
 176 outputIlx dflags filename mod tycons stg_binds
 177   =  doOutput filename (\ f -> printForC f pp_ilx)
 178   where
 179     pp_ilx = ilxGen mod tycons stg_binds
 180 #endif
 181 \end{code}
 182
 183
 184 %************************************************************************
 185 %*                                                                      *
 186 \subsection{Foreign import/export}
 187 %*                                                                      *
 188 %************************************************************************
 189
 190 \begin{code}
 191 outputForeignStubs dflags c_code h_code
 192   = do
 193         dumpIfSet_dyn dflags Opt_D_dump_foreign
 194                       "Foreign export header file" stub_h_output_d
 195
 196         stub_h_file_exists
 197            <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
 198                 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
 199
 200         dumpIfSet_dyn dflags Opt_D_dump_foreign
 201                       "Foreign export stubs" stub_c_output_d
 202
 203         hc_header <- readIORef v_HCHeader
 204
 205         stub_c_file_exists
 206            <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
 207                 ("#define IN_STG_CODE 0\n" ++
 208                  hc_header ++
 209                  "#include \"RtsAPI.h\"\n" ++
 210                  cplusplus_hdr)
 211                  cplusplus_ftr
 212            -- we're adding the default hc_header to the stub file, but this
 213            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
 214            -- avoid the register variables etc. being enabled.
 215
 216         return (stub_h_file_exists, stub_c_file_exists)
 217   where
 218     -- C stubs for "foreign export"ed functions.
 219     stub_c_output_d = pprCode CStyle c_code
 220     stub_c_output_w = showSDoc stub_c_output_d
 221
 222     -- Header file protos for "foreign export"ed functions.
 223     stub_h_output_d = pprCode CStyle h_code
 224     stub_h_output_w = showSDoc stub_h_output_d
 225
 226 cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
 227 cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
 228
 229 -- Don't use doOutput for dumping the f. export stubs
 230 -- since it is more than likely that the stubs file will
 231 -- turn out to be empty, in which case no file should be created.
 232 outputForeignStubs_help fname ""      header footer = return False
 233 outputForeignStubs_help fname doc_str header footer
 234    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
 235         return True
 236 \end{code}
 237