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