never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE MultiWayIf #-}
3 {-# LANGUAGE DerivingVia #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE GADTs #-}
7 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
8 #include "ghcplatform.h"
9
10 {- Functions for providing the default interpretation of the 'TPhase' actions
11 -}
12 module GHC.Driver.Pipeline.Execute where
13
14 import GHC.Prelude
15 import Control.Monad
16 import Control.Monad.IO.Class
17 import Control.Monad.Catch
18 import GHC.Driver.Hooks
19 import Control.Monad.Trans.Reader
20 import GHC.Driver.Pipeline.Monad
21 import GHC.Driver.Pipeline.Phases
22 import GHC.Driver.Env hiding (Hsc)
23 import GHC.Unit.Module.Location
24 import GHC.Driver.Phases
25 import GHC.Unit.Module.Name ( ModuleName )
26 import GHC.Unit.Types
27 import GHC.Types.SourceFile
28 import GHC.Unit.Module.Status
29 import GHC.Unit.Module.ModIface
30 import GHC.Linker.Types
31 import GHC.Driver.Backend
32 import GHC.Driver.Session
33 import GHC.Driver.CmdLine
34 import GHC.Unit.Module.ModSummary
35 import qualified GHC.LanguageExtensions as LangExt
36 import GHC.Types.SrcLoc
37 import GHC.Driver.Main
38 import GHC.Tc.Types
39 import GHC.Types.Error
40 import GHC.Driver.Errors.Types
41 import GHC.Fingerprint
42 import GHC.Utils.Logger
43 import GHC.Utils.TmpFs
44 import GHC.Platform
45 import Data.List (intercalate, isInfixOf)
46 import GHC.Unit.Env
47 import GHC.SysTools.Info
48 import GHC.Utils.Error
49 import Data.Maybe
50 import GHC.CmmToLlvm.Mangler
51 import GHC.SysTools
52 import GHC.Utils.Panic.Plain
53 import System.Directory
54 import System.FilePath
55 import GHC.Utils.Misc
56 import GHC.Utils.Outputable
57 import qualified Control.Exception as Exception
58 import GHC.Unit.Info
59 import GHC.Unit.State
60 import GHC.Unit.Home
61 import GHC.Data.Maybe
62 import GHC.Iface.Make
63 import Data.Time
64 import GHC.Driver.Config.Parser
65 import GHC.Parser.Header
66 import GHC.Data.StringBuffer
67 import GHC.Types.SourceError
68 import GHC.Unit.Finder
69 import GHC.Runtime.Loader
70 import Data.IORef
71 import GHC.Types.Name.Env
72 import GHC.Platform.Ways
73 import GHC.Platform.ArchOS
74 import GHC.CmmToLlvm.Base ( llvmVersionList )
75 import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub)
76 import GHC.Settings
77 import System.IO
78 import GHC.Linker.ExtraObj
79 import GHC.Linker.Dynamic
80 import Data.Version
81 import GHC.Utils.Panic
82 import GHC.Unit.Module.Env
83 import GHC.Driver.Env.KnotVars
84 import GHC.Driver.Config.Finder
85 import GHC.Rename.Names
86 import Data.Bifunctor (first)
87
88 newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a }
89 deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO)
90
91 instance MonadUse TPhase HookedUse where
92 use fa = HookedUse $ \(hooks, (PhaseHook k)) ->
93 case runPhaseHook hooks of
94 Nothing -> k fa
95 Just (PhaseHook h) -> h fa
96
97 -- | The default mechanism to run a pipeline, see Note [The Pipeline Monad]
98 runPipeline :: Hooks -> HookedUse a -> IO a
99 runPipeline hooks pipeline = runHookedUse pipeline (hooks, PhaseHook runPhase)
100
101 -- | Default interpretation of each phase, in terms of IO.
102 runPhase :: TPhase out -> IO out
103 runPhase (T_Unlit pipe_env hsc_env inp_path) = do
104 out_path <- phaseOutputFilenameNew (Cpp HsSrcFile) pipe_env hsc_env Nothing
105 runUnlitPhase hsc_env inp_path out_path
106 runPhase (T_FileArgs hsc_env inp_path) = getFileArgs hsc_env inp_path
107 runPhase (T_Cpp pipe_env hsc_env inp_path) = do
108 out_path <- phaseOutputFilenameNew (HsPp HsSrcFile) pipe_env hsc_env Nothing
109 runCppPhase hsc_env inp_path out_path
110 runPhase (T_HsPp pipe_env hsc_env origin_path inp_path) = do
111 out_path <- phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing
112 runHsPpPhase hsc_env origin_path inp_path out_path
113 runPhase (T_HscRecomp pipe_env hsc_env fp hsc_src) = do
114 runHscPhase pipe_env hsc_env fp hsc_src
115 runPhase (T_Hsc hsc_env mod_sum) = runHscTcPhase hsc_env mod_sum
116 runPhase (T_HscPostTc hsc_env ms fer m mfi) =
117 runHscPostTcPhase hsc_env ms fer m mfi
118 runPhase (T_HscBackend pipe_env hsc_env mod_name hsc_src location x) = do
119 runHscBackendPhase pipe_env hsc_env mod_name hsc_src location x
120 runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do
121 output_fn <- phaseOutputFilenameNew Cmm pipe_env hsc_env Nothing
122 doCpp (hsc_logger hsc_env)
123 (hsc_tmpfs hsc_env)
124 (hsc_dflags hsc_env)
125 (hsc_unit_env hsc_env)
126 False{-not raw-}
127 input_fn output_fn
128 return output_fn
129 runPhase (T_Cmm pipe_env hsc_env input_fn) = do
130 let dflags = hsc_dflags hsc_env
131 let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)
132 output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
133 mstub <- hscCompileCmmFile hsc_env input_fn output_fn
134 stub_o <- mapM (compileStub hsc_env) mstub
135 let foreign_os = (maybeToList stub_o)
136 return (foreign_os, output_fn)
137
138 runPhase (T_Cc phase pipe_env hsc_env input_fn) = runCcPhase phase pipe_env hsc_env input_fn
139 runPhase (T_As cpp pipe_env hsc_env location input_fn) = do
140 runAsPhase cpp pipe_env hsc_env location input_fn
141 runPhase (T_LlvmOpt pipe_env hsc_env input_fn) =
142 runLlvmOptPhase pipe_env hsc_env input_fn
143 runPhase (T_LlvmLlc pipe_env hsc_env input_fn) =
144 runLlvmLlcPhase pipe_env hsc_env input_fn
145 runPhase (T_LlvmMangle pipe_env hsc_env input_fn) =
146 runLlvmManglePhase pipe_env hsc_env input_fn
147 runPhase (T_MergeForeign pipe_env hsc_env location input_fn fos) =
148 runMergeForeign pipe_env hsc_env location input_fn fos
149
150 runLlvmManglePhase :: PipeEnv -> HscEnv -> FilePath -> IO [Char]
151 runLlvmManglePhase pipe_env hsc_env input_fn = do
152 let next_phase = As False
153 output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
154 let dflags = hsc_dflags hsc_env
155 llvmFixupAsm (targetPlatform dflags) input_fn output_fn
156 return output_fn
157
158 runMergeForeign :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> [FilePath] -> IO FilePath
159 runMergeForeign _pipe_env hsc_env _location input_fn foreign_os = do
160 if null foreign_os
161 then return input_fn
162 else do
163 -- Work around a binutil < 2.31 bug where you can't merge objects if the output file
164 -- is one of the inputs
165 new_o <- newTempName (hsc_logger hsc_env)
166 (hsc_tmpfs hsc_env)
167 (tmpDir (hsc_dflags hsc_env))
168 TFL_CurrentModule "o"
169 copyFile input_fn new_o
170 let dflags = hsc_dflags hsc_env
171 logger = hsc_logger hsc_env
172 let tmpfs = hsc_tmpfs hsc_env
173 joinObjectFiles logger tmpfs dflags (new_o : foreign_os) input_fn
174 return input_fn
175
176 runLlvmLlcPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
177 runLlvmLlcPhase pipe_env hsc_env input_fn = do
178 -- Note [Clamping of llc optimizations]
179 --
180 -- See #13724
181 --
182 -- we clamp the llc optimization between [1,2]. This is because passing -O0
183 -- to llc 3.9 or llc 4.0, the naive register allocator can fail with
184 --
185 -- Error while trying to spill R1 from class GPR: Cannot scavenge register
186 -- without an emergency spill slot!
187 --
188 -- Observed at least with target 'arm-unknown-linux-gnueabihf'.
189 --
190 --
191 -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile
192 -- rts/HeapStackCheck.cmm
193 --
194 -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
195 -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40
196 -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358
197 -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26
198 -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876
199 -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699
200 -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381
201 -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457
202 -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20
203 -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134
204 -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498
205 -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67
206 -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920
207 -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133
208 -- 13 llc 0x000000010195bf0b main + 491
209 -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1
210 -- Stack dump:
211 -- 0. Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
212 -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.
213 -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'
214 --
215 -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa
216 --
217 let dflags = hsc_dflags hsc_env
218 logger = hsc_logger hsc_env
219 llvmOpts = case optLevel dflags of
220 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
221 1 -> "-O1"
222 _ -> "-O2"
223
224 defaultOptions = map GHC.SysTools.Option . concatMap words . snd
225 $ unzip (llvmOptions dflags)
226 optFlag = if null (getOpts dflags opt_lc)
227 then map GHC.SysTools.Option $ words llvmOpts
228 else []
229
230 next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
231 | gopt Opt_NoLlvmMangler dflags -> return (As False)
232 | otherwise -> return LlvmMangle
233
234 output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
235
236 GHC.SysTools.runLlvmLlc logger dflags
237 ( optFlag
238 ++ defaultOptions
239 ++ [ GHC.SysTools.FileOption "" input_fn
240 , GHC.SysTools.Option "-o"
241 , GHC.SysTools.FileOption "" output_fn
242 ]
243 )
244
245 return output_fn
246
247 runLlvmOptPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
248 runLlvmOptPhase pipe_env hsc_env input_fn = do
249 let dflags = hsc_dflags hsc_env
250 logger = hsc_logger hsc_env
251 let -- we always (unless -optlo specified) run Opt since we rely on it to
252 -- fix up some pretty big deficiencies in the code we generate
253 optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2]
254 llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of
255 Just passes -> passes
256 Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "
257 ++ "is missing passes for level "
258 ++ show optIdx)
259 defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst
260 $ unzip (llvmOptions dflags)
261
262 -- don't specify anything if user has specified commands. We do this
263 -- for opt but not llc since opt is very specifically for optimisation
264 -- passes only, so if the user is passing us extra options we assume
265 -- they know what they are doing and don't get in the way.
266 optFlag = if null (getOpts dflags opt_lo)
267 then map GHC.SysTools.Option $ words llvmOpts
268 else []
269
270 output_fn <- phaseOutputFilenameNew LlvmLlc pipe_env hsc_env Nothing
271
272 GHC.SysTools.runLlvmOpt logger dflags
273 ( optFlag
274 ++ defaultOptions ++
275 [ GHC.SysTools.FileOption "" input_fn
276 , GHC.SysTools.Option "-o"
277 , GHC.SysTools.FileOption "" output_fn]
278 )
279
280 return output_fn
281
282
283 runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
284 runAsPhase with_cpp pipe_env hsc_env location input_fn = do
285 let dflags = hsc_dflags hsc_env
286 let logger = hsc_logger hsc_env
287 let unit_env = hsc_unit_env hsc_env
288 let platform = ue_platform unit_env
289
290 -- LLVM from version 3.0 onwards doesn't support the OS X system
291 -- assembler, so we use clang as the assembler instead. (#5636)
292 let (as_prog, get_asm_info) | backend dflags == LLVM
293 , platformOS platform == OSDarwin
294 = (GHC.SysTools.runClang, pure Clang)
295 | otherwise
296 = (GHC.SysTools.runAs, getAssemblerInfo logger dflags)
297
298 asmInfo <- get_asm_info
299
300 let cmdline_include_paths = includePaths dflags
301 let pic_c_flags = picCCOpts dflags
302
303 output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location
304
305 -- we create directories for the object file, because it
306 -- might be a hierarchical module.
307 createDirectoryIfMissing True (takeDirectory output_fn)
308
309 let global_includes = [ GHC.SysTools.Option ("-I" ++ p)
310 | p <- includePathsGlobal cmdline_include_paths ]
311 let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)
312 | p <- includePathsQuote cmdline_include_paths ++
313 includePathsQuoteImplicit cmdline_include_paths]
314 let runAssembler inputFilename outputFilename
315 = withAtomicRename outputFilename $ \temp_outputFilename ->
316 as_prog
317 logger dflags
318 (local_includes ++ global_includes
319 -- See Note [-fPIC for assembler]
320 ++ map GHC.SysTools.Option pic_c_flags
321 -- See Note [Produce big objects on Windows]
322 ++ [ GHC.SysTools.Option "-Wa,-mbig-obj"
323 | platformOS (targetPlatform dflags) == OSMinGW32
324 , not $ target32Bit (targetPlatform dflags)
325 ]
326
327 -- We only support SparcV9 and better because V8 lacks an atomic CAS
328 -- instruction so we have to make sure that the assembler accepts the
329 -- instruction set. Note that the user can still override this
330 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
331 -- regardless of the ordering.
332 --
333 -- This is a temporary hack.
334 ++ (if platformArch (targetPlatform dflags) == ArchSPARC
335 then [GHC.SysTools.Option "-mcpu=v9"]
336 else [])
337 ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51]
338 then [GHC.SysTools.Option "-Qunused-arguments"]
339 else [])
340 ++ [ GHC.SysTools.Option "-x"
341 , if with_cpp
342 then GHC.SysTools.Option "assembler-with-cpp"
343 else GHC.SysTools.Option "assembler"
344 , GHC.SysTools.Option "-c"
345 , GHC.SysTools.FileOption "" inputFilename
346 , GHC.SysTools.Option "-o"
347 , GHC.SysTools.FileOption "" temp_outputFilename
348 ])
349
350 debugTraceMsg logger 4 (text "Running the assembler")
351 runAssembler input_fn output_fn
352
353 return output_fn
354
355
356 runCcPhase :: Phase -> PipeEnv -> HscEnv -> FilePath -> IO FilePath
357 runCcPhase cc_phase pipe_env hsc_env input_fn = do
358 let dflags = hsc_dflags hsc_env
359 let logger = hsc_logger hsc_env
360 let unit_env = hsc_unit_env hsc_env
361 let home_unit = hsc_home_unit hsc_env
362 let tmpfs = hsc_tmpfs hsc_env
363 let platform = ue_platform unit_env
364 let hcc = cc_phase `eqPhase` HCc
365
366 let cmdline_include_paths = includePaths dflags
367
368 -- HC files have the dependent packages stamped into them
369 pkgs <- if hcc then getHCFilePackages input_fn else return []
370
371 -- add package include paths even if we're just compiling .c
372 -- files; this is the Value Add(TM) that using ghc instead of
373 -- gcc gives you :)
374 ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs)
375 let pkg_include_dirs = collectIncludeDirs ps
376 let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
377 (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
378 let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
379 (includePathsQuote cmdline_include_paths ++
380 includePathsQuoteImplicit cmdline_include_paths)
381 let include_paths = include_paths_quote ++ include_paths_global
382
383 -- pass -D or -optP to preprocessor when compiling foreign C files
384 -- (#16737). Doing it in this way is simpler and also enable the C
385 -- compiler to perform preprocessing and parsing in a single pass,
386 -- but it may introduce inconsistency if a different pgm_P is specified.
387 let more_preprocessor_opts = concat
388 [ ["-Xpreprocessor", i]
389 | not hcc
390 , i <- getOpts dflags opt_P
391 ]
392
393 let gcc_extra_viac_flags = extraGccViaCFlags dflags
394 let pic_c_flags = picCCOpts dflags
395
396 let verbFlags = getVerbFlags dflags
397
398 -- cc-options are not passed when compiling .hc files. Our
399 -- hc code doesn't not #include any header files anyway, so these
400 -- options aren't necessary.
401 let pkg_extra_cc_opts
402 | hcc = []
403 | otherwise = collectExtraCcOpts ps
404
405 let framework_paths
406 | platformUsesFrameworks platform
407 = let pkgFrameworkPaths = collectFrameworksDirs ps
408 cmdlineFrameworkPaths = frameworkPaths dflags
409 in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
410 | otherwise
411 = []
412
413 let cc_opt | optLevel dflags >= 2 = [ "-O2" ]
414 | optLevel dflags >= 1 = [ "-O" ]
415 | otherwise = []
416
417 -- Decide next phase
418 let next_phase = As False
419 output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
420
421 let
422 more_hcc_opts =
423 -- on x86 the floating point regs have greater precision
424 -- than a double, which leads to unpredictable results.
425 -- By default, we turn this off with -ffloat-store unless
426 -- the user specified -fexcess-precision.
427 (if platformArch platform == ArchX86 &&
428 not (gopt Opt_ExcessPrecision dflags)
429 then [ "-ffloat-store" ]
430 else []) ++
431
432 -- gcc's -fstrict-aliasing allows two accesses to memory
433 -- to be considered non-aliasing if they have different types.
434 -- This interacts badly with the C code we generate, which is
435 -- very weakly typed, being derived from C--.
436 ["-fno-strict-aliasing"]
437
438 ghcVersionH <- getGhcVersionPathName dflags unit_env
439
440 GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (
441 [ GHC.SysTools.FileOption "" input_fn
442 , GHC.SysTools.Option "-o"
443 , GHC.SysTools.FileOption "" output_fn
444 ]
445 ++ map GHC.SysTools.Option (
446 pic_c_flags
447
448 -- Stub files generated for foreign exports references the runIO_closure
449 -- and runNonIO_closure symbols, which are defined in the base package.
450 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
451 -- way we do the import depends on whether we're currently compiling
452 -- the base package or not.
453 ++ (if platformOS platform == OSMinGW32 &&
454 isHomeUnitId home_unit baseUnitId
455 then [ "-DCOMPILING_BASE_PACKAGE" ]
456 else [])
457
458 -- We only support SparcV9 and better because V8 lacks an atomic CAS
459 -- instruction. Note that the user can still override this
460 -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
461 -- regardless of the ordering.
462 --
463 -- This is a temporary hack. See #2872, commit
464 -- 5bd3072ac30216a505151601884ac88bf404c9f2
465 ++ (if platformArch platform == ArchSPARC
466 then ["-mcpu=v9"]
467 else [])
468
469 -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
470 ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
471 then ["-Wimplicit"]
472 else [])
473
474 ++ (if hcc
475 then gcc_extra_viac_flags ++ more_hcc_opts
476 else [])
477 ++ verbFlags
478 ++ [ "-S" ]
479 ++ cc_opt
480 ++ [ "-include", ghcVersionH ]
481 ++ framework_paths
482 ++ include_paths
483 ++ more_preprocessor_opts
484 ++ pkg_extra_cc_opts
485 ))
486
487 return output_fn
488
489 -- This is where all object files get written from, for hs-boot and hsig files as well.
490 runHscBackendPhase :: PipeEnv
491 -> HscEnv
492 -> ModuleName
493 -> HscSource
494 -> ModLocation
495 -> HscBackendAction
496 -> IO ([FilePath], ModIface, Maybe Linkable, FilePath)
497 runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
498 let dflags = hsc_dflags hsc_env
499 logger = hsc_logger hsc_env
500 o_file = if dynamicNow dflags then ml_dyn_obj_file location else ml_obj_file location -- The real object file
501 next_phase = hscPostBackendPhase src_flavour (backend dflags)
502 case result of
503 HscUpdate iface ->
504 do
505 case src_flavour of
506 HsigFile -> do
507 -- We need to create a REAL but empty .o file
508 -- because we are going to attempt to put it in a library
509 let input_fn = expectJust "runPhase" (ml_hs_file location)
510 basename = dropExtension input_fn
511 compileEmptyStub dflags hsc_env basename location mod_name
512
513 -- In the case of hs-boot files, generate a dummy .o-boot
514 -- stamp file for the benefit of Make
515 HsBootFile -> touchObjectFile logger dflags o_file
516 HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile"
517
518 return ([], iface, Nothing, o_file)
519 HscRecomp { hscs_guts = cgguts,
520 hscs_mod_location = mod_location,
521 hscs_partial_iface = partial_iface,
522 hscs_old_iface_hash = mb_old_iface_hash
523 }
524 -> case backend dflags of
525 NoBackend -> panic "HscRecomp not relevant for NoBackend"
526 Interpreter -> do
527 -- In interpreted mode the regular codeGen backend is not run so we
528 -- generate a interface without codeGen info.
529 final_iface <- mkFullIface hsc_env partial_iface Nothing
530 hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location
531
532 (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location
533
534 stub_o <- case hasStub of
535 Nothing -> return []
536 Just stub_c -> do
537 stub_o <- compileStub hsc_env stub_c
538 return [DotO stub_o]
539
540 let hs_unlinked = [BCOs comp_bc spt_entries]
541 unlinked_time <- getCurrentTime
542 let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name)
543 (hs_unlinked ++ stub_o)
544 return ([], final_iface, Just linkable, panic "interpreter")
545 _ -> do
546 output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)
547 (outputFilename, mStub, foreign_files, cg_infos) <-
548 hscGenHardCode hsc_env cgguts mod_location output_fn
549 final_iface <- mkFullIface hsc_env partial_iface (Just cg_infos)
550
551 -- See Note [Writing interface files]
552 hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
553
554 stub_o <- mapM (compileStub hsc_env) mStub
555 foreign_os <-
556 mapM (uncurry (compileForeign hsc_env)) foreign_files
557 let fos = (maybe [] return stub_o ++ foreign_os)
558
559 -- This is awkward, no linkable is produced here because we still
560 -- have some way to do before the object file is produced
561 -- In future we can split up the driver logic more so that this function
562 -- is in TPipeline and in this branch we can invoke the rest of the backend phase.
563 return (fos, final_iface, Nothing, outputFilename)
564
565
566 runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath
567 runUnlitPhase hsc_env input_fn output_fn = do
568 let
569 -- escape the characters \, ", and ', but don't try to escape
570 -- Unicode or anything else (so we don't use Util.charToC
571 -- here). If we get this wrong, then in
572 -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in
573 -- a SrcLoc is the same as the source filenaame, the two will
574 -- look bogusly different. See test:
575 -- libraries/hpc/tests/function/subdir/tough2.hs
576 escape ('\\':cs) = '\\':'\\': escape cs
577 escape ('\"':cs) = '\\':'\"': escape cs
578 escape ('\'':cs) = '\\':'\'': escape cs
579 escape (c:cs) = c : escape cs
580 escape [] = []
581
582 let flags = [ -- The -h option passes the file name for unlit to
583 -- put in a #line directive
584 GHC.SysTools.Option "-h"
585 -- See Note [Don't normalise input filenames].
586 , GHC.SysTools.Option $ escape input_fn
587 , GHC.SysTools.FileOption "" input_fn
588 , GHC.SysTools.FileOption "" output_fn
589 ]
590
591 let dflags = hsc_dflags hsc_env
592 logger = hsc_logger hsc_env
593 GHC.SysTools.runUnlit logger dflags flags
594
595 return output_fn
596
597 getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, [Warn]))
598 getFileArgs hsc_env input_fn = do
599 let dflags0 = hsc_dflags hsc_env
600 parser_opts = initParserOpts dflags0
601 src_opts <- getOptionsFromFile parser_opts input_fn
602 (dflags1, unhandled_flags, warns)
603 <- parseDynamicFilePragma dflags0 src_opts
604 checkProcessArgsResult unhandled_flags
605 return (dflags1, warns)
606
607 runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath
608 runCppPhase hsc_env input_fn output_fn = do
609 doCpp (hsc_logger hsc_env)
610 (hsc_tmpfs hsc_env)
611 (hsc_dflags hsc_env)
612 (hsc_unit_env hsc_env)
613 True{-raw-}
614 input_fn output_fn
615 return output_fn
616
617
618 runHscPhase :: PipeEnv
619 -> HscEnv
620 -> FilePath
621 -> HscSource
622 -> IO (HscEnv, ModSummary, HscRecompStatus)
623 runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
624 let dflags0 = hsc_dflags hsc_env0
625 PipeEnv{ src_basename=basename,
626 src_suffix=suff } = pipe_env
627
628 -- we add the current directory (i.e. the directory in which
629 -- the .hs files resides) to the include path, since this is
630 -- what gcc does, and it's probably what you want.
631 let current_dir = takeDirectory basename
632 new_includes = addImplicitQuoteInclude paths [current_dir]
633 paths = includePaths dflags0
634 dflags = dflags0 { includePaths = new_includes }
635 hsc_env = hscSetFlags dflags hsc_env0
636
637
638
639 -- gather the imports and module name
640 (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
641 buf <- hGetStringBuffer input_fn
642 let imp_prelude = xopt LangExt.ImplicitPrelude dflags
643 popts = initParserOpts dflags
644 rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
645 rn_imps = fmap (first rn_pkg_qual)
646 eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
647 case eimps of
648 Left errs -> throwErrors (GhcPsMessage <$> errs)
649 Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return
650 (Just buf, mod_name, rn_imps imps, rn_imps src_imps, ghc_prim_imp)
651
652 -- Take -o into account if present
653 -- Very like -ohi, but we must *only* do this if we aren't linking
654 -- (If we're linking then the -o applies to the linked thing, not to
655 -- the object file for one module.)
656 -- Note the nasty duplication with the same computation in compileFile above
657 location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name
658 let o_file = ml_obj_file location -- The real object file
659 hi_file = ml_hi_file location
660 hie_file = ml_hie_file location
661 dyn_o_file = ml_dyn_obj_file location
662
663 src_hash <- getFileHash (basename <.> suff)
664 hi_date <- modificationTimeIfExists hi_file
665 hie_date <- modificationTimeIfExists hie_file
666 o_mod <- modificationTimeIfExists o_file
667 dyn_o_mod <- modificationTimeIfExists dyn_o_file
668
669 -- Tell the finder cache about this module
670 mod <- do
671 let home_unit = hsc_home_unit hsc_env
672 let fc = hsc_FC hsc_env
673 addHomeModuleToFinder fc home_unit mod_name location
674
675 -- Make the ModSummary to hand to hscMain
676 let
677 mod_summary = ModSummary { ms_mod = mod,
678 ms_hsc_src = src_flavour,
679 ms_hspp_file = input_fn,
680 ms_hspp_opts = dflags,
681 ms_hspp_buf = hspp_buf,
682 ms_location = location,
683 ms_hs_hash = src_hash,
684 ms_obj_date = o_mod,
685 ms_dyn_obj_date = dyn_o_mod,
686 ms_parsed_mod = Nothing,
687 ms_iface_date = hi_date,
688 ms_hie_date = hie_date,
689 ms_ghc_prim_import = ghc_prim_imp,
690 ms_textual_imps = imps,
691 ms_srcimps = src_imps }
692
693
694 -- run the compiler!
695 let msg :: Messager
696 msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what
697 plugin_hsc_env' <- initializePlugins hsc_env (Just $ ms_mnwib mod_summary)
698
699 -- Need to set the knot-tying mutable variable for interface
700 -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.
701 -- See also Note [hsc_type_env_var hack]
702 type_env_var <- newIORef emptyNameEnv
703 let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }
704
705 status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary
706 Nothing Nothing (1, 1)
707
708 return (plugin_hsc_env, mod_summary, status)
709
710 -- | Calculate the ModLocation from the provided DynFlags. This function is only used
711 -- in one-shot mode and therefore takes into account the effect of -o/-ohi flags
712 -- (which do nothing in --make mode)
713 mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO ModLocation
714 mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
715 let PipeEnv{ src_basename=basename,
716 src_suffix=suff } = pipe_env
717 let location1 = mkHomeModLocation2 fopts mod_name basename suff
718
719 -- Boot-ify it if necessary
720 let location2
721 | HsBootFile <- src_flavour = addBootSuffixLocnOut location1
722 | otherwise = location1
723
724
725 -- Take -ohi into account if present
726 -- This can't be done in mkHomeModuleLocation because
727 -- it only applies to the module being compiles
728 let ohi = outputHi dflags
729 location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
730 | otherwise = location2
731
732 let dynohi = dynOutputHi dflags
733 location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }
734 | otherwise = location3
735
736 -- Take -o into account if present
737 -- Very like -ohi, but we must *only* do this if we aren't linking
738 -- (If we're linking then the -o applies to the linked thing, not to
739 -- the object file for one module.)
740 -- Note the nasty duplication with the same computation in compileFile
741 -- above
742 let expl_o_file = outputFile_ dflags
743 expl_dyn_o_file = dynOutputFile_ dflags
744 location5 | Just ofile <- expl_o_file
745 , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file
746 , isNoLink (ghcLink dflags)
747 = location4 { ml_obj_file = ofile
748 , ml_dyn_obj_file = dyn_ofile }
749 | Just dyn_ofile <- expl_dyn_o_file
750 = location4 { ml_dyn_obj_file = dyn_ofile }
751 | otherwise = location4
752 return location5
753 where
754 fopts = initFinderOpts dflags
755
756 runHscTcPhase :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage)
757 runHscTcPhase = hscTypecheckAndGetWarnings
758
759 runHscPostTcPhase ::
760 HscEnv
761 -> ModSummary
762 -> FrontendResult
763 -> Messages GhcMessage
764 -> Maybe Fingerprint
765 -> IO HscBackendAction
766 runHscPostTcPhase hsc_env mod_summary tc_result tc_warnings mb_old_hash = do
767 runHsc hsc_env $ do
768 hscDesugarAndSimplify mod_summary tc_result tc_warnings mb_old_hash
769
770
771 runHsPpPhase :: HscEnv -> FilePath -> FilePath -> FilePath -> IO FilePath
772 runHsPpPhase hsc_env orig_fn input_fn output_fn = do
773 let dflags = hsc_dflags hsc_env
774 let logger = hsc_logger hsc_env
775 GHC.SysTools.runPp logger dflags
776 ( [ GHC.SysTools.Option orig_fn
777 , GHC.SysTools.Option input_fn
778 , GHC.SysTools.FileOption "" output_fn
779 ] )
780 return output_fn
781
782 phaseOutputFilenameNew :: Phase -- ^ The next phase
783 -> PipeEnv
784 -> HscEnv
785 -> Maybe ModLocation -- ^ A ModLocation, if we are compiling a Haskell source file
786 -> IO FilePath
787 phaseOutputFilenameNew next_phase pipe_env hsc_env maybe_loc = do
788 let PipeEnv{stop_phase, src_basename, output_spec} = pipe_env
789 let dflags = hsc_dflags hsc_env
790 logger = hsc_logger hsc_env
791 tmpfs = hsc_tmpfs hsc_env
792 getOutputFilename logger tmpfs (stopPhaseToPhase stop_phase) output_spec
793 src_basename dflags next_phase maybe_loc
794
795
796 -- | Computes the next output filename for something in the compilation
797 -- pipeline. This is controlled by several variables:
798 --
799 -- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This
800 -- is used to tell if we're in the last phase or not, because
801 -- in that case flags like @-o@ may be important.
802 -- 2. 'PipelineOutput': is this intended to be a 'Temporary' or
803 -- 'Persistent' build output? Temporary files just go in
804 -- a fresh temporary name.
805 -- 3. 'String': what was the basename of the original input file?
806 -- 4. 'DynFlags': the obvious thing
807 -- 5. 'Phase': the phase we want to determine the output filename of.
808 -- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're
809 -- compiling; this can be used to override the default output
810 -- of an object file. (TODO: do we actually need this?)
811 getOutputFilename
812 :: Logger
813 -> TmpFs
814 -> Phase
815 -> PipelineOutput
816 -> String
817 -> DynFlags
818 -> Phase -- next phase
819 -> Maybe ModLocation
820 -> IO FilePath
821 getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location
822 -- 1. If we are generating object files for a .hs file, then return the odir as the ModLocation
823 -- will have been modified to point to the accurate locations
824 | StopLn <- next_phase, Just loc <- maybe_location =
825 return $ if dynamicNow dflags then ml_dyn_obj_file loc
826 else ml_obj_file loc
827 -- 2. If output style is persistant then
828 | is_last_phase, Persistent <- output = persistent_fn
829 -- 3. Specific file is only set when outputFile is set by -o
830 -- If we are in dynamic mode but -dyno is not set then write to the same path as
831 -- -o with a .dyn_* extension. This case is not triggered for object files which
832 -- are always handled by the ModLocation.
833 | is_last_phase, SpecificFile <- output =
834 return $
835 if dynamicNow dflags
836 then case dynOutputFile_ dflags of
837 Nothing -> let ofile = getOutputFile_ dflags
838 new_ext = case takeExtension ofile of
839 "" -> "dyn"
840 ext -> "dyn_" ++ tail ext
841 in replaceExtension ofile new_ext
842 Just fn -> fn
843 else getOutputFile_ dflags
844 | keep_this_output = persistent_fn
845 | Temporary lifetime <- output = newTempName logger tmpfs (tmpDir dflags) lifetime suffix
846 | otherwise = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule
847 suffix
848 where
849 getOutputFile_ dflags = case outputFile_ dflags of
850 Nothing -> pprPanic "SpecificFile: No filename" (ppr $ (dynamicNow dflags, outputFile_ dflags, dynOutputFile_ dflags))
851 Just fn -> fn
852
853 hcsuf = hcSuf dflags
854 odir = objectDir dflags
855 osuf = objectSuf dflags
856 keep_hc = gopt Opt_KeepHcFiles dflags
857 keep_hscpp = gopt Opt_KeepHscppFiles dflags
858 keep_s = gopt Opt_KeepSFiles dflags
859 keep_bc = gopt Opt_KeepLlvmFiles dflags
860
861 myPhaseInputExt HCc = hcsuf
862 myPhaseInputExt MergeForeign = osuf
863 myPhaseInputExt StopLn = osuf
864 myPhaseInputExt other = phaseInputExt other
865
866 is_last_phase = next_phase `eqPhase` stop_phase
867
868 -- sometimes, we keep output from intermediate stages
869 keep_this_output =
870 case next_phase of
871 As _ | keep_s -> True
872 LlvmOpt | keep_bc -> True
873 HCc | keep_hc -> True
874 HsPp _ | keep_hscpp -> True -- See #10869
875 _other -> False
876
877 suffix = myPhaseInputExt next_phase
878
879 -- persistent object files get put in odir
880 persistent_fn
881 | StopLn <- next_phase = return odir_persistent
882 | otherwise = return persistent
883
884 persistent = basename <.> suffix
885
886 odir_persistent
887 | Just d <- odir = (d </> persistent)
888 | otherwise = persistent
889
890
891 -- | LLVM Options. These are flags to be passed to opt and llc, to ensure
892 -- consistency we list them in pairs, so that they form groups.
893 llvmOptions :: DynFlags
894 -> [(String, String)] -- ^ pairs of (opt, llc) arguments
895 llvmOptions dflags =
896 [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
897 ++ [("-relocation-model=" ++ rmodel
898 ,"-relocation-model=" ++ rmodel) | not (null rmodel)]
899 ++ [("-stack-alignment=" ++ (show align)
900 ,"-stack-alignment=" ++ (show align)) | align > 0 ]
901
902 -- Additional llc flags
903 ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu)
904 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]
905 ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]
906 ++ [("", "-target-abi=" ++ abi) | not (null abi) ]
907
908 where target = platformMisc_llvmTarget $ platformMisc dflags
909 Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)
910
911 -- Relocation models
912 rmodel | gopt Opt_PIC dflags = "pic"
913 | positionIndependent dflags = "pic"
914 | ways dflags `hasWay` WayDyn = "dynamic-no-pic"
915 | otherwise = "static"
916
917 platform = targetPlatform dflags
918
919 align :: Int
920 align = case platformArch platform of
921 ArchX86_64 | isAvxEnabled dflags -> 32
922 _ -> 0
923
924 attrs :: String
925 attrs = intercalate "," $ mattr
926 ++ ["+sse42" | isSse4_2Enabled dflags ]
927 ++ ["+sse2" | isSse2Enabled platform ]
928 ++ ["+sse" | isSseEnabled platform ]
929 ++ ["+avx512f" | isAvx512fEnabled dflags ]
930 ++ ["+avx2" | isAvx2Enabled dflags ]
931 ++ ["+avx" | isAvxEnabled dflags ]
932 ++ ["+avx512cd"| isAvx512cdEnabled dflags ]
933 ++ ["+avx512er"| isAvx512erEnabled dflags ]
934 ++ ["+avx512pf"| isAvx512pfEnabled dflags ]
935 ++ ["+bmi" | isBmiEnabled dflags ]
936 ++ ["+bmi2" | isBmi2Enabled dflags ]
937
938 abi :: String
939 abi = case platformArch (targetPlatform dflags) of
940 ArchRISCV64 -> "lp64d"
941 _ -> ""
942
943 -- -----------------------------------------------------------------------------
944 -- Running CPP
945
946 -- | Run CPP
947 --
948 -- UnitEnv is needed to compute MIN_VERSION macros
949 doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()
950 doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do
951 let hscpp_opts = picPOpts dflags
952 let cmdline_include_paths = includePaths dflags
953 let unit_state = ue_units unit_env
954 pkg_include_dirs <- mayThrowUnitErr
955 (collectIncludeDirs <$> preloadUnitsInfo unit_env)
956 let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
957 (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
958 let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
959 (includePathsQuote cmdline_include_paths ++
960 includePathsQuoteImplicit cmdline_include_paths)
961 let include_paths = include_paths_quote ++ include_paths_global
962
963 let verbFlags = getVerbFlags dflags
964
965 let cpp_prog args | raw = GHC.SysTools.runCpp logger dflags args
966 | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags
967 (GHC.SysTools.Option "-E" : args)
968
969 let platform = targetPlatform dflags
970 targetArch = stringEncodeArch $ platformArch platform
971 targetOS = stringEncodeOS $ platformOS platform
972 isWindows = platformOS platform == OSMinGW32
973 let target_defs =
974 [ "-D" ++ HOST_OS ++ "_BUILD_OS",
975 "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
976 "-D" ++ targetOS ++ "_HOST_OS",
977 "-D" ++ targetArch ++ "_HOST_ARCH" ]
978 -- remember, in code we *compile*, the HOST is the same our TARGET,
979 -- and BUILD is the same as our HOST.
980
981 let io_manager_defs =
982 [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++
983 [ "-D__IO_MANAGER_MIO__=1" ]
984
985 let sse_defs =
986 [ "-D__SSE__" | isSseEnabled platform ] ++
987 [ "-D__SSE2__" | isSse2Enabled platform ] ++
988 [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
989
990 let avx_defs =
991 [ "-D__AVX__" | isAvxEnabled dflags ] ++
992 [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
993 [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
994 [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
995 [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
996 [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
997
998 backend_defs <- getBackendDefs logger dflags
999
1000 let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
1001 -- Default CPP defines in Haskell source
1002 ghcVersionH <- getGhcVersionPathName dflags unit_env
1003 let hsSourceCppOpts = [ "-include", ghcVersionH ]
1004
1005 -- MIN_VERSION macros
1006 let uids = explicitUnits unit_state
1007 pkgs = catMaybes (map (lookupUnit unit_state) uids)
1008 mb_macro_include <-
1009 if not (null pkgs) && gopt Opt_VersionMacros dflags
1010 then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"
1011 writeFile macro_stub (generatePackageVersionMacros pkgs)
1012 -- Include version macros for every *exposed* package.
1013 -- Without -hide-all-packages and with a package database
1014 -- size of 1000 packages, it takes cpp an estimated 2
1015 -- milliseconds to process this file. See #10970
1016 -- comment 8.
1017 return [GHC.SysTools.FileOption "-include" macro_stub]
1018 else return []
1019
1020 cpp_prog ( map GHC.SysTools.Option verbFlags
1021 ++ map GHC.SysTools.Option include_paths
1022 ++ map GHC.SysTools.Option hsSourceCppOpts
1023 ++ map GHC.SysTools.Option target_defs
1024 ++ map GHC.SysTools.Option backend_defs
1025 ++ map GHC.SysTools.Option th_defs
1026 ++ map GHC.SysTools.Option hscpp_opts
1027 ++ map GHC.SysTools.Option sse_defs
1028 ++ map GHC.SysTools.Option avx_defs
1029 ++ map GHC.SysTools.Option io_manager_defs
1030 ++ mb_macro_include
1031 -- Set the language mode to assembler-with-cpp when preprocessing. This
1032 -- alleviates some of the C99 macro rules relating to whitespace and the hash
1033 -- operator, which we tend to abuse. Clang in particular is not very happy
1034 -- about this.
1035 ++ [ GHC.SysTools.Option "-x"
1036 , GHC.SysTools.Option "assembler-with-cpp"
1037 , GHC.SysTools.Option input_fn
1038 -- We hackily use Option instead of FileOption here, so that the file
1039 -- name is not back-slashed on Windows. cpp is capable of
1040 -- dealing with / in filenames, so it works fine. Furthermore
1041 -- if we put in backslashes, cpp outputs #line directives
1042 -- with *double* backslashes. And that in turn means that
1043 -- our error messages get double backslashes in them.
1044 -- In due course we should arrange that the lexer deals
1045 -- with these \\ escapes properly.
1046 , GHC.SysTools.Option "-o"
1047 , GHC.SysTools.FileOption "" output_fn
1048 ])
1049
1050 getBackendDefs :: Logger -> DynFlags -> IO [String]
1051 getBackendDefs logger dflags | backend dflags == LLVM = do
1052 llvmVer <- figureLlvmVersion logger dflags
1053 return $ case fmap llvmVersionList llvmVer of
1054 Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]
1055 Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
1056 _ -> []
1057 where
1058 format (major, minor)
1059 | minor >= 100 = error "getBackendDefs: Unsupported minor version"
1060 | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
1061
1062 getBackendDefs _ _ =
1063 return []
1064
1065 -- | What phase to run after one of the backend code generators has run
1066 hscPostBackendPhase :: HscSource -> Backend -> Phase
1067 hscPostBackendPhase HsBootFile _ = StopLn
1068 hscPostBackendPhase HsigFile _ = StopLn
1069 hscPostBackendPhase _ bcknd =
1070 case bcknd of
1071 ViaC -> HCc
1072 NCG -> As False
1073 LLVM -> LlvmOpt
1074 NoBackend -> StopLn
1075 Interpreter -> StopLn
1076
1077
1078 compileStub :: HscEnv -> FilePath -> IO FilePath
1079 compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c
1080
1081
1082 -- ---------------------------------------------------------------------------
1083 -- join object files into a single relocatable object file, using ld -r
1084
1085 {-
1086 Note [Produce big objects on Windows]
1087 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1088
1089 The Windows Portable Executable object format has a limit of 32k sections, which
1090 we tend to blow through pretty easily. Thankfully, there is a "big object"
1091 extension, which raises this limit to 2^32. However, it must be explicitly
1092 enabled in the toolchain:
1093
1094 * the assembler accepts the -mbig-obj flag, which causes it to produce a
1095 bigobj-enabled COFF object.
1096
1097 * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name
1098 suggests, this tells the linker to produce a bigobj-enabled COFF object, no a
1099 PE executable.
1100
1101 We must enable bigobj output in a few places:
1102
1103 * When merging object files (GHC.Driver.Pipeline.joinObjectFiles)
1104
1105 * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...))
1106
1107 Unfortunately the big object format is not supported on 32-bit targets so
1108 none of this can be used in that case.
1109
1110
1111 Note [Merging object files for GHCi]
1112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1113 GHCi can usually loads standard linkable object files using GHC's linker
1114 implementation. However, most users build their projects with -split-sections,
1115 meaning that such object files can have an extremely high number of sections.
1116 As the linker must map each of these sections individually, loading such object
1117 files is very inefficient.
1118
1119 To avoid this inefficiency, we use the linker's `-r` flag and a linker script
1120 to produce a merged relocatable object file. This file will contain a singe
1121 text section section and can consequently be mapped far more efficiently. As
1122 gcc tends to do unpredictable things to our linker command line, we opt to
1123 invoke ld directly in this case, in contrast to our usual strategy of linking
1124 via gcc.
1125
1126 -}
1127
1128 joinObjectFiles :: Logger -> TmpFs -> DynFlags -> [FilePath] -> FilePath -> IO ()
1129 joinObjectFiles logger tmpfs dflags o_files output_fn = do
1130 let toolSettings' = toolSettings dflags
1131 ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
1132 osInfo = platformOS (targetPlatform dflags)
1133 ld_r args = GHC.SysTools.runMergeObjects logger tmpfs dflags (
1134 -- See Note [Produce big objects on Windows]
1135 concat
1136 [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"]
1137 | OSMinGW32 == osInfo
1138 , not $ target32Bit (targetPlatform dflags)
1139 ]
1140 ++ map GHC.SysTools.Option ld_build_id
1141 ++ [ GHC.SysTools.Option "-o",
1142 GHC.SysTools.FileOption "" output_fn ]
1143 ++ args)
1144
1145 -- suppress the generation of the .note.gnu.build-id section,
1146 -- which we don't need and sometimes causes ld to emit a
1147 -- warning:
1148 ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]
1149 | otherwise = []
1150
1151 if ldIsGnuLd
1152 then do
1153 script <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "ldscript"
1154 cwd <- getCurrentDirectory
1155 let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
1156 writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
1157 ld_r [GHC.SysTools.FileOption "" script]
1158 else if toolSettings_ldSupportsFilelist toolSettings'
1159 then do
1160 filelist <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "filelist"
1161 writeFile filelist $ unlines o_files
1162 ld_r [GHC.SysTools.Option "-filelist",
1163 GHC.SysTools.FileOption "" filelist]
1164 else
1165 ld_r (map (GHC.SysTools.FileOption "") o_files)
1166
1167 -----------------------------------------------------------------------------
1168 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1169
1170 getHCFilePackages :: FilePath -> IO [UnitId]
1171 getHCFilePackages filename =
1172 Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1173 l <- hGetLine h
1174 case l of
1175 '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1176 return (map stringToUnitId (words rest))
1177 _other ->
1178 return []
1179
1180
1181 linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
1182 linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do
1183 when (haveRtsOptsFlags dflags) $
1184 logMsg logger MCInfo noSrcSpan
1185 $ withPprStyle defaultUserStyle
1186 (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
1187 text " Call hs_init_ghc() from your main() function to set these options.")
1188 linkDynLib logger tmpfs dflags unit_env o_files dep_units
1189
1190
1191
1192 -- ---------------------------------------------------------------------------
1193 -- Macros (cribbed from Cabal)
1194
1195 generatePackageVersionMacros :: [UnitInfo] -> String
1196 generatePackageVersionMacros pkgs = concat
1197 -- Do not add any C-style comments. See #3389.
1198 [ generateMacros "" pkgname version
1199 | pkg <- pkgs
1200 , let version = unitPackageVersion pkg
1201 pkgname = map fixchar (unitPackageNameString pkg)
1202 ]
1203
1204 fixchar :: Char -> Char
1205 fixchar '-' = '_'
1206 fixchar c = c
1207
1208 generateMacros :: String -> String -> Version -> String
1209 generateMacros prefix name version =
1210 concat
1211 ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
1212 ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
1213 ," (major1) < ",major1," || \\\n"
1214 ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
1215 ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
1216 ,"\n\n"
1217 ]
1218 where
1219 (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
1220
1221
1222 -- -----------------------------------------------------------------------------
1223 -- Misc.
1224
1225
1226
1227 touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()
1228 touchObjectFile logger dflags path = do
1229 createDirectoryIfMissing True $ takeDirectory path
1230 GHC.SysTools.touch logger dflags "Touching object file" path
1231
1232 -- | Find out path to @ghcversion.h@ file
1233 getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
1234 getGhcVersionPathName dflags unit_env = do
1235 candidates <- case ghcVersionFile dflags of
1236 Just path -> return [path]
1237 Nothing -> do
1238 ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])
1239 return ((</> "ghcversion.h") <$> collectIncludeDirs ps)
1240
1241 found <- filterM doesFileExist candidates
1242 case found of
1243 [] -> throwGhcExceptionIO (InstallationError
1244 ("ghcversion.h missing; tried: "
1245 ++ intercalate ", " candidates))
1246 (x:_) -> return x
1247
1248 -- Note [-fPIC for assembler]
1249 -- When compiling .c source file GHC's driver pipeline basically
1250 -- does the following two things:
1251 -- 1. ${CC} -S 'PIC_CFLAGS' source.c
1252 -- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S
1253 --
1254 -- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?
1255 -- Because on some architectures (at least sparc32) assembler also chooses
1256 -- the relocation type!
1257 -- Consider the following C module:
1258 --
1259 -- /* pic-sample.c */
1260 -- int v;
1261 -- void set_v (int n) { v = n; }
1262 -- int get_v (void) { return v; }
1263 --
1264 -- $ gcc -S -fPIC pic-sample.c
1265 -- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary
1266 -- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary
1267 --
1268 -- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od
1269 -- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od
1270 -- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od
1271 --
1272 -- Most of architectures won't show any difference in this test, but on sparc32
1273 -- the following assembly snippet:
1274 --
1275 -- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7
1276 --
1277 -- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:
1278 --
1279 -- 3c: 2f 00 00 00 sethi %hi(0), %l7
1280 -- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8
1281 -- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8
1282
1283 {- Note [Don't normalise input filenames]
1284
1285 Summary
1286 We used to normalise input filenames when starting the unlit phase. This
1287 broke hpc in `--make` mode with imported literate modules (#2991).
1288
1289 Introduction
1290 1) --main
1291 When compiling a module with --main, GHC scans its imports to find out which
1292 other modules it needs to compile too. It turns out that there is a small
1293 difference between saying `ghc --make A.hs`, when `A` imports `B`, and
1294 specifying both modules on the command line with `ghc --make A.hs B.hs`. In
1295 the former case, the filename for B is inferred to be './B.hs' instead of
1296 'B.hs'.
1297
1298 2) unlit
1299 When GHC compiles a literate haskell file, the source code first needs to go
1300 through unlit, which turns it into normal Haskell source code. At the start
1301 of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the
1302 option `-h` and the name of the original file. We used to normalise this
1303 filename using System.FilePath.normalise, which among other things removes
1304 an initial './'. unlit then uses that filename in #line directives that it
1305 inserts in the transformed source code.
1306
1307 3) SrcSpan
1308 A SrcSpan represents a portion of a source code file. It has fields
1309 linenumber, start column, end column, and also a reference to the file it
1310 originated from. The SrcSpans for a literate haskell file refer to the
1311 filename that was passed to unlit -h.
1312
1313 4) -fhpc
1314 At some point during compilation with -fhpc, in the function
1315 `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a
1316 `SrcSpan` refers to with the name of the file we are currently compiling.
1317 For some reason I don't yet understand, they can sometimes legitimally be
1318 different, and then hpc ignores that SrcSpan.
1319
1320 Problem
1321 When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate
1322 module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the
1323 start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).
1324 Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are
1325 still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),
1326 doesn't include ticks for B, and we have unhappy customers (#2991).
1327
1328 Solution
1329 Do not normalise `input_fn` when starting the unlit phase.
1330
1331 Alternative solution
1332 Another option would be to not compare the two filenames on equality, but to
1333 use System.FilePath.equalFilePath. That function first normalises its
1334 arguments. The problem is that by the time we need to do the comparison, the
1335 filenames have been turned into FastStrings, probably for performance
1336 reasons, so System.FilePath.equalFilePath can not be used directly.
1337
1338 Archeology
1339 The call to `normalise` was added in a commit called "Fix slash
1340 direction on Windows with the new filePath code" (c9b6b5e8). The problem
1341 that commit was addressing has since been solved in a different manner, in a
1342 commit called "Fix the filename passed to unlit" (1eedbc6b). So the
1343 `normalise` is no longer necessary.
1344 -}