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