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