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