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