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