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