2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section{Code output phase}
7 module CodeOutput( codeOutput, outputForeignStubs ) where
9 #include "HsVersions.h"
11 #ifndef OMIT_NATIVE_CODEGEN
12 import UniqSupply ( mkSplitUniqSupply )
13 import AsmCodeGen ( nativeCodeGen )
17 import JavaGen ( javaGen )
18 import qualified PrintJava
19 import OccurAnal ( occurAnalyseBinds )
22 import Finder ( mkStubPaths )
23 import PprC ( writeCs )
24 import CmmLint ( cmmLint )
26 import PackageConfig ( rtsPackageId )
28 import FastString ( unpackFS )
32 import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit )
34 import Pretty ( Mode(..), printDoc )
35 import Module ( Module, ModLocation(..), moduleName )
37 import Maybes ( firstJust )
39 import Distribution.Package ( showPackageId )
40 import Directory ( doesFileExist )
45 %************************************************************************
49 %************************************************************************
52 codeOutput :: DynFlags
57 -> [Cmm] -- Compiled C--
58 -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
60 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
62 -- You can have C (c_output) or assembly-language (ncg_output),
63 -- but not both. [Allowing for both gives a space leak on
64 -- flat_abstractC. WDP 94/10]
66 -- Dunno if the above comment is still meaningful now. JRS 001024.
68 do { when (dopt Opt_DoCmmLinting dflags) $ do
69 { showPass dflags "CmmLint"
70 ; let lints = map cmmLint flat_abstractC
71 ; case firstJust lints of
72 Just err -> do { printDump err
78 ; showPass dflags "CodeOutput"
79 ; let filenm = hscOutName dflags
80 ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
81 ; case hscTarget dflags of {
82 HscInterpreted -> return ();
83 HscAsm -> outputAsm dflags filenm flat_abstractC;
84 HscC -> outputC dflags filenm this_mod location
85 flat_abstractC stubs_exist pkg_deps
89 outputJava dflags filenm mod_name tycons core_binds;
91 panic "Java support not compiled into this ghc";
97 doOutput :: String -> (Handle -> IO ()) -> IO ()
98 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
102 %************************************************************************
106 %************************************************************************
109 outputC dflags filenm mod location flat_absC
110 (stub_h_exists, _) packages foreign_stubs
112 -- figure out which header files to #include in the generated .hc file:
114 -- * extra_includes from packages
115 -- * -#include options from the cmdline and OPTIONS pragmas
116 -- * the _stub.h file, if there is one.
118 pkg_configs <- getPreloadPackagesAnd dflags packages
119 let pkg_names = map (showPackageId.package) pkg_configs
121 c_includes <- getPackageCIncludes pkg_configs
122 let cmdline_includes = cmdlineHcIncludes dflags -- -#include options
125 = case foreign_stubs of
127 ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs)
128 -- Remove duplicates, because distinct foreign import decls
129 -- may cite the same #include. Order doesn't matter.
131 all_headers = c_includes
132 ++ reverse cmdline_includes
135 let cc_injects = unlines (map mk_include all_headers)
138 '"':_{-"-} -> "#include "++h_file
139 '<':_ -> "#include "++h_file
140 _ -> "#include \""++h_file++"\""
142 doOutput filenm $ \ h -> do
143 hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
146 hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"")
147 writeCs dflags h flat_absC
149 (_, stub_h) = mkStubPaths dflags (moduleName mod) location
153 %************************************************************************
155 \subsection{Assembler}
157 %************************************************************************
160 outputAsm dflags filenm flat_absC
162 #ifndef OMIT_NATIVE_CODEGEN
164 = do ncg_uniqs <- mkSplitUniqSupply 'n'
165 ncg_output_d <- _scc_ "NativeCodeGen"
166 nativeCodeGen dflags flat_absC ncg_uniqs
167 dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
168 _scc_ "OutputAsm" doOutput filenm $
169 \f -> printDoc LeftMode f ncg_output_d
172 #else /* OMIT_NATIVE_CODEGEN */
174 = pprPanic "This compiler was built without a native code generator"
175 (text "Use -fvia-C instead")
181 %************************************************************************
185 %************************************************************************
189 outputJava dflags filenm mod tycons core_binds
190 = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
191 -- User style printing for now to keep indentation
193 occ_anal_binds = occurAnalyseBinds core_binds
194 -- Make sure we have up to date dead-var information
195 java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
196 pp_java = PrintJava.compilationUnit java_code
201 %************************************************************************
203 \subsection{Foreign import/export}
205 %************************************************************************
208 outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
209 -> IO (Bool, -- Header file created
210 Bool) -- C file created
211 outputForeignStubs dflags mod location stubs
212 | NoStubs <- stubs = do
213 -- When compiling External Core files, may need to use stub
214 -- files from a previous compilation
215 stub_c_exists <- doesFileExist stub_c
216 stub_h_exists <- doesFileExist stub_h
217 return (stub_h_exists, stub_c_exists)
219 | ForeignStubs h_code c_code _ _ <- stubs
222 stub_c_output_d = pprCode CStyle c_code
223 stub_c_output_w = showSDoc stub_c_output_d
225 -- Header file protos for "foreign export"ed functions.
226 stub_h_output_d = pprCode CStyle h_code
227 stub_h_output_w = showSDoc stub_h_output_d
230 createDirectoryHierarchy (directoryOf stub_c)
232 dumpIfSet_dyn dflags Opt_D_dump_foreign
233 "Foreign export header file" stub_h_output_d
235 -- we need the #includes from the rts package for the stub files
237 let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in
238 concatMap mk_include (includes rts_pkg)
239 mk_include i = "#include \"" ++ i ++ "\"\n"
242 <- outputForeignStubs_help stub_h stub_h_output_w
243 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
245 dumpIfSet_dyn dflags Opt_D_dump_foreign
246 "Foreign export stubs" stub_c_output_d
249 <- outputForeignStubs_help stub_c stub_c_output_w
250 ("#define IN_STG_CODE 0\n" ++
251 "#include \"Rts.h\"\n" ++
255 -- We're adding the default hc_header to the stub file, but this
256 -- isn't really HC code, so we need to define IN_STG_CODE==0 to
257 -- avoid the register variables etc. being enabled.
259 return (stub_h_file_exists, stub_c_file_exists)
261 (stub_c, stub_h) = mkStubPaths dflags (moduleName mod) location
263 cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
264 cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
266 -- Don't use doOutput for dumping the f. export stubs
267 -- since it is more than likely that the stubs file will
268 -- turn out to be empty, in which case no file should be created.
269 outputForeignStubs_help fname "" header footer = return False
270 outputForeignStubs_help fname doc_str header footer
271 = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")