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