Snapshot of codegen refactoring to share with simonpj
[ghc.git] / 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 import AsmCodeGen ( nativeCodeGen )
12 import LlvmCodeGen ( llvmCodeGen )
13
14 import UniqSupply       ( mkSplitUniqSupply )
15
16 import Finder           ( mkStubPaths )
17 import PprC             ( writeCs )
18 import CmmLint          ( cmmLint )
19 import Packages
20 import Util
21 import OldCmm           ( RawCmmPgm )
22 import HscTypes
23 import DynFlags
24 import Config
25 import SysTools
26
27 import ErrUtils         ( dumpIfSet_dyn, showPass, ghcExit )
28 import Outputable
29 import Module
30 import Maybes           ( firstJusts )
31
32 import Control.Exception
33 import Control.Monad
34 import System.Directory
35 import System.FilePath
36 import System.IO
37 \end{code}
38
39 %************************************************************************
40 %*                                                                      *
41 \subsection{Steering}
42 %*                                                                      *
43 %************************************************************************
44
45 \begin{code}
46 codeOutput :: DynFlags
47            -> Module
48            -> ModLocation
49            -> ForeignStubs
50            -> [PackageId]
51            -> [RawCmmPgm]                       -- Compiled C--
52            -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})
53
54 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
55   = 
56     -- You can have C (c_output) or assembly-language (ncg_output),
57     -- but not both.  [Allowing for both gives a space leak on
58     -- flat_abstractC.  WDP 94/10]
59
60     -- Dunno if the above comment is still meaningful now.  JRS 001024.
61
62     do  { when (dopt Opt_DoCmmLinting dflags) $ do
63                 { showPass dflags "CmmLint"
64                 ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
65                 ; case firstJusts lints of
66                         Just err -> do { printDump err
67                                        ; ghcExit dflags 1
68                                        }
69                         Nothing  -> return ()
70                 }
71
72         ; showPass dflags "CodeOutput"
73         ; let filenm = hscOutName dflags 
74         ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
75         ; case hscTarget dflags of {
76              HscInterpreted -> return ();
77              HscAsm         -> outputAsm dflags filenm flat_abstractC;
78              HscC           -> outputC dflags filenm flat_abstractC pkg_deps;
79              HscLlvm        -> outputLlvm dflags filenm flat_abstractC;
80              HscNothing     -> panic "codeOutput: HscNothing"
81           }
82         ; return stubs_exist
83         }
84
85 doOutput :: String -> (Handle -> IO ()) -> IO ()
86 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
87 \end{code}
88
89
90 %************************************************************************
91 %*                                                                      *
92 \subsection{C}
93 %*                                                                      *
94 %************************************************************************
95
96 \begin{code}
97 outputC :: DynFlags
98         -> FilePath
99         -> [RawCmmPgm]
100         -> [PackageId]
101         -> IO ()
102
103 outputC dflags filenm flat_absC packages
104   = do 
105        -- figure out which header files to #include in the generated .hc file:
106        --
107        --   * extra_includes from packages
108        --   * -#include options from the cmdline and OPTIONS pragmas
109        --   * the _stub.h file, if there is one.
110        --
111        let rts = getPackageDetails (pkgState dflags) rtsPackageId
112                        
113        let cc_injects = unlines (map mk_include (includes rts))
114            mk_include h_file = 
115             case h_file of 
116                '"':_{-"-} -> "#include "++h_file
117                '<':_      -> "#include "++h_file
118                _          -> "#include \""++h_file++"\""
119
120        pkg_configs <- getPreloadPackagesAnd dflags packages
121        let pkg_names = map (display.sourcePackageId) pkg_configs
122
123        doOutput filenm $ \ h -> do
124           hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
125           hPutStr h cc_injects
126           writeCs dflags h flat_absC
127 \end{code}
128
129
130 %************************************************************************
131 %*                                                                      *
132 \subsection{Assembler}
133 %*                                                                      *
134 %************************************************************************
135
136 \begin{code}
137 outputAsm :: DynFlags -> FilePath -> [RawCmmPgm] -> IO ()
138 outputAsm dflags filenm flat_absC
139  | cGhcWithNativeCodeGen == "YES"
140   = do ncg_uniqs <- mkSplitUniqSupply 'n'
141
142        {-# SCC "OutputAsm" #-} doOutput filenm $
143            \f -> {-# SCC "NativeCodeGen" #-}
144                  nativeCodeGen dflags f ncg_uniqs flat_absC
145
146  | otherwise
147   = panic "This compiler was built without a native code generator"
148 \end{code}
149
150
151 %************************************************************************
152 %*                                                                      *
153 \subsection{LLVM}
154 %*                                                                      *
155 %************************************************************************
156
157 \begin{code}
158 outputLlvm :: DynFlags -> FilePath -> [RawCmmPgm] -> IO ()
159 outputLlvm dflags filenm flat_absC
160   = do ncg_uniqs <- mkSplitUniqSupply 'n'
161        doOutput filenm $ \f -> llvmCodeGen dflags f ncg_uniqs flat_absC
162 \end{code}
163
164
165 %************************************************************************
166 %*                                                                      *
167 \subsection{Foreign import/export}
168 %*                                                                      *
169 %************************************************************************
170
171 \begin{code}
172 outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
173                    -> IO (Bool,         -- Header file created
174                           Maybe FilePath) -- C file created
175 outputForeignStubs dflags mod location stubs
176  = do
177    let stub_h = mkStubPaths dflags (moduleName mod) location
178    stub_c <- newTempName dflags "c"
179
180    case stubs of
181      NoStubs -> do
182         -- When compiling External Core files, may need to use stub
183         -- files from a previous compilation
184         stub_h_exists <- doesFileExist stub_h
185         return (stub_h_exists, Nothing)
186
187      ForeignStubs h_code c_code -> do
188         let
189             stub_c_output_d = pprCode CStyle c_code
190             stub_c_output_w = showSDoc stub_c_output_d
191         
192             -- Header file protos for "foreign export"ed functions.
193             stub_h_output_d = pprCode CStyle h_code
194             stub_h_output_w = showSDoc stub_h_output_d
195         -- in
196
197         createDirectoryHierarchy (takeDirectory stub_h)
198
199         dumpIfSet_dyn dflags Opt_D_dump_foreign
200                       "Foreign export header file" stub_h_output_d
201
202         -- we need the #includes from the rts package for the stub files
203         let rts_includes = 
204                let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in
205                concatMap mk_include (includes rts_pkg)
206             mk_include i = "#include \"" ++ i ++ "\"\n"
207
208             -- wrapper code mentions the ffi_arg type, which comes from ffi.h
209             ffi_includes | cLibFFI   = "#include \"ffi.h\"\n"
210                          | otherwise = ""
211
212         stub_h_file_exists
213            <- outputForeignStubs_help stub_h stub_h_output_w
214                 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
215
216         dumpIfSet_dyn dflags Opt_D_dump_foreign
217                       "Foreign export stubs" stub_c_output_d
218
219         stub_c_file_exists
220            <- outputForeignStubs_help stub_c stub_c_output_w
221                 ("#define IN_STG_CODE 0\n" ++ 
222                  "#include \"Rts.h\"\n" ++
223                  rts_includes ++
224                  ffi_includes ++
225                  cplusplus_hdr)
226                  cplusplus_ftr
227            -- We're adding the default hc_header to the stub file, but this
228            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
229            -- avoid the register variables etc. being enabled.
230
231         return (stub_h_file_exists, if stub_c_file_exists
232                                        then Just stub_c
233                                        else Nothing )
234  where
235    cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
236    cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
237
238
239 -- Don't use doOutput for dumping the f. export stubs
240 -- since it is more than likely that the stubs file will
241 -- turn out to be empty, in which case no file should be created.
242 outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
243 outputForeignStubs_help _fname ""      _header _footer = return False
244 outputForeignStubs_help fname doc_str header footer
245    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
246         return True
247 \end{code}
248