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