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