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