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