Pass preprocessor options to C compiler when building foreign C files (#16737)
[ghc.git] / compiler / main / DriverPipeline.hs
1 {-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns #-}
2 {-# OPTIONS_GHC -fno-cse #-}
3 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4
5 -----------------------------------------------------------------------------
6 --
7 -- GHC Driver
8 --
9 -- (c) The University of Glasgow 2005
10 --
11 -----------------------------------------------------------------------------
12
13 module DriverPipeline (
14 -- Run a series of compilation steps in a pipeline, for a
15 -- collection of source files.
16 oneShot, compileFile,
17
18 -- Interfaces for the batch-mode driver
19 linkBinary,
20
21 -- Interfaces for the compilation manager (interpreted/batch-mode)
22 preprocess,
23 compileOne, compileOne',
24 link,
25
26 -- Exports for hooks to override runPhase and link
27 PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
28 phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,
29 hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
30 runPhase, exeFileName,
31 maybeCreateManifest,
32 linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
33 ) where
34
35 #include "HsVersions.h"
36
37 import GhcPrelude
38
39 import PipelineMonad
40 import Packages
41 import HeaderInfo
42 import DriverPhases
43 import SysTools
44 import SysTools.ExtraObj
45 import HscMain
46 import Finder
47 import HscTypes hiding ( Hsc )
48 import Outputable
49 import Module
50 import ErrUtils
51 import DynFlags
52 import Config
53 import Panic
54 import Util
55 import StringBuffer ( hGetStringBuffer, hPutStringBuffer )
56 import BasicTypes ( SuccessFlag(..) )
57 import Maybes ( expectJust )
58 import SrcLoc
59 import LlvmCodeGen ( llvmFixupAsm )
60 import MonadUtils
61 import Platform
62 import TcRnTypes
63 import Hooks
64 import qualified GHC.LanguageExtensions as LangExt
65 import FileCleanup
66 import Ar
67 import Bag ( unitBag )
68 import FastString ( mkFastString )
69
70 import Exception
71 import System.Directory
72 import System.FilePath
73 import System.IO
74 import Control.Monad
75 import Data.List ( isInfixOf, isSuffixOf, intercalate )
76 import Data.Maybe
77 import Data.Version
78 import Data.Either ( partitionEithers )
79
80 import Data.Time ( UTCTime )
81
82 -- ---------------------------------------------------------------------------
83 -- Pre-process
84
85 -- | Just preprocess a file, put the result in a temp. file (used by the
86 -- compilation manager during the summary phase).
87 --
88 -- We return the augmented DynFlags, because they contain the result
89 -- of slurping in the OPTIONS pragmas
90
91 preprocess :: HscEnv
92 -> FilePath -- ^ input filename
93 -> Maybe InputFileBuffer
94 -- ^ optional buffer to use instead of reading the input file
95 -> Maybe Phase -- ^ starting phase
96 -> IO (Either ErrorMessages (DynFlags, FilePath))
97 preprocess hsc_env input_fn mb_input_buf mb_phase =
98 handleSourceError (\err -> return (Left (srcErrorMessages err))) $
99 ghandle handler $
100 fmap Right $
101 ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
102 runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)
103 Nothing
104 -- We keep the processed file for the whole session to save on
105 -- duplicated work in ghci.
106 (Temporary TFL_GhcSession)
107 Nothing{-no ModLocation-}
108 []{-no foreign objects-}
109 where
110 srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
111 handler (ProgramError msg) = return $ Left $ unitBag $
112 mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg
113 handler ex = throwGhcExceptionIO ex
114
115 -- ---------------------------------------------------------------------------
116
117 -- | Compile
118 --
119 -- Compile a single module, under the control of the compilation manager.
120 --
121 -- This is the interface between the compilation manager and the
122 -- compiler proper (hsc), where we deal with tedious details like
123 -- reading the OPTIONS pragma from the source file, converting the
124 -- C or assembly that GHC produces into an object file, and compiling
125 -- FFI stub files.
126 --
127 -- NB. No old interface can also mean that the source has changed.
128
129 compileOne :: HscEnv
130 -> ModSummary -- ^ summary for module being compiled
131 -> Int -- ^ module N ...
132 -> Int -- ^ ... of M
133 -> Maybe ModIface -- ^ old interface, if we have one
134 -> Maybe Linkable -- ^ old linkable, if we have one
135 -> SourceModified
136 -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful
137
138 compileOne = compileOne' Nothing (Just batchMsg)
139
140 compileOne' :: Maybe TcGblEnv
141 -> Maybe Messager
142 -> HscEnv
143 -> ModSummary -- ^ summary for module being compiled
144 -> Int -- ^ module N ...
145 -> Int -- ^ ... of M
146 -> Maybe ModIface -- ^ old interface, if we have one
147 -> Maybe Linkable -- ^ old linkable, if we have one
148 -> SourceModified
149 -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful
150
151 compileOne' m_tc_result mHscMessage
152 hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
153 source_modified0
154 = do
155
156 debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
157
158 (status, hmi0) <- hscIncrementalCompile
159 always_do_basic_recompilation_check
160 m_tc_result mHscMessage
161 hsc_env summary source_modified mb_old_iface (mod_index, nmods)
162
163 let flags = hsc_dflags hsc_env0
164 in do unless (gopt Opt_KeepHiFiles flags) $
165 addFilesToClean flags TFL_CurrentModule $
166 [ml_hi_file $ ms_location summary]
167 unless (gopt Opt_KeepOFiles flags) $
168 addFilesToClean flags TFL_GhcSession $
169 [ml_obj_file $ ms_location summary]
170
171 case (status, hsc_lang) of
172 (HscUpToDate, _) ->
173 -- TODO recomp014 triggers this assert. What's going on?!
174 -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
175 return hmi0 { hm_linkable = maybe_old_linkable }
176 (HscNotGeneratingCode, HscNothing) ->
177 let mb_linkable = if isHsBootOrSig src_flavour
178 then Nothing
179 -- TODO: Questionable.
180 else Just (LM (ms_hs_date summary) this_mod [])
181 in return hmi0 { hm_linkable = mb_linkable }
182 (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"
183 (_, HscNothing) -> panic "compileOne HscNothing"
184 (HscUpdateBoot, HscInterpreted) -> do
185 return hmi0
186 (HscUpdateBoot, _) -> do
187 touchObjectFile dflags object_filename
188 return hmi0
189 (HscUpdateSig, HscInterpreted) ->
190 let linkable = LM (ms_hs_date summary) this_mod []
191 in return hmi0 { hm_linkable = Just linkable }
192 (HscUpdateSig, _) -> do
193 output_fn <- getOutputFilename next_phase
194 (Temporary TFL_CurrentModule) basename dflags
195 next_phase (Just location)
196
197 -- #10660: Use the pipeline instead of calling
198 -- compileEmptyStub directly, so -dynamic-too gets
199 -- handled properly
200 _ <- runPipeline StopLn hsc_env
201 (output_fn,
202 Nothing,
203 Just (HscOut src_flavour
204 mod_name HscUpdateSig))
205 (Just basename)
206 Persistent
207 (Just location)
208 []
209 o_time <- getModificationUTCTime object_filename
210 let linkable = LM o_time this_mod [DotO object_filename]
211 return hmi0 { hm_linkable = Just linkable }
212 (HscRecomp cgguts summary, HscInterpreted) -> do
213 (hasStub, comp_bc, spt_entries) <-
214 hscInteractive hsc_env cgguts summary
215
216 stub_o <- case hasStub of
217 Nothing -> return []
218 Just stub_c -> do
219 stub_o <- compileStub hsc_env stub_c
220 return [DotO stub_o]
221
222 let hs_unlinked = [BCOs comp_bc spt_entries]
223 unlinked_time = ms_hs_date summary
224 -- Why do we use the timestamp of the source file here,
225 -- rather than the current time? This works better in
226 -- the case where the local clock is out of sync
227 -- with the filesystem's clock. It's just as accurate:
228 -- if the source is modified, then the linkable will
229 -- be out of date.
230 let linkable = LM unlinked_time (ms_mod summary)
231 (hs_unlinked ++ stub_o)
232 return hmi0 { hm_linkable = Just linkable }
233 (HscRecomp cgguts summary, _) -> do
234 output_fn <- getOutputFilename next_phase
235 (Temporary TFL_CurrentModule)
236 basename dflags next_phase (Just location)
237 -- We're in --make mode: finish the compilation pipeline.
238 _ <- runPipeline StopLn hsc_env
239 (output_fn,
240 Nothing,
241 Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
242 (Just basename)
243 Persistent
244 (Just location)
245 []
246 -- The object filename comes from the ModLocation
247 o_time <- getModificationUTCTime object_filename
248 let linkable = LM o_time this_mod [DotO object_filename]
249 return hmi0 { hm_linkable = Just linkable }
250
251 where dflags0 = ms_hspp_opts summary
252
253 this_mod = ms_mod summary
254 location = ms_location summary
255 input_fn = expectJust "compile:hs" (ml_hs_file location)
256 input_fnpp = ms_hspp_file summary
257 mod_graph = hsc_mod_graph hsc_env0
258 needsLinker = needsTemplateHaskellOrQQ mod_graph
259 isDynWay = any (== WayDyn) (ways dflags0)
260 isProfWay = any (== WayProf) (ways dflags0)
261 internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)
262
263 src_flavour = ms_hsc_src summary
264 mod_name = ms_mod_name summary
265 next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
266 object_filename = ml_obj_file location
267
268 -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
269 -- the linker can correctly load the object files. This isn't necessary
270 -- when using -fexternal-interpreter.
271 dflags1 = if dynamicGhc && internalInterpreter &&
272 not isDynWay && not isProfWay && needsLinker
273 then gopt_set dflags0 Opt_BuildDynamicToo
274 else dflags0
275
276 -- #16331 - when no "internal interpreter" is available but we
277 -- need to process some TemplateHaskell or QuasiQuotes, we automatically
278 -- turn on -fexternal-interpreter.
279 dflags2 = if not internalInterpreter && needsLinker
280 then gopt_set dflags1 Opt_ExternalInterpreter
281 else dflags1
282
283 basename = dropExtension input_fn
284
285 -- We add the directory in which the .hs files resides) to the import
286 -- path. This is needed when we try to compile the .hc file later, if it
287 -- imports a _stub.h file that we created here.
288 current_dir = takeDirectory basename
289 old_paths = includePaths dflags2
290 !prevailing_dflags = hsc_dflags hsc_env0
291 dflags =
292 dflags2 { includePaths = addQuoteInclude old_paths [current_dir]
293 , log_action = log_action prevailing_dflags }
294 -- use the prevailing log_action / log_finaliser,
295 -- not the one cached in the summary. This is so
296 -- that we can change the log_action without having
297 -- to re-summarize all the source files.
298 hsc_env = hsc_env0 {hsc_dflags = dflags}
299
300 -- Figure out what lang we're generating
301 hsc_lang = hscTarget dflags
302
303 -- -fforce-recomp should also work with --make
304 force_recomp = gopt Opt_ForceRecomp dflags
305 source_modified
306 | force_recomp = SourceModified
307 | otherwise = source_modified0
308
309 always_do_basic_recompilation_check = case hsc_lang of
310 HscInterpreted -> True
311 _ -> False
312
313 -----------------------------------------------------------------------------
314 -- stub .h and .c files (for foreign export support), and cc files.
315
316 -- The _stub.c file is derived from the haskell source file, possibly taking
317 -- into account the -stubdir option.
318 --
319 -- The object file created by compiling the _stub.c file is put into a
320 -- temporary file, which will be later combined with the main .o file
321 -- (see the MergeForeigns phase).
322 --
323 -- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files
324 -- from TH, that are then compiled and linked to the module. This is
325 -- useful to implement facilities such as inline-c.
326
327 compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
328 compileForeign _ RawObject object_file = return object_file
329 compileForeign hsc_env lang stub_c = do
330 let phase = case lang of
331 LangC -> Cc
332 LangCxx -> Ccxx
333 LangObjc -> Cobjc
334 LangObjcxx -> Cobjcxx
335 LangAsm -> As True -- allow CPP
336 RawObject -> panic "compileForeign: should be unreachable"
337 (_, stub_o) <- runPipeline StopLn hsc_env
338 (stub_c, Nothing, Just (RealPhase phase))
339 Nothing (Temporary TFL_GhcSession)
340 Nothing{-no ModLocation-}
341 []
342 return stub_o
343
344 compileStub :: HscEnv -> FilePath -> IO FilePath
345 compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c
346
347 compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
348 compileEmptyStub dflags hsc_env basename location mod_name = do
349 -- To maintain the invariant that every Haskell file
350 -- compiles to object code, we make an empty (but
351 -- valid) stub object file for signatures. However,
352 -- we make sure this object file has a unique symbol,
353 -- so that ranlib on OS X doesn't complain, see
354 -- http://ghc.haskell.org/trac/ghc/ticket/12673
355 -- and https://github.com/haskell/cabal/issues/2257
356 empty_stub <- newTempName dflags TFL_CurrentModule "c"
357 let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"
358 writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
359 _ <- runPipeline StopLn hsc_env
360 (empty_stub, Nothing, Nothing)
361 (Just basename)
362 Persistent
363 (Just location)
364 []
365 return ()
366
367 -- ---------------------------------------------------------------------------
368 -- Link
369
370 link :: GhcLink -- interactive or batch
371 -> DynFlags -- dynamic flags
372 -> Bool -- attempt linking in batch mode?
373 -> HomePackageTable -- what to link
374 -> IO SuccessFlag
375
376 -- For the moment, in the batch linker, we don't bother to tell doLink
377 -- which packages to link -- it just tries all that are available.
378 -- batch_attempt_linking should only be *looked at* in batch mode. It
379 -- should only be True if the upsweep was successful and someone
380 -- exports main, i.e., we have good reason to believe that linking
381 -- will succeed.
382
383 link ghcLink dflags
384 = lookupHook linkHook l dflags ghcLink dflags
385 where
386 l LinkInMemory _ _ _
387 = if cGhcWithInterpreter == "YES"
388 then -- Not Linking...(demand linker will do the job)
389 return Succeeded
390 else panicBadLink LinkInMemory
391
392 l NoLink _ _ _
393 = return Succeeded
394
395 l LinkBinary dflags batch_attempt_linking hpt
396 = link' dflags batch_attempt_linking hpt
397
398 l LinkStaticLib dflags batch_attempt_linking hpt
399 = link' dflags batch_attempt_linking hpt
400
401 l LinkDynLib dflags batch_attempt_linking hpt
402 = link' dflags batch_attempt_linking hpt
403
404 panicBadLink :: GhcLink -> a
405 panicBadLink other = panic ("link: GHC not built to link this way: " ++
406 show other)
407
408 link' :: DynFlags -- dynamic flags
409 -> Bool -- attempt linking in batch mode?
410 -> HomePackageTable -- what to link
411 -> IO SuccessFlag
412
413 link' dflags batch_attempt_linking hpt
414 | batch_attempt_linking
415 = do
416 let
417 staticLink = case ghcLink dflags of
418 LinkStaticLib -> True
419 _ -> False
420
421 home_mod_infos = eltsHpt hpt
422
423 -- the packages we depend on
424 pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos
425
426 -- the linkables to link
427 linkables = map (expectJust "link".hm_linkable) home_mod_infos
428
429 debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
430
431 -- check for the -no-link flag
432 if isNoLink (ghcLink dflags)
433 then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
434 return Succeeded
435 else do
436
437 let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
438 obj_files = concatMap getOfiles linkables
439
440 exe_file = exeFileName staticLink dflags
441
442 linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps
443
444 if not (gopt Opt_ForceRecomp dflags) && not linking_needed
445 then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.")
446 return Succeeded
447 else do
448
449 compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")
450
451 -- Don't showPass in Batch mode; doLink will do that for us.
452 let link = case ghcLink dflags of
453 LinkBinary -> linkBinary
454 LinkStaticLib -> linkStaticLib
455 LinkDynLib -> linkDynLibCheck
456 other -> panicBadLink other
457 link dflags obj_files pkg_deps
458
459 debugTraceMsg dflags 3 (text "link: done")
460
461 -- linkBinary only returns if it succeeds
462 return Succeeded
463
464 | otherwise
465 = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
466 text " Main.main not exported; not linking.")
467 return Succeeded
468
469
470 linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
471 linkingNeeded dflags staticLink linkables pkg_deps = do
472 -- if the modification time on the executable is later than the
473 -- modification times on all of the objects and libraries, then omit
474 -- linking (unless the -fforce-recomp flag was given).
475 let exe_file = exeFileName staticLink dflags
476 e_exe_time <- tryIO $ getModificationUTCTime exe_file
477 case e_exe_time of
478 Left _ -> return True
479 Right t -> do
480 -- first check object files and extra_ld_inputs
481 let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
482 e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
483 let (errs,extra_times) = partitionEithers e_extra_times
484 let obj_times = map linkableTime linkables ++ extra_times
485 if not (null errs) || any (t <) obj_times
486 then return True
487 else do
488
489 -- next, check libraries. XXX this only checks Haskell libraries,
490 -- not extra_libraries or -l things from the command line.
491 let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib)
492 | Just c <- map (lookupInstalledPackage dflags) pkg_deps,
493 lib <- packageHsLibs dflags c ]
494
495 pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
496 if any isNothing pkg_libfiles then return True else do
497 e_lib_times <- mapM (tryIO . getModificationUTCTime)
498 (catMaybes pkg_libfiles)
499 let (lib_errs,lib_times) = partitionEithers e_lib_times
500 if not (null lib_errs) || any (t <) lib_times
501 then return True
502 else checkLinkInfo dflags pkg_deps exe_file
503
504 findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
505 findHSLib dflags dirs lib = do
506 let batch_lib_file = if WayDyn `notElem` ways dflags
507 then "lib" ++ lib <.> "a"
508 else mkSOName (targetPlatform dflags) lib
509 found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
510 case found of
511 [] -> return Nothing
512 (x:_) -> return (Just x)
513
514 -- -----------------------------------------------------------------------------
515 -- Compile files in one-shot mode.
516
517 oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
518 oneShot hsc_env stop_phase srcs = do
519 o_files <- mapM (compileFile hsc_env stop_phase) srcs
520 doLink (hsc_dflags hsc_env) stop_phase o_files
521
522 compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
523 compileFile hsc_env stop_phase (src, mb_phase) = do
524 exists <- doesFileExist src
525 when (not exists) $
526 throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
527
528 let
529 dflags = hsc_dflags hsc_env
530 split = gopt Opt_SplitObjs dflags
531 mb_o_file = outputFile dflags
532 ghc_link = ghcLink dflags -- Set by -c or -no-link
533
534 -- When linking, the -o argument refers to the linker's output.
535 -- otherwise, we use it as the name for the pipeline's output.
536 output
537 -- If we are doing -fno-code, then act as if the output is
538 -- 'Temporary'. This stops GHC trying to copy files to their
539 -- final location.
540 | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule
541 | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
542 -- -o foo applies to linker
543 | isJust mb_o_file = SpecificFile
544 -- -o foo applies to the file we are compiling now
545 | otherwise = Persistent
546
547 stop_phase' = case stop_phase of
548 As _ | split -> SplitAs
549 _ -> stop_phase
550 ( _, out_file) <- runPipeline stop_phase' hsc_env
551 (src, Nothing, fmap RealPhase mb_phase)
552 Nothing
553 output
554 Nothing{-no ModLocation-} []
555 return out_file
556
557
558 doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
559 doLink dflags stop_phase o_files
560 | not (isStopLn stop_phase)
561 = return () -- We stopped before the linking phase
562
563 | otherwise
564 = case ghcLink dflags of
565 NoLink -> return ()
566 LinkBinary -> linkBinary dflags o_files []
567 LinkStaticLib -> linkStaticLib dflags o_files []
568 LinkDynLib -> linkDynLibCheck dflags o_files []
569 other -> panicBadLink other
570
571
572 -- ---------------------------------------------------------------------------
573
574 -- | Run a compilation pipeline, consisting of multiple phases.
575 --
576 -- This is the interface to the compilation pipeline, which runs
577 -- a series of compilation steps on a single source file, specifying
578 -- at which stage to stop.
579 --
580 -- The DynFlags can be modified by phases in the pipeline (eg. by
581 -- OPTIONS_GHC pragmas), and the changes affect later phases in the
582 -- pipeline.
583 runPipeline
584 :: Phase -- ^ When to stop
585 -> HscEnv -- ^ Compilation environment
586 -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
587 -- ^ Pipeline input file name, optional
588 -- buffer and maybe -x suffix
589 -> Maybe FilePath -- ^ original basename (if different from ^^^)
590 -> PipelineOutput -- ^ Output filename
591 -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
592 -> [FilePath] -- ^ foreign objects
593 -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
594 runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)
595 mb_basename output maybe_loc foreign_os
596
597 = do let
598 dflags0 = hsc_dflags hsc_env0
599
600 -- Decide where dump files should go based on the pipeline output
601 dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
602 hsc_env = hsc_env0 {hsc_dflags = dflags}
603
604 (input_basename, suffix) = splitExtension input_fn
605 suffix' = drop 1 suffix -- strip off the .
606 basename | Just b <- mb_basename = b
607 | otherwise = input_basename
608
609 -- If we were given a -x flag, then use that phase to start from
610 start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase
611
612 isHaskell (RealPhase (Unlit _)) = True
613 isHaskell (RealPhase (Cpp _)) = True
614 isHaskell (RealPhase (HsPp _)) = True
615 isHaskell (RealPhase (Hsc _)) = True
616 isHaskell (HscOut {}) = True
617 isHaskell _ = False
618
619 isHaskellishFile = isHaskell start_phase
620
621 env = PipeEnv{ stop_phase,
622 src_filename = input_fn,
623 src_basename = basename,
624 src_suffix = suffix',
625 output_spec = output }
626
627 when (isBackpackishSuffix suffix') $
628 throwGhcExceptionIO (UsageError
629 ("use --backpack to process " ++ input_fn))
630
631 -- We want to catch cases of "you can't get there from here" before
632 -- we start the pipeline, because otherwise it will just run off the
633 -- end.
634 let happensBefore' = happensBefore dflags
635 case start_phase of
636 RealPhase start_phase' ->
637 -- See Note [Partial ordering on phases]
638 -- Not the same as: (stop_phase `happensBefore` start_phase')
639 when (not (start_phase' `happensBefore'` stop_phase ||
640 start_phase' `eqPhase` stop_phase)) $
641 throwGhcExceptionIO (UsageError
642 ("cannot compile this file to desired target: "
643 ++ input_fn))
644 HscOut {} -> return ()
645
646 -- Write input buffer to temp file if requested
647 input_fn' <- case (start_phase, mb_input_buf) of
648 (RealPhase real_start_phase, Just input_buf) -> do
649 let suffix = phaseInputExt real_start_phase
650 fn <- newTempName dflags TFL_CurrentModule suffix
651 hdl <- openBinaryFile fn WriteMode
652 -- Add a LINE pragma so reported source locations will
653 -- mention the real input file, not this temp file.
654 hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"
655 hPutStringBuffer hdl input_buf
656 hClose hdl
657 return fn
658 (_, _) -> return input_fn
659
660 debugTraceMsg dflags 4 (text "Running the pipeline")
661 r <- runPipeline' start_phase hsc_env env input_fn'
662 maybe_loc foreign_os
663
664 -- If we are compiling a Haskell module, and doing
665 -- -dynamic-too, but couldn't do the -dynamic-too fast
666 -- path, then rerun the pipeline for the dyn way
667 let dflags = hsc_dflags hsc_env
668 -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
669 when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do
670 when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
671 debugTraceMsg dflags 4
672 (text "Running the pipeline again for -dynamic-too")
673 let dflags' = dynamicTooMkDynamicDynFlags dflags
674 hsc_env' <- newHscEnv dflags'
675 _ <- runPipeline' start_phase hsc_env' env input_fn'
676 maybe_loc foreign_os
677 return ()
678 return r
679
680 runPipeline'
681 :: PhasePlus -- ^ When to start
682 -> HscEnv -- ^ Compilation environment
683 -> PipeEnv
684 -> FilePath -- ^ Input filename
685 -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
686 -> [FilePath] -- ^ foreign objects, if we have one
687 -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
688 runPipeline' start_phase hsc_env env input_fn
689 maybe_loc foreign_os
690 = do
691 -- Execute the pipeline...
692 let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }
693
694 evalP (pipeLoop start_phase input_fn) env state
695
696 -- ---------------------------------------------------------------------------
697 -- outer pipeline loop
698
699 -- | pipeLoop runs phases until we reach the stop phase
700 pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
701 pipeLoop phase input_fn = do
702 env <- getPipeEnv
703 dflags <- getDynFlags
704 -- See Note [Partial ordering on phases]
705 let happensBefore' = happensBefore dflags
706 stopPhase = stop_phase env
707 case phase of
708 RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done
709 -> -- Sometimes, a compilation phase doesn't actually generate any output
710 -- (eg. the CPP phase when -fcpp is not turned on). If we end on this
711 -- stage, but we wanted to keep the output, then we have to explicitly
712 -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
713 -- further compilation stages can tell what the original filename was.
714 case output_spec env of
715 Temporary _ ->
716 return (dflags, input_fn)
717 output ->
718 do pst <- getPipeState
719 final_fn <- liftIO $ getOutputFilename
720 stopPhase output (src_basename env)
721 dflags stopPhase (maybe_loc pst)
722 when (final_fn /= input_fn) $ do
723 let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
724 line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
725 liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
726 return (dflags, final_fn)
727
728
729 | not (realPhase `happensBefore'` stopPhase)
730 -- Something has gone wrong. We'll try to cover all the cases when
731 -- this could happen, so if we reach here it is a panic.
732 -- eg. it might happen if the -C flag is used on a source file that
733 -- has {-# OPTIONS -fasm #-}.
734 -> panic ("pipeLoop: at phase " ++ show realPhase ++
735 " but I wanted to stop at phase " ++ show stopPhase)
736
737 _
738 -> do liftIO $ debugTraceMsg dflags 4
739 (text "Running phase" <+> ppr phase)
740 (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
741 r <- pipeLoop next_phase output_fn
742 case phase of
743 HscOut {} ->
744 whenGeneratingDynamicToo dflags $ do
745 setDynFlags $ dynamicTooMkDynamicDynFlags dflags
746 -- TODO shouldn't ignore result:
747 _ <- pipeLoop phase input_fn
748 return ()
749 _ ->
750 return ()
751 return r
752
753 runHookedPhase :: PhasePlus -> FilePath -> DynFlags
754 -> CompPipeline (PhasePlus, FilePath)
755 runHookedPhase pp input dflags =
756 lookupHook runPhaseHook runPhase dflags pp input dflags
757
758 -- -----------------------------------------------------------------------------
759 -- In each phase, we need to know into what filename to generate the
760 -- output. All the logic about which filenames we generate output
761 -- into is embodied in the following function.
762
763 -- | Computes the next output filename after we run @next_phase@.
764 -- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad
765 -- (which specifies all of the ambient information.)
766 phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
767 phaseOutputFilename next_phase = do
768 PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
769 PipeState{maybe_loc, hsc_env} <- getPipeState
770 let dflags = hsc_dflags hsc_env
771 liftIO $ getOutputFilename stop_phase output_spec
772 src_basename dflags next_phase maybe_loc
773
774 -- | Computes the next output filename for something in the compilation
775 -- pipeline. This is controlled by several variables:
776 --
777 -- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This
778 -- is used to tell if we're in the last phase or not, because
779 -- in that case flags like @-o@ may be important.
780 -- 2. 'PipelineOutput': is this intended to be a 'Temporary' or
781 -- 'Persistent' build output? Temporary files just go in
782 -- a fresh temporary name.
783 -- 3. 'String': what was the basename of the original input file?
784 -- 4. 'DynFlags': the obvious thing
785 -- 5. 'Phase': the phase we want to determine the output filename of.
786 -- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're
787 -- compiling; this can be used to override the default output
788 -- of an object file. (TODO: do we actually need this?)
789 getOutputFilename
790 :: Phase -> PipelineOutput -> String
791 -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
792 getOutputFilename stop_phase output basename dflags next_phase maybe_location
793 | is_last_phase, Persistent <- output = persistent_fn
794 | is_last_phase, SpecificFile <- output = case outputFile dflags of
795 Just f -> return f
796 Nothing ->
797 panic "SpecificFile: No filename"
798 | keep_this_output = persistent_fn
799 | Temporary lifetime <- output = newTempName dflags lifetime suffix
800 | otherwise = newTempName dflags TFL_CurrentModule
801 suffix
802 where
803 hcsuf = hcSuf dflags
804 odir = objectDir dflags
805 osuf = objectSuf dflags
806 keep_hc = gopt Opt_KeepHcFiles dflags
807 keep_hscpp = gopt Opt_KeepHscppFiles dflags
808 keep_s = gopt Opt_KeepSFiles dflags
809 keep_bc = gopt Opt_KeepLlvmFiles dflags
810
811 myPhaseInputExt HCc = hcsuf
812 myPhaseInputExt MergeForeign = osuf
813 myPhaseInputExt StopLn = osuf
814 myPhaseInputExt other = phaseInputExt other
815
816 is_last_phase = next_phase `eqPhase` stop_phase
817
818 -- sometimes, we keep output from intermediate stages
819 keep_this_output =
820 case next_phase of
821 As _ | keep_s -> True
822 LlvmOpt | keep_bc -> True
823 HCc | keep_hc -> True
824 HsPp _ | keep_hscpp -> True -- See Trac #10869
825 _other -> False
826
827 suffix = myPhaseInputExt next_phase
828
829 -- persistent object files get put in odir
830 persistent_fn
831 | StopLn <- next_phase = return odir_persistent
832 | otherwise = return persistent
833
834 persistent = basename <.> suffix
835
836 odir_persistent
837 | Just loc <- maybe_location = ml_obj_file loc
838 | Just d <- odir = d </> persistent
839 | otherwise = persistent
840
841
842 -- | The fast LLVM Pipeline skips the mangler and assembler,
843 -- emitting object code directly from llc.
844 --
845 -- slow: opt -> llc -> .s -> mangler -> as -> .o
846 -- fast: opt -> llc -> .o
847 --
848 -- hidden flag: -ffast-llvm
849 --
850 -- if keep-s-files is specified, we need to go through
851 -- the slow pipeline (Kavon Farvardin requested this).
852 fastLlvmPipeline :: DynFlags -> Bool
853 fastLlvmPipeline dflags
854 = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags
855
856 -- | LLVM Options. These are flags to be passed to opt and llc, to ensure
857 -- consistency we list them in pairs, so that they form groups.
858 llvmOptions :: DynFlags
859 -> [(String, String)] -- ^ pairs of (opt, llc) arguments
860 llvmOptions dflags =
861 [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
862 ++ [("-relocation-model=" ++ rmodel
863 ,"-relocation-model=" ++ rmodel) | not (null rmodel)]
864 ++ [("-stack-alignment=" ++ (show align)
865 ,"-stack-alignment=" ++ (show align)) | align > 0 ]
866 ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ]
867
868 -- Additional llc flags
869 ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu)
870 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]
871 ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]
872
873 where target = LLVM_TARGET
874 Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags)
875
876 -- Relocation models
877 rmodel | gopt Opt_PIC dflags = "pic"
878 | positionIndependent dflags = "pic"
879 | WayDyn `elem` ways dflags = "dynamic-no-pic"
880 | otherwise = "static"
881
882 align :: Int
883 align = case platformArch (targetPlatform dflags) of
884 ArchX86_64 | isAvxEnabled dflags -> 32
885 _ -> 0
886
887 attrs :: String
888 attrs = intercalate "," $ mattr
889 ++ ["+sse42" | isSse4_2Enabled dflags ]
890 ++ ["+sse2" | isSse2Enabled dflags ]
891 ++ ["+sse" | isSseEnabled dflags ]
892 ++ ["+avx512f" | isAvx512fEnabled dflags ]
893 ++ ["+avx2" | isAvx2Enabled dflags ]
894 ++ ["+avx" | isAvxEnabled dflags ]
895 ++ ["+avx512cd"| isAvx512cdEnabled dflags ]
896 ++ ["+avx512er"| isAvx512erEnabled dflags ]
897 ++ ["+avx512pf"| isAvx512pfEnabled dflags ]
898 ++ ["+bmi" | isBmiEnabled dflags ]
899 ++ ["+bmi2" | isBmi2Enabled dflags ]
900
901 -- -----------------------------------------------------------------------------
902 -- | Each phase in the pipeline returns the next phase to execute, and the
903 -- name of the file in which the output was placed.
904 --
905 -- We must do things dynamically this way, because we often don't know
906 -- what the rest of the phases will be until part-way through the
907 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
908 -- of a source file can change the latter stages of the pipeline from
909 -- taking the LLVM route to using the native code generator.
910 --
911 runPhase :: PhasePlus -- ^ Run this phase
912 -> FilePath -- ^ name of the input file
913 -> DynFlags -- ^ for convenience, we pass the current dflags in
914 -> CompPipeline (PhasePlus, -- next phase to run
915 FilePath) -- output filename
916
917 -- Invariant: the output filename always contains the output
918 -- Interesting case: Hsc when there is no recompilation to do
919 -- Then the output filename is still a .o file
920
921
922 -------------------------------------------------------------------------------
923 -- Unlit phase
924
925 runPhase (RealPhase (Unlit sf)) input_fn dflags
926 = do
927 output_fn <- phaseOutputFilename (Cpp sf)
928
929 let flags = [ -- The -h option passes the file name for unlit to
930 -- put in a #line directive
931 SysTools.Option "-h"
932 -- See Note [Don't normalise input filenames].
933 , SysTools.Option $ escape input_fn
934 , SysTools.FileOption "" input_fn
935 , SysTools.FileOption "" output_fn
936 ]
937
938 liftIO $ SysTools.runUnlit dflags flags
939
940 return (RealPhase (Cpp sf), output_fn)
941 where
942 -- escape the characters \, ", and ', but don't try to escape
943 -- Unicode or anything else (so we don't use Util.charToC
944 -- here). If we get this wrong, then in
945 -- Coverage.isGoodTickSrcSpan where we check that the filename in
946 -- a SrcLoc is the same as the source filenaame, the two will
947 -- look bogusly different. See test:
948 -- libraries/hpc/tests/function/subdir/tough2.hs
949 escape ('\\':cs) = '\\':'\\': escape cs
950 escape ('\"':cs) = '\\':'\"': escape cs
951 escape ('\'':cs) = '\\':'\'': escape cs
952 escape (c:cs) = c : escape cs
953 escape [] = []
954
955 -------------------------------------------------------------------------------
956 -- Cpp phase : (a) gets OPTIONS out of file
957 -- (b) runs cpp if necessary
958
959 runPhase (RealPhase (Cpp sf)) input_fn dflags0
960 = do
961 src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
962 (dflags1, unhandled_flags, warns)
963 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
964 setDynFlags dflags1
965 liftIO $ checkProcessArgsResult dflags1 unhandled_flags
966
967 if not (xopt LangExt.Cpp dflags1) then do
968 -- we have to be careful to emit warnings only once.
969 unless (gopt Opt_Pp dflags1) $
970 liftIO $ handleFlagWarnings dflags1 warns
971
972 -- no need to preprocess CPP, just pass input file along
973 -- to the next phase of the pipeline.
974 return (RealPhase (HsPp sf), input_fn)
975 else do
976 output_fn <- phaseOutputFilename (HsPp sf)
977 liftIO $ doCpp dflags1 True{-raw-}
978 input_fn output_fn
979 -- re-read the pragmas now that we've preprocessed the file
980 -- See #2464,#3457
981 src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
982 (dflags2, unhandled_flags, warns)
983 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
984 liftIO $ checkProcessArgsResult dflags2 unhandled_flags
985 unless (gopt Opt_Pp dflags2) $
986 liftIO $ handleFlagWarnings dflags2 warns
987 -- the HsPp pass below will emit warnings
988
989 setDynFlags dflags2
990
991 return (RealPhase (HsPp sf), output_fn)
992
993 -------------------------------------------------------------------------------
994 -- HsPp phase
995
996 runPhase (RealPhase (HsPp sf)) input_fn dflags
997 = do
998 if not (gopt Opt_Pp dflags) then
999 -- no need to preprocess, just pass input file along
1000 -- to the next phase of the pipeline.
1001 return (RealPhase (Hsc sf), input_fn)
1002 else do
1003 PipeEnv{src_basename, src_suffix} <- getPipeEnv
1004 let orig_fn = src_basename <.> src_suffix
1005 output_fn <- phaseOutputFilename (Hsc sf)
1006 liftIO $ SysTools.runPp dflags
1007 ( [ SysTools.Option orig_fn
1008 , SysTools.Option input_fn
1009 , SysTools.FileOption "" output_fn
1010 ]
1011 )
1012
1013 -- re-read pragmas now that we've parsed the file (see #3674)
1014 src_opts <- liftIO $ getOptionsFromFile dflags output_fn
1015 (dflags1, unhandled_flags, warns)
1016 <- liftIO $ parseDynamicFilePragma dflags src_opts
1017 setDynFlags dflags1
1018 liftIO $ checkProcessArgsResult dflags1 unhandled_flags
1019 liftIO $ handleFlagWarnings dflags1 warns
1020
1021 return (RealPhase (Hsc sf), output_fn)
1022
1023 -----------------------------------------------------------------------------
1024 -- Hsc phase
1025
1026 -- Compilation of a single module, in "legacy" mode (_not_ under
1027 -- the direction of the compilation manager).
1028 runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
1029 = do -- normal Hsc mode, not mkdependHS
1030
1031 PipeEnv{ stop_phase=stop,
1032 src_basename=basename,
1033 src_suffix=suff } <- getPipeEnv
1034
1035 -- we add the current directory (i.e. the directory in which
1036 -- the .hs files resides) to the include path, since this is
1037 -- what gcc does, and it's probably what you want.
1038 let current_dir = takeDirectory basename
1039 new_includes = addQuoteInclude paths [current_dir]
1040 paths = includePaths dflags0
1041 dflags = dflags0 { includePaths = new_includes }
1042
1043 setDynFlags dflags
1044
1045 -- gather the imports and module name
1046 (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do
1047 do
1048 buf <- hGetStringBuffer input_fn
1049 eimps <- getImports dflags buf input_fn (basename <.> suff)
1050 case eimps of
1051 Left errs -> throwErrors errs
1052 Right (src_imps,imps,L _ mod_name) -> return
1053 (Just buf, mod_name, imps, src_imps)
1054
1055 -- Take -o into account if present
1056 -- Very like -ohi, but we must *only* do this if we aren't linking
1057 -- (If we're linking then the -o applies to the linked thing, not to
1058 -- the object file for one module.)
1059 -- Note the nasty duplication with the same computation in compileFile above
1060 location <- getLocation src_flavour mod_name
1061
1062 let o_file = ml_obj_file location -- The real object file
1063 hi_file = ml_hi_file location
1064 hie_file = ml_hie_file location
1065 dest_file | writeInterfaceOnlyMode dflags
1066 = hi_file
1067 | otherwise
1068 = o_file
1069
1070 -- Figure out if the source has changed, for recompilation avoidance.
1071 --
1072 -- Setting source_unchanged to True means that M.o (or M.hie) seems
1073 -- to be up to date wrt M.hs; so no need to recompile unless imports have
1074 -- changed (which the compiler itself figures out).
1075 -- Setting source_unchanged to False tells the compiler that M.o is out of
1076 -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
1077 src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
1078
1079 source_unchanged <- liftIO $
1080 if not (isStopLn stop)
1081 -- SourceModified unconditionally if
1082 -- (a) recompilation checker is off, or
1083 -- (b) we aren't going all the way to .o file (e.g. ghc -S)
1084 then return SourceModified
1085 -- Otherwise look at file modification dates
1086 else do dest_file_mod <- sourceModified dest_file src_timestamp
1087 hie_file_mod <- if gopt Opt_WriteHie dflags
1088 then sourceModified hie_file
1089 src_timestamp
1090 else pure False
1091 if dest_file_mod || hie_file_mod
1092 then return SourceModified
1093 else return SourceUnmodified
1094
1095 PipeState{hsc_env=hsc_env'} <- getPipeState
1096
1097 -- Tell the finder cache about this module
1098 mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location
1099
1100 -- Make the ModSummary to hand to hscMain
1101 let
1102 mod_summary = ModSummary { ms_mod = mod,
1103 ms_hsc_src = src_flavour,
1104 ms_hspp_file = input_fn,
1105 ms_hspp_opts = dflags,
1106 ms_hspp_buf = hspp_buf,
1107 ms_location = location,
1108 ms_hs_date = src_timestamp,
1109 ms_obj_date = Nothing,
1110 ms_parsed_mod = Nothing,
1111 ms_iface_date = Nothing,
1112 ms_hie_date = Nothing,
1113 ms_textual_imps = imps,
1114 ms_srcimps = src_imps }
1115
1116 -- run the compiler!
1117 let msg hsc_env _ what _ = oneShotMsg hsc_env what
1118 (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
1119 mod_summary source_unchanged Nothing (1,1)
1120
1121 return (HscOut src_flavour mod_name result,
1122 panic "HscOut doesn't have an input filename")
1123
1124 runPhase (HscOut src_flavour mod_name result) _ dflags = do
1125 location <- getLocation src_flavour mod_name
1126 setModLocation location
1127
1128 let o_file = ml_obj_file location -- The real object file
1129 hsc_lang = hscTarget dflags
1130 next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
1131
1132 case result of
1133 HscNotGeneratingCode ->
1134 return (RealPhase StopLn,
1135 panic "No output filename from Hsc when no-code")
1136 HscUpToDate ->
1137 do liftIO $ touchObjectFile dflags o_file
1138 -- The .o file must have a later modification date
1139 -- than the source file (else we wouldn't get Nothing)
1140 -- but we touch it anyway, to keep 'make' happy (we think).
1141 return (RealPhase StopLn, o_file)
1142 HscUpdateBoot ->
1143 do -- In the case of hs-boot files, generate a dummy .o-boot
1144 -- stamp file for the benefit of Make
1145 liftIO $ touchObjectFile dflags o_file
1146 return (RealPhase StopLn, o_file)
1147 HscUpdateSig ->
1148 do -- We need to create a REAL but empty .o file
1149 -- because we are going to attempt to put it in a library
1150 PipeState{hsc_env=hsc_env'} <- getPipeState
1151 let input_fn = expectJust "runPhase" (ml_hs_file location)
1152 basename = dropExtension input_fn
1153 liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name
1154 return (RealPhase StopLn, o_file)
1155 HscRecomp cgguts mod_summary
1156 -> do output_fn <- phaseOutputFilename next_phase
1157
1158 PipeState{hsc_env=hsc_env'} <- getPipeState
1159
1160 (outputFilename, mStub, foreign_files) <- liftIO $
1161 hscGenHardCode hsc_env' cgguts mod_summary output_fn
1162 stub_o <- liftIO (mapM (compileStub hsc_env') mStub)
1163 foreign_os <- liftIO $
1164 mapM (uncurry (compileForeign hsc_env')) foreign_files
1165 setForeignOs (maybe [] return stub_o ++ foreign_os)
1166
1167 return (RealPhase next_phase, outputFilename)
1168
1169 -----------------------------------------------------------------------------
1170 -- Cmm phase
1171
1172 runPhase (RealPhase CmmCpp) input_fn dflags
1173 = do
1174 output_fn <- phaseOutputFilename Cmm
1175 liftIO $ doCpp dflags False{-not raw-}
1176 input_fn output_fn
1177 return (RealPhase Cmm, output_fn)
1178
1179 runPhase (RealPhase Cmm) input_fn dflags
1180 = do
1181 let hsc_lang = hscTarget dflags
1182
1183 let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang
1184
1185 output_fn <- phaseOutputFilename next_phase
1186
1187 PipeState{hsc_env} <- getPipeState
1188
1189 liftIO $ hscCompileCmmFile hsc_env input_fn output_fn
1190
1191 return (RealPhase next_phase, output_fn)
1192
1193 -----------------------------------------------------------------------------
1194 -- Cc phase
1195
1196 runPhase (RealPhase cc_phase) input_fn dflags
1197 | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]
1198 = do
1199 let platform = targetPlatform dflags
1200 hcc = cc_phase `eqPhase` HCc
1201
1202 let cmdline_include_paths = includePaths dflags
1203
1204 -- HC files have the dependent packages stamped into them
1205 pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []
1206
1207 -- add package include paths even if we're just compiling .c
1208 -- files; this is the Value Add(TM) that using ghc instead of
1209 -- gcc gives you :)
1210 pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
1211 let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
1212 (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
1213 let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
1214 (includePathsQuote cmdline_include_paths)
1215 let include_paths = include_paths_quote ++ include_paths_global
1216
1217 -- pass -D or -optP to preprocessor when compiling foreign C files
1218 -- (#16737). Doing it in this way is simpler and also enable the C
1219 -- compiler to performs preprocessing and parsing in a single pass,
1220 -- but it may introduce inconsistency if a different pgm_P is specified.
1221 let more_preprocessor_opts = concat
1222 [ ["-Xpreprocessor", i]
1223 | not hcc
1224 , i <- getOpts dflags opt_P
1225 ]
1226
1227 let gcc_extra_viac_flags = extraGccViaCFlags dflags
1228 let pic_c_flags = picCCOpts dflags
1229
1230 let verbFlags = getVerbFlags dflags
1231
1232 -- cc-options are not passed when compiling .hc files. Our
1233 -- hc code doesn't not #include any header files anyway, so these
1234 -- options aren't necessary.
1235 pkg_extra_cc_opts <- liftIO $
1236 if hcc
1237 then return []
1238 else getPackageExtraCcOpts dflags pkgs
1239
1240 framework_paths <-
1241 if platformUsesFrameworks platform
1242 then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs
1243 let cmdlineFrameworkPaths = frameworkPaths dflags
1244 return $ map ("-F"++)
1245 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
1246 else return []
1247
1248 let cc_opt | optLevel dflags >= 2 = [ "-O2" ]
1249 | optLevel dflags >= 1 = [ "-O" ]
1250 | otherwise = []
1251
1252 -- Decide next phase
1253 let next_phase = As False
1254 output_fn <- phaseOutputFilename next_phase
1255
1256 let
1257 more_hcc_opts =
1258 -- on x86 the floating point regs have greater precision
1259 -- than a double, which leads to unpredictable results.
1260 -- By default, we turn this off with -ffloat-store unless
1261 -- the user specified -fexcess-precision.
1262 (if platformArch platform == ArchX86 &&
1263 not (gopt Opt_ExcessPrecision dflags)
1264 then [ "-ffloat-store" ]
1265 else []) ++
1266
1267 -- gcc's -fstrict-aliasing allows two accesses to memory
1268 -- to be considered non-aliasing if they have different types.
1269 -- This interacts badly with the C code we generate, which is
1270 -- very weakly typed, being derived from C--.
1271 ["-fno-strict-aliasing"]
1272
1273 ghcVersionH <- liftIO $ getGhcVersionPathName dflags
1274
1275 let gcc_lang_opt | cc_phase `eqPhase` Ccxx = "c++"
1276 | cc_phase `eqPhase` Cobjc = "objective-c"
1277 | cc_phase `eqPhase` Cobjcxx = "objective-c++"
1278 | otherwise = "c"
1279 liftIO $ SysTools.runCc dflags (
1280 -- force the C compiler to interpret this file as C when
1281 -- compiling .hc files, by adding the -x c option.
1282 -- Also useful for plain .c files, just in case GHC saw a
1283 -- -x c option.
1284 [ SysTools.Option "-x", SysTools.Option gcc_lang_opt
1285 , SysTools.FileOption "" input_fn
1286 , SysTools.Option "-o"
1287 , SysTools.FileOption "" output_fn
1288 ]
1289 ++ map SysTools.Option (
1290 pic_c_flags
1291
1292 -- Stub files generated for foreign exports references the runIO_closure
1293 -- and runNonIO_closure symbols, which are defined in the base package.
1294 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
1295 -- way we do the import depends on whether we're currently compiling
1296 -- the base package or not.
1297 ++ (if platformOS platform == OSMinGW32 &&
1298 thisPackage dflags == baseUnitId
1299 then [ "-DCOMPILING_BASE_PACKAGE" ]
1300 else [])
1301
1302 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1303 -- instruction. Note that the user can still override this
1304 -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
1305 -- regardless of the ordering.
1306 --
1307 -- This is a temporary hack. See #2872, commit
1308 -- 5bd3072ac30216a505151601884ac88bf404c9f2
1309 ++ (if platformArch platform == ArchSPARC
1310 then ["-mcpu=v9"]
1311 else [])
1312
1313 -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
1314 ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
1315 then ["-Wimplicit"]
1316 else [])
1317
1318 ++ (if hcc
1319 then gcc_extra_viac_flags ++ more_hcc_opts
1320 else [])
1321 ++ verbFlags
1322 ++ [ "-S" ]
1323 ++ cc_opt
1324 ++ [ "-include", ghcVersionH ]
1325 ++ framework_paths
1326 ++ include_paths
1327 ++ more_preprocessor_opts
1328 ++ pkg_extra_cc_opts
1329 ))
1330
1331 return (RealPhase next_phase, output_fn)
1332
1333 -----------------------------------------------------------------------------
1334 -- Splitting phase
1335
1336 runPhase (RealPhase Splitter) input_fn dflags
1337 = do -- tmp_pfx is the prefix used for the split .s files
1338
1339 split_s_prefix <-
1340 liftIO $ newTempName dflags TFL_CurrentModule "split"
1341 let n_files_fn = split_s_prefix
1342
1343 liftIO $ SysTools.runSplit dflags
1344 [ SysTools.FileOption "" input_fn
1345 , SysTools.FileOption "" split_s_prefix
1346 , SysTools.FileOption "" n_files_fn
1347 ]
1348
1349 -- Save the number of split files for future references
1350 s <- liftIO $ readFile n_files_fn
1351 let n_files = read s :: Int
1352 dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
1353
1354 setDynFlags dflags'
1355
1356 -- Remember to delete all these files
1357 liftIO $ addFilesToClean dflags' TFL_CurrentModule $
1358 [ split_s_prefix ++ "__" ++ show n ++ ".s"
1359 | n <- [1..n_files]]
1360
1361 return (RealPhase SplitAs,
1362 "**splitter**") -- we don't use the filename in SplitAs
1363
1364 -----------------------------------------------------------------------------
1365 -- As, SpitAs phase : Assembler
1366
1367 -- This is for calling the assembler on a regular assembly file (not split).
1368 runPhase (RealPhase (As with_cpp)) input_fn dflags
1369 = do
1370 -- LLVM from version 3.0 onwards doesn't support the OS X system
1371 -- assembler, so we use clang as the assembler instead. (#5636)
1372 let whichAsProg | hscTarget dflags == HscLlvm &&
1373 platformOS (targetPlatform dflags) == OSDarwin
1374 = return SysTools.runClang
1375 | otherwise = return SysTools.runAs
1376
1377 as_prog <- whichAsProg
1378 let cmdline_include_paths = includePaths dflags
1379 let pic_c_flags = picCCOpts dflags
1380
1381 next_phase <- maybeMergeForeign
1382 output_fn <- phaseOutputFilename next_phase
1383
1384 -- we create directories for the object file, because it
1385 -- might be a hierarchical module.
1386 liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
1387
1388 ccInfo <- liftIO $ getCompilerInfo dflags
1389 let global_includes = [ SysTools.Option ("-I" ++ p)
1390 | p <- includePathsGlobal cmdline_include_paths ]
1391 let local_includes = [ SysTools.Option ("-iquote" ++ p)
1392 | p <- includePathsQuote cmdline_include_paths ]
1393 let runAssembler inputFilename outputFilename
1394 = liftIO $ as_prog dflags
1395 (local_includes ++ global_includes
1396 -- See Note [-fPIC for assembler]
1397 ++ map SysTools.Option pic_c_flags
1398 -- See Note [Produce big objects on Windows]
1399 ++ [ SysTools.Option "-Wa,-mbig-obj"
1400 | platformOS (targetPlatform dflags) == OSMinGW32
1401 , not $ target32Bit (targetPlatform dflags)
1402 ]
1403
1404 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1405 -- instruction so we have to make sure that the assembler accepts the
1406 -- instruction set. Note that the user can still override this
1407 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1408 -- regardless of the ordering.
1409 --
1410 -- This is a temporary hack.
1411 ++ (if platformArch (targetPlatform dflags) == ArchSPARC
1412 then [SysTools.Option "-mcpu=v9"]
1413 else [])
1414 ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
1415 then [SysTools.Option "-Qunused-arguments"]
1416 else [])
1417 ++ [ SysTools.Option "-x"
1418 , if with_cpp
1419 then SysTools.Option "assembler-with-cpp"
1420 else SysTools.Option "assembler"
1421 , SysTools.Option "-c"
1422 , SysTools.FileOption "" inputFilename
1423 , SysTools.Option "-o"
1424 , SysTools.FileOption "" outputFilename
1425 ])
1426
1427 liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
1428 runAssembler input_fn output_fn
1429 return (RealPhase next_phase, output_fn)
1430
1431
1432 -- This is for calling the assembler on a split assembly file (so a collection
1433 -- of assembly files)
1434 runPhase (RealPhase SplitAs) _input_fn dflags
1435 = do
1436 -- we'll handle the stub_o file in this phase, so don't MergeForeign,
1437 -- just jump straight to StopLn afterwards.
1438 let next_phase = StopLn
1439 output_fn <- phaseOutputFilename next_phase
1440
1441 let base_o = dropExtension output_fn
1442 osuf = objectSuf dflags
1443 split_odir = base_o ++ "_" ++ osuf ++ "_split"
1444
1445 let pic_c_flags = picCCOpts dflags
1446
1447 -- this also creates the hierarchy
1448 liftIO $ createDirectoryIfMissing True split_odir
1449
1450 -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1451 -- later and we don't want to pick up any old objects.
1452 fs <- liftIO $ getDirectoryContents split_odir
1453 liftIO $ mapM_ removeFile $
1454 map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1455
1456 let (split_s_prefix, n) = case splitInfo dflags of
1457 Nothing -> panic "No split info"
1458 Just x -> x
1459
1460 let split_s n = split_s_prefix ++ "__" ++ show n <.> "s"
1461
1462 split_obj :: Int -> FilePath
1463 split_obj n = split_odir </>
1464 takeFileName base_o ++ "__" ++ show n <.> osuf
1465
1466 let assemble_file n
1467 = SysTools.runAs dflags (
1468
1469 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1470 -- instruction so we have to make sure that the assembler accepts the
1471 -- instruction set. Note that the user can still override this
1472 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1473 -- regardless of the ordering.
1474 --
1475 -- This is a temporary hack.
1476 (if platformArch (targetPlatform dflags) == ArchSPARC
1477 then [SysTools.Option "-mcpu=v9"]
1478 else []) ++
1479
1480 -- See Note [-fPIC for assembler]
1481 map SysTools.Option pic_c_flags ++
1482
1483 [ SysTools.Option "-c"
1484 , SysTools.Option "-o"
1485 , SysTools.FileOption "" (split_obj n)
1486 , SysTools.FileOption "" (split_s n)
1487 ])
1488
1489 liftIO $ mapM_ assemble_file [1..n]
1490
1491 -- Note [pipeline-split-init]
1492 -- If we have a stub file -- which will be part of foreign_os --
1493 -- it may contain constructor
1494 -- functions for initialisation of this module. We can't
1495 -- simply leave the stub as a separate object file, because it
1496 -- will never be linked in: nothing refers to it. We need to
1497 -- ensure that if we ever refer to the data in this module
1498 -- that needs initialisation, then we also pull in the
1499 -- initialisation routine.
1500 --
1501 -- To that end, we make a DANGEROUS ASSUMPTION here: the data
1502 -- that needs to be initialised is all in the FIRST split
1503 -- object. See Note [codegen-split-init].
1504 --
1505 -- We also merge in all the foreign objects since we're at it.
1506
1507 PipeState{foreign_os} <- getPipeState
1508 if null foreign_os
1509 then return ()
1510 else liftIO $ do
1511 tmp_split_1 <- newTempName dflags TFL_CurrentModule osuf
1512 let split_1 = split_obj 1
1513 copyFile split_1 tmp_split_1
1514 removeFile split_1
1515 joinObjectFiles dflags (tmp_split_1 : foreign_os) split_1
1516
1517 -- join them into a single .o file
1518 liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
1519
1520 return (RealPhase next_phase, output_fn)
1521
1522 -----------------------------------------------------------------------------
1523 -- LlvmOpt phase
1524 runPhase (RealPhase LlvmOpt) input_fn dflags
1525 = do
1526 output_fn <- phaseOutputFilename LlvmLlc
1527
1528 liftIO $ SysTools.runLlvmOpt dflags
1529 ( optFlag
1530 ++ defaultOptions ++
1531 [ SysTools.FileOption "" input_fn
1532 , SysTools.Option "-o"
1533 , SysTools.FileOption "" output_fn]
1534 )
1535
1536 return (RealPhase LlvmLlc, output_fn)
1537 where
1538 -- we always (unless -optlo specified) run Opt since we rely on it to
1539 -- fix up some pretty big deficiencies in the code we generate
1540 optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2]
1541 llvmOpts = case lookup optIdx $ llvmPasses dflags of
1542 Just passes -> passes
1543 Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "
1544 ++ "is missing passes for level "
1545 ++ show optIdx)
1546
1547 -- don't specify anything if user has specified commands. We do this
1548 -- for opt but not llc since opt is very specifically for optimisation
1549 -- passes only, so if the user is passing us extra options we assume
1550 -- they know what they are doing and don't get in the way.
1551 optFlag = if null (getOpts dflags opt_lo)
1552 then map SysTools.Option $ words llvmOpts
1553 else []
1554
1555 defaultOptions = map SysTools.Option . concat . fmap words . fst
1556 $ unzip (llvmOptions dflags)
1557
1558 -----------------------------------------------------------------------------
1559 -- LlvmLlc phase
1560
1561 runPhase (RealPhase LlvmLlc) input_fn dflags
1562 = do
1563 next_phase <- if fastLlvmPipeline dflags
1564 then maybeMergeForeign
1565 -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
1566 else case gopt Opt_NoLlvmMangler dflags of
1567 False -> return LlvmMangle
1568 True | gopt Opt_SplitObjs dflags -> return Splitter
1569 True -> return (As False)
1570
1571 output_fn <- phaseOutputFilename next_phase
1572
1573 liftIO $ SysTools.runLlvmLlc dflags
1574 ( optFlag
1575 ++ defaultOptions
1576 ++ [ SysTools.FileOption "" input_fn
1577 , SysTools.Option "-o"
1578 , SysTools.FileOption "" output_fn
1579 ]
1580 )
1581
1582 return (RealPhase next_phase, output_fn)
1583 where
1584 -- Note [Clamping of llc optimizations]
1585 --
1586 -- See #13724
1587 --
1588 -- we clamp the llc optimization between [1,2]. This is because passing -O0
1589 -- to llc 3.9 or llc 4.0, the naive register allocator can fail with
1590 --
1591 -- Error while trying to spill R1 from class GPR: Cannot scavenge register
1592 -- without an emergency spill slot!
1593 --
1594 -- Observed at least with target 'arm-unknown-linux-gnueabihf'.
1595 --
1596 --
1597 -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile
1598 -- rts/HeapStackCheck.cmm
1599 --
1600 -- 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
1601 -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40
1602 -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358
1603 -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26
1604 -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876
1605 -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699
1606 -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381
1607 -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457
1608 -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20
1609 -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134
1610 -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498
1611 -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67
1612 -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920
1613 -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133
1614 -- 13 llc 0x000000010195bf0b main + 491
1615 -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1
1616 -- Stack dump:
1617 -- 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
1618 -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.
1619 -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'
1620 --
1621 -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa
1622 --
1623 llvmOpts = case optLevel dflags of
1624 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
1625 1 -> "-O1"
1626 _ -> "-O2"
1627
1628 optFlag = if null (getOpts dflags opt_lc)
1629 then map SysTools.Option $ words llvmOpts
1630 else []
1631
1632 defaultOptions = map SysTools.Option . concat . fmap words . snd
1633 $ unzip (llvmOptions dflags)
1634
1635
1636 -----------------------------------------------------------------------------
1637 -- LlvmMangle phase
1638
1639 runPhase (RealPhase LlvmMangle) input_fn dflags
1640 = do
1641 let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False
1642 output_fn <- phaseOutputFilename next_phase
1643 liftIO $ llvmFixupAsm dflags input_fn output_fn
1644 return (RealPhase next_phase, output_fn)
1645
1646 -----------------------------------------------------------------------------
1647 -- merge in stub objects
1648
1649 runPhase (RealPhase MergeForeign) input_fn dflags
1650 = do
1651 PipeState{foreign_os} <- getPipeState
1652 output_fn <- phaseOutputFilename StopLn
1653 liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
1654 if null foreign_os
1655 then panic "runPhase(MergeForeign): no foreign objects"
1656 else do
1657 liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn
1658 return (RealPhase StopLn, output_fn)
1659
1660 -- warning suppression
1661 runPhase (RealPhase other) _input_fn _dflags =
1662 panic ("runPhase: don't know how to run phase " ++ show other)
1663
1664 maybeMergeForeign :: CompPipeline Phase
1665 maybeMergeForeign
1666 = do
1667 PipeState{foreign_os} <- getPipeState
1668 if null foreign_os then return StopLn else return MergeForeign
1669
1670 getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
1671 getLocation src_flavour mod_name = do
1672 dflags <- getDynFlags
1673
1674 PipeEnv{ src_basename=basename,
1675 src_suffix=suff } <- getPipeEnv
1676 PipeState { maybe_loc=maybe_loc} <- getPipeState
1677 case maybe_loc of
1678 -- Build a ModLocation to pass to hscMain.
1679 -- The source filename is rather irrelevant by now, but it's used
1680 -- by hscMain for messages. hscMain also needs
1681 -- the .hi and .o filenames. If we already have a ModLocation
1682 -- then simply update the extensions of the interface and object
1683 -- files to match the DynFlags, otherwise use the logic in Finder.
1684 Just l -> return $ l
1685 { ml_hs_file = Just $ basename <.> suff
1686 , ml_hi_file = ml_hi_file l -<.> hiSuf dflags
1687 , ml_obj_file = ml_obj_file l -<.> objectSuf dflags
1688 }
1689 _ -> do
1690 location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
1691
1692 -- Boot-ify it if necessary
1693 let location2
1694 | HsBootFile <- src_flavour = addBootSuffixLocnOut location1
1695 | otherwise = location1
1696
1697
1698 -- Take -ohi into account if present
1699 -- This can't be done in mkHomeModuleLocation because
1700 -- it only applies to the module being compiles
1701 let ohi = outputHi dflags
1702 location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
1703 | otherwise = location2
1704
1705 -- Take -o into account if present
1706 -- Very like -ohi, but we must *only* do this if we aren't linking
1707 -- (If we're linking then the -o applies to the linked thing, not to
1708 -- the object file for one module.)
1709 -- Note the nasty duplication with the same computation in compileFile
1710 -- above
1711 let expl_o_file = outputFile dflags
1712 location4 | Just ofile <- expl_o_file
1713 , isNoLink (ghcLink dflags)
1714 = location3 { ml_obj_file = ofile }
1715 | otherwise = location3
1716 return location4
1717
1718 -----------------------------------------------------------------------------
1719 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1720
1721 getHCFilePackages :: FilePath -> IO [InstalledUnitId]
1722 getHCFilePackages filename =
1723 Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1724 l <- hGetLine h
1725 case l of
1726 '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1727 return (map stringToInstalledUnitId (words rest))
1728 _other ->
1729 return []
1730
1731 -----------------------------------------------------------------------------
1732 -- Static linking, of .o files
1733
1734 -- The list of packages passed to link is the list of packages on
1735 -- which this program depends, as discovered by the compilation
1736 -- manager. It is combined with the list of packages that the user
1737 -- specifies on the command line with -package flags.
1738 --
1739 -- In one-shot linking mode, we can't discover the package
1740 -- dependencies (because we haven't actually done any compilation or
1741 -- read any interface files), so the user must explicitly specify all
1742 -- the packages.
1743
1744 {-
1745 Note [-Xlinker -rpath vs -Wl,-rpath]
1746 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1747
1748 -Wl takes a comma-separated list of options which in the case of
1749 -Wl,-rpath -Wl,some,path,with,commas parses the path with commas
1750 as separate options.
1751 Buck, the build system, produces paths with commas in them.
1752
1753 -Xlinker doesn't have this disadvantage and as far as I can tell
1754 it is supported by both gcc and clang. Anecdotally nvcc supports
1755 -Xlinker, but not -Wl.
1756 -}
1757
1758 linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
1759 linkBinary = linkBinary' False
1760
1761 linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
1762 linkBinary' staticLink dflags o_files dep_packages = do
1763 let platform = targetPlatform dflags
1764 mySettings = settings dflags
1765 verbFlags = getVerbFlags dflags
1766 output_fn = exeFileName staticLink dflags
1767
1768 -- get the full list of packages to link with, by combining the
1769 -- explicit packages with the auto packages and all of their
1770 -- dependencies, and eliminating duplicates.
1771
1772 full_output_fn <- if isAbsolute output_fn
1773 then return output_fn
1774 else do d <- getCurrentDirectory
1775 return $ normalise (d </> output_fn)
1776 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1777 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1778 get_pkg_lib_path_opts l
1779 | osElfTarget (platformOS platform) &&
1780 dynLibLoader dflags == SystemDependent &&
1781 WayDyn `elem` ways dflags
1782 = let libpath = if gopt Opt_RelativeDynlibPaths dflags
1783 then "$ORIGIN" </>
1784 (l `makeRelativeTo` full_output_fn)
1785 else l
1786 -- See Note [-Xlinker -rpath vs -Wl,-rpath]
1787 rpath = if gopt Opt_RPath dflags
1788 then ["-Xlinker", "-rpath", "-Xlinker", libpath]
1789 else []
1790 -- Solaris 11's linker does not support -rpath-link option. It silently
1791 -- ignores it and then complains about next option which is -l<some
1792 -- dir> as being a directory and not expected object file, E.g
1793 -- ld: elf error: file
1794 -- /tmp/ghc-src/libraries/base/dist-install/build:
1795 -- elf_begin: I/O error: region read: Is a directory
1796 rpathlink = if (platformOS platform) == OSSolaris2
1797 then []
1798 else ["-Xlinker", "-rpath-link", "-Xlinker", l]
1799 in ["-L" ++ l] ++ rpathlink ++ rpath
1800 | osMachOTarget (platformOS platform) &&
1801 dynLibLoader dflags == SystemDependent &&
1802 WayDyn `elem` ways dflags &&
1803 gopt Opt_RPath dflags
1804 = let libpath = if gopt Opt_RelativeDynlibPaths dflags
1805 then "@loader_path" </>
1806 (l `makeRelativeTo` full_output_fn)
1807 else l
1808 in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
1809 | otherwise = ["-L" ++ l]
1810
1811 pkg_lib_path_opts <-
1812 if gopt Opt_SingleLibFolder dflags
1813 then do
1814 libs <- getLibs dflags dep_packages
1815 tmpDir <- newTempDir dflags
1816 sequence_ [ copyFile lib (tmpDir </> basename)
1817 | (lib, basename) <- libs]
1818 return [ "-L" ++ tmpDir ]
1819 else pure pkg_lib_path_opts
1820
1821 let
1822 dead_strip
1823 | gopt Opt_WholeArchiveHsLibs dflags = []
1824 | otherwise = if osSubsectionsViaSymbols (platformOS platform)
1825 then ["-Wl,-dead_strip"]
1826 else []
1827 let lib_paths = libraryPaths dflags
1828 let lib_path_opts = map ("-L"++) lib_paths
1829
1830 extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
1831 noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
1832
1833 let
1834 (pre_hs_libs, post_hs_libs)
1835 | gopt Opt_WholeArchiveHsLibs dflags
1836 = if platformOS platform == OSDarwin
1837 then (["-Wl,-all_load"], [])
1838 -- OS X does not have a flag to turn off -all_load
1839 else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
1840 | otherwise
1841 = ([],[])
1842
1843 pkg_link_opts <- do
1844 (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages
1845 return $ if staticLink
1846 then package_hs_libs -- If building an executable really means making a static
1847 -- library (e.g. iOS), then we only keep the -l options for
1848 -- HS packages, because libtool doesn't accept other options.
1849 -- In the case of iOS these need to be added by hand to the
1850 -- final link in Xcode.
1851 else other_flags ++ dead_strip
1852 ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
1853 ++ extra_libs
1854 -- -Wl,-u,<sym> contained in other_flags
1855 -- needs to be put before -l<package>,
1856 -- otherwise Solaris linker fails linking
1857 -- a binary with unresolved symbols in RTS
1858 -- which are defined in base package
1859 -- the reason for this is a note in ld(1) about
1860 -- '-u' option: "The placement of this option
1861 -- on the command line is significant.
1862 -- This option must be placed before the library
1863 -- that defines the symbol."
1864
1865 -- frameworks
1866 pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages
1867 let framework_opts = getFrameworkOpts dflags platform
1868
1869 -- probably _stub.o files
1870 let extra_ld_inputs = ldInputs dflags
1871
1872 -- Here are some libs that need to be linked at the *end* of
1873 -- the command line, because they contain symbols that are referred to
1874 -- by the RTS. We can't therefore use the ordinary way opts for these.
1875 let debug_opts | WayDebug `elem` ways dflags = [
1876 #if defined(HAVE_LIBBFD)
1877 "-lbfd", "-liberty"
1878 #endif
1879 ]
1880 | otherwise = []
1881
1882 thread_opts | WayThreaded `elem` ways dflags = [
1883 #if NEED_PTHREAD_LIB
1884 "-lpthread"
1885 #endif
1886 ]
1887 | otherwise = []
1888
1889 rc_objs <- maybeCreateManifest dflags output_fn
1890
1891 let link = if staticLink
1892 then SysTools.runLibtool
1893 else SysTools.runLink
1894 link dflags (
1895 map SysTools.Option verbFlags
1896 ++ [ SysTools.Option "-o"
1897 , SysTools.FileOption "" output_fn
1898 ]
1899 ++ libmLinkOpts
1900 ++ map SysTools.Option (
1901 []
1902
1903 -- See Note [No PIE when linking]
1904 ++ picCCOpts dflags
1905
1906 -- Permit the linker to auto link _symbol to _imp_symbol.
1907 -- This lets us link against DLLs without needing an "import library".
1908 ++ (if platformOS platform == OSMinGW32
1909 then ["-Wl,--enable-auto-import"]
1910 else [])
1911
1912 -- '-no_compact_unwind'
1913 -- C++/Objective-C exceptions cannot use optimised
1914 -- stack unwinding code. The optimised form is the
1915 -- default in Xcode 4 on at least x86_64, and
1916 -- without this flag we're also seeing warnings
1917 -- like
1918 -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
1919 -- on x86.
1920 ++ (if sLdSupportsCompactUnwind mySettings &&
1921 not staticLink &&
1922 (platformOS platform == OSDarwin) &&
1923 case platformArch platform of
1924 ArchX86 -> True
1925 ArchX86_64 -> True
1926 ArchARM {} -> True
1927 ArchARM64 -> True
1928 _ -> False
1929 then ["-Wl,-no_compact_unwind"]
1930 else [])
1931
1932 -- '-Wl,-read_only_relocs,suppress'
1933 -- ld gives loads of warnings like:
1934 -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
1935 -- when linking any program. We're not sure
1936 -- whether this is something we ought to fix, but
1937 -- for now this flags silences them.
1938 ++ (if platformOS platform == OSDarwin &&
1939 platformArch platform == ArchX86 &&
1940 not staticLink
1941 then ["-Wl,-read_only_relocs,suppress"]
1942 else [])
1943
1944 ++ (if sLdIsGnuLd mySettings &&
1945 not (gopt Opt_WholeArchiveHsLibs dflags)
1946 then ["-Wl,--gc-sections"]
1947 else [])
1948
1949 ++ o_files
1950 ++ lib_path_opts)
1951 ++ extra_ld_inputs
1952 ++ map SysTools.Option (
1953 rc_objs
1954 ++ framework_opts
1955 ++ pkg_lib_path_opts
1956 ++ extraLinkObj:noteLinkObjs
1957 ++ pkg_link_opts
1958 ++ pkg_framework_opts
1959 ++ debug_opts
1960 ++ thread_opts
1961 ++ (if platformOS platform == OSDarwin
1962 then [ "-Wl,-dead_strip_dylibs" ]
1963 else [])
1964 ))
1965
1966 exeFileName :: Bool -> DynFlags -> FilePath
1967 exeFileName staticLink dflags
1968 | Just s <- outputFile dflags =
1969 case platformOS (targetPlatform dflags) of
1970 OSMinGW32 -> s <?.> "exe"
1971 _ -> if staticLink
1972 then s <?.> "a"
1973 else s
1974 | otherwise =
1975 if platformOS (targetPlatform dflags) == OSMinGW32
1976 then "main.exe"
1977 else if staticLink
1978 then "liba.a"
1979 else "a.out"
1980 where s <?.> ext | null (takeExtension s) = s <.> ext
1981 | otherwise = s
1982
1983 maybeCreateManifest
1984 :: DynFlags
1985 -> FilePath -- filename of executable
1986 -> IO [FilePath] -- extra objects to embed, maybe
1987 maybeCreateManifest dflags exe_filename
1988 | platformOS (targetPlatform dflags) == OSMinGW32 &&
1989 gopt Opt_GenManifest dflags
1990 = do let manifest_filename = exe_filename <.> "manifest"
1991
1992 writeFile manifest_filename $
1993 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1994 " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1995 " <assemblyIdentity version=\"1.0.0.0\"\n"++
1996 " processorArchitecture=\"X86\"\n"++
1997 " name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1998 " type=\"win32\"/>\n\n"++
1999 " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
2000 " <security>\n"++
2001 " <requestedPrivileges>\n"++
2002 " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
2003 " </requestedPrivileges>\n"++
2004 " </security>\n"++
2005 " </trustInfo>\n"++
2006 "</assembly>\n"
2007
2008 -- Windows will find the manifest file if it is named
2009 -- foo.exe.manifest. However, for extra robustness, and so that
2010 -- we can move the binary around, we can embed the manifest in
2011 -- the binary itself using windres:
2012 if not (gopt Opt_EmbedManifest dflags) then return [] else do
2013
2014 rc_filename <- newTempName dflags TFL_CurrentModule "rc"
2015 rc_obj_filename <-
2016 newTempName dflags TFL_GhcSession (objectSuf dflags)
2017
2018 writeFile rc_filename $
2019 "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
2020 -- magic numbers :-)
2021 -- show is a bit hackish above, but we need to escape the
2022 -- backslashes in the path.
2023
2024 runWindres dflags $ map SysTools.Option $
2025 ["--input="++rc_filename,
2026 "--output="++rc_obj_filename,
2027 "--output-format=coff"]
2028 -- no FileOptions here: windres doesn't like seeing
2029 -- backslashes, apparently
2030
2031 removeFile manifest_filename
2032
2033 return [rc_obj_filename]
2034 | otherwise = return []
2035
2036
2037 linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
2038 linkDynLibCheck dflags o_files dep_packages
2039 = do
2040 when (haveRtsOptsFlags dflags) $ do
2041 putLogMsg dflags NoReason SevInfo noSrcSpan
2042 (defaultUserStyle dflags)
2043 (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
2044 text " Call hs_init_ghc() from your main() function to set these options.")
2045
2046 linkDynLib dflags o_files dep_packages
2047
2048 -- | Linking a static lib will not really link anything. It will merely produce
2049 -- a static archive of all dependent static libraries. The resulting library
2050 -- will still need to be linked with any remaining link flags.
2051 linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
2052 linkStaticLib dflags o_files dep_packages = do
2053 let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
2054 modules = o_files ++ extra_ld_inputs
2055 output_fn = exeFileName True dflags
2056
2057 full_output_fn <- if isAbsolute output_fn
2058 then return output_fn
2059 else do d <- getCurrentDirectory
2060 return $ normalise (d </> output_fn)
2061 output_exists <- doesFileExist full_output_fn
2062 (when output_exists) $ removeFile full_output_fn
2063
2064 pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages
2065 archives <- concat <$> mapM (collectArchives dflags) pkg_cfgs
2066
2067 ar <- foldl mappend
2068 <$> (Archive <$> mapM loadObj modules)
2069 <*> mapM loadAr archives
2070
2071 if sLdIsGnuLd (settings dflags)
2072 then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
2073 else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
2074
2075 -- run ranlib over the archive. write*Ar does *not* create the symbol index.
2076 runRanlib dflags [SysTools.FileOption "" output_fn]
2077
2078 -- -----------------------------------------------------------------------------
2079 -- Running CPP
2080
2081 doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
2082 doCpp dflags raw input_fn output_fn = do
2083 let hscpp_opts = picPOpts dflags
2084 let cmdline_include_paths = includePaths dflags
2085
2086 pkg_include_dirs <- getPackageIncludePath dflags []
2087 let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
2088 (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
2089 let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
2090 (includePathsQuote cmdline_include_paths)
2091 let include_paths = include_paths_quote ++ include_paths_global
2092
2093 let verbFlags = getVerbFlags dflags
2094
2095 let cpp_prog args | raw = SysTools.runCpp dflags args
2096 | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
2097
2098 let target_defs =
2099 [ "-D" ++ HOST_OS ++ "_BUILD_OS",
2100 "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
2101 "-D" ++ TARGET_OS ++ "_HOST_OS",
2102 "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ]
2103 -- remember, in code we *compile*, the HOST is the same our TARGET,
2104 -- and BUILD is the same as our HOST.
2105
2106 let sse_defs =
2107 [ "-D__SSE__" | isSseEnabled dflags ] ++
2108 [ "-D__SSE2__" | isSse2Enabled dflags ] ++
2109 [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
2110
2111 let avx_defs =
2112 [ "-D__AVX__" | isAvxEnabled dflags ] ++
2113 [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
2114 [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
2115 [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
2116 [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
2117 [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
2118
2119 backend_defs <- getBackendDefs dflags
2120
2121 let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
2122 -- Default CPP defines in Haskell source
2123 ghcVersionH <- getGhcVersionPathName dflags
2124 let hsSourceCppOpts = [ "-include", ghcVersionH ]
2125
2126 -- MIN_VERSION macros
2127 let uids = explicitPackages (pkgState dflags)
2128 pkgs = catMaybes (map (lookupPackage dflags) uids)
2129 mb_macro_include <-
2130 if not (null pkgs) && gopt Opt_VersionMacros dflags
2131 then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
2132 writeFile macro_stub (generatePackageVersionMacros pkgs)
2133 -- Include version macros for every *exposed* package.
2134 -- Without -hide-all-packages and with a package database
2135 -- size of 1000 packages, it takes cpp an estimated 2
2136 -- milliseconds to process this file. See Trac #10970
2137 -- comment 8.
2138 return [SysTools.FileOption "-include" macro_stub]
2139 else return []
2140
2141 cpp_prog ( map SysTools.Option verbFlags
2142 ++ map SysTools.Option include_paths
2143 ++ map SysTools.Option hsSourceCppOpts
2144 ++ map SysTools.Option target_defs
2145 ++ map SysTools.Option backend_defs
2146 ++ map SysTools.Option th_defs
2147 ++ map SysTools.Option hscpp_opts
2148 ++ map SysTools.Option sse_defs
2149 ++ map SysTools.Option avx_defs
2150 ++ mb_macro_include
2151 -- Set the language mode to assembler-with-cpp when preprocessing. This
2152 -- alleviates some of the C99 macro rules relating to whitespace and the hash
2153 -- operator, which we tend to abuse. Clang in particular is not very happy
2154 -- about this.
2155 ++ [ SysTools.Option "-x"
2156 , SysTools.Option "assembler-with-cpp"
2157 , SysTools.Option input_fn
2158 -- We hackily use Option instead of FileOption here, so that the file
2159 -- name is not back-slashed on Windows. cpp is capable of
2160 -- dealing with / in filenames, so it works fine. Furthermore
2161 -- if we put in backslashes, cpp outputs #line directives
2162 -- with *double* backslashes. And that in turn means that
2163 -- our error messages get double backslashes in them.
2164 -- In due course we should arrange that the lexer deals
2165 -- with these \\ escapes properly.
2166 , SysTools.Option "-o"
2167 , SysTools.FileOption "" output_fn
2168 ])
2169
2170 getBackendDefs :: DynFlags -> IO [String]
2171 getBackendDefs dflags | hscTarget dflags == HscLlvm = do
2172 llvmVer <- figureLlvmVersion dflags
2173 return $ case llvmVer of
2174 Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
2175 _ -> []
2176 where
2177 format (major, minor)
2178 | minor >= 100 = error "getBackendDefs: Unsupported minor version"
2179 | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
2180
2181 getBackendDefs _ =
2182 return []
2183
2184 -- ---------------------------------------------------------------------------
2185 -- Macros (cribbed from Cabal)
2186
2187 generatePackageVersionMacros :: [PackageConfig] -> String
2188 generatePackageVersionMacros pkgs = concat
2189 -- Do not add any C-style comments. See Trac #3389.
2190 [ generateMacros "" pkgname version
2191 | pkg <- pkgs
2192 , let version = packageVersion pkg
2193 pkgname = map fixchar (packageNameString pkg)
2194 ]
2195
2196 fixchar :: Char -> Char
2197 fixchar '-' = '_'
2198 fixchar c = c
2199
2200 generateMacros :: String -> String -> Version -> String
2201 generateMacros prefix name version =
2202 concat
2203 ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
2204 ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
2205 ," (major1) < ",major1," || \\\n"
2206 ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
2207 ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
2208 ,"\n\n"
2209 ]
2210 where
2211 (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
2212
2213 -- ---------------------------------------------------------------------------
2214 -- join object files into a single relocatable object file, using ld -r
2215
2216 {-
2217 Note [Produce big objects on Windows]
2218 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2219
2220 The Windows Portable Executable object format has a limit of 32k sections, which
2221 we tend to blow through pretty easily. Thankfully, there is a "big object"
2222 extension, which raises this limit to 2^32. However, it must be explicitly
2223 enabled in the toolchain:
2224
2225 * the assembler accepts the -mbig-obj flag, which causes it to produce a
2226 bigobj-enabled COFF object.
2227
2228 * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name
2229 suggests, this tells the linker to produce a bigobj-enabled COFF object, no a
2230 PE executable.
2231
2232 We must enable bigobj output in a few places:
2233
2234 * When merging object files (DriverPipeline.joinObjectFiles)
2235
2236 * When assembling (DriverPipeline.runPhase (RealPhase As ...))
2237
2238 Unfortunately the big object format is not supported on 32-bit targets so
2239 none of this can be used in that case.
2240 -}
2241
2242 joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
2243 joinObjectFiles dflags o_files output_fn = do
2244 let mySettings = settings dflags
2245 ldIsGnuLd = sLdIsGnuLd mySettings
2246 osInfo = platformOS (targetPlatform dflags)
2247 ld_r args cc = SysTools.runLink dflags ([
2248 SysTools.Option "-nostdlib",
2249 SysTools.Option "-Wl,-r"
2250 ]
2251 -- See Note [No PIE while linking] in DynFlags
2252 ++ (if sGccSupportsNoPie mySettings
2253 then [SysTools.Option "-no-pie"]
2254 else [])
2255
2256 ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]
2257 then []
2258 else [SysTools.Option "-nodefaultlibs"])
2259 ++ (if osInfo == OSFreeBSD
2260 then [SysTools.Option "-L/usr/lib"]
2261 else [])
2262 -- gcc on sparc sets -Wl,--relax implicitly, but
2263 -- -r and --relax are incompatible for ld, so
2264 -- disable --relax explicitly.
2265 ++ (if platformArch (targetPlatform dflags)
2266 `elem` [ArchSPARC, ArchSPARC64]
2267 && ldIsGnuLd
2268 then [SysTools.Option "-Wl,-no-relax"]
2269 else [])
2270 -- See Note [Produce big objects on Windows]
2271 ++ [ SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64"
2272 | OSMinGW32 == osInfo
2273 , not $ target32Bit (targetPlatform dflags)
2274 ]
2275 ++ map SysTools.Option ld_build_id
2276 ++ [ SysTools.Option "-o",
2277 SysTools.FileOption "" output_fn ]
2278 ++ args)
2279
2280 -- suppress the generation of the .note.gnu.build-id section,
2281 -- which we don't need and sometimes causes ld to emit a
2282 -- warning:
2283 ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"]
2284 | otherwise = []
2285
2286 ccInfo <- getCompilerInfo dflags
2287 if ldIsGnuLd
2288 then do
2289 script <- newTempName dflags TFL_CurrentModule "ldscript"
2290 cwd <- getCurrentDirectory
2291 let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
2292 writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
2293 ld_r [SysTools.FileOption "" script] ccInfo
2294 else if sLdSupportsFilelist mySettings
2295 then do
2296 filelist <- newTempName dflags TFL_CurrentModule "filelist"
2297 writeFile filelist $ unlines o_files
2298 ld_r [SysTools.Option "-Wl,-filelist",
2299 SysTools.FileOption "-Wl," filelist] ccInfo
2300 else do
2301 ld_r (map (SysTools.FileOption "") o_files) ccInfo
2302
2303 -- -----------------------------------------------------------------------------
2304 -- Misc.
2305
2306 writeInterfaceOnlyMode :: DynFlags -> Bool
2307 writeInterfaceOnlyMode dflags =
2308 gopt Opt_WriteInterface dflags &&
2309 HscNothing == hscTarget dflags
2310
2311 -- | Figure out if a source file was modified after an output file (or if we
2312 -- anyways need to consider the source file modified since the output is gone).
2313 sourceModified :: FilePath -- ^ destination file we are looking for
2314 -> UTCTime -- ^ last time of modification of source file
2315 -> IO Bool -- ^ do we need to regenerate the output?
2316 sourceModified dest_file src_timestamp = do
2317 dest_file_exists <- doesFileExist dest_file
2318 if not dest_file_exists
2319 then return True -- Need to recompile
2320 else do t2 <- getModificationUTCTime dest_file
2321 return (t2 <= src_timestamp)
2322
2323 -- | What phase to run after one of the backend code generators has run
2324 hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
2325 hscPostBackendPhase _ HsBootFile _ = StopLn
2326 hscPostBackendPhase _ HsigFile _ = StopLn
2327 hscPostBackendPhase dflags _ hsc_lang =
2328 case hsc_lang of
2329 HscC -> HCc
2330 HscAsm | gopt Opt_SplitObjs dflags -> Splitter
2331 | otherwise -> As False
2332 HscLlvm -> LlvmOpt
2333 HscNothing -> StopLn
2334 HscInterpreted -> StopLn
2335
2336 touchObjectFile :: DynFlags -> FilePath -> IO ()
2337 touchObjectFile dflags path = do
2338 createDirectoryIfMissing True $ takeDirectory path
2339 SysTools.touch dflags "Touching object file" path
2340
2341 -- | Find out path to @ghcversion.h@ file
2342 getGhcVersionPathName :: DynFlags -> IO FilePath
2343 getGhcVersionPathName dflags = do
2344 candidates <- case ghcVersionFile dflags of
2345 Just path -> return [path]
2346 Nothing -> (map (</> "ghcversion.h")) <$>
2347 (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
2348
2349 found <- filterM doesFileExist candidates
2350 case found of
2351 [] -> throwGhcExceptionIO (InstallationError
2352 ("ghcversion.h missing; tried: "
2353 ++ intercalate ", " candidates))
2354 (x:_) -> return x
2355
2356 -- Note [-fPIC for assembler]
2357 -- When compiling .c source file GHC's driver pipeline basically
2358 -- does the following two things:
2359 -- 1. ${CC} -S 'PIC_CFLAGS' source.c
2360 -- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S
2361 --
2362 -- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?
2363 -- Because on some architectures (at least sparc32) assembler also chooses
2364 -- the relocation type!
2365 -- Consider the following C module:
2366 --
2367 -- /* pic-sample.c */
2368 -- int v;
2369 -- void set_v (int n) { v = n; }
2370 -- int get_v (void) { return v; }
2371 --
2372 -- $ gcc -S -fPIC pic-sample.c
2373 -- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary
2374 -- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary
2375 --
2376 -- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od
2377 -- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od
2378 -- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od
2379 --
2380 -- Most of architectures won't show any difference in this test, but on sparc32
2381 -- the following assembly snippet:
2382 --
2383 -- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7
2384 --
2385 -- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:
2386 --
2387 -- 3c: 2f 00 00 00 sethi %hi(0), %l7
2388 -- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8
2389 -- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8
2390
2391 {- Note [Don't normalise input filenames]
2392
2393 Summary
2394 We used to normalise input filenames when starting the unlit phase. This
2395 broke hpc in `--make` mode with imported literate modules (#2991).
2396
2397 Introduction
2398 1) --main
2399 When compiling a module with --main, GHC scans its imports to find out which
2400 other modules it needs to compile too. It turns out that there is a small
2401 difference between saying `ghc --make A.hs`, when `A` imports `B`, and
2402 specifying both modules on the command line with `ghc --make A.hs B.hs`. In
2403 the former case, the filename for B is inferred to be './B.hs' instead of
2404 'B.hs'.
2405
2406 2) unlit
2407 When GHC compiles a literate haskell file, the source code first needs to go
2408 through unlit, which turns it into normal Haskell source code. At the start
2409 of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the
2410 option `-h` and the name of the original file. We used to normalise this
2411 filename using System.FilePath.normalise, which among other things removes
2412 an initial './'. unlit then uses that filename in #line directives that it
2413 inserts in the transformed source code.
2414
2415 3) SrcSpan
2416 A SrcSpan represents a portion of a source code file. It has fields
2417 linenumber, start column, end column, and also a reference to the file it
2418 originated from. The SrcSpans for a literate haskell file refer to the
2419 filename that was passed to unlit -h.
2420
2421 4) -fhpc
2422 At some point during compilation with -fhpc, in the function
2423 `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a
2424 `SrcSpan` refers to with the name of the file we are currently compiling.
2425 For some reason I don't yet understand, they can sometimes legitimally be
2426 different, and then hpc ignores that SrcSpan.
2427
2428 Problem
2429 When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate
2430 module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the
2431 start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).
2432 Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are
2433 still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),
2434 doesn't include ticks for B, and we have unhappy customers (#2991).
2435
2436 Solution
2437 Do not normalise `input_fn` when starting the unlit phase.
2438
2439 Alternative solution
2440 Another option would be to not compare the two filenames on equality, but to
2441 use System.FilePath.equalFilePath. That function first normalises its
2442 arguments. The problem is that by the time we need to do the comparison, the
2443 filenames have been turned into FastStrings, probably for performance
2444 reasons, so System.FilePath.equalFilePath can not be used directly.
2445
2446 Archeology
2447 The call to `normalise` was added in a commit called "Fix slash
2448 direction on Windows with the new filePath code" (c9b6b5e8). The problem
2449 that commit was addressing has since been solved in a different manner, in a
2450 commit called "Fix the filename passed to unlit" (1eedbc6b). So the
2451 `normalise` is no longer necessary.
2452 -}