478de594acf88037ef919f5aeeb9e4ccb02b8827
[ghc.git] / compiler / main / CodeOutput.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4 \section{Code output phase}
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module CodeOutput( codeOutput, outputForeignStubs ) where
10
11 #include "HsVersions.h"
12
13 import GhcPrelude
14
15 import AsmCodeGen ( nativeCodeGen )
16 import LlvmCodeGen ( llvmCodeGen )
17
18 import UniqSupply ( mkSplitUniqSupply )
19
20 import Finder ( mkStubPaths )
21 import PprC ( writeCs )
22 import CmmLint ( cmmLint )
23 import Packages
24 import Cmm ( RawCmmGroup )
25 import HscTypes
26 import DynFlags
27 import Config
28 import Stream (Stream)
29 import qualified Stream
30 import FileCleanup
31
32 import ErrUtils
33 import Outputable
34 import Module
35 import SrcLoc
36
37 import Control.Exception
38 import System.Directory
39 import System.FilePath
40 import System.IO
41
42 {-
43 ************************************************************************
44 * *
45 \subsection{Steering}
46 * *
47 ************************************************************************
48 -}
49
50 codeOutput :: DynFlags
51 -> Module
52 -> FilePath
53 -> ModLocation
54 -> ForeignStubs
55 -> [(ForeignSrcLang, FilePath)]
56 -- ^ additional files to be compiled with with the C compiler
57 -> [InstalledUnitId]
58 -> Stream IO RawCmmGroup () -- Compiled C--
59 -> IO (FilePath,
60 (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
61 [(ForeignSrcLang, FilePath)]{-foreign_fps-})
62
63 codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
64 cmm_stream
65 =
66 do {
67 -- Lint each CmmGroup as it goes past
68 ; let linted_cmm_stream =
69 if gopt Opt_DoCmmLinting dflags
70 then Stream.mapM do_lint cmm_stream
71 else cmm_stream
72
73 do_lint cmm = withTiming (pure dflags)
74 (text "CmmLint"<+>brackets (ppr this_mod))
75 (const ()) $ do
76 { case cmmLint dflags cmm of
77 Just err -> do { log_action dflags
78 dflags
79 NoReason
80 SevDump
81 noSrcSpan
82 (defaultDumpStyle dflags)
83 err
84 ; ghcExit dflags 1
85 }
86 Nothing -> return ()
87 ; return cmm
88 }
89
90 ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
91 ; case hscTarget dflags of {
92 HscAsm -> outputAsm dflags this_mod location filenm
93 linted_cmm_stream;
94 HscC -> outputC dflags filenm linted_cmm_stream pkg_deps;
95 HscLlvm -> outputLlvm dflags filenm linted_cmm_stream;
96 HscInterpreted -> panic "codeOutput: HscInterpreted";
97 HscNothing -> panic "codeOutput: HscNothing"
98 }
99 ; return (filenm, stubs_exist, foreign_fps)
100 }
101
102 doOutput :: String -> (Handle -> IO a) -> IO a
103 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
104
105 {-
106 ************************************************************************
107 * *
108 \subsection{C}
109 * *
110 ************************************************************************
111 -}
112
113 outputC :: DynFlags
114 -> FilePath
115 -> Stream IO RawCmmGroup ()
116 -> [InstalledUnitId]
117 -> IO ()
118
119 outputC dflags filenm cmm_stream packages
120 = do
121 -- ToDo: make the C backend consume the C-- incrementally, by
122 -- pushing the cmm_stream inside (c.f. nativeCodeGen)
123 rawcmms <- Stream.collect cmm_stream
124
125 -- figure out which header files to #include in the generated .hc file:
126 --
127 -- * extra_includes from packages
128 -- * -#include options from the cmdline and OPTIONS pragmas
129 -- * the _stub.h file, if there is one.
130 --
131 let rts = getPackageDetails dflags rtsUnitId
132
133 let cc_injects = unlines (map mk_include (includes rts))
134 mk_include h_file =
135 case h_file of
136 '"':_{-"-} -> "#include "++h_file
137 '<':_ -> "#include "++h_file
138 _ -> "#include \""++h_file++"\""
139
140 let pkg_names = map installedUnitIdString packages
141
142 doOutput filenm $ \ h -> do
143 hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
144 hPutStr h cc_injects
145 writeCs dflags h rawcmms
146
147 {-
148 ************************************************************************
149 * *
150 \subsection{Assembler}
151 * *
152 ************************************************************************
153 -}
154
155 outputAsm :: DynFlags -> Module -> ModLocation -> FilePath
156 -> Stream IO RawCmmGroup ()
157 -> IO ()
158 outputAsm dflags this_mod location filenm cmm_stream
159 | cGhcWithNativeCodeGen == "YES"
160 = do ncg_uniqs <- mkSplitUniqSupply 'n'
161
162 debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)
163
164 _ <- {-# SCC "OutputAsm" #-} doOutput filenm $
165 \h -> {-# SCC "NativeCodeGen" #-}
166 nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream
167 return ()
168
169 | otherwise
170 = panic "This compiler was built without a native code generator"
171
172 {-
173 ************************************************************************
174 * *
175 \subsection{LLVM}
176 * *
177 ************************************************************************
178 -}
179
180 outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
181 outputLlvm dflags filenm cmm_stream
182 = do ncg_uniqs <- mkSplitUniqSupply 'n'
183
184 {-# SCC "llvm_output" #-} doOutput filenm $
185 \f -> {-# SCC "llvm_CodeGen" #-}
186 llvmCodeGen dflags f ncg_uniqs cmm_stream
187
188 {-
189 ************************************************************************
190 * *
191 \subsection{Foreign import/export}
192 * *
193 ************************************************************************
194 -}
195
196 outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
197 -> IO (Bool, -- Header file created
198 Maybe FilePath) -- C file created
199 outputForeignStubs dflags mod location stubs
200 = do
201 let stub_h = mkStubPaths dflags (moduleName mod) location
202 stub_c <- newTempName dflags TFL_CurrentModule "c"
203
204 case stubs of
205 NoStubs ->
206 return (False, Nothing)
207
208 ForeignStubs h_code c_code -> do
209 let
210 stub_c_output_d = pprCode CStyle c_code
211 stub_c_output_w = showSDoc dflags stub_c_output_d
212
213 -- Header file protos for "foreign export"ed functions.
214 stub_h_output_d = pprCode CStyle h_code
215 stub_h_output_w = showSDoc dflags stub_h_output_d
216
217 createDirectoryIfMissing True (takeDirectory stub_h)
218
219 dumpIfSet_dyn dflags Opt_D_dump_foreign
220 "Foreign export header file" stub_h_output_d
221
222 -- we need the #includes from the rts package for the stub files
223 let rts_includes =
224 let rts_pkg = getPackageDetails dflags rtsUnitId in
225 concatMap mk_include (includes rts_pkg)
226 mk_include i = "#include \"" ++ i ++ "\"\n"
227
228 -- wrapper code mentions the ffi_arg type, which comes from ffi.h
229 ffi_includes | cLibFFI = "#include \"ffi.h\"\n"
230 | otherwise = ""
231
232 stub_h_file_exists
233 <- outputForeignStubs_help stub_h stub_h_output_w
234 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
235
236 dumpIfSet_dyn dflags Opt_D_dump_foreign
237 "Foreign export stubs" stub_c_output_d
238
239 stub_c_file_exists
240 <- outputForeignStubs_help stub_c stub_c_output_w
241 ("#define IN_STG_CODE 0\n" ++
242 "#include \"Rts.h\"\n" ++
243 rts_includes ++
244 ffi_includes ++
245 cplusplus_hdr)
246 cplusplus_ftr
247 -- We're adding the default hc_header to the stub file, but this
248 -- isn't really HC code, so we need to define IN_STG_CODE==0 to
249 -- avoid the register variables etc. being enabled.
250
251 return (stub_h_file_exists, if stub_c_file_exists
252 then Just stub_c
253 else Nothing )
254 where
255 cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
256 cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
257
258
259 -- Don't use doOutput for dumping the f. export stubs
260 -- since it is more than likely that the stubs file will
261 -- turn out to be empty, in which case no file should be created.
262 outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
263 outputForeignStubs_help _fname "" _header _footer = return False
264 outputForeignStubs_help fname doc_str header footer
265 = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
266 return True
267