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