compiler: Write .o files atomically. See #14533
[ghc.git] / compiler / main / DriverPipeline.hs
1 {-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns #-}
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 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 dflags 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 split = gopt Opt_SplitObjs dflags
509 mb_o_file = outputFile dflags
510 ghc_link = ghcLink dflags -- Set by -c or -no-link
511
512 -- When linking, the -o argument refers to the linker's output.
513 -- otherwise, we use it as the name for the pipeline's output.
514 output
515 -- If we are doing -fno-code, then act as if the output is
516 -- 'Temporary'. This stops GHC trying to copy files to their
517 -- final location.
518 | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule
519 | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
520 -- -o foo applies to linker
521 | isJust mb_o_file = SpecificFile
522 -- -o foo applies to the file we are compiling now
523 | otherwise = Persistent
524
525 stop_phase' = case stop_phase of
526 As _ | split -> SplitAs
527 _ -> stop_phase
528
529 ( _, out_file) <- runPipeline stop_phase' hsc_env
530 (src, fmap RealPhase mb_phase) Nothing output
531 Nothing{-no ModLocation-} []
532 return out_file
533
534
535 doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
536 doLink dflags stop_phase o_files
537 | not (isStopLn stop_phase)
538 = return () -- We stopped before the linking phase
539
540 | otherwise
541 = case ghcLink dflags of
542 NoLink -> return ()
543 LinkBinary -> linkBinary dflags o_files []
544 LinkStaticLib -> linkStaticLib dflags o_files []
545 LinkDynLib -> linkDynLibCheck dflags o_files []
546 other -> panicBadLink other
547
548
549 -- ---------------------------------------------------------------------------
550
551 -- | Run a compilation pipeline, consisting of multiple phases.
552 --
553 -- This is the interface to the compilation pipeline, which runs
554 -- a series of compilation steps on a single source file, specifying
555 -- at which stage to stop.
556 --
557 -- The DynFlags can be modified by phases in the pipeline (eg. by
558 -- OPTIONS_GHC pragmas), and the changes affect later phases in the
559 -- pipeline.
560 runPipeline
561 :: Phase -- ^ When to stop
562 -> HscEnv -- ^ Compilation environment
563 -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)
564 -> Maybe FilePath -- ^ original basename (if different from ^^^)
565 -> PipelineOutput -- ^ Output filename
566 -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
567 -> [FilePath] -- ^ foreign objects
568 -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
569 runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
570 mb_basename output maybe_loc foreign_os
571
572 = do let
573 dflags0 = hsc_dflags hsc_env0
574
575 -- Decide where dump files should go based on the pipeline output
576 dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
577 hsc_env = hsc_env0 {hsc_dflags = dflags}
578
579 (input_basename, suffix) = splitExtension input_fn
580 suffix' = drop 1 suffix -- strip off the .
581 basename | Just b <- mb_basename = b
582 | otherwise = input_basename
583
584 -- If we were given a -x flag, then use that phase to start from
585 start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase
586
587 isHaskell (RealPhase (Unlit _)) = True
588 isHaskell (RealPhase (Cpp _)) = True
589 isHaskell (RealPhase (HsPp _)) = True
590 isHaskell (RealPhase (Hsc _)) = True
591 isHaskell (HscOut {}) = True
592 isHaskell _ = False
593
594 isHaskellishFile = isHaskell start_phase
595
596 env = PipeEnv{ stop_phase,
597 src_filename = input_fn,
598 src_basename = basename,
599 src_suffix = suffix',
600 output_spec = output }
601
602 when (isBackpackishSuffix suffix') $
603 throwGhcExceptionIO (UsageError
604 ("use --backpack to process " ++ input_fn))
605
606 -- We want to catch cases of "you can't get there from here" before
607 -- we start the pipeline, because otherwise it will just run off the
608 -- end.
609 let happensBefore' = happensBefore dflags
610 case start_phase of
611 RealPhase start_phase' ->
612 -- See Note [Partial ordering on phases]
613 -- Not the same as: (stop_phase `happensBefore` start_phase')
614 when (not (start_phase' `happensBefore'` stop_phase ||
615 start_phase' `eqPhase` stop_phase)) $
616 throwGhcExceptionIO (UsageError
617 ("cannot compile this file to desired target: "
618 ++ input_fn))
619 HscOut {} -> return ()
620
621 debugTraceMsg dflags 4 (text "Running the pipeline")
622 r <- runPipeline' start_phase hsc_env env input_fn
623 maybe_loc foreign_os
624
625 -- If we are compiling a Haskell module, and doing
626 -- -dynamic-too, but couldn't do the -dynamic-too fast
627 -- path, then rerun the pipeline for the dyn way
628 let dflags = hsc_dflags hsc_env
629 -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
630 when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do
631 when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
632 debugTraceMsg dflags 4
633 (text "Running the pipeline again for -dynamic-too")
634 let dflags' = dynamicTooMkDynamicDynFlags dflags
635 hsc_env' <- newHscEnv dflags'
636 _ <- runPipeline' start_phase hsc_env' env input_fn
637 maybe_loc foreign_os
638 return ()
639 return r
640
641 runPipeline'
642 :: PhasePlus -- ^ When to start
643 -> HscEnv -- ^ Compilation environment
644 -> PipeEnv
645 -> FilePath -- ^ Input filename
646 -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
647 -> [FilePath] -- ^ foreign objects, if we have one
648 -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
649 runPipeline' start_phase hsc_env env input_fn
650 maybe_loc foreign_os
651 = do
652 -- Execute the pipeline...
653 let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }
654
655 evalP (pipeLoop start_phase input_fn) env state
656
657 -- ---------------------------------------------------------------------------
658 -- outer pipeline loop
659
660 -- | pipeLoop runs phases until we reach the stop phase
661 pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
662 pipeLoop phase input_fn = do
663 env <- getPipeEnv
664 dflags <- getDynFlags
665 -- See Note [Partial ordering on phases]
666 let happensBefore' = happensBefore dflags
667 stopPhase = stop_phase env
668 case phase of
669 RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done
670 -> -- Sometimes, a compilation phase doesn't actually generate any output
671 -- (eg. the CPP phase when -fcpp is not turned on). If we end on this
672 -- stage, but we wanted to keep the output, then we have to explicitly
673 -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
674 -- further compilation stages can tell what the original filename was.
675 case output_spec env of
676 Temporary _ ->
677 return (dflags, input_fn)
678 output ->
679 do pst <- getPipeState
680 final_fn <- liftIO $ getOutputFilename
681 stopPhase output (src_basename env)
682 dflags stopPhase (maybe_loc pst)
683 when (final_fn /= input_fn) $ do
684 let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
685 line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
686 liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
687 return (dflags, final_fn)
688
689
690 | not (realPhase `happensBefore'` stopPhase)
691 -- Something has gone wrong. We'll try to cover all the cases when
692 -- this could happen, so if we reach here it is a panic.
693 -- eg. it might happen if the -C flag is used on a source file that
694 -- has {-# OPTIONS -fasm #-}.
695 -> panic ("pipeLoop: at phase " ++ show realPhase ++
696 " but I wanted to stop at phase " ++ show stopPhase)
697
698 _
699 -> do liftIO $ debugTraceMsg dflags 4
700 (text "Running phase" <+> ppr phase)
701 (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
702 r <- pipeLoop next_phase output_fn
703 case phase of
704 HscOut {} ->
705 whenGeneratingDynamicToo dflags $ do
706 setDynFlags $ dynamicTooMkDynamicDynFlags dflags
707 -- TODO shouldn't ignore result:
708 _ <- pipeLoop phase input_fn
709 return ()
710 _ ->
711 return ()
712 return r
713
714 runHookedPhase :: PhasePlus -> FilePath -> DynFlags
715 -> CompPipeline (PhasePlus, FilePath)
716 runHookedPhase pp input dflags =
717 lookupHook runPhaseHook runPhase dflags pp input dflags
718
719 -- -----------------------------------------------------------------------------
720 -- In each phase, we need to know into what filename to generate the
721 -- output. All the logic about which filenames we generate output
722 -- into is embodied in the following function.
723
724 -- | Computes the next output filename after we run @next_phase@.
725 -- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad
726 -- (which specifies all of the ambient information.)
727 phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
728 phaseOutputFilename next_phase = do
729 PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
730 PipeState{maybe_loc, hsc_env} <- getPipeState
731 let dflags = hsc_dflags hsc_env
732 liftIO $ getOutputFilename stop_phase output_spec
733 src_basename dflags next_phase maybe_loc
734
735 -- | Computes the next output filename for something in the compilation
736 -- pipeline. This is controlled by several variables:
737 --
738 -- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This
739 -- is used to tell if we're in the last phase or not, because
740 -- in that case flags like @-o@ may be important.
741 -- 2. 'PipelineOutput': is this intended to be a 'Temporary' or
742 -- 'Persistent' build output? Temporary files just go in
743 -- a fresh temporary name.
744 -- 3. 'String': what was the basename of the original input file?
745 -- 4. 'DynFlags': the obvious thing
746 -- 5. 'Phase': the phase we want to determine the output filename of.
747 -- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're
748 -- compiling; this can be used to override the default output
749 -- of an object file. (TODO: do we actually need this?)
750 getOutputFilename
751 :: Phase -> PipelineOutput -> String
752 -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
753 getOutputFilename stop_phase output basename dflags next_phase maybe_location
754 | is_last_phase, Persistent <- output = persistent_fn
755 | is_last_phase, SpecificFile <- output = case outputFile dflags of
756 Just f -> return f
757 Nothing ->
758 panic "SpecificFile: No filename"
759 | keep_this_output = persistent_fn
760 | Temporary lifetime <- output = newTempName dflags lifetime suffix
761 | otherwise = newTempName dflags TFL_CurrentModule
762 suffix
763 where
764 hcsuf = hcSuf dflags
765 odir = objectDir dflags
766 osuf = objectSuf dflags
767 keep_hc = gopt Opt_KeepHcFiles dflags
768 keep_hscpp = gopt Opt_KeepHscppFiles dflags
769 keep_s = gopt Opt_KeepSFiles dflags
770 keep_bc = gopt Opt_KeepLlvmFiles dflags
771
772 myPhaseInputExt HCc = hcsuf
773 myPhaseInputExt MergeForeign = osuf
774 myPhaseInputExt StopLn = osuf
775 myPhaseInputExt other = phaseInputExt other
776
777 is_last_phase = next_phase `eqPhase` stop_phase
778
779 -- sometimes, we keep output from intermediate stages
780 keep_this_output =
781 case next_phase of
782 As _ | keep_s -> True
783 LlvmOpt | keep_bc -> True
784 HCc | keep_hc -> True
785 HsPp _ | keep_hscpp -> True -- See Trac #10869
786 _other -> False
787
788 suffix = myPhaseInputExt next_phase
789
790 -- persistent object files get put in odir
791 persistent_fn
792 | StopLn <- next_phase = return odir_persistent
793 | otherwise = return persistent
794
795 persistent = basename <.> suffix
796
797 odir_persistent
798 | Just loc <- maybe_location = ml_obj_file loc
799 | Just d <- odir = d </> persistent
800 | otherwise = persistent
801
802
803 -- | The fast LLVM Pipeline skips the mangler and assembler,
804 -- emitting object code directly from llc.
805 --
806 -- slow: opt -> llc -> .s -> mangler -> as -> .o
807 -- fast: opt -> llc -> .o
808 --
809 -- hidden flag: -ffast-llvm
810 --
811 -- if keep-s-files is specified, we need to go through
812 -- the slow pipeline (Kavon Farvardin requested this).
813 fastLlvmPipeline :: DynFlags -> Bool
814 fastLlvmPipeline dflags
815 = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags
816
817 -- | LLVM Options. These are flags to be passed to opt and llc, to ensure
818 -- consistency we list them in pairs, so that they form groups.
819 llvmOptions :: DynFlags
820 -> [(String, String)] -- ^ pairs of (opt, llc) arguments
821 llvmOptions dflags =
822 [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
823 ++ [("-relocation-model=" ++ rmodel
824 ,"-relocation-model=" ++ rmodel) | not (null rmodel)]
825 ++ [("-stack-alignment=" ++ (show align)
826 ,"-stack-alignment=" ++ (show align)) | align > 0 ]
827 ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ]
828
829 -- Additional llc flags
830 ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu)
831 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]
832 ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]
833
834 where target = LLVM_TARGET
835 Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags)
836
837 -- Relocation models
838 rmodel | gopt Opt_PIC dflags = "pic"
839 | positionIndependent dflags = "pic"
840 | WayDyn `elem` ways dflags = "dynamic-no-pic"
841 | otherwise = "static"
842
843 align :: Int
844 align = case platformArch (targetPlatform dflags) of
845 ArchX86_64 | isAvxEnabled dflags -> 32
846 _ -> 0
847
848 attrs :: String
849 attrs = intercalate "," $ mattr
850 ++ ["+sse42" | isSse4_2Enabled dflags ]
851 ++ ["+sse2" | isSse2Enabled dflags ]
852 ++ ["+sse" | isSseEnabled dflags ]
853 ++ ["+avx512f" | isAvx512fEnabled dflags ]
854 ++ ["+avx2" | isAvx2Enabled dflags ]
855 ++ ["+avx" | isAvxEnabled dflags ]
856 ++ ["+avx512cd"| isAvx512cdEnabled dflags ]
857 ++ ["+avx512er"| isAvx512erEnabled dflags ]
858 ++ ["+avx512pf"| isAvx512pfEnabled dflags ]
859 ++ ["+bmi" | isBmiEnabled dflags ]
860 ++ ["+bmi2" | isBmi2Enabled dflags ]
861
862 -- -----------------------------------------------------------------------------
863 -- | Each phase in the pipeline returns the next phase to execute, and the
864 -- name of the file in which the output was placed.
865 --
866 -- We must do things dynamically this way, because we often don't know
867 -- what the rest of the phases will be until part-way through the
868 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
869 -- of a source file can change the latter stages of the pipeline from
870 -- taking the LLVM route to using the native code generator.
871 --
872 runPhase :: PhasePlus -- ^ Run this phase
873 -> FilePath -- ^ name of the input file
874 -> DynFlags -- ^ for convenience, we pass the current dflags in
875 -> CompPipeline (PhasePlus, -- next phase to run
876 FilePath) -- output filename
877
878 -- Invariant: the output filename always contains the output
879 -- Interesting case: Hsc when there is no recompilation to do
880 -- Then the output filename is still a .o file
881
882
883 -------------------------------------------------------------------------------
884 -- Unlit phase
885
886 runPhase (RealPhase (Unlit sf)) input_fn dflags
887 = do
888 output_fn <- phaseOutputFilename (Cpp sf)
889
890 let flags = [ -- The -h option passes the file name for unlit to
891 -- put in a #line directive
892 SysTools.Option "-h"
893 -- See Note [Don't normalise input filenames].
894 , SysTools.Option $ escape input_fn
895 , SysTools.FileOption "" input_fn
896 , SysTools.FileOption "" output_fn
897 ]
898
899 liftIO $ SysTools.runUnlit dflags flags
900
901 return (RealPhase (Cpp sf), output_fn)
902 where
903 -- escape the characters \, ", and ', but don't try to escape
904 -- Unicode or anything else (so we don't use Util.charToC
905 -- here). If we get this wrong, then in
906 -- Coverage.isGoodTickSrcSpan where we check that the filename in
907 -- a SrcLoc is the same as the source filenaame, the two will
908 -- look bogusly different. See test:
909 -- libraries/hpc/tests/function/subdir/tough2.hs
910 escape ('\\':cs) = '\\':'\\': escape cs
911 escape ('\"':cs) = '\\':'\"': escape cs
912 escape ('\'':cs) = '\\':'\'': escape cs
913 escape (c:cs) = c : escape cs
914 escape [] = []
915
916 -------------------------------------------------------------------------------
917 -- Cpp phase : (a) gets OPTIONS out of file
918 -- (b) runs cpp if necessary
919
920 runPhase (RealPhase (Cpp sf)) input_fn dflags0
921 = do
922 src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
923 (dflags1, unhandled_flags, warns)
924 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
925 setDynFlags dflags1
926 liftIO $ checkProcessArgsResult dflags1 unhandled_flags
927
928 if not (xopt LangExt.Cpp dflags1) then do
929 -- we have to be careful to emit warnings only once.
930 unless (gopt Opt_Pp dflags1) $
931 liftIO $ handleFlagWarnings dflags1 warns
932
933 -- no need to preprocess CPP, just pass input file along
934 -- to the next phase of the pipeline.
935 return (RealPhase (HsPp sf), input_fn)
936 else do
937 output_fn <- phaseOutputFilename (HsPp sf)
938 liftIO $ doCpp dflags1 True{-raw-}
939 input_fn output_fn
940 -- re-read the pragmas now that we've preprocessed the file
941 -- See #2464,#3457
942 src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
943 (dflags2, unhandled_flags, warns)
944 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
945 liftIO $ checkProcessArgsResult dflags2 unhandled_flags
946 unless (gopt Opt_Pp dflags2) $
947 liftIO $ handleFlagWarnings dflags2 warns
948 -- the HsPp pass below will emit warnings
949
950 setDynFlags dflags2
951
952 return (RealPhase (HsPp sf), output_fn)
953
954 -------------------------------------------------------------------------------
955 -- HsPp phase
956
957 runPhase (RealPhase (HsPp sf)) input_fn dflags
958 = do
959 if not (gopt Opt_Pp dflags) then
960 -- no need to preprocess, just pass input file along
961 -- to the next phase of the pipeline.
962 return (RealPhase (Hsc sf), input_fn)
963 else do
964 PipeEnv{src_basename, src_suffix} <- getPipeEnv
965 let orig_fn = src_basename <.> src_suffix
966 output_fn <- phaseOutputFilename (Hsc sf)
967 liftIO $ SysTools.runPp dflags
968 ( [ SysTools.Option orig_fn
969 , SysTools.Option input_fn
970 , SysTools.FileOption "" output_fn
971 ]
972 )
973
974 -- re-read pragmas now that we've parsed the file (see #3674)
975 src_opts <- liftIO $ getOptionsFromFile dflags output_fn
976 (dflags1, unhandled_flags, warns)
977 <- liftIO $ parseDynamicFilePragma dflags src_opts
978 setDynFlags dflags1
979 liftIO $ checkProcessArgsResult dflags1 unhandled_flags
980 liftIO $ handleFlagWarnings dflags1 warns
981
982 return (RealPhase (Hsc sf), output_fn)
983
984 -----------------------------------------------------------------------------
985 -- Hsc phase
986
987 -- Compilation of a single module, in "legacy" mode (_not_ under
988 -- the direction of the compilation manager).
989 runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
990 = do -- normal Hsc mode, not mkdependHS
991
992 PipeEnv{ stop_phase=stop,
993 src_basename=basename,
994 src_suffix=suff } <- getPipeEnv
995
996 -- we add the current directory (i.e. the directory in which
997 -- the .hs files resides) to the include path, since this is
998 -- what gcc does, and it's probably what you want.
999 let current_dir = takeDirectory basename
1000 new_includes = addQuoteInclude paths [current_dir]
1001 paths = includePaths dflags0
1002 dflags = dflags0 { includePaths = new_includes }
1003
1004 setDynFlags dflags
1005
1006 -- gather the imports and module name
1007 (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do
1008 do
1009 buf <- hGetStringBuffer input_fn
1010 (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
1011 return (Just buf, mod_name, imps, src_imps)
1012
1013 -- Take -o into account if present
1014 -- Very like -ohi, but we must *only* do this if we aren't linking
1015 -- (If we're linking then the -o applies to the linked thing, not to
1016 -- the object file for one module.)
1017 -- Note the nasty duplication with the same computation in compileFile above
1018 location <- getLocation src_flavour mod_name
1019
1020 let o_file = ml_obj_file location -- The real object file
1021 hi_file = ml_hi_file location
1022 hie_file = ml_hie_file location
1023 dest_file | writeInterfaceOnlyMode dflags
1024 = hi_file
1025 | otherwise
1026 = o_file
1027
1028 -- Figure out if the source has changed, for recompilation avoidance.
1029 --
1030 -- Setting source_unchanged to True means that M.o (or M.hie) seems
1031 -- to be up to date wrt M.hs; so no need to recompile unless imports have
1032 -- changed (which the compiler itself figures out).
1033 -- Setting source_unchanged to False tells the compiler that M.o is out of
1034 -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
1035 src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
1036
1037 source_unchanged <- liftIO $
1038 if not (isStopLn stop)
1039 -- SourceModified unconditionally if
1040 -- (a) recompilation checker is off, or
1041 -- (b) we aren't going all the way to .o file (e.g. ghc -S)
1042 then return SourceModified
1043 -- Otherwise look at file modification dates
1044 else do dest_file_mod <- sourceModified dest_file src_timestamp
1045 hie_file_mod <- if gopt Opt_WriteHie dflags
1046 then sourceModified hie_file
1047 src_timestamp
1048 else pure False
1049 if dest_file_mod || hie_file_mod
1050 then return SourceModified
1051 else return SourceUnmodified
1052
1053 PipeState{hsc_env=hsc_env'} <- getPipeState
1054
1055 -- Tell the finder cache about this module
1056 mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location
1057
1058 -- Make the ModSummary to hand to hscMain
1059 let
1060 mod_summary = ModSummary { ms_mod = mod,
1061 ms_hsc_src = src_flavour,
1062 ms_hspp_file = input_fn,
1063 ms_hspp_opts = dflags,
1064 ms_hspp_buf = hspp_buf,
1065 ms_location = location,
1066 ms_hs_date = src_timestamp,
1067 ms_obj_date = Nothing,
1068 ms_parsed_mod = Nothing,
1069 ms_iface_date = Nothing,
1070 ms_hie_date = Nothing,
1071 ms_textual_imps = imps,
1072 ms_srcimps = src_imps }
1073
1074 -- run the compiler!
1075 let msg hsc_env _ what _ = oneShotMsg hsc_env what
1076 (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
1077 mod_summary source_unchanged Nothing (1,1)
1078
1079 return (HscOut src_flavour mod_name result,
1080 panic "HscOut doesn't have an input filename")
1081
1082 runPhase (HscOut src_flavour mod_name result) _ dflags = do
1083 location <- getLocation src_flavour mod_name
1084 setModLocation location
1085
1086 let o_file = ml_obj_file location -- The real object file
1087 hsc_lang = hscTarget dflags
1088 next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
1089
1090 case result of
1091 HscNotGeneratingCode ->
1092 return (RealPhase StopLn,
1093 panic "No output filename from Hsc when no-code")
1094 HscUpToDate ->
1095 do liftIO $ touchObjectFile dflags o_file
1096 -- The .o file must have a later modification date
1097 -- than the source file (else we wouldn't get Nothing)
1098 -- but we touch it anyway, to keep 'make' happy (we think).
1099 return (RealPhase StopLn, o_file)
1100 HscUpdateBoot ->
1101 do -- In the case of hs-boot files, generate a dummy .o-boot
1102 -- stamp file for the benefit of Make
1103 liftIO $ touchObjectFile dflags o_file
1104 return (RealPhase StopLn, o_file)
1105 HscUpdateSig ->
1106 do -- We need to create a REAL but empty .o file
1107 -- because we are going to attempt to put it in a library
1108 PipeState{hsc_env=hsc_env'} <- getPipeState
1109 let input_fn = expectJust "runPhase" (ml_hs_file location)
1110 basename = dropExtension input_fn
1111 liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name
1112 return (RealPhase StopLn, o_file)
1113 HscRecomp cgguts mod_summary
1114 -> do output_fn <- phaseOutputFilename next_phase
1115
1116 PipeState{hsc_env=hsc_env'} <- getPipeState
1117
1118 (outputFilename, mStub, foreign_files) <- liftIO $
1119 hscGenHardCode hsc_env' cgguts mod_summary output_fn
1120 stub_o <- liftIO (mapM (compileStub hsc_env') mStub)
1121 foreign_os <- liftIO $
1122 mapM (uncurry (compileForeign hsc_env')) foreign_files
1123 setForeignOs (maybe [] return stub_o ++ foreign_os)
1124
1125 return (RealPhase next_phase, outputFilename)
1126
1127 -----------------------------------------------------------------------------
1128 -- Cmm phase
1129
1130 runPhase (RealPhase CmmCpp) input_fn dflags
1131 = do
1132 output_fn <- phaseOutputFilename Cmm
1133 liftIO $ doCpp dflags False{-not raw-}
1134 input_fn output_fn
1135 return (RealPhase Cmm, output_fn)
1136
1137 runPhase (RealPhase Cmm) input_fn dflags
1138 = do
1139 let hsc_lang = hscTarget dflags
1140
1141 let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang
1142
1143 output_fn <- phaseOutputFilename next_phase
1144
1145 PipeState{hsc_env} <- getPipeState
1146
1147 liftIO $ hscCompileCmmFile hsc_env input_fn output_fn
1148
1149 return (RealPhase next_phase, output_fn)
1150
1151 -----------------------------------------------------------------------------
1152 -- Cc phase
1153
1154 -- we don't support preprocessing .c files (with -E) now. Doing so introduces
1155 -- way too many hacks, and I can't say I've ever used it anyway.
1156
1157 runPhase (RealPhase cc_phase) input_fn dflags
1158 | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]
1159 = do
1160 let platform = targetPlatform dflags
1161 hcc = cc_phase `eqPhase` HCc
1162
1163 let cmdline_include_paths = includePaths dflags
1164
1165 -- HC files have the dependent packages stamped into them
1166 pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []
1167
1168 -- add package include paths even if we're just compiling .c
1169 -- files; this is the Value Add(TM) that using ghc instead of
1170 -- gcc gives you :)
1171 pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
1172 let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
1173 (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
1174 let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
1175 (includePathsQuote cmdline_include_paths)
1176 let include_paths = include_paths_quote ++ include_paths_global
1177
1178 let gcc_extra_viac_flags = extraGccViaCFlags dflags
1179 let pic_c_flags = picCCOpts dflags
1180
1181 let verbFlags = getVerbFlags dflags
1182
1183 -- cc-options are not passed when compiling .hc files. Our
1184 -- hc code doesn't not #include any header files anyway, so these
1185 -- options aren't necessary.
1186 pkg_extra_cc_opts <- liftIO $
1187 if cc_phase `eqPhase` HCc
1188 then return []
1189 else getPackageExtraCcOpts dflags pkgs
1190
1191 framework_paths <-
1192 if platformUsesFrameworks platform
1193 then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs
1194 let cmdlineFrameworkPaths = frameworkPaths dflags
1195 return $ map ("-F"++)
1196 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
1197 else return []
1198
1199 let cc_opt | optLevel dflags >= 2 = [ "-O2" ]
1200 | optLevel dflags >= 1 = [ "-O" ]
1201 | otherwise = []
1202
1203 -- Decide next phase
1204 let next_phase = As False
1205 output_fn <- phaseOutputFilename next_phase
1206
1207 let
1208 more_hcc_opts =
1209 -- on x86 the floating point regs have greater precision
1210 -- than a double, which leads to unpredictable results.
1211 -- By default, we turn this off with -ffloat-store unless
1212 -- the user specified -fexcess-precision.
1213 (if platformArch platform == ArchX86 &&
1214 not (gopt Opt_ExcessPrecision dflags)
1215 then [ "-ffloat-store" ]
1216 else []) ++
1217
1218 -- gcc's -fstrict-aliasing allows two accesses to memory
1219 -- to be considered non-aliasing if they have different types.
1220 -- This interacts badly with the C code we generate, which is
1221 -- very weakly typed, being derived from C--.
1222 ["-fno-strict-aliasing"]
1223
1224 ghcVersionH <- liftIO $ getGhcVersionPathName dflags
1225
1226 let gcc_lang_opt | cc_phase `eqPhase` Ccxx = "c++"
1227 | cc_phase `eqPhase` Cobjc = "objective-c"
1228 | cc_phase `eqPhase` Cobjcxx = "objective-c++"
1229 | otherwise = "c"
1230 liftIO $ SysTools.runCc dflags (
1231 -- force the C compiler to interpret this file as C when
1232 -- compiling .hc files, by adding the -x c option.
1233 -- Also useful for plain .c files, just in case GHC saw a
1234 -- -x c option.
1235 [ SysTools.Option "-x", SysTools.Option gcc_lang_opt
1236 , SysTools.FileOption "" input_fn
1237 , SysTools.Option "-o"
1238 , SysTools.FileOption "" output_fn
1239 ]
1240 ++ map SysTools.Option (
1241 pic_c_flags
1242
1243 -- Stub files generated for foreign exports references the runIO_closure
1244 -- and runNonIO_closure symbols, which are defined in the base package.
1245 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
1246 -- way we do the import depends on whether we're currently compiling
1247 -- the base package or not.
1248 ++ (if platformOS platform == OSMinGW32 &&
1249 thisPackage dflags == baseUnitId
1250 then [ "-DCOMPILING_BASE_PACKAGE" ]
1251 else [])
1252
1253 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1254 -- instruction. Note that the user can still override this
1255 -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
1256 -- regardless of the ordering.
1257 --
1258 -- This is a temporary hack. See #2872, commit
1259 -- 5bd3072ac30216a505151601884ac88bf404c9f2
1260 ++ (if platformArch platform == ArchSPARC
1261 then ["-mcpu=v9"]
1262 else [])
1263
1264 -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
1265 ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
1266 then ["-Wimplicit"]
1267 else [])
1268
1269 ++ (if hcc
1270 then gcc_extra_viac_flags ++ more_hcc_opts
1271 else [])
1272 ++ verbFlags
1273 ++ [ "-S" ]
1274 ++ cc_opt
1275 ++ [ "-include", ghcVersionH ]
1276 ++ framework_paths
1277 ++ include_paths
1278 ++ pkg_extra_cc_opts
1279 ))
1280
1281 return (RealPhase next_phase, output_fn)
1282
1283 -----------------------------------------------------------------------------
1284 -- Splitting phase
1285
1286 runPhase (RealPhase Splitter) input_fn dflags
1287 = do -- tmp_pfx is the prefix used for the split .s files
1288
1289 split_s_prefix <-
1290 liftIO $ newTempName dflags TFL_CurrentModule "split"
1291 let n_files_fn = split_s_prefix
1292
1293 liftIO $ SysTools.runSplit dflags
1294 [ SysTools.FileOption "" input_fn
1295 , SysTools.FileOption "" split_s_prefix
1296 , SysTools.FileOption "" n_files_fn
1297 ]
1298
1299 -- Save the number of split files for future references
1300 s <- liftIO $ readFile n_files_fn
1301 let n_files = read s :: Int
1302 dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
1303
1304 setDynFlags dflags'
1305
1306 -- Remember to delete all these files
1307 liftIO $ addFilesToClean dflags' TFL_CurrentModule $
1308 [ split_s_prefix ++ "__" ++ show n ++ ".s"
1309 | n <- [1..n_files]]
1310
1311 return (RealPhase SplitAs,
1312 "**splitter**") -- we don't use the filename in SplitAs
1313
1314 -----------------------------------------------------------------------------
1315 -- As, SpitAs phase : Assembler
1316
1317 -- This is for calling the assembler on a regular assembly file (not split).
1318 runPhase (RealPhase (As with_cpp)) input_fn dflags
1319 = do
1320 -- LLVM from version 3.0 onwards doesn't support the OS X system
1321 -- assembler, so we use clang as the assembler instead. (#5636)
1322 let whichAsProg | hscTarget dflags == HscLlvm &&
1323 platformOS (targetPlatform dflags) == OSDarwin
1324 = return SysTools.runClang
1325 | otherwise = return SysTools.runAs
1326
1327 as_prog <- whichAsProg
1328 let cmdline_include_paths = includePaths dflags
1329 let pic_c_flags = picCCOpts dflags
1330
1331 next_phase <- maybeMergeForeign
1332 output_fn <- phaseOutputFilename next_phase
1333
1334 -- we create directories for the object file, because it
1335 -- might be a hierarchical module.
1336 liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
1337
1338 ccInfo <- liftIO $ getCompilerInfo dflags
1339 let global_includes = [ SysTools.Option ("-I" ++ p)
1340 | p <- includePathsGlobal cmdline_include_paths ]
1341 let local_includes = [ SysTools.Option ("-iquote" ++ p)
1342 | p <- includePathsQuote cmdline_include_paths ]
1343 let runAssembler inputFilename outputFilename
1344 = liftIO $ as_prog dflags
1345 (local_includes ++ global_includes
1346 -- See Note [-fPIC for assembler]
1347 ++ map SysTools.Option pic_c_flags
1348 -- See Note [Produce big objects on Windows]
1349 ++ [ SysTools.Option "-Wa,-mbig-obj"
1350 | platformOS (targetPlatform dflags) == OSMinGW32
1351 , not $ target32Bit (targetPlatform dflags)
1352 ]
1353
1354 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1355 -- instruction so we have to make sure that the assembler accepts the
1356 -- instruction set. Note that the user can still override this
1357 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1358 -- regardless of the ordering.
1359 --
1360 -- This is a temporary hack.
1361 ++ (if platformArch (targetPlatform dflags) == ArchSPARC
1362 then [SysTools.Option "-mcpu=v9"]
1363 else [])
1364 ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
1365 then [SysTools.Option "-Qunused-arguments"]
1366 else [])
1367 ++ [ SysTools.Option "-x"
1368 , if with_cpp
1369 then SysTools.Option "assembler-with-cpp"
1370 else SysTools.Option "assembler"
1371 , SysTools.Option "-c"
1372 , SysTools.FileOption "" inputFilename
1373 , SysTools.Option "-o"
1374 , SysTools.FileOption "" outputFilename
1375 ])
1376
1377 liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
1378
1379 -- Atomic write by writing to temp file and then renaming
1380 let temp_output_fn = output_fn <.> "tmp"
1381 runAssembler input_fn temp_output_fn
1382 liftIO $ renameFile temp_output_fn output_fn
1383
1384 return (RealPhase next_phase, output_fn)
1385
1386
1387 -- This is for calling the assembler on a split assembly file (so a collection
1388 -- of assembly files)
1389 runPhase (RealPhase SplitAs) _input_fn dflags
1390 = do
1391 -- we'll handle the stub_o file in this phase, so don't MergeForeign,
1392 -- just jump straight to StopLn afterwards.
1393 let next_phase = StopLn
1394 output_fn <- phaseOutputFilename next_phase
1395
1396 let base_o = dropExtension output_fn
1397 osuf = objectSuf dflags
1398 split_odir = base_o ++ "_" ++ osuf ++ "_split"
1399
1400 let pic_c_flags = picCCOpts dflags
1401
1402 -- this also creates the hierarchy
1403 liftIO $ createDirectoryIfMissing True split_odir
1404
1405 -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1406 -- later and we don't want to pick up any old objects.
1407 fs <- liftIO $ getDirectoryContents split_odir
1408 liftIO $ mapM_ removeFile $
1409 map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1410
1411 let (split_s_prefix, n) = case splitInfo dflags of
1412 Nothing -> panic "No split info"
1413 Just x -> x
1414
1415 let split_s n = split_s_prefix ++ "__" ++ show n <.> "s"
1416
1417 split_obj :: Int -> FilePath
1418 split_obj n = split_odir </>
1419 takeFileName base_o ++ "__" ++ show n <.> osuf
1420
1421 let assemble_file n
1422 = SysTools.runAs dflags (
1423
1424 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1425 -- instruction so we have to make sure that the assembler accepts the
1426 -- instruction set. Note that the user can still override this
1427 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1428 -- regardless of the ordering.
1429 --
1430 -- This is a temporary hack.
1431 (if platformArch (targetPlatform dflags) == ArchSPARC
1432 then [SysTools.Option "-mcpu=v9"]
1433 else []) ++
1434
1435 -- See Note [-fPIC for assembler]
1436 map SysTools.Option pic_c_flags ++
1437
1438 [ SysTools.Option "-c"
1439 , SysTools.Option "-o"
1440 , SysTools.FileOption "" (split_obj n)
1441 , SysTools.FileOption "" (split_s n)
1442 ])
1443
1444 liftIO $ mapM_ assemble_file [1..n]
1445
1446 -- Note [pipeline-split-init]
1447 -- If we have a stub file -- which will be part of foreign_os --
1448 -- it may contain constructor
1449 -- functions for initialisation of this module. We can't
1450 -- simply leave the stub as a separate object file, because it
1451 -- will never be linked in: nothing refers to it. We need to
1452 -- ensure that if we ever refer to the data in this module
1453 -- that needs initialisation, then we also pull in the
1454 -- initialisation routine.
1455 --
1456 -- To that end, we make a DANGEROUS ASSUMPTION here: the data
1457 -- that needs to be initialised is all in the FIRST split
1458 -- object. See Note [codegen-split-init].
1459 --
1460 -- We also merge in all the foreign objects since we're at it.
1461
1462 PipeState{foreign_os} <- getPipeState
1463 if null foreign_os
1464 then return ()
1465 else liftIO $ do
1466 tmp_split_1 <- newTempName dflags TFL_CurrentModule osuf
1467 let split_1 = split_obj 1
1468 copyFile split_1 tmp_split_1
1469 removeFile split_1
1470 joinObjectFiles dflags (tmp_split_1 : foreign_os) split_1
1471
1472 -- join them into a single .o file
1473 liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
1474
1475 return (RealPhase next_phase, output_fn)
1476
1477 -----------------------------------------------------------------------------
1478 -- LlvmOpt phase
1479 runPhase (RealPhase LlvmOpt) input_fn dflags
1480 = do
1481 output_fn <- phaseOutputFilename LlvmLlc
1482
1483 liftIO $ SysTools.runLlvmOpt dflags
1484 ( optFlag
1485 ++ defaultOptions ++
1486 [ SysTools.FileOption "" input_fn
1487 , SysTools.Option "-o"
1488 , SysTools.FileOption "" output_fn]
1489 )
1490
1491 return (RealPhase LlvmLlc, output_fn)
1492 where
1493 -- we always (unless -optlo specified) run Opt since we rely on it to
1494 -- fix up some pretty big deficiencies in the code we generate
1495 optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2]
1496 llvmOpts = case lookup optIdx $ llvmPasses dflags of
1497 Just passes -> passes
1498 Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "
1499 ++ "is missing passes for level "
1500 ++ show optIdx)
1501
1502 -- don't specify anything if user has specified commands. We do this
1503 -- for opt but not llc since opt is very specifically for optimisation
1504 -- passes only, so if the user is passing us extra options we assume
1505 -- they know what they are doing and don't get in the way.
1506 optFlag = if null (getOpts dflags opt_lo)
1507 then map SysTools.Option $ words llvmOpts
1508 else []
1509
1510 defaultOptions = map SysTools.Option . concat . fmap words . fst
1511 $ unzip (llvmOptions dflags)
1512
1513 -----------------------------------------------------------------------------
1514 -- LlvmLlc phase
1515
1516 runPhase (RealPhase LlvmLlc) input_fn dflags
1517 = do
1518 next_phase <- if fastLlvmPipeline dflags
1519 then maybeMergeForeign
1520 -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
1521 else case gopt Opt_NoLlvmMangler dflags of
1522 False -> return LlvmMangle
1523 True | gopt Opt_SplitObjs dflags -> return Splitter
1524 True -> return (As False)
1525
1526 output_fn <- phaseOutputFilename next_phase
1527
1528 liftIO $ SysTools.runLlvmLlc dflags
1529 ( optFlag
1530 ++ defaultOptions
1531 ++ [ SysTools.FileOption "" input_fn
1532 , SysTools.Option "-o"
1533 , SysTools.FileOption "" output_fn
1534 ]
1535 )
1536
1537 return (RealPhase next_phase, output_fn)
1538 where
1539 -- Note [Clamping of llc optimizations]
1540 --
1541 -- See #13724
1542 --
1543 -- we clamp the llc optimization between [1,2]. This is because passing -O0
1544 -- to llc 3.9 or llc 4.0, the naive register allocator can fail with
1545 --
1546 -- Error while trying to spill R1 from class GPR: Cannot scavenge register
1547 -- without an emergency spill slot!
1548 --
1549 -- Observed at least with target 'arm-unknown-linux-gnueabihf'.
1550 --
1551 --
1552 -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile
1553 -- rts/HeapStackCheck.cmm
1554 --
1555 -- 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
1556 -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40
1557 -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358
1558 -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26
1559 -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876
1560 -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699
1561 -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381
1562 -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457
1563 -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20
1564 -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134
1565 -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498
1566 -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67
1567 -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920
1568 -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133
1569 -- 13 llc 0x000000010195bf0b main + 491
1570 -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1
1571 -- Stack dump:
1572 -- 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
1573 -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.
1574 -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'
1575 --
1576 -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa
1577 --
1578 llvmOpts = case optLevel dflags of
1579 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
1580 1 -> "-O1"
1581 _ -> "-O2"
1582
1583 optFlag = if null (getOpts dflags opt_lc)
1584 then map SysTools.Option $ words llvmOpts
1585 else []
1586
1587 defaultOptions = map SysTools.Option . concat . fmap words . snd
1588 $ unzip (llvmOptions dflags)
1589
1590
1591 -----------------------------------------------------------------------------
1592 -- LlvmMangle phase
1593
1594 runPhase (RealPhase LlvmMangle) input_fn dflags
1595 = do
1596 let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False
1597 output_fn <- phaseOutputFilename next_phase
1598 liftIO $ llvmFixupAsm dflags input_fn output_fn
1599 return (RealPhase next_phase, output_fn)
1600
1601 -----------------------------------------------------------------------------
1602 -- merge in stub objects
1603
1604 runPhase (RealPhase MergeForeign) input_fn dflags
1605 = do
1606 PipeState{foreign_os} <- getPipeState
1607 output_fn <- phaseOutputFilename StopLn
1608 liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
1609 if null foreign_os
1610 then panic "runPhase(MergeForeign): no foreign objects"
1611 else do
1612 liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn
1613 return (RealPhase StopLn, output_fn)
1614
1615 -- warning suppression
1616 runPhase (RealPhase other) _input_fn _dflags =
1617 panic ("runPhase: don't know how to run phase " ++ show other)
1618
1619 maybeMergeForeign :: CompPipeline Phase
1620 maybeMergeForeign
1621 = do
1622 PipeState{foreign_os} <- getPipeState
1623 if null foreign_os then return StopLn else return MergeForeign
1624
1625 getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
1626 getLocation src_flavour mod_name = do
1627 dflags <- getDynFlags
1628
1629 PipeEnv{ src_basename=basename,
1630 src_suffix=suff } <- getPipeEnv
1631 PipeState { maybe_loc=maybe_loc} <- getPipeState
1632 case maybe_loc of
1633 -- Build a ModLocation to pass to hscMain.
1634 -- The source filename is rather irrelevant by now, but it's used
1635 -- by hscMain for messages. hscMain also needs
1636 -- the .hi and .o filenames. If we already have a ModLocation
1637 -- then simply update the extensions of the interface and object
1638 -- files to match the DynFlags, otherwise use the logic in Finder.
1639 Just l -> return $ l
1640 { ml_hs_file = Just $ basename <.> suff
1641 , ml_hi_file = ml_hi_file l -<.> hiSuf dflags
1642 , ml_obj_file = ml_obj_file l -<.> objectSuf dflags
1643 }
1644 _ -> do
1645 location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
1646
1647 -- Boot-ify it if necessary
1648 let location2
1649 | HsBootFile <- src_flavour = addBootSuffixLocnOut location1
1650 | otherwise = location1
1651
1652
1653 -- Take -ohi into account if present
1654 -- This can't be done in mkHomeModuleLocation because
1655 -- it only applies to the module being compiles
1656 let ohi = outputHi dflags
1657 location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
1658 | otherwise = location2
1659
1660 -- Take -o into account if present
1661 -- Very like -ohi, but we must *only* do this if we aren't linking
1662 -- (If we're linking then the -o applies to the linked thing, not to
1663 -- the object file for one module.)
1664 -- Note the nasty duplication with the same computation in compileFile
1665 -- above
1666 let expl_o_file = outputFile dflags
1667 location4 | Just ofile <- expl_o_file
1668 , isNoLink (ghcLink dflags)
1669 = location3 { ml_obj_file = ofile }
1670 | otherwise = location3
1671 return location4
1672
1673 -----------------------------------------------------------------------------
1674 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1675
1676 getHCFilePackages :: FilePath -> IO [InstalledUnitId]
1677 getHCFilePackages filename =
1678 Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1679 l <- hGetLine h
1680 case l of
1681 '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1682 return (map stringToInstalledUnitId (words rest))
1683 _other ->
1684 return []
1685
1686 -----------------------------------------------------------------------------
1687 -- Static linking, of .o files
1688
1689 -- The list of packages passed to link is the list of packages on
1690 -- which this program depends, as discovered by the compilation
1691 -- manager. It is combined with the list of packages that the user
1692 -- specifies on the command line with -package flags.
1693 --
1694 -- In one-shot linking mode, we can't discover the package
1695 -- dependencies (because we haven't actually done any compilation or
1696 -- read any interface files), so the user must explicitly specify all
1697 -- the packages.
1698
1699 {-
1700 Note [-Xlinker -rpath vs -Wl,-rpath]
1701 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1702
1703 -Wl takes a comma-separated list of options which in the case of
1704 -Wl,-rpath -Wl,some,path,with,commas parses the path with commas
1705 as separate options.
1706 Buck, the build system, produces paths with commas in them.
1707
1708 -Xlinker doesn't have this disadvantage and as far as I can tell
1709 it is supported by both gcc and clang. Anecdotally nvcc supports
1710 -Xlinker, but not -Wl.
1711 -}
1712
1713 linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
1714 linkBinary = linkBinary' False
1715
1716 linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
1717 linkBinary' staticLink dflags o_files dep_packages = do
1718 let platform = targetPlatform dflags
1719 mySettings = settings dflags
1720 verbFlags = getVerbFlags dflags
1721 output_fn = exeFileName staticLink dflags
1722
1723 -- get the full list of packages to link with, by combining the
1724 -- explicit packages with the auto packages and all of their
1725 -- dependencies, and eliminating duplicates.
1726
1727 full_output_fn <- if isAbsolute output_fn
1728 then return output_fn
1729 else do d <- getCurrentDirectory
1730 return $ normalise (d </> output_fn)
1731 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1732 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1733 get_pkg_lib_path_opts l
1734 | osElfTarget (platformOS platform) &&
1735 dynLibLoader dflags == SystemDependent &&
1736 WayDyn `elem` ways dflags
1737 = let libpath = if gopt Opt_RelativeDynlibPaths dflags
1738 then "$ORIGIN" </>
1739 (l `makeRelativeTo` full_output_fn)
1740 else l
1741 -- See Note [-Xlinker -rpath vs -Wl,-rpath]
1742 rpath = if gopt Opt_RPath dflags
1743 then ["-Xlinker", "-rpath", "-Xlinker", libpath]
1744 else []
1745 -- Solaris 11's linker does not support -rpath-link option. It silently
1746 -- ignores it and then complains about next option which is -l<some
1747 -- dir> as being a directory and not expected object file, E.g
1748 -- ld: elf error: file
1749 -- /tmp/ghc-src/libraries/base/dist-install/build:
1750 -- elf_begin: I/O error: region read: Is a directory
1751 rpathlink = if (platformOS platform) == OSSolaris2
1752 then []
1753 else ["-Xlinker", "-rpath-link", "-Xlinker", l]
1754 in ["-L" ++ l] ++ rpathlink ++ rpath
1755 | osMachOTarget (platformOS platform) &&
1756 dynLibLoader dflags == SystemDependent &&
1757 WayDyn `elem` ways dflags &&
1758 gopt Opt_RPath dflags
1759 = let libpath = if gopt Opt_RelativeDynlibPaths dflags
1760 then "@loader_path" </>
1761 (l `makeRelativeTo` full_output_fn)
1762 else l
1763 in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
1764 | otherwise = ["-L" ++ l]
1765
1766 pkg_lib_path_opts <-
1767 if gopt Opt_SingleLibFolder dflags
1768 then do
1769 libs <- getLibs dflags dep_packages
1770 tmpDir <- newTempDir dflags
1771 sequence_ [ copyFile lib (tmpDir </> basename)
1772 | (lib, basename) <- libs]
1773 return [ "-L" ++ tmpDir ]
1774 else pure pkg_lib_path_opts
1775
1776 let
1777 dead_strip
1778 | gopt Opt_WholeArchiveHsLibs dflags = []
1779 | otherwise = if osSubsectionsViaSymbols (platformOS platform)
1780 then ["-Wl,-dead_strip"]
1781 else []
1782 let lib_paths = libraryPaths dflags
1783 let lib_path_opts = map ("-L"++) lib_paths
1784
1785 extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
1786 noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
1787
1788 let
1789 (pre_hs_libs, post_hs_libs)
1790 | gopt Opt_WholeArchiveHsLibs dflags
1791 = if platformOS platform == OSDarwin
1792 then (["-Wl,-all_load"], [])
1793 -- OS X does not have a flag to turn off -all_load
1794 else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
1795 | otherwise
1796 = ([],[])
1797
1798 pkg_link_opts <- do
1799 (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages
1800 return $ if staticLink
1801 then package_hs_libs -- If building an executable really means making a static
1802 -- library (e.g. iOS), then we only keep the -l options for
1803 -- HS packages, because libtool doesn't accept other options.
1804 -- In the case of iOS these need to be added by hand to the
1805 -- final link in Xcode.
1806 else other_flags ++ dead_strip
1807 ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
1808 ++ extra_libs
1809 -- -Wl,-u,<sym> contained in other_flags
1810 -- needs to be put before -l<package>,
1811 -- otherwise Solaris linker fails linking
1812 -- a binary with unresolved symbols in RTS
1813 -- which are defined in base package
1814 -- the reason for this is a note in ld(1) about
1815 -- '-u' option: "The placement of this option
1816 -- on the command line is significant.
1817 -- This option must be placed before the library
1818 -- that defines the symbol."
1819
1820 -- frameworks
1821 pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages
1822 let framework_opts = getFrameworkOpts dflags platform
1823
1824 -- probably _stub.o files
1825 let extra_ld_inputs = ldInputs dflags
1826
1827 -- Here are some libs that need to be linked at the *end* of
1828 -- the command line, because they contain symbols that are referred to
1829 -- by the RTS. We can't therefore use the ordinary way opts for these.
1830 let debug_opts | WayDebug `elem` ways dflags = [
1831 #if defined(HAVE_LIBBFD)
1832 "-lbfd", "-liberty"
1833 #endif
1834 ]
1835 | otherwise = []
1836
1837 thread_opts | WayThreaded `elem` ways dflags = [
1838 #if NEED_PTHREAD_LIB
1839 "-lpthread"
1840 #endif
1841 ]
1842 | otherwise = []
1843
1844 rc_objs <- maybeCreateManifest dflags output_fn
1845
1846 let link = if staticLink
1847 then SysTools.runLibtool
1848 else SysTools.runLink
1849 link dflags (
1850 map SysTools.Option verbFlags
1851 ++ [ SysTools.Option "-o"
1852 , SysTools.FileOption "" output_fn
1853 ]
1854 ++ libmLinkOpts
1855 ++ map SysTools.Option (
1856 []
1857
1858 -- See Note [No PIE when linking]
1859 ++ picCCOpts dflags
1860
1861 -- Permit the linker to auto link _symbol to _imp_symbol.
1862 -- This lets us link against DLLs without needing an "import library".
1863 ++ (if platformOS platform == OSMinGW32
1864 then ["-Wl,--enable-auto-import"]
1865 else [])
1866
1867 -- '-no_compact_unwind'
1868 -- C++/Objective-C exceptions cannot use optimised
1869 -- stack unwinding code. The optimised form is the
1870 -- default in Xcode 4 on at least x86_64, and
1871 -- without this flag we're also seeing warnings
1872 -- like
1873 -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
1874 -- on x86.
1875 ++ (if sLdSupportsCompactUnwind mySettings &&
1876 not staticLink &&
1877 (platformOS platform == OSDarwin) &&
1878 case platformArch platform of
1879 ArchX86 -> True
1880 ArchX86_64 -> True
1881 ArchARM {} -> True
1882 ArchARM64 -> True
1883 _ -> False
1884 then ["-Wl,-no_compact_unwind"]
1885 else [])
1886
1887 -- '-Wl,-read_only_relocs,suppress'
1888 -- ld gives loads of warnings like:
1889 -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
1890 -- when linking any program. We're not sure
1891 -- whether this is something we ought to fix, but
1892 -- for now this flags silences them.
1893 ++ (if platformOS platform == OSDarwin &&
1894 platformArch platform == ArchX86 &&
1895 not staticLink
1896 then ["-Wl,-read_only_relocs,suppress"]
1897 else [])
1898
1899 ++ (if sLdIsGnuLd mySettings &&
1900 not (gopt Opt_WholeArchiveHsLibs dflags)
1901 then ["-Wl,--gc-sections"]
1902 else [])
1903
1904 ++ o_files
1905 ++ lib_path_opts)
1906 ++ extra_ld_inputs
1907 ++ map SysTools.Option (
1908 rc_objs
1909 ++ framework_opts
1910 ++ pkg_lib_path_opts
1911 ++ extraLinkObj:noteLinkObjs
1912 ++ pkg_link_opts
1913 ++ pkg_framework_opts
1914 ++ debug_opts
1915 ++ thread_opts
1916 ++ (if platformOS platform == OSDarwin
1917 then [ "-Wl,-dead_strip_dylibs" ]
1918 else [])
1919 ))
1920
1921 exeFileName :: Bool -> DynFlags -> FilePath
1922 exeFileName staticLink dflags
1923 | Just s <- outputFile dflags =
1924 case platformOS (targetPlatform dflags) of
1925 OSMinGW32 -> s <?.> "exe"
1926 _ -> if staticLink
1927 then s <?.> "a"
1928 else s
1929 | otherwise =
1930 if platformOS (targetPlatform dflags) == OSMinGW32
1931 then "main.exe"
1932 else if staticLink
1933 then "liba.a"
1934 else "a.out"
1935 where s <?.> ext | null (takeExtension s) = s <.> ext
1936 | otherwise = s
1937
1938 maybeCreateManifest
1939 :: DynFlags
1940 -> FilePath -- filename of executable
1941 -> IO [FilePath] -- extra objects to embed, maybe
1942 maybeCreateManifest dflags exe_filename
1943 | platformOS (targetPlatform dflags) == OSMinGW32 &&
1944 gopt Opt_GenManifest dflags
1945 = do let manifest_filename = exe_filename <.> "manifest"
1946
1947 writeFile manifest_filename $
1948 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1949 " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1950 " <assemblyIdentity version=\"1.0.0.0\"\n"++
1951 " processorArchitecture=\"X86\"\n"++
1952 " name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1953 " type=\"win32\"/>\n\n"++
1954 " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1955 " <security>\n"++
1956 " <requestedPrivileges>\n"++
1957 " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1958 " </requestedPrivileges>\n"++
1959 " </security>\n"++
1960 " </trustInfo>\n"++
1961 "</assembly>\n"
1962
1963 -- Windows will find the manifest file if it is named
1964 -- foo.exe.manifest. However, for extra robustness, and so that
1965 -- we can move the binary around, we can embed the manifest in
1966 -- the binary itself using windres:
1967 if not (gopt Opt_EmbedManifest dflags) then return [] else do
1968
1969 rc_filename <- newTempName dflags TFL_CurrentModule "rc"
1970 rc_obj_filename <-
1971 newTempName dflags TFL_GhcSession (objectSuf dflags)
1972
1973 writeFile rc_filename $
1974 "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
1975 -- magic numbers :-)
1976 -- show is a bit hackish above, but we need to escape the
1977 -- backslashes in the path.
1978
1979 runWindres dflags $ map SysTools.Option $
1980 ["--input="++rc_filename,
1981 "--output="++rc_obj_filename,
1982 "--output-format=coff"]
1983 -- no FileOptions here: windres doesn't like seeing
1984 -- backslashes, apparently
1985
1986 removeFile manifest_filename
1987
1988 return [rc_obj_filename]
1989 | otherwise = return []
1990
1991
1992 linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
1993 linkDynLibCheck dflags o_files dep_packages
1994 = do
1995 when (haveRtsOptsFlags dflags) $ do
1996 putLogMsg dflags NoReason SevInfo noSrcSpan
1997 (defaultUserStyle dflags)
1998 (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
1999 text " Call hs_init_ghc() from your main() function to set these options.")
2000
2001 linkDynLib dflags o_files dep_packages
2002
2003 -- | Linking a static lib will not really link anything. It will merely produce
2004 -- a static archive of all dependent static libraries. The resulting library
2005 -- will still need to be linked with any remaining link flags.
2006 linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
2007 linkStaticLib dflags o_files dep_packages = do
2008 let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
2009 modules = o_files ++ extra_ld_inputs
2010 output_fn = exeFileName True dflags
2011
2012 full_output_fn <- if isAbsolute output_fn
2013 then return output_fn
2014 else do d <- getCurrentDirectory
2015 return $ normalise (d </> output_fn)
2016 output_exists <- doesFileExist full_output_fn
2017 (when output_exists) $ removeFile full_output_fn
2018
2019 pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages
2020 archives <- concat <$> mapM (collectArchives dflags) pkg_cfgs
2021
2022 ar <- foldl mappend
2023 <$> (Archive <$> mapM loadObj modules)
2024 <*> mapM loadAr archives
2025
2026 if sLdIsGnuLd (settings dflags)
2027 then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
2028 else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
2029
2030 -- run ranlib over the archive. write*Ar does *not* create the symbol index.
2031 runRanlib dflags [SysTools.FileOption "" output_fn]
2032
2033 -- -----------------------------------------------------------------------------
2034 -- Running CPP
2035
2036 doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
2037 doCpp dflags raw input_fn output_fn = do
2038 let hscpp_opts = picPOpts dflags
2039 let cmdline_include_paths = includePaths dflags
2040
2041 pkg_include_dirs <- getPackageIncludePath dflags []
2042 let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
2043 (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
2044 let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
2045 (includePathsQuote cmdline_include_paths)
2046 let include_paths = include_paths_quote ++ include_paths_global
2047
2048 let verbFlags = getVerbFlags dflags
2049
2050 let cpp_prog args | raw = SysTools.runCpp dflags args
2051 | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
2052
2053 let target_defs =
2054 [ "-D" ++ HOST_OS ++ "_BUILD_OS",
2055 "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
2056 "-D" ++ TARGET_OS ++ "_HOST_OS",
2057 "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ]
2058 -- remember, in code we *compile*, the HOST is the same our TARGET,
2059 -- and BUILD is the same as our HOST.
2060
2061 let sse_defs =
2062 [ "-D__SSE__" | isSseEnabled dflags ] ++
2063 [ "-D__SSE2__" | isSse2Enabled dflags ] ++
2064 [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
2065
2066 let avx_defs =
2067 [ "-D__AVX__" | isAvxEnabled dflags ] ++
2068 [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
2069 [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
2070 [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
2071 [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
2072 [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
2073
2074 backend_defs <- getBackendDefs dflags
2075
2076 let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
2077 -- Default CPP defines in Haskell source
2078 ghcVersionH <- getGhcVersionPathName dflags
2079 let hsSourceCppOpts = [ "-include", ghcVersionH ]
2080
2081 -- MIN_VERSION macros
2082 let uids = explicitPackages (pkgState dflags)
2083 pkgs = catMaybes (map (lookupPackage dflags) uids)
2084 mb_macro_include <-
2085 if not (null pkgs) && gopt Opt_VersionMacros dflags
2086 then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
2087 writeFile macro_stub (generatePackageVersionMacros pkgs)
2088 -- Include version macros for every *exposed* package.
2089 -- Without -hide-all-packages and with a package database
2090 -- size of 1000 packages, it takes cpp an estimated 2
2091 -- milliseconds to process this file. See Trac #10970
2092 -- comment 8.
2093 return [SysTools.FileOption "-include" macro_stub]
2094 else return []
2095
2096 cpp_prog ( map SysTools.Option verbFlags
2097 ++ map SysTools.Option include_paths
2098 ++ map SysTools.Option hsSourceCppOpts
2099 ++ map SysTools.Option target_defs
2100 ++ map SysTools.Option backend_defs
2101 ++ map SysTools.Option th_defs
2102 ++ map SysTools.Option hscpp_opts
2103 ++ map SysTools.Option sse_defs
2104 ++ map SysTools.Option avx_defs
2105 ++ mb_macro_include
2106 -- Set the language mode to assembler-with-cpp when preprocessing. This
2107 -- alleviates some of the C99 macro rules relating to whitespace and the hash
2108 -- operator, which we tend to abuse. Clang in particular is not very happy
2109 -- about this.
2110 ++ [ SysTools.Option "-x"
2111 , SysTools.Option "assembler-with-cpp"
2112 , SysTools.Option input_fn
2113 -- We hackily use Option instead of FileOption here, so that the file
2114 -- name is not back-slashed on Windows. cpp is capable of
2115 -- dealing with / in filenames, so it works fine. Furthermore
2116 -- if we put in backslashes, cpp outputs #line directives
2117 -- with *double* backslashes. And that in turn means that
2118 -- our error messages get double backslashes in them.
2119 -- In due course we should arrange that the lexer deals
2120 -- with these \\ escapes properly.
2121 , SysTools.Option "-o"
2122 , SysTools.FileOption "" output_fn
2123 ])
2124
2125 getBackendDefs :: DynFlags -> IO [String]
2126 getBackendDefs dflags | hscTarget dflags == HscLlvm = do
2127 llvmVer <- figureLlvmVersion dflags
2128 return $ case llvmVer of
2129 Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
2130 _ -> []
2131 where
2132 format (major, minor)
2133 | minor >= 100 = error "getBackendDefs: Unsupported minor version"
2134 | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
2135
2136 getBackendDefs _ =
2137 return []
2138
2139 -- ---------------------------------------------------------------------------
2140 -- Macros (cribbed from Cabal)
2141
2142 generatePackageVersionMacros :: [PackageConfig] -> String
2143 generatePackageVersionMacros pkgs = concat
2144 -- Do not add any C-style comments. See Trac #3389.
2145 [ generateMacros "" pkgname version
2146 | pkg <- pkgs
2147 , let version = packageVersion pkg
2148 pkgname = map fixchar (packageNameString pkg)
2149 ]
2150
2151 fixchar :: Char -> Char
2152 fixchar '-' = '_'
2153 fixchar c = c
2154
2155 generateMacros :: String -> String -> Version -> String
2156 generateMacros prefix name version =
2157 concat
2158 ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
2159 ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
2160 ," (major1) < ",major1," || \\\n"
2161 ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
2162 ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
2163 ,"\n\n"
2164 ]
2165 where
2166 (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
2167
2168 -- ---------------------------------------------------------------------------
2169 -- join object files into a single relocatable object file, using ld -r
2170
2171 {-
2172 Note [Produce big objects on Windows]
2173 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2174
2175 The Windows Portable Executable object format has a limit of 32k sections, which
2176 we tend to blow through pretty easily. Thankfully, there is a "big object"
2177 extension, which raises this limit to 2^32. However, it must be explicitly
2178 enabled in the toolchain:
2179
2180 * the assembler accepts the -mbig-obj flag, which causes it to produce a
2181 bigobj-enabled COFF object.
2182
2183 * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name
2184 suggests, this tells the linker to produce a bigobj-enabled COFF object, no a
2185 PE executable.
2186
2187 We must enable bigobj output in a few places:
2188
2189 * When merging object files (DriverPipeline.joinObjectFiles)
2190
2191 * When assembling (DriverPipeline.runPhase (RealPhase As ...))
2192
2193 Unfortunately the big object format is not supported on 32-bit targets so
2194 none of this can be used in that case.
2195 -}
2196
2197 joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
2198 joinObjectFiles dflags o_files output_fn = do
2199 let mySettings = settings dflags
2200 ldIsGnuLd = sLdIsGnuLd mySettings
2201 osInfo = platformOS (targetPlatform dflags)
2202 ld_r args cc = SysTools.runLink dflags ([
2203 SysTools.Option "-nostdlib",
2204 SysTools.Option "-Wl,-r"
2205 ]
2206 -- See Note [No PIE while linking] in DynFlags
2207 ++ (if sGccSupportsNoPie mySettings
2208 then [SysTools.Option "-no-pie"]
2209 else [])
2210
2211 ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]
2212 then []
2213 else [SysTools.Option "-nodefaultlibs"])
2214 ++ (if osInfo == OSFreeBSD
2215 then [SysTools.Option "-L/usr/lib"]
2216 else [])
2217 -- gcc on sparc sets -Wl,--relax implicitly, but
2218 -- -r and --relax are incompatible for ld, so
2219 -- disable --relax explicitly.
2220 ++ (if platformArch (targetPlatform dflags)
2221 `elem` [ArchSPARC, ArchSPARC64]
2222 && ldIsGnuLd
2223 then [SysTools.Option "-Wl,-no-relax"]
2224 else [])
2225 -- See Note [Produce big objects on Windows]
2226 ++ [ SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64"
2227 | OSMinGW32 == osInfo
2228 , not $ target32Bit (targetPlatform dflags)
2229 ]
2230 ++ map SysTools.Option ld_build_id
2231 ++ [ SysTools.Option "-o",
2232 SysTools.FileOption "" output_fn ]
2233 ++ args)
2234
2235 -- suppress the generation of the .note.gnu.build-id section,
2236 -- which we don't need and sometimes causes ld to emit a
2237 -- warning:
2238 ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"]
2239 | otherwise = []
2240
2241 ccInfo <- getCompilerInfo dflags
2242 if ldIsGnuLd
2243 then do
2244 script <- newTempName dflags TFL_CurrentModule "ldscript"
2245 cwd <- getCurrentDirectory
2246 let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
2247 writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
2248 ld_r [SysTools.FileOption "" script] ccInfo
2249 else if sLdSupportsFilelist mySettings
2250 then do
2251 filelist <- newTempName dflags TFL_CurrentModule "filelist"
2252 writeFile filelist $ unlines o_files
2253 ld_r [SysTools.Option "-Wl,-filelist",
2254 SysTools.FileOption "-Wl," filelist] ccInfo
2255 else do
2256 ld_r (map (SysTools.FileOption "") o_files) ccInfo
2257
2258 -- -----------------------------------------------------------------------------
2259 -- Misc.
2260
2261 writeInterfaceOnlyMode :: DynFlags -> Bool
2262 writeInterfaceOnlyMode dflags =
2263 gopt Opt_WriteInterface dflags &&
2264 HscNothing == hscTarget dflags
2265
2266 -- | Figure out if a source file was modified after an output file (or if we
2267 -- anyways need to consider the source file modified since the output is gone).
2268 sourceModified :: FilePath -- ^ destination file we are looking for
2269 -> UTCTime -- ^ last time of modification of source file
2270 -> IO Bool -- ^ do we need to regenerate the output?
2271 sourceModified dest_file src_timestamp = do
2272 dest_file_exists <- doesFileExist dest_file
2273 if not dest_file_exists
2274 then return True -- Need to recompile
2275 else do t2 <- getModificationUTCTime dest_file
2276 return (t2 <= src_timestamp)
2277
2278 -- | What phase to run after one of the backend code generators has run
2279 hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
2280 hscPostBackendPhase _ HsBootFile _ = StopLn
2281 hscPostBackendPhase _ HsigFile _ = StopLn
2282 hscPostBackendPhase dflags _ hsc_lang =
2283 case hsc_lang of
2284 HscC -> HCc
2285 HscAsm | gopt Opt_SplitObjs dflags -> Splitter
2286 | otherwise -> As False
2287 HscLlvm -> LlvmOpt
2288 HscNothing -> StopLn
2289 HscInterpreted -> StopLn
2290
2291 touchObjectFile :: DynFlags -> FilePath -> IO ()
2292 touchObjectFile dflags path = do
2293 createDirectoryIfMissing True $ takeDirectory path
2294 SysTools.touch dflags "Touching object file" path
2295
2296 -- | Find out path to @ghcversion.h@ file
2297 getGhcVersionPathName :: DynFlags -> IO FilePath
2298 getGhcVersionPathName dflags = do
2299 candidates <- case ghcVersionFile dflags of
2300 Just path -> return [path]
2301 Nothing -> (map (</> "ghcversion.h")) <$>
2302 (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
2303
2304 found <- filterM doesFileExist candidates
2305 case found of
2306 [] -> throwGhcExceptionIO (InstallationError
2307 ("ghcversion.h missing; tried: "
2308 ++ intercalate ", " candidates))
2309 (x:_) -> return x
2310
2311 -- Note [-fPIC for assembler]
2312 -- When compiling .c source file GHC's driver pipeline basically
2313 -- does the following two things:
2314 -- 1. ${CC} -S 'PIC_CFLAGS' source.c
2315 -- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S
2316 --
2317 -- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?
2318 -- Because on some architectures (at least sparc32) assembler also chooses
2319 -- the relocation type!
2320 -- Consider the following C module:
2321 --
2322 -- /* pic-sample.c */
2323 -- int v;
2324 -- void set_v (int n) { v = n; }
2325 -- int get_v (void) { return v; }
2326 --
2327 -- $ gcc -S -fPIC pic-sample.c
2328 -- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary
2329 -- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary
2330 --
2331 -- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od
2332 -- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od
2333 -- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od
2334 --
2335 -- Most of architectures won't show any difference in this test, but on sparc32
2336 -- the following assembly snippet:
2337 --
2338 -- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7
2339 --
2340 -- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:
2341 --
2342 -- 3c: 2f 00 00 00 sethi %hi(0), %l7
2343 -- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8
2344 -- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8
2345
2346 {- Note [Don't normalise input filenames]
2347
2348 Summary
2349 We used to normalise input filenames when starting the unlit phase. This
2350 broke hpc in `--make` mode with imported literate modules (#2991).
2351
2352 Introduction
2353 1) --main
2354 When compiling a module with --main, GHC scans its imports to find out which
2355 other modules it needs to compile too. It turns out that there is a small
2356 difference between saying `ghc --make A.hs`, when `A` imports `B`, and
2357 specifying both modules on the command line with `ghc --make A.hs B.hs`. In
2358 the former case, the filename for B is inferred to be './B.hs' instead of
2359 'B.hs'.
2360
2361 2) unlit
2362 When GHC compiles a literate haskell file, the source code first needs to go
2363 through unlit, which turns it into normal Haskell source code. At the start
2364 of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the
2365 option `-h` and the name of the original file. We used to normalise this
2366 filename using System.FilePath.normalise, which among other things removes
2367 an initial './'. unlit then uses that filename in #line directives that it
2368 inserts in the transformed source code.
2369
2370 3) SrcSpan
2371 A SrcSpan represents a portion of a source code file. It has fields
2372 linenumber, start column, end column, and also a reference to the file it
2373 originated from. The SrcSpans for a literate haskell file refer to the
2374 filename that was passed to unlit -h.
2375
2376 4) -fhpc
2377 At some point during compilation with -fhpc, in the function
2378 `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a
2379 `SrcSpan` refers to with the name of the file we are currently compiling.
2380 For some reason I don't yet understand, they can sometimes legitimally be
2381 different, and then hpc ignores that SrcSpan.
2382
2383 Problem
2384 When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate
2385 module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the
2386 start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).
2387 Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are
2388 still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),
2389 doesn't include ticks for B, and we have unhappy customers (#2991).
2390
2391 Solution
2392 Do not normalise `input_fn` when starting the unlit phase.
2393
2394 Alternative solution
2395 Another option would be to not compare the two filenames on equality, but to
2396 use System.FilePath.equalFilePath. That function first normalises its
2397 arguments. The problem is that by the time we need to do the comparison, the
2398 filenames have been turned into FastStrings, probably for performance
2399 reasons, so System.FilePath.equalFilePath can not be used directly.
2400
2401 Archeology
2402 The call to `normalise` was added in a commit called "Fix slash
2403 direction on Windows with the new filePath code" (c9b6b5e8). The problem
2404 that commit was addressing has since been solved in a different manner, in a
2405 commit called "Fix the filename passed to unlit" (1eedbc6b). So the
2406 `normalise` is no longer necessary.
2407 -}