never executed always true always false
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4 \section{Code output phase}
5 -}
6
7
8
9 module GHC.Driver.CodeOutput
10 ( codeOutput
11 , outputForeignStubs
12 , profilingInitCode
13 , ipInitCode
14 )
15 where
16
17 import GHC.Prelude
18 import GHC.Platform
19 import GHC.ForeignSrcLang
20
21 import GHC.CmmToAsm ( nativeCodeGen )
22 import GHC.CmmToLlvm ( llvmCodeGen )
23
24 import GHC.CmmToC ( cmmToC )
25 import GHC.Cmm.Lint ( cmmLint )
26 import GHC.Cmm ( RawCmmGroup )
27 import GHC.Cmm.CLabel
28
29 import GHC.Driver.Session
30 import GHC.Driver.Config.Finder (initFinderOpts)
31 import GHC.Driver.Config.CmmToAsm (initNCGConfig)
32 import GHC.Driver.Ppr
33 import GHC.Driver.Backend
34
35 import qualified GHC.Data.ShortText as ST
36 import GHC.Data.Stream ( Stream )
37 import qualified GHC.Data.Stream as Stream
38
39 import GHC.Utils.TmpFs
40
41
42 import GHC.Utils.Error
43 import GHC.Utils.Outputable
44 import GHC.Utils.Panic
45 import GHC.Utils.Logger
46 import GHC.Utils.Exception (bracket)
47 import GHC.Utils.Ppr (Mode(..))
48
49 import GHC.Unit
50 import GHC.Unit.Finder ( mkStubPaths )
51
52 import GHC.Types.SrcLoc
53 import GHC.Types.CostCentre
54 import GHC.Types.ForeignStubs
55 import GHC.Types.Unique.Supply ( mkSplitUniqSupply )
56
57 import System.Directory
58 import System.FilePath
59 import System.IO
60 import Data.Set (Set)
61 import qualified Data.Set as Set
62
63 {-
64 ************************************************************************
65 * *
66 \subsection{Steering}
67 * *
68 ************************************************************************
69 -}
70
71 codeOutput
72 :: Logger
73 -> TmpFs
74 -> DynFlags
75 -> UnitState
76 -> Module
77 -> FilePath
78 -> ModLocation
79 -> (a -> ForeignStubs)
80 -> [(ForeignSrcLang, FilePath)]
81 -- ^ additional files to be compiled with the C compiler
82 -> Set UnitId -- ^ Dependencies
83 -> Stream IO RawCmmGroup a -- Compiled C--
84 -> IO (FilePath,
85 (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
86 [(ForeignSrcLang, FilePath)]{-foreign_fps-},
87 a)
88 codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps
89 cmm_stream
90 =
91 do {
92 -- Lint each CmmGroup as it goes past
93 ; let linted_cmm_stream =
94 if gopt Opt_DoCmmLinting dflags
95 then Stream.mapM do_lint cmm_stream
96 else cmm_stream
97
98 do_lint cmm = withTimingSilent logger
99 (text "CmmLint"<+>brackets (ppr this_mod))
100 (const ()) $ do
101 { case cmmLint (targetPlatform dflags) cmm of
102 Just err -> do { logMsg logger
103 MCDump
104 noSrcSpan
105 $ withPprStyle defaultDumpStyle err
106 ; ghcExit logger 1
107 }
108 Nothing -> return ()
109 ; return cmm
110 }
111
112 ; a <- case backend dflags of
113 NCG -> outputAsm logger dflags this_mod location filenm
114 linted_cmm_stream
115 ViaC -> outputC logger dflags filenm linted_cmm_stream pkg_deps
116 LLVM -> outputLlvm logger dflags filenm linted_cmm_stream
117 Interpreter -> panic "codeOutput: Interpreter"
118 NoBackend -> panic "codeOutput: NoBackend"
119 ; let stubs = genForeignStubs a
120 ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs
121 ; return (filenm, stubs_exist, foreign_fps, a)
122 }
123
124 doOutput :: String -> (Handle -> IO a) -> IO a
125 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
126
127 {-
128 ************************************************************************
129 * *
130 \subsection{C}
131 * *
132 ************************************************************************
133 -}
134
135 outputC :: Logger
136 -> DynFlags
137 -> FilePath
138 -> Stream IO RawCmmGroup a
139 -> Set UnitId
140 -> IO a
141 outputC logger dflags filenm cmm_stream unit_deps =
142 withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do
143 let pkg_names = map unitIdString (Set.toAscList unit_deps)
144 doOutput filenm $ \ h -> do
145 hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
146 hPutStr h "#include \"Stg.h\"\n"
147 let platform = targetPlatform dflags
148 writeC cmm = do
149 let doc = cmmToC platform cmm
150 putDumpFileMaybe logger Opt_D_dump_c_backend
151 "C backend output"
152 FormatC
153 doc
154 let ctx = initSDocContext dflags (PprCode CStyle)
155 printSDocLn ctx LeftMode h doc
156 Stream.consume cmm_stream id writeC
157
158 {-
159 ************************************************************************
160 * *
161 \subsection{Assembler}
162 * *
163 ************************************************************************
164 -}
165
166 outputAsm :: Logger
167 -> DynFlags
168 -> Module
169 -> ModLocation
170 -> FilePath
171 -> Stream IO RawCmmGroup a
172 -> IO a
173 outputAsm logger dflags this_mod location filenm cmm_stream = do
174 ncg_uniqs <- mkSplitUniqSupply 'n'
175 debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm)
176 let ncg_config = initNCGConfig dflags this_mod
177 {-# SCC "OutputAsm" #-} doOutput filenm $
178 \h -> {-# SCC "NativeCodeGen" #-}
179 nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream
180
181 {-
182 ************************************************************************
183 * *
184 \subsection{LLVM}
185 * *
186 ************************************************************************
187 -}
188
189 outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
190 outputLlvm logger dflags filenm cmm_stream =
191 {-# SCC "llvm_output" #-} doOutput filenm $
192 \f -> {-# SCC "llvm_CodeGen" #-}
193 llvmCodeGen logger dflags f cmm_stream
194
195 {-
196 ************************************************************************
197 * *
198 \subsection{Foreign import/export}
199 * *
200 ************************************************************************
201 -}
202
203 outputForeignStubs
204 :: Logger
205 -> TmpFs
206 -> DynFlags
207 -> UnitState
208 -> Module
209 -> ModLocation
210 -> ForeignStubs
211 -> IO (Bool, -- Header file created
212 Maybe FilePath) -- C file created
213 outputForeignStubs logger tmpfs dflags unit_state mod location stubs
214 = do
215 let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location
216 stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
217
218 case stubs of
219 NoStubs ->
220 return (False, Nothing)
221
222 ForeignStubs (CHeader h_code) (CStub c_code) -> do
223 let
224 stub_c_output_d = pprCode CStyle c_code
225 stub_c_output_w = showSDoc dflags stub_c_output_d
226
227 -- Header file protos for "foreign export"ed functions.
228 stub_h_output_d = pprCode CStyle h_code
229 stub_h_output_w = showSDoc dflags stub_h_output_d
230
231 createDirectoryIfMissing True (takeDirectory stub_h)
232
233 putDumpFileMaybe logger Opt_D_dump_foreign
234 "Foreign export header file"
235 FormatC
236 stub_h_output_d
237
238 -- we need the #includes from the rts package for the stub files
239 let rts_includes =
240 let mrts_pkg = lookupUnitId unit_state rtsUnitId
241 mk_include i = "#include \"" ++ ST.unpack i ++ "\"\n"
242 in case mrts_pkg of
243 Just rts_pkg -> concatMap mk_include (unitIncludes rts_pkg)
244 -- This case only happens when compiling foreign stub for the rts
245 -- library itself. The only time we do this at the moment is for
246 -- IPE information for the RTS info tables
247 Nothing -> ""
248
249 -- wrapper code mentions the ffi_arg type, which comes from ffi.h
250 ffi_includes
251 | platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n"
252 | otherwise = ""
253
254 stub_h_file_exists
255 <- outputForeignStubs_help stub_h stub_h_output_w
256 ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr
257
258 putDumpFileMaybe logger Opt_D_dump_foreign
259 "Foreign export stubs" FormatC stub_c_output_d
260
261 stub_c_file_exists
262 <- outputForeignStubs_help stub_c stub_c_output_w
263 ("#define IN_STG_CODE 0\n" ++
264 "#include <Rts.h>\n" ++
265 rts_includes ++
266 ffi_includes ++
267 cplusplus_hdr)
268 cplusplus_ftr
269 -- We're adding the default hc_header to the stub file, but this
270 -- isn't really HC code, so we need to define IN_STG_CODE==0 to
271 -- avoid the register variables etc. being enabled.
272
273 return (stub_h_file_exists, if stub_c_file_exists
274 then Just stub_c
275 else Nothing )
276 where
277 cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n"
278 cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n"
279
280
281 -- Don't use doOutput for dumping the f. export stubs
282 -- since it is more than likely that the stubs file will
283 -- turn out to be empty, in which case no file should be created.
284 outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
285 outputForeignStubs_help _fname "" _header _footer = return False
286 outputForeignStubs_help fname doc_str header footer
287 = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
288 return True
289
290 -- -----------------------------------------------------------------------------
291 -- Initialising cost centres
292
293 -- We must produce declarations for the cost-centres defined in this
294 -- module;
295
296 -- | Generate code to initialise cost centres
297 profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub
298 profilingInitCode platform this_mod (local_CCs, singleton_CCSs)
299 = CStub $ vcat
300 $ map emit_cc_decl local_CCs
301 ++ map emit_ccs_decl singleton_CCSs
302 ++ [emit_cc_list local_CCs]
303 ++ [emit_ccs_list singleton_CCSs]
304 ++ [ text "static void prof_init_" <> ppr this_mod
305 <> text "(void) __attribute__((constructor));"
306 , text "static void prof_init_" <> ppr this_mod <> text "(void)"
307 , braces (vcat
308 [ text "registerCcList" <> parens local_cc_list_label <> semi
309 , text "registerCcsList" <> parens singleton_cc_list_label <> semi
310 ])
311 ]
312 where
313 emit_cc_decl cc =
314 text "extern CostCentre" <+> cc_lbl <> text "[];"
315 where cc_lbl = pdoc platform (mkCCLabel cc)
316 local_cc_list_label = text "local_cc_" <> ppr this_mod
317 emit_cc_list ccs =
318 text "static CostCentre *" <> local_cc_list_label <> text "[] ="
319 <+> braces (vcat $ [ pdoc platform (mkCCLabel cc) <> comma
320 | cc <- ccs
321 ] ++ [text "NULL"])
322 <> semi
323
324 emit_ccs_decl ccs =
325 text "extern CostCentreStack" <+> ccs_lbl <> text "[];"
326 where ccs_lbl = pdoc platform (mkCCSLabel ccs)
327 singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod
328 emit_ccs_list ccs =
329 text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="
330 <+> braces (vcat $ [ pdoc platform (mkCCSLabel cc) <> comma
331 | cc <- ccs
332 ] ++ [text "NULL"])
333 <> semi
334
335 -- | Generate code to initialise info pointer origin
336 -- See note [Mapping Info Tables to Source Positions]
337 ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> CStub
338 ipInitCode dflags this_mod ents
339 = if not (gopt Opt_InfoTableMap dflags)
340 then mempty
341 else CStub $ vcat
342 $ map emit_ipe_decl ents
343 ++ [emit_ipe_list ents]
344 ++ [ text "static void ip_init_" <> ppr this_mod
345 <> text "(void) __attribute__((constructor));"
346 , text "static void ip_init_" <> ppr this_mod <> text "(void)"
347 , braces (vcat
348 [ text "registerInfoProvList" <> parens local_ipe_list_label <> semi
349 ])
350 ]
351 where
352 platform = targetPlatform dflags
353 emit_ipe_decl ipe =
354 text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"
355 where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)
356 local_ipe_list_label = text "local_ipe_" <> ppr this_mod
357 emit_ipe_list ipes =
358 text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="
359 <+> braces (vcat $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma
360 | ipe <- ipes
361 ] ++ [text "NULL"])
362 <> semi
363
364