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