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