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