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