Remove all target-specific portions of Config.hs
[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 Stream (Stream)
28 import qualified Stream
29 import FileCleanup
30
31 import ErrUtils
32 import Outputable
33 import Module
34 import SrcLoc
35
36 import Control.Exception
37 import System.Directory
38 import System.FilePath
39 import System.IO
40
41 {-
42 ************************************************************************
43 * *
44 \subsection{Steering}
45 * *
46 ************************************************************************
47 -}
48
49 codeOutput :: DynFlags
50 -> Module
51 -> FilePath
52 -> ModLocation
53 -> ForeignStubs
54 -> [(ForeignSrcLang, FilePath)]
55 -- ^ additional files to be compiled with with the C compiler
56 -> [InstalledUnitId]
57 -> Stream IO RawCmmGroup () -- Compiled C--
58 -> IO (FilePath,
59 (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
60 [(ForeignSrcLang, FilePath)]{-foreign_fps-})
61
62 codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
63 cmm_stream
64 =
65 do {
66 -- Lint each CmmGroup as it goes past
67 ; let linted_cmm_stream =
68 if gopt Opt_DoCmmLinting dflags
69 then Stream.mapM do_lint cmm_stream
70 else cmm_stream
71
72 do_lint cmm = withTiming (pure dflags)
73 (text "CmmLint"<+>brackets (ppr this_mod))
74 (const ()) $ do
75 { case cmmLint dflags cmm of
76 Just err -> do { log_action dflags
77 dflags
78 NoReason
79 SevDump
80 noSrcSpan
81 (defaultDumpStyle dflags)
82 err
83 ; ghcExit dflags 1
84 }
85 Nothing -> return ()
86 ; return cmm
87 }
88
89 ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
90 ; case hscTarget dflags of {
91 HscAsm -> outputAsm dflags this_mod location filenm
92 linted_cmm_stream;
93 HscC -> outputC dflags filenm linted_cmm_stream pkg_deps;
94 HscLlvm -> outputLlvm dflags filenm linted_cmm_stream;
95 HscInterpreted -> panic "codeOutput: HscInterpreted";
96 HscNothing -> panic "codeOutput: HscNothing"
97 }
98 ; return (filenm, stubs_exist, foreign_fps)
99 }
100
101 doOutput :: String -> (Handle -> IO a) -> IO a
102 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
103
104 {-
105 ************************************************************************
106 * *
107 \subsection{C}
108 * *
109 ************************************************************************
110 -}
111
112 outputC :: DynFlags
113 -> FilePath
114 -> Stream IO RawCmmGroup ()
115 -> [InstalledUnitId]
116 -> IO ()
117
118 outputC dflags filenm cmm_stream packages
119 = do
120 -- ToDo: make the C backend consume the C-- incrementally, by
121 -- pushing the cmm_stream inside (c.f. nativeCodeGen)
122 rawcmms <- Stream.collect cmm_stream
123
124 -- figure out which header files to #include in the generated .hc file:
125 --
126 -- * extra_includes from packages
127 -- * -#include options from the cmdline and OPTIONS pragmas
128 -- * the _stub.h file, if there is one.
129 --
130 let rts = getPackageDetails dflags rtsUnitId
131
132 let cc_injects = unlines (map mk_include (includes rts))
133 mk_include h_file =
134 case h_file of
135 '"':_{-"-} -> "#include "++h_file
136 '<':_ -> "#include "++h_file
137 _ -> "#include \""++h_file++"\""
138
139 let pkg_names = map installedUnitIdString packages
140
141 doOutput filenm $ \ h -> do
142 hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
143 hPutStr h cc_injects
144 writeCs dflags h rawcmms
145
146 {-
147 ************************************************************************
148 * *
149 \subsection{Assembler}
150 * *
151 ************************************************************************
152 -}
153
154 outputAsm :: DynFlags -> Module -> ModLocation -> FilePath
155 -> Stream IO RawCmmGroup ()
156 -> IO ()
157 outputAsm dflags this_mod location filenm cmm_stream
158 | sGhcWithNativeCodeGen $ settings dflags
159 = do ncg_uniqs <- mkSplitUniqSupply 'n'
160
161 debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)
162
163 _ <- {-# SCC "OutputAsm" #-} doOutput filenm $
164 \h -> {-# SCC "NativeCodeGen" #-}
165 nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream
166 return ()
167
168 | otherwise
169 = panic "This compiler was built without a native code generator"
170
171 {-
172 ************************************************************************
173 * *
174 \subsection{LLVM}
175 * *
176 ************************************************************************
177 -}
178
179 outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
180 outputLlvm dflags filenm cmm_stream
181 = do ncg_uniqs <- mkSplitUniqSupply 'n'
182
183 {-# SCC "llvm_output" #-} doOutput filenm $
184 \f -> {-# SCC "llvm_CodeGen" #-}
185 llvmCodeGen dflags f ncg_uniqs cmm_stream
186
187 {-
188 ************************************************************************
189 * *
190 \subsection{Foreign import/export}
191 * *
192 ************************************************************************
193 -}
194
195 outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
196 -> IO (Bool, -- Header file created
197 Maybe FilePath) -- C file created
198 outputForeignStubs dflags mod location stubs
199 = do
200 let stub_h = mkStubPaths dflags (moduleName mod) location
201 stub_c <- newTempName dflags TFL_CurrentModule "c"
202
203 case stubs of
204 NoStubs ->
205 return (False, Nothing)
206
207 ForeignStubs h_code c_code -> do
208 let
209 stub_c_output_d = pprCode CStyle c_code
210 stub_c_output_w = showSDoc dflags stub_c_output_d
211
212 -- Header file protos for "foreign export"ed functions.
213 stub_h_output_d = pprCode CStyle h_code
214 stub_h_output_w = showSDoc dflags stub_h_output_d
215
216 createDirectoryIfMissing True (takeDirectory stub_h)
217
218 dumpIfSet_dyn dflags Opt_D_dump_foreign
219 "Foreign export header file" stub_h_output_d
220
221 -- we need the #includes from the rts package for the stub files
222 let rts_includes =
223 let rts_pkg = getPackageDetails dflags rtsUnitId in
224 concatMap mk_include (includes rts_pkg)
225 mk_include i = "#include \"" ++ i ++ "\"\n"
226
227 -- wrapper code mentions the ffi_arg type, which comes from ffi.h
228 ffi_includes
229 | sLibFFI $ settings dflags = "#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