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