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