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