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