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