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