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