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