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