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