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