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 #ifdef ILX
  79              HscILX         -> outputIlx dflags filenm mod_name tycons stg_binds
  80                                >> return stub_names
  81 #endif
  82         }
  83
  84 doOutput :: String -> (Handle -> IO ()) -> IO ()
  85 doOutput filenm io_action
  86   = (do handle <- openFile filenm WriteMode
  87         io_action handle
  88         hClose handle)
  89     `catch` (\err -> pprPanic "Failed to open or write code output file"
  90                               (text filenm))
  91 \end{code}
  92
  93
  94 %************************************************************************
  95 %*                                                                      *
  96 \subsection{C}
  97 %*                                                                      *
  98 %************************************************************************
  99
 100 \begin{code}
 101 outputC dflags filenm flat_absC (stub_h_exists, _)
 102   = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
 103        header <- readIORef v_HCHeader
 104        doOutput filenm $ \ h -> do
 105           hPutStr h header
 106           when stub_h_exists $
 107              hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
 108           writeRealC h flat_absC
 109 \end{code}
 110
 111
 112 %************************************************************************
 113 %*                                                                      *
 114 \subsection{Assembler}
 115 %*                                                                      *
 116 %************************************************************************
 117
 118 \begin{code}
 119 outputAsm dflags filenm flat_absC
 120
 121 #ifndef OMIT_NATIVE_CODEGEN
 122
 123   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 124        let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen"
 125                                         nativeCodeGen flat_absC ncg_uniqs
 126        dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
 127        dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" ncg_output_d
 128        _scc_ "OutputAsm" doOutput filenm ( \f -> printForAsm f ncg_output_d)
 129   where
 130
 131 #else /* OMIT_NATIVE_CODEGEN */
 132
 133   = pprPanic "This compiler was built without a native code generator"
 134              (text "Use -fvia-C instead")
 135
 136 #endif
 137 \end{code}
 138
 139
 140 %************************************************************************
 141 %*                                                                      *
 142 \subsection{Java}
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 \begin{code}
 147 outputJava dflags filenm mod tycons core_binds
 148   = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
 149         -- User style printing for now to keep indentation
 150   where
 151     occ_anal_binds = occurAnalyseBinds core_binds
 152         -- Make sure we have up to date dead-var information
 153     java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
 154     pp_java   = PrintJava.compilationUnit java_code
 155 \end{code}
 156
 157
 158 %************************************************************************
 159 %*                                                                      *
 160 \subsection{Ilx}
 161 %*                                                                      *
 162 %************************************************************************
 163
 164 \begin{code}
 165 #ifdef ILX
 166 outputIlx dflags filename mod tycons stg_binds
 167   =  doOutput filename (\ f -> printForC f pp_ilx)
 168   where
 169     pp_ilx = ilxGen mod tycons stg_binds
 170 #endif
 171 \end{code}
 172
 173
 174 %************************************************************************
 175 %*                                                                      *
 176 \subsection{Foreign import/export}
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 \begin{code}
 181 outputForeignStubs dflags c_code h_code
 182   = do
 183         dumpIfSet_dyn dflags Opt_D_dump_foreign
 184                       "Foreign export header file" stub_h_output_d
 185
 186         stub_h_file_exists
 187            <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
 188                 "#include \"HsFFI.h\"\n"
 189
 190         dumpIfSet_dyn dflags Opt_D_dump_foreign
 191                       "Foreign export stubs" stub_c_output_d
 192
 193         hc_header <- readIORef v_HCHeader
 194
 195         stub_c_file_exists
 196            <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
 197                 (hc_header ++ "#include \"RtsAPI.h\"\n")
 198
 199         return (stub_h_file_exists, stub_c_file_exists)
 200   where
 201     -- C stubs for "foreign export"ed functions.
 202     stub_c_output_d = pprCode CStyle c_code
 203     stub_c_output_w = showSDoc stub_c_output_d
 204
 205     -- Header file protos for "foreign export"ed functions.
 206     stub_h_output_d = pprCode CStyle h_code
 207     stub_h_output_w = showSDoc stub_h_output_d
 208
 209
 210 -- Don't use doOutput for dumping the f. export stubs
 211 -- since it is more than likely that the stubs file will
 212 -- turn out to be empty, in which case no file should be created.
 213 outputForeignStubs_help fname "" injects     = return False
 214 outputForeignStubs_help fname doc_str injects
 215    = do writeFile fname (injects ++ doc_str)
 216         return True
 217 \end{code}
 218