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