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