Fix #9243 so recompilation avoidance works with -fno-code
[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, writeInterfaceOnlyMode
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 hi_file = ml_hi_file location
939 dest_file | writeInterfaceOnlyMode dflags
940 = hi_file
941 | otherwise
942 = o_file
943
944 -- Figure out if the source has changed, for recompilation avoidance.
945 --
946 -- Setting source_unchanged to True means that M.o seems
947 -- to be up to date wrt M.hs; so no need to recompile unless imports have
948 -- changed (which the compiler itself figures out).
949 -- Setting source_unchanged to False tells the compiler that M.o is out of
950 -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
951 src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
952
953 source_unchanged <- liftIO $
954 if not (isStopLn stop)
955 -- SourceModified unconditionally if
956 -- (a) recompilation checker is off, or
957 -- (b) we aren't going all the way to .o file (e.g. ghc -S)
958 then return SourceModified
959 -- Otherwise look at file modification dates
960 else do dest_file_exists <- doesFileExist dest_file
961 if not dest_file_exists
962 then return SourceModified -- Need to recompile
963 else do t2 <- getModificationUTCTime dest_file
964 if t2 > src_timestamp
965 then return SourceUnmodified
966 else return SourceModified
967
968 PipeState{hsc_env=hsc_env'} <- getPipeState
969
970 -- Tell the finder cache about this module
971 mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location
972
973 -- Make the ModSummary to hand to hscMain
974 let
975 mod_summary = ModSummary { ms_mod = mod,
976 ms_hsc_src = src_flavour,
977 ms_hspp_file = input_fn,
978 ms_hspp_opts = dflags,
979 ms_hspp_buf = hspp_buf,
980 ms_location = location,
981 ms_hs_date = src_timestamp,
982 ms_obj_date = Nothing,
983 ms_iface_date = Nothing,
984 ms_textual_imps = imps,
985 ms_srcimps = src_imps }
986
987 -- run the compiler!
988 result <- liftIO $ hscCompileOneShot hsc_env'
989 mod_summary source_unchanged
990
991 return (HscOut src_flavour mod_name result,
992 panic "HscOut doesn't have an input filename")
993
994 runPhase (HscOut src_flavour mod_name result) _ dflags = do
995 location <- getLocation src_flavour mod_name
996 setModLocation location
997
998 let o_file = ml_obj_file location -- The real object file
999 hsc_lang = hscTarget dflags
1000 next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
1001
1002 case result of
1003 HscNotGeneratingCode ->
1004 return (RealPhase next_phase,
1005 panic "No output filename from Hsc when no-code")
1006 HscUpToDate ->
1007 do liftIO $ touchObjectFile dflags o_file
1008 -- The .o file must have a later modification date
1009 -- than the source file (else we wouldn't get Nothing)
1010 -- but we touch it anyway, to keep 'make' happy (we think).
1011 return (RealPhase StopLn, o_file)
1012 HscUpdateBoot ->
1013 do -- In the case of hs-boot files, generate a dummy .o-boot
1014 -- stamp file for the benefit of Make
1015 liftIO $ touchObjectFile dflags o_file
1016 return (RealPhase next_phase, o_file)
1017 HscUpdateSig ->
1018 do -- We need to create a REAL but empty .o file
1019 -- because we are going to attempt to put it in a library
1020 PipeState{hsc_env=hsc_env'} <- getPipeState
1021 let input_fn = expectJust "runPhase" (ml_hs_file location)
1022 basename = dropExtension input_fn
1023 liftIO $ compileEmptyStub dflags hsc_env' basename location
1024 return (RealPhase next_phase, o_file)
1025 HscRecomp cgguts mod_summary
1026 -> do output_fn <- phaseOutputFilename next_phase
1027
1028 PipeState{hsc_env=hsc_env'} <- getPipeState
1029
1030 (outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary output_fn
1031 case mStub of
1032 Nothing -> return ()
1033 Just stub_c ->
1034 do stub_o <- liftIO $ compileStub hsc_env' stub_c
1035 setStubO stub_o
1036
1037 return (RealPhase next_phase, outputFilename)
1038
1039 -----------------------------------------------------------------------------
1040 -- Cmm phase
1041
1042 runPhase (RealPhase CmmCpp) input_fn dflags
1043 = do
1044 output_fn <- phaseOutputFilename Cmm
1045 liftIO $ doCpp dflags False{-not raw-}
1046 input_fn output_fn
1047 return (RealPhase Cmm, output_fn)
1048
1049 runPhase (RealPhase Cmm) input_fn dflags
1050 = do
1051 let hsc_lang = hscTarget dflags
1052
1053 let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang
1054
1055 output_fn <- phaseOutputFilename next_phase
1056
1057 PipeState{hsc_env} <- getPipeState
1058
1059 liftIO $ hscCompileCmmFile hsc_env input_fn output_fn
1060
1061 return (RealPhase next_phase, output_fn)
1062
1063 -----------------------------------------------------------------------------
1064 -- Cc phase
1065
1066 -- we don't support preprocessing .c files (with -E) now. Doing so introduces
1067 -- way too many hacks, and I can't say I've ever used it anyway.
1068
1069 runPhase (RealPhase cc_phase) input_fn dflags
1070 | any (cc_phase `eqPhase`) [Cc, Ccpp, HCc, Cobjc, Cobjcpp]
1071 = do
1072 let platform = targetPlatform dflags
1073 hcc = cc_phase `eqPhase` HCc
1074
1075 let cmdline_include_paths = includePaths dflags
1076
1077 -- HC files have the dependent packages stamped into them
1078 pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []
1079
1080 -- add package include paths even if we're just compiling .c
1081 -- files; this is the Value Add(TM) that using ghc instead of
1082 -- gcc gives you :)
1083 pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
1084 let include_paths = foldr (\ x xs -> ("-I" ++ x) : xs) []
1085 (cmdline_include_paths ++ pkg_include_dirs)
1086
1087 let gcc_extra_viac_flags = extraGccViaCFlags dflags
1088 let pic_c_flags = picCCOpts dflags
1089
1090 let verbFlags = getVerbFlags dflags
1091
1092 -- cc-options are not passed when compiling .hc files. Our
1093 -- hc code doesn't not #include any header files anyway, so these
1094 -- options aren't necessary.
1095 pkg_extra_cc_opts <- liftIO $
1096 if cc_phase `eqPhase` HCc
1097 then return []
1098 else getPackageExtraCcOpts dflags pkgs
1099
1100 framework_paths <-
1101 if platformUsesFrameworks platform
1102 then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs
1103 let cmdlineFrameworkPaths = frameworkPaths dflags
1104 return $ map ("-F"++)
1105 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
1106 else return []
1107
1108 let split_objs = gopt Opt_SplitObjs dflags
1109 split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
1110 | otherwise = [ ]
1111
1112 let cc_opt | optLevel dflags >= 2 = [ "-O2" ]
1113 | optLevel dflags >= 1 = [ "-O" ]
1114 | otherwise = []
1115
1116 -- Decide next phase
1117 let next_phase = As False
1118 output_fn <- phaseOutputFilename next_phase
1119
1120 let
1121 more_hcc_opts =
1122 -- on x86 the floating point regs have greater precision
1123 -- than a double, which leads to unpredictable results.
1124 -- By default, we turn this off with -ffloat-store unless
1125 -- the user specified -fexcess-precision.
1126 (if platformArch platform == ArchX86 &&
1127 not (gopt Opt_ExcessPrecision dflags)
1128 then [ "-ffloat-store" ]
1129 else []) ++
1130
1131 -- gcc's -fstrict-aliasing allows two accesses to memory
1132 -- to be considered non-aliasing if they have different types.
1133 -- This interacts badly with the C code we generate, which is
1134 -- very weakly typed, being derived from C--.
1135 ["-fno-strict-aliasing"]
1136
1137 ghcVersionH <- liftIO $ getGhcVersionPathName dflags
1138
1139 let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++"
1140 | cc_phase `eqPhase` Cobjc = "objective-c"
1141 | cc_phase `eqPhase` Cobjcpp = "objective-c++"
1142 | otherwise = "c"
1143 liftIO $ SysTools.runCc dflags (
1144 -- force the C compiler to interpret this file as C when
1145 -- compiling .hc files, by adding the -x c option.
1146 -- Also useful for plain .c files, just in case GHC saw a
1147 -- -x c option.
1148 [ SysTools.Option "-x", SysTools.Option gcc_lang_opt
1149 , SysTools.FileOption "" input_fn
1150 , SysTools.Option "-o"
1151 , SysTools.FileOption "" output_fn
1152 ]
1153 ++ map SysTools.Option (
1154 pic_c_flags
1155
1156 -- Stub files generated for foreign exports references the runIO_closure
1157 -- and runNonIO_closure symbols, which are defined in the base package.
1158 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
1159 -- way we do the import depends on whether we're currently compiling
1160 -- the base package or not.
1161 ++ (if platformOS platform == OSMinGW32 &&
1162 thisPackage dflags == basePackageKey
1163 then [ "-DCOMPILING_BASE_PACKAGE" ]
1164 else [])
1165
1166 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1167 -- instruction. Note that the user can still override this
1168 -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
1169 -- regardless of the ordering.
1170 --
1171 -- This is a temporary hack. See #2872, commit
1172 -- 5bd3072ac30216a505151601884ac88bf404c9f2
1173 ++ (if platformArch platform == ArchSPARC
1174 then ["-mcpu=v9"]
1175 else [])
1176
1177 -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
1178 ++ (if (cc_phase /= Ccpp && cc_phase /= Cobjcpp)
1179 then ["-Wimplicit"]
1180 else [])
1181
1182 ++ (if hcc
1183 then gcc_extra_viac_flags ++ more_hcc_opts
1184 else [])
1185 ++ verbFlags
1186 ++ [ "-S" ]
1187 ++ cc_opt
1188 ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt
1189 , "-include", ghcVersionH
1190 ]
1191 ++ framework_paths
1192 ++ split_opt
1193 ++ include_paths
1194 ++ pkg_extra_cc_opts
1195 ))
1196
1197 return (RealPhase next_phase, output_fn)
1198
1199 -----------------------------------------------------------------------------
1200 -- Splitting phase
1201
1202 runPhase (RealPhase Splitter) input_fn dflags
1203 = do -- tmp_pfx is the prefix used for the split .s files
1204
1205 split_s_prefix <- liftIO $ SysTools.newTempName dflags "split"
1206 let n_files_fn = split_s_prefix
1207
1208 liftIO $ SysTools.runSplit dflags
1209 [ SysTools.FileOption "" input_fn
1210 , SysTools.FileOption "" split_s_prefix
1211 , SysTools.FileOption "" n_files_fn
1212 ]
1213
1214 -- Save the number of split files for future references
1215 s <- liftIO $ readFile n_files_fn
1216 let n_files = read s :: Int
1217 dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
1218
1219 setDynFlags dflags'
1220
1221 -- Remember to delete all these files
1222 liftIO $ addFilesToClean dflags'
1223 [ split_s_prefix ++ "__" ++ show n ++ ".s"
1224 | n <- [1..n_files]]
1225
1226 return (RealPhase SplitAs,
1227 "**splitter**") -- we don't use the filename in SplitAs
1228
1229 -----------------------------------------------------------------------------
1230 -- As, SpitAs phase : Assembler
1231
1232 -- This is for calling the assembler on a regular assembly file (not split).
1233 runPhase (RealPhase (As with_cpp)) input_fn dflags
1234 = do
1235 -- LLVM from version 3.0 onwards doesn't support the OS X system
1236 -- assembler, so we use clang as the assembler instead. (#5636)
1237 let whichAsProg | hscTarget dflags == HscLlvm &&
1238 platformOS (targetPlatform dflags) == OSDarwin
1239 = do
1240 -- be careful what options we call clang with
1241 -- see #5903 and #7617 for bugs caused by this.
1242 llvmVer <- liftIO $ figureLlvmVersion dflags
1243 return $ case llvmVer of
1244 Just n | n >= 30 -> SysTools.runClang
1245 _ -> SysTools.runAs
1246
1247 | otherwise = return SysTools.runAs
1248
1249 as_prog <- whichAsProg
1250 let cmdline_include_paths = includePaths dflags
1251 let pic_c_flags = picCCOpts dflags
1252
1253 next_phase <- maybeMergeStub
1254 output_fn <- phaseOutputFilename next_phase
1255
1256 -- we create directories for the object file, because it
1257 -- might be a hierarchical module.
1258 liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
1259
1260 ccInfo <- liftIO $ getCompilerInfo dflags
1261 let runAssembler inputFilename outputFilename
1262 = liftIO $ as_prog dflags
1263 ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
1264
1265 -- See Note [-fPIC for assembler]
1266 ++ map SysTools.Option pic_c_flags
1267
1268 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1269 -- instruction so we have to make sure that the assembler accepts the
1270 -- instruction set. Note that the user can still override this
1271 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1272 -- regardless of the ordering.
1273 --
1274 -- This is a temporary hack.
1275 ++ (if platformArch (targetPlatform dflags) == ArchSPARC
1276 then [SysTools.Option "-mcpu=v9"]
1277 else [])
1278 ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
1279 then [SysTools.Option "-Qunused-arguments"]
1280 else [])
1281 ++ [ SysTools.Option "-x"
1282 , if with_cpp
1283 then SysTools.Option "assembler-with-cpp"
1284 else SysTools.Option "assembler"
1285 , SysTools.Option "-c"
1286 , SysTools.FileOption "" inputFilename
1287 , SysTools.Option "-o"
1288 , SysTools.FileOption "" outputFilename
1289 ])
1290
1291 liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
1292 runAssembler input_fn output_fn
1293 return (RealPhase next_phase, output_fn)
1294
1295
1296 -- This is for calling the assembler on a split assembly file (so a collection
1297 -- of assembly files)
1298 runPhase (RealPhase SplitAs) _input_fn dflags
1299 = do
1300 -- we'll handle the stub_o file in this phase, so don't MergeStub,
1301 -- just jump straight to StopLn afterwards.
1302 let next_phase = StopLn
1303 output_fn <- phaseOutputFilename next_phase
1304
1305 let base_o = dropExtension output_fn
1306 osuf = objectSuf dflags
1307 split_odir = base_o ++ "_" ++ osuf ++ "_split"
1308
1309 let pic_c_flags = picCCOpts dflags
1310
1311 -- this also creates the hierarchy
1312 liftIO $ createDirectoryIfMissing True split_odir
1313
1314 -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1315 -- later and we don't want to pick up any old objects.
1316 fs <- liftIO $ getDirectoryContents split_odir
1317 liftIO $ mapM_ removeFile $
1318 map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1319
1320 let (split_s_prefix, n) = case splitInfo dflags of
1321 Nothing -> panic "No split info"
1322 Just x -> x
1323
1324 let split_s n = split_s_prefix ++ "__" ++ show n <.> "s"
1325
1326 split_obj :: Int -> FilePath
1327 split_obj n = split_odir </>
1328 takeFileName base_o ++ "__" ++ show n <.> osuf
1329
1330 let assemble_file n
1331 = SysTools.runAs dflags (
1332
1333 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1334 -- instruction so we have to make sure that the assembler accepts the
1335 -- instruction set. Note that the user can still override this
1336 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1337 -- regardless of the ordering.
1338 --
1339 -- This is a temporary hack.
1340 (if platformArch (targetPlatform dflags) == ArchSPARC
1341 then [SysTools.Option "-mcpu=v9"]
1342 else []) ++
1343
1344 -- See Note [-fPIC for assembler]
1345 map SysTools.Option pic_c_flags ++
1346
1347 [ SysTools.Option "-c"
1348 , SysTools.Option "-o"
1349 , SysTools.FileOption "" (split_obj n)
1350 , SysTools.FileOption "" (split_s n)
1351 ])
1352
1353 liftIO $ mapM_ assemble_file [1..n]
1354
1355 -- Note [pipeline-split-init]
1356 -- If we have a stub file, it may contain constructor
1357 -- functions for initialisation of this module. We can't
1358 -- simply leave the stub as a separate object file, because it
1359 -- will never be linked in: nothing refers to it. We need to
1360 -- ensure that if we ever refer to the data in this module
1361 -- that needs initialisation, then we also pull in the
1362 -- initialisation routine.
1363 --
1364 -- To that end, we make a DANGEROUS ASSUMPTION here: the data
1365 -- that needs to be initialised is all in the FIRST split
1366 -- object. See Note [codegen-split-init].
1367
1368 PipeState{maybe_stub_o} <- getPipeState
1369 case maybe_stub_o of
1370 Nothing -> return ()
1371 Just stub_o -> liftIO $ do
1372 tmp_split_1 <- newTempName dflags osuf
1373 let split_1 = split_obj 1
1374 copyFile split_1 tmp_split_1
1375 removeFile split_1
1376 joinObjectFiles dflags [tmp_split_1, stub_o] split_1
1377
1378 -- join them into a single .o file
1379 liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
1380
1381 return (RealPhase next_phase, output_fn)
1382
1383 -----------------------------------------------------------------------------
1384 -- LlvmOpt phase
1385
1386 runPhase (RealPhase LlvmOpt) input_fn dflags
1387 = do
1388 ver <- liftIO $ readIORef (llvmVersion dflags)
1389
1390 let opt_lvl = max 0 (min 2 $ optLevel dflags)
1391 -- don't specify anything if user has specified commands. We do this
1392 -- for opt but not llc since opt is very specifically for optimisation
1393 -- passes only, so if the user is passing us extra options we assume
1394 -- they know what they are doing and don't get in the way.
1395 optFlag = if null (getOpts dflags opt_lo)
1396 then map SysTools.Option $ words (llvmOpts ver !! opt_lvl)
1397 else []
1398 tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier
1399 | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
1400 | otherwise = "--enable-tbaa=false"
1401
1402
1403 output_fn <- phaseOutputFilename LlvmLlc
1404
1405 liftIO $ SysTools.runLlvmOpt dflags
1406 ([ SysTools.FileOption "" input_fn,
1407 SysTools.Option "-o",
1408 SysTools.FileOption "" output_fn]
1409 ++ optFlag
1410 ++ [SysTools.Option tbaa])
1411
1412 return (RealPhase LlvmLlc, output_fn)
1413 where
1414 -- we always (unless -optlo specified) run Opt since we rely on it to
1415 -- fix up some pretty big deficiencies in the code we generate
1416 llvmOpts ver = [ "-mem2reg -globalopt"
1417 , if ver >= 34 then "-O1 -globalopt" else "-O1"
1418 -- LLVM 3.4 -O1 doesn't eliminate aliases reliably (bug #8855)
1419 , "-O2"
1420 ]
1421
1422 -----------------------------------------------------------------------------
1423 -- LlvmLlc phase
1424
1425 runPhase (RealPhase LlvmLlc) input_fn dflags
1426 = do
1427 ver <- liftIO $ readIORef (llvmVersion dflags)
1428
1429 let opt_lvl = max 0 (min 2 $ optLevel dflags)
1430 -- iOS requires external references to be loaded indirectly from the
1431 -- DATA segment or dyld traps at runtime writing into TEXT: see #7722
1432 rmodel | platformOS (targetPlatform dflags) == OSiOS = "dynamic-no-pic"
1433 | gopt Opt_PIC dflags = "pic"
1434 | not (gopt Opt_Static dflags) = "dynamic-no-pic"
1435 | otherwise = "static"
1436 tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier
1437 | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
1438 | otherwise = "--enable-tbaa=false"
1439
1440 -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
1441 let next_phase = case gopt Opt_NoLlvmMangler dflags of
1442 False -> LlvmMangle
1443 True | gopt Opt_SplitObjs dflags -> Splitter
1444 True -> As False
1445
1446 output_fn <- phaseOutputFilename next_phase
1447
1448 -- AVX can cause LLVM 3.2 to generate a C-like frame pointer
1449 -- prelude, see #9391
1450 when (ver == 32 && isAvxEnabled dflags) $ liftIO $ errorMsg dflags $ text
1451 "Note: LLVM 3.2 has known problems with AVX instructions (see trac #9391)"
1452
1453 liftIO $ SysTools.runLlvmLlc dflags
1454 ([ SysTools.Option (llvmOpts !! opt_lvl),
1455 SysTools.Option $ "-relocation-model=" ++ rmodel,
1456 SysTools.FileOption "" input_fn,
1457 SysTools.Option "-o", SysTools.FileOption "" output_fn]
1458 ++ [SysTools.Option tbaa]
1459 ++ map SysTools.Option fpOpts
1460 ++ map SysTools.Option abiOpts
1461 ++ map SysTools.Option sseOpts
1462 ++ map SysTools.Option (avxOpts ver)
1463 ++ map SysTools.Option avx512Opts
1464 ++ map SysTools.Option stackAlignOpts)
1465
1466 return (RealPhase next_phase, output_fn)
1467 where
1468 -- Bug in LLVM at O3 on OSX.
1469 llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
1470 then ["-O1", "-O2", "-O2"]
1471 else ["-O1", "-O2", "-O3"]
1472 -- On ARMv7 using LLVM, LLVM fails to allocate floating point registers
1473 -- while compiling GHC source code. It's probably due to fact that it
1474 -- does not enable VFP by default. Let's do this manually here
1475 fpOpts = case platformArch (targetPlatform dflags) of
1476 ArchARM ARMv7 ext _ -> if (elem VFPv3 ext)
1477 then ["-mattr=+v7,+vfp3"]
1478 else if (elem VFPv3D16 ext)
1479 then ["-mattr=+v7,+vfp3,+d16"]
1480 else []
1481 ArchARM ARMv6 ext _ -> if (elem VFPv2 ext)
1482 then ["-mattr=+v6,+vfp2"]
1483 else ["-mattr=+v6"]
1484 _ -> []
1485 -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still
1486 -- compiles into soft-float ABI. We need to explicitly set abi
1487 -- to hard
1488 abiOpts = case platformArch (targetPlatform dflags) of
1489 ArchARM _ _ HARD -> ["-float-abi=hard"]
1490 ArchARM _ _ _ -> []
1491 _ -> []
1492
1493 sseOpts | isSse4_2Enabled dflags = ["-mattr=+sse42"]
1494 | isSse2Enabled dflags = ["-mattr=+sse2"]
1495 | isSseEnabled dflags = ["-mattr=+sse"]
1496 | otherwise = []
1497
1498 avxOpts ver | isAvx512fEnabled dflags = ["-mattr=+avx512f"]
1499 | isAvx2Enabled dflags = ["-mattr=+avx2"]
1500 | isAvxEnabled dflags = ["-mattr=+avx"]
1501 | ver == 32 = ["-mattr=-avx"] -- see #9391
1502 | otherwise = []
1503
1504 avx512Opts =
1505 [ "-mattr=+avx512cd" | isAvx512cdEnabled dflags ] ++
1506 [ "-mattr=+avx512er" | isAvx512erEnabled dflags ] ++
1507 [ "-mattr=+avx512pf" | isAvx512pfEnabled dflags ]
1508
1509 stackAlignOpts =
1510 case platformArch (targetPlatform dflags) of
1511 ArchX86_64 | isAvxEnabled dflags -> ["-stack-alignment=32"]
1512 _ -> []
1513
1514 -----------------------------------------------------------------------------
1515 -- LlvmMangle phase
1516
1517 runPhase (RealPhase LlvmMangle) input_fn dflags
1518 = do
1519 let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False
1520 output_fn <- phaseOutputFilename next_phase
1521 liftIO $ llvmFixupAsm dflags input_fn output_fn
1522 return (RealPhase next_phase, output_fn)
1523
1524 -----------------------------------------------------------------------------
1525 -- merge in stub objects
1526
1527 runPhase (RealPhase MergeStub) input_fn dflags
1528 = do
1529 PipeState{maybe_stub_o} <- getPipeState
1530 output_fn <- phaseOutputFilename StopLn
1531 liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
1532 case maybe_stub_o of
1533 Nothing ->
1534 panic "runPhase(MergeStub): no stub"
1535 Just stub_o -> do
1536 liftIO $ joinObjectFiles dflags [input_fn, stub_o] output_fn
1537 return (RealPhase StopLn, output_fn)
1538
1539 -- warning suppression
1540 runPhase (RealPhase other) _input_fn _dflags =
1541 panic ("runPhase: don't know how to run phase " ++ show other)
1542
1543 maybeMergeStub :: CompPipeline Phase
1544 maybeMergeStub
1545 = do
1546 PipeState{maybe_stub_o} <- getPipeState
1547 if isJust maybe_stub_o then return MergeStub else return StopLn
1548
1549 getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
1550 getLocation src_flavour mod_name = do
1551 dflags <- getDynFlags
1552
1553 PipeEnv{ src_basename=basename,
1554 src_suffix=suff } <- getPipeEnv
1555
1556 -- Build a ModLocation to pass to hscMain.
1557 -- The source filename is rather irrelevant by now, but it's used
1558 -- by hscMain for messages. hscMain also needs
1559 -- the .hi and .o filenames, and this is as good a way
1560 -- as any to generate them, and better than most. (e.g. takes
1561 -- into account the -osuf flags)
1562 location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
1563
1564 -- Boot-ify it if necessary
1565 let location2 | HsBootFile <- src_flavour = addBootSuffixLocn location1
1566 | otherwise = location1
1567
1568
1569 -- Take -ohi into account if present
1570 -- This can't be done in mkHomeModuleLocation because
1571 -- it only applies to the module being compiles
1572 let ohi = outputHi dflags
1573 location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
1574 | otherwise = location2
1575
1576 -- Take -o into account if present
1577 -- Very like -ohi, but we must *only* do this if we aren't linking
1578 -- (If we're linking then the -o applies to the linked thing, not to
1579 -- the object file for one module.)
1580 -- Note the nasty duplication with the same computation in compileFile above
1581 let expl_o_file = outputFile dflags
1582 location4 | Just ofile <- expl_o_file
1583 , isNoLink (ghcLink dflags)
1584 = location3 { ml_obj_file = ofile }
1585 | otherwise = location3
1586
1587 return location4
1588
1589 -----------------------------------------------------------------------------
1590 -- MoveBinary sort-of-phase
1591 -- After having produced a binary, move it somewhere else and generate a
1592 -- wrapper script calling the binary. Currently, we need this only in
1593 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1594 -- central directory.
1595 -- This is called from linkBinary below, after linking. I haven't made it
1596 -- a separate phase to minimise interfering with other modules, and
1597 -- we don't need the generality of a phase (MoveBinary is always
1598 -- done after linking and makes only sense in a parallel setup) -- HWL
1599
1600 runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
1601 runPhase_MoveBinary dflags input_fn
1602 | WayPar `elem` ways dflags && not (gopt Opt_Static dflags) =
1603 panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
1604 | WayPar `elem` ways dflags = do
1605 let sysMan = pgm_sysman dflags
1606 pvm_root <- getEnv "PVM_ROOT"
1607 pvm_arch <- getEnv "PVM_ARCH"
1608 let
1609 pvm_executable_base = "=" ++ input_fn
1610 pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1611 -- nuke old binary; maybe use configur'ed names for cp and rm?
1612 _ <- tryIO (removeFile pvm_executable)
1613 -- move the newly created binary into PVM land
1614 copy dflags "copying PVM executable" input_fn pvm_executable
1615 -- generate a wrapper script for running a parallel prg under PVM
1616 writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1617 return True
1618 | otherwise = return True
1619
1620 mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
1621 mkExtraObj dflags extn xs
1622 = do cFile <- newTempName dflags extn
1623 oFile <- newTempName dflags "o"
1624 writeFile cFile xs
1625 let rtsDetails = getPackageDetails dflags rtsPackageKey
1626 SysTools.runCc dflags
1627 ([Option "-c",
1628 FileOption "" cFile,
1629 Option "-o",
1630 FileOption "" oFile]
1631 ++ map (FileOption "-I") (includeDirs rtsDetails))
1632 return oFile
1633
1634 -- When linking a binary, we need to create a C main() function that
1635 -- starts everything off. This used to be compiled statically as part
1636 -- of the RTS, but that made it hard to change the -rtsopts setting,
1637 -- so now we generate and compile a main() stub as part of every
1638 -- binary and pass the -rtsopts setting directly to the RTS (#5373)
1639 --
1640 mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
1641 mkExtraObjToLinkIntoBinary dflags = do
1642 when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
1643 log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
1644 (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
1645 text " Call hs_init_ghc() from your main() function to set these options.")
1646
1647 mkExtraObj dflags "c" (showSDoc dflags main)
1648
1649 where
1650 main
1651 | gopt Opt_NoHsMain dflags = Outputable.empty
1652 | otherwise = vcat [
1653 text "#include \"Rts.h\"",
1654 text "extern StgClosure ZCMain_main_closure;",
1655 text "int main(int argc, char *argv[])",
1656 char '{',
1657 text " RtsConfig __conf = defaultRtsConfig;",
1658 text " __conf.rts_opts_enabled = "
1659 <> text (show (rtsOptsEnabled dflags)) <> semi,
1660 case rtsOpts dflags of
1661 Nothing -> Outputable.empty
1662 Just opts -> ptext (sLit " __conf.rts_opts= ") <>
1663 text (show opts) <> semi,
1664 text " __conf.rts_hs_main = rtsTrue;",
1665 text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
1666 char '}',
1667 char '\n' -- final newline, to keep gcc happy
1668 ]
1669
1670 -- Write out the link info section into a new assembly file. Previously
1671 -- this was included as inline assembly in the main.c file but this
1672 -- is pretty fragile. gas gets upset trying to calculate relative offsets
1673 -- that span the .note section (notably .text) when debug info is present
1674 mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageKey] -> IO [FilePath]
1675 mkNoteObjsToLinkIntoBinary dflags dep_packages = do
1676 link_info <- getLinkInfo dflags dep_packages
1677
1678 if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
1679 then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
1680 else return []
1681
1682 where
1683 link_opts info = hcat [
1684 text "\t.section ", text ghcLinkInfoSectionName,
1685 text ",\"\",",
1686 text elfSectionNote,
1687 text "\n",
1688
1689 text "\t.ascii \"", info', text "\"\n",
1690
1691 -- ALL generated assembly must have this section to disable
1692 -- executable stacks. See also
1693 -- compiler/nativeGen/AsmCodeGen.lhs for another instance
1694 -- where we need to do this.
1695 (if platformHasGnuNonexecStack (targetPlatform dflags)
1696 then text ".section .note.GNU-stack,\"\",@progbits\n"
1697 else Outputable.empty)
1698
1699 ]
1700 where
1701 info' = text $ escape info
1702
1703 escape :: String -> String
1704 escape = concatMap (charToC.fromIntegral.ord)
1705
1706 elfSectionNote :: String
1707 elfSectionNote = case platformArch (targetPlatform dflags) of
1708 ArchARM _ _ _ -> "%note"
1709 _ -> "@note"
1710
1711 -- The "link info" is a string representing the parameters of the
1712 -- link. We save this information in the binary, and the next time we
1713 -- link, if nothing else has changed, we use the link info stored in
1714 -- the existing binary to decide whether to re-link or not.
1715 getLinkInfo :: DynFlags -> [PackageKey] -> IO String
1716 getLinkInfo dflags dep_packages = do
1717 package_link_opts <- getPackageLinkOpts dflags dep_packages
1718 pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
1719 then getPackageFrameworks dflags dep_packages
1720 else return []
1721 let extra_ld_inputs = ldInputs dflags
1722 let
1723 link_info = (package_link_opts,
1724 pkg_frameworks,
1725 rtsOpts dflags,
1726 rtsOptsEnabled dflags,
1727 gopt Opt_NoHsMain dflags,
1728 map showOpt extra_ld_inputs,
1729 getOpts dflags opt_l)
1730 --
1731 return (show link_info)
1732
1733 -- generates a Perl skript starting a parallel prg under PVM
1734 mk_pvm_wrapper_script :: String -> String -> String -> String
1735 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1736 [
1737 "eval 'exec perl -S $0 ${1+\"$@\"}'",
1738 " if $running_under_some_shell;",
1739 "# =!=!=!=!=!=!=!=!=!=!=!",
1740 "# This script is automatically generated: DO NOT EDIT!!!",
1741 "# Generated by Glasgow Haskell Compiler",
1742 "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1743 "#",
1744 "$pvm_executable = '" ++ pvm_executable ++ "';",
1745 "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1746 "$SysMan = '" ++ sysMan ++ "';",
1747 "",
1748 {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1749 "# first, some magical shortcuts to run "commands" on the binary",
1750 "# (which is hidden)",
1751 "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1752 " local($cmd) = $1;",
1753 " system("$cmd $pvm_executable");",
1754 " exit(0); # all done",
1755 "}", -}
1756 "",
1757 "# Now, run the real binary; process the args first",
1758 "$ENV{'PE'} = $pvm_executable_base;", -- ++ pvm_executable_base,
1759 "$debug = '';",
1760 "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1761 "@nonPVM_args = ();",
1762 "$in_RTS_args = 0;",
1763 "",
1764 "args: while ($a = shift(@ARGV)) {",
1765 " if ( $a eq '+RTS' ) {",
1766 " $in_RTS_args = 1;",
1767 " } elsif ( $a eq '-RTS' ) {",
1768 " $in_RTS_args = 0;",
1769 " }",
1770 " if ( $a eq '-d' && $in_RTS_args ) {",
1771 " $debug = '-';",
1772 " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1773 " $nprocessors = $1;",
1774 " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1775 " $nprocessors = $1;",
1776 " } else {",
1777 " push(@nonPVM_args, $a);",
1778 " }",
1779 "}",
1780 "",
1781 "local($return_val) = 0;",
1782 "# Start the parallel execution by calling SysMan",
1783 "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1784 "$return_val = $?;",
1785 "# ToDo: fix race condition moving files and flushing them!!",
1786 "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1787 "exit($return_val);"
1788 ]
1789
1790 -----------------------------------------------------------------------------
1791 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1792
1793 getHCFilePackages :: FilePath -> IO [PackageKey]
1794 getHCFilePackages filename =
1795 Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1796 l <- hGetLine h
1797 case l of
1798 '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1799 return (map stringToPackageKey (words rest))
1800 _other ->
1801 return []
1802
1803 -----------------------------------------------------------------------------
1804 -- Static linking, of .o files
1805
1806 -- The list of packages passed to link is the list of packages on
1807 -- which this program depends, as discovered by the compilation
1808 -- manager. It is combined with the list of packages that the user
1809 -- specifies on the command line with -package flags.
1810 --
1811 -- In one-shot linking mode, we can't discover the package
1812 -- dependencies (because we haven't actually done any compilation or
1813 -- read any interface files), so the user must explicitly specify all
1814 -- the packages.
1815
1816 linkBinary :: DynFlags -> [FilePath] -> [PackageKey] -> IO ()
1817 linkBinary = linkBinary' False
1818
1819 linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageKey] -> IO ()
1820 linkBinary' staticLink dflags o_files dep_packages = do
1821 let platform = targetPlatform dflags
1822 mySettings = settings dflags
1823 verbFlags = getVerbFlags dflags
1824 output_fn = exeFileName staticLink dflags
1825
1826 -- get the full list of packages to link with, by combining the
1827 -- explicit packages with the auto packages and all of their
1828 -- dependencies, and eliminating duplicates.
1829
1830 full_output_fn <- if isAbsolute output_fn
1831 then return output_fn
1832 else do d <- getCurrentDirectory
1833 return $ normalise (d </> output_fn)
1834 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1835 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1836 get_pkg_lib_path_opts l
1837 | osElfTarget (platformOS platform) &&
1838 dynLibLoader dflags == SystemDependent &&
1839 not (gopt Opt_Static dflags)
1840 = let libpath = if gopt Opt_RelativeDynlibPaths dflags
1841 then "$ORIGIN" </>
1842 (l `makeRelativeTo` full_output_fn)
1843 else l
1844 rpath = if gopt Opt_RPath dflags
1845 then ["-Wl,-rpath", "-Wl," ++ libpath]
1846 else []
1847 -- Solaris 11's linker does not support -rpath-link option. It silently
1848 -- ignores it and then complains about next option which is -l<some
1849 -- dir> as being a directory and not expected object file, E.g
1850 -- ld: elf error: file
1851 -- /tmp/ghc-src/libraries/base/dist-install/build:
1852 -- elf_begin: I/O error: region read: Is a directory
1853 rpathlink = if (platformOS platform) == OSSolaris2
1854 then []
1855 else ["-Wl,-rpath-link", "-Wl," ++ l]
1856 in ["-L" ++ l] ++ rpathlink ++ rpath
1857 | osMachOTarget (platformOS platform) &&
1858 dynLibLoader dflags == SystemDependent &&
1859 not (gopt Opt_Static dflags) &&
1860 gopt Opt_RPath dflags
1861 = let libpath = if gopt Opt_RelativeDynlibPaths dflags
1862 then "@loader_path" </>
1863 (l `makeRelativeTo` full_output_fn)
1864 else l
1865 in ["-L" ++ l] ++ ["-Wl,-rpath", "-Wl," ++ libpath]
1866 | otherwise = ["-L" ++ l]
1867
1868 let lib_paths = libraryPaths dflags
1869 let lib_path_opts = map ("-L"++) lib_paths
1870
1871 extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
1872 noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
1873
1874 pkg_link_opts <- do
1875 (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages
1876 return $ if staticLink
1877 then package_hs_libs -- If building an executable really means making a static
1878 -- library (e.g. iOS), then we only keep the -l options for
1879 -- HS packages, because libtool doesn't accept other options.
1880 -- In the case of iOS these need to be added by hand to the
1881 -- final link in Xcode.
1882 else other_flags ++ package_hs_libs ++ extra_libs -- -Wl,-u,<sym> contained in other_flags
1883 -- needs to be put before -l<package>,
1884 -- otherwise Solaris linker fails linking
1885 -- a binary with unresolved symbols in RTS
1886 -- which are defined in base package
1887 -- the reason for this is a note in ld(1) about
1888 -- '-u' option: "The placement of this option
1889 -- on the command line is significant.
1890 -- This option must be placed before the library
1891 -- that defines the symbol."
1892
1893 pkg_framework_path_opts <-
1894 if platformUsesFrameworks platform
1895 then do pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1896 return $ map ("-F" ++) pkg_framework_paths
1897 else return []
1898
1899 framework_path_opts <-
1900 if platformUsesFrameworks platform
1901 then do let framework_paths = frameworkPaths dflags
1902 return $ map ("-F" ++) framework_paths
1903 else return []
1904
1905 pkg_framework_opts <-
1906 if platformUsesFrameworks platform
1907 then do pkg_frameworks <- getPackageFrameworks dflags dep_packages
1908 return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1909 else return []
1910
1911 framework_opts <-
1912 if platformUsesFrameworks platform
1913 then do let frameworks = cmdlineFrameworks dflags
1914 -- reverse because they're added in reverse order from
1915 -- the cmd line:
1916 return $ concat [ ["-framework", fw]
1917 | fw <- reverse frameworks ]
1918 else return []
1919
1920 -- probably _stub.o files
1921 let extra_ld_inputs = ldInputs dflags
1922
1923 -- Here are some libs that need to be linked at the *end* of
1924 -- the command line, because they contain symbols that are referred to
1925 -- by the RTS. We can't therefore use the ordinary way opts for these.
1926 let
1927 debug_opts | WayDebug `elem` ways dflags = [
1928 #if defined(HAVE_LIBBFD)
1929 "-lbfd", "-liberty"
1930 #endif
1931 ]
1932 | otherwise = []
1933
1934 let thread_opts
1935 | WayThreaded `elem` ways dflags =
1936 let os = platformOS (targetPlatform dflags)
1937 in if os == OSOsf3 then ["-lpthread", "-lexc"]
1938 else if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD,
1939 OSNetBSD, OSHaiku, OSQNXNTO, OSiOS, OSDarwin]
1940 then []
1941 else ["-lpthread"]
1942 | otherwise = []
1943
1944 rc_objs <- maybeCreateManifest dflags output_fn
1945
1946 let link = if staticLink
1947 then SysTools.runLibtool
1948 else SysTools.runLink
1949 link dflags (
1950 map SysTools.Option verbFlags
1951 ++ [ SysTools.Option "-o"
1952 , SysTools.FileOption "" output_fn
1953 ]
1954 ++ map SysTools.Option (
1955 []
1956
1957 -- Permit the linker to auto link _symbol to _imp_symbol.
1958 -- This lets us link against DLLs without needing an "import library".
1959 ++ (if platformOS platform == OSMinGW32
1960 then ["-Wl,--enable-auto-import"]
1961 else [])
1962
1963 -- '-no_compact_unwind'
1964 -- C++/Objective-C exceptions cannot use optimised
1965 -- stack unwinding code. The optimised form is the
1966 -- default in Xcode 4 on at least x86_64, and
1967 -- without this flag we're also seeing warnings
1968 -- like
1969 -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
1970 -- on x86.
1971 ++ (if sLdSupportsCompactUnwind mySettings &&
1972 not staticLink &&
1973 (platformOS platform == OSDarwin || platformOS platform == OSiOS) &&
1974 case platformArch platform of
1975 ArchX86 -> True
1976 ArchX86_64 -> True
1977 ArchARM {} -> True
1978 ArchARM64 -> True
1979 _ -> False
1980 then ["-Wl,-no_compact_unwind"]
1981 else [])
1982
1983 -- '-no_pie'
1984 -- iOS uses 'dynamic-no-pic', so we must pass this to ld to suppress a warning; see #7722
1985 ++ (if platformOS platform == OSiOS &&
1986 not staticLink
1987 then ["-Wl,-no_pie"]
1988 else [])
1989
1990 -- '-Wl,-read_only_relocs,suppress'
1991 -- ld gives loads of warnings like:
1992 -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
1993 -- when linking any program. We're not sure
1994 -- whether this is something we ought to fix, but
1995 -- for now this flags silences them.
1996 ++ (if platformOS platform == OSDarwin &&
1997 platformArch platform == ArchX86 &&
1998 not staticLink
1999 then ["-Wl,-read_only_relocs,suppress"]
2000 else [])
2001
2002 ++ o_files
2003 ++ lib_path_opts)
2004 ++ extra_ld_inputs
2005 ++ map SysTools.Option (
2006 rc_objs
2007 ++ framework_path_opts
2008 ++ framework_opts
2009 ++ pkg_lib_path_opts
2010 ++ extraLinkObj:noteLinkObjs
2011 ++ pkg_link_opts
2012 ++ pkg_framework_path_opts
2013 ++ pkg_framework_opts
2014 ++ debug_opts
2015 ++ thread_opts
2016 ))
2017
2018 -- parallel only: move binary to another dir -- HWL
2019 success <- runPhase_MoveBinary dflags output_fn
2020 unless success $
2021 throwGhcExceptionIO (InstallationError ("cannot move binary"))
2022
2023
2024 exeFileName :: Bool -> DynFlags -> FilePath
2025 exeFileName staticLink dflags
2026 | Just s <- outputFile dflags =
2027 case platformOS (targetPlatform dflags) of
2028 OSMinGW32 -> s <?.> "exe"
2029 _ -> if staticLink
2030 then s <?.> "a"
2031 else s
2032 | otherwise =
2033 if platformOS (targetPlatform dflags) == OSMinGW32
2034 then "main.exe"
2035 else if staticLink
2036 then "liba.a"
2037 else "a.out"
2038 where s <?.> ext | null (takeExtension s) = s <.> ext
2039 | otherwise = s
2040
2041 maybeCreateManifest
2042 :: DynFlags
2043 -> FilePath -- filename of executable
2044 -> IO [FilePath] -- extra objects to embed, maybe
2045 maybeCreateManifest dflags exe_filename
2046 | platformOS (targetPlatform dflags) == OSMinGW32 &&
2047 gopt Opt_GenManifest dflags
2048 = do let manifest_filename = exe_filename <.> "manifest"
2049
2050 writeFile manifest_filename $
2051 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
2052 " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
2053 " <assemblyIdentity version=\"1.0.0.0\"\n"++
2054 " processorArchitecture=\"X86\"\n"++
2055 " name=\"" ++ dropExtension exe_filename ++ "\"\n"++
2056 " type=\"win32\"/>\n\n"++
2057 " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
2058 " <security>\n"++
2059 " <requestedPrivileges>\n"++
2060 " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
2061 " </requestedPrivileges>\n"++
2062 " </security>\n"++
2063 " </trustInfo>\n"++
2064 "</assembly>\n"
2065
2066 -- Windows will find the manifest file if it is named
2067 -- foo.exe.manifest. However, for extra robustness, and so that
2068 -- we can move the binary around, we can embed the manifest in
2069 -- the binary itself using windres:
2070 if not (gopt Opt_EmbedManifest dflags) then return [] else do
2071
2072 rc_filename <- newTempName dflags "rc"
2073 rc_obj_filename <- newTempName dflags (objectSuf dflags)
2074
2075 writeFile rc_filename $
2076 "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
2077 -- magic numbers :-)
2078 -- show is a bit hackish above, but we need to escape the
2079 -- backslashes in the path.
2080
2081 runWindres dflags $ map SysTools.Option $
2082 ["--input="++rc_filename,
2083 "--output="++rc_obj_filename,
2084 "--output-format=coff"]
2085 -- no FileOptions here: windres doesn't like seeing
2086 -- backslashes, apparently
2087
2088 removeFile manifest_filename
2089
2090 return [rc_obj_filename]
2091 | otherwise = return []
2092
2093
2094 linkDynLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO ()
2095 linkDynLibCheck dflags o_files dep_packages
2096 = do
2097 when (haveRtsOptsFlags dflags) $ do
2098 log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
2099 (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
2100 text " Call hs_init_ghc() from your main() function to set these options.")
2101
2102 linkDynLib dflags o_files dep_packages
2103
2104 linkStaticLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO ()
2105 linkStaticLibCheck dflags o_files dep_packages
2106 = do
2107 when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $
2108 throwGhcExceptionIO (ProgramError "Static archive creation only supported on Darwin/OS X/iOS")
2109 linkBinary' True dflags o_files dep_packages
2110
2111 -- -----------------------------------------------------------------------------
2112 -- Running CPP
2113
2114 doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
2115 doCpp dflags raw input_fn output_fn = do
2116 let hscpp_opts = picPOpts dflags
2117 let cmdline_include_paths = includePaths dflags
2118
2119 pkg_include_dirs <- getPackageIncludePath dflags []
2120 let include_paths = foldr (\ x xs -> "-I" : x : xs) []
2121 (cmdline_include_paths ++ pkg_include_dirs)
2122
2123 let verbFlags = getVerbFlags dflags
2124
2125 let cpp_prog args | raw = SysTools.runCpp dflags args
2126 | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
2127
2128 let target_defs =
2129 [ "-D" ++ HOST_OS ++ "_BUILD_OS=1",
2130 "-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1",
2131 "-D" ++ TARGET_OS ++ "_HOST_OS=1",
2132 "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
2133 -- remember, in code we *compile*, the HOST is the same our TARGET,
2134 -- and BUILD is the same as our HOST.
2135
2136 let sse_defs =
2137 [ "-D__SSE__=1" | isSseEnabled dflags ] ++
2138 [ "-D__SSE2__=1" | isSse2Enabled dflags ] ++
2139 [ "-D__SSE4_2__=1" | isSse4_2Enabled dflags ]
2140
2141 let avx_defs =
2142 [ "-D__AVX__=1" | isAvxEnabled dflags ] ++
2143 [ "-D__AVX2__=1" | isAvx2Enabled dflags ] ++
2144 [ "-D__AVX512CD__=1" | isAvx512cdEnabled dflags ] ++
2145 [ "-D__AVX512ER__=1" | isAvx512erEnabled dflags ] ++
2146 [ "-D__AVX512F__=1" | isAvx512fEnabled dflags ] ++
2147 [ "-D__AVX512PF__=1" | isAvx512pfEnabled dflags ]
2148
2149 backend_defs <- getBackendDefs dflags
2150
2151 #ifdef GHCI
2152 let th_defs = [ "-D__GLASGOW_HASKELL_TH__=YES" ]
2153 #else
2154 let th_defs = [ "-D__GLASGOW_HASKELL_TH__=NO" ]
2155 #endif
2156 -- Default CPP defines in Haskell source
2157 ghcVersionH <- getGhcVersionPathName dflags
2158 let hsSourceCppOpts =
2159 [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt
2160 , "-include", ghcVersionH
2161 ]
2162
2163 cpp_prog ( map SysTools.Option verbFlags
2164 ++ map SysTools.Option include_paths
2165 ++ map SysTools.Option hsSourceCppOpts
2166 ++ map SysTools.Option target_defs
2167 ++ map SysTools.Option backend_defs
2168 ++ map SysTools.Option th_defs
2169 ++ map SysTools.Option hscpp_opts
2170 ++ map SysTools.Option sse_defs
2171 ++ map SysTools.Option avx_defs
2172 -- Set the language mode to assembler-with-cpp when preprocessing. This
2173 -- alleviates some of the C99 macro rules relating to whitespace and the hash
2174 -- operator, which we tend to abuse. Clang in particular is not very happy
2175 -- about this.
2176 ++ [ SysTools.Option "-x"
2177 , SysTools.Option "assembler-with-cpp"
2178 , SysTools.Option input_fn
2179 -- We hackily use Option instead of FileOption here, so that the file
2180 -- name is not back-slashed on Windows. cpp is capable of
2181 -- dealing with / in filenames, so it works fine. Furthermore
2182 -- if we put in backslashes, cpp outputs #line directives
2183 -- with *double* backslashes. And that in turn means that
2184 -- our error messages get double backslashes in them.
2185 -- In due course we should arrange that the lexer deals
2186 -- with these \\ escapes properly.
2187 , SysTools.Option "-o"
2188 , SysTools.FileOption "" output_fn
2189 ])
2190
2191 getBackendDefs :: DynFlags -> IO [String]
2192 getBackendDefs dflags | hscTarget dflags == HscLlvm = do
2193 llvmVer <- figureLlvmVersion dflags
2194 return $ case llvmVer of
2195 Just n -> [ "-D__GLASGOW_HASKELL_LLVM__="++show n ]
2196 _ -> []
2197
2198 getBackendDefs _ =
2199 return []
2200
2201 -- ---------------------------------------------------------------------------
2202 -- join object files into a single relocatable object file, using ld -r
2203
2204 joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
2205 joinObjectFiles dflags o_files output_fn = do
2206 let mySettings = settings dflags
2207 ldIsGnuLd = sLdIsGnuLd mySettings
2208 osInfo = platformOS (targetPlatform dflags)
2209 ld_r args cc = SysTools.runLink dflags ([
2210 SysTools.Option "-nostdlib",
2211 SysTools.Option "-Wl,-r"
2212 ]
2213 ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]
2214 then []
2215 else [SysTools.Option "-nodefaultlibs"])
2216 ++ (if osInfo == OSFreeBSD
2217 then [SysTools.Option "-L/usr/lib"]
2218 else [])
2219 -- gcc on sparc sets -Wl,--relax implicitly, but
2220 -- -r and --relax are incompatible for ld, so
2221 -- disable --relax explicitly.
2222 ++ (if platformArch (targetPlatform dflags) == ArchSPARC
2223 && ldIsGnuLd
2224 then [SysTools.Option "-Wl,-no-relax"]
2225 else [])
2226 ++ map SysTools.Option ld_build_id
2227 ++ [ SysTools.Option "-o",
2228 SysTools.FileOption "" output_fn ]
2229 ++ args)
2230
2231 -- suppress the generation of the .note.gnu.build-id section,
2232 -- which we don't need and sometimes causes ld to emit a
2233 -- warning:
2234 ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"]
2235 | otherwise = []
2236
2237 ccInfo <- getCompilerInfo dflags
2238 if ldIsGnuLd
2239 then do
2240 script <- newTempName dflags "ldscript"
2241 cwd <- getCurrentDirectory
2242 let o_files_abs = map (cwd </>) o_files
2243 writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
2244 ld_r [SysTools.FileOption "" script] ccInfo
2245 else if sLdSupportsFilelist mySettings
2246 then do
2247 filelist <- newTempName dflags "filelist"
2248 writeFile filelist $ unlines o_files
2249 ld_r [SysTools.Option "-Wl,-filelist",
2250 SysTools.FileOption "-Wl," filelist] ccInfo
2251 else do
2252 ld_r (map (SysTools.FileOption "") o_files) ccInfo
2253
2254 -- -----------------------------------------------------------------------------
2255 -- Misc.
2256
2257 writeInterfaceOnlyMode :: DynFlags -> Bool
2258 writeInterfaceOnlyMode dflags =
2259 gopt Opt_WriteInterface dflags &&
2260 HscNothing == hscTarget dflags
2261
2262 -- | What phase to run after one of the backend code generators has run
2263 hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
2264 hscPostBackendPhase _ HsBootFile _ = StopLn
2265 hscPostBackendPhase _ HsigFile _ = StopLn
2266 hscPostBackendPhase dflags _ hsc_lang =
2267 case hsc_lang of
2268 HscC -> HCc
2269 HscAsm | gopt Opt_SplitObjs dflags -> Splitter
2270 | otherwise -> As False
2271 HscLlvm -> LlvmOpt
2272 HscNothing -> StopLn
2273 HscInterpreted -> StopLn
2274
2275 touchObjectFile :: DynFlags -> FilePath -> IO ()
2276 touchObjectFile dflags path = do
2277 createDirectoryIfMissing True $ takeDirectory path
2278 SysTools.touch dflags "Touching object file" path
2279
2280 haveRtsOptsFlags :: DynFlags -> Bool
2281 haveRtsOptsFlags dflags =
2282 isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of
2283 RtsOptsSafeOnly -> False
2284 _ -> True
2285
2286 -- | Find out path to @ghcversion.h@ file
2287 getGhcVersionPathName :: DynFlags -> IO FilePath
2288 getGhcVersionPathName dflags = do
2289 dirs <- getPackageIncludePath dflags [rtsPackageKey]
2290
2291 found <- filterM doesFileExist (map (</> "ghcversion.h") dirs)
2292 case found of
2293 [] -> throwGhcExceptionIO (InstallationError ("ghcversion.h missing"))
2294 (x:_) -> return x
2295
2296 -- Note [-fPIC for assembler]
2297 -- When compiling .c source file GHC's driver pipeline basically
2298 -- does the following two things:
2299 -- 1. ${CC} -S 'PIC_CFLAGS' source.c
2300 -- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S
2301 --
2302 -- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?
2303 -- Because on some architectures (at least sparc32) assembler also chooses
2304 -- the relocation type!
2305 -- Consider the following C module:
2306 --
2307 -- /* pic-sample.c */
2308 -- int v;
2309 -- void set_v (int n) { v = n; }
2310 -- int get_v (void) { return v; }
2311 --
2312 -- $ gcc -S -fPIC pic-sample.c
2313 -- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary
2314 -- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary
2315 --
2316 -- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od
2317 -- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od
2318 -- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od
2319 --
2320 -- Most of architectures won't show any difference in this test, but on sparc32
2321 -- the following assembly snippet:
2322 --
2323 -- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7
2324 --
2325 -- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:
2326 --
2327 -- 3c: 2f 00 00 00 sethi %hi(0), %l7
2328 -- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8
2329 -- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8