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