Merge branch 'master' into ghc-parmake-gsoc
[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 Monad CompPipeline where
673 return a = P $ \_env state -> return (state, a)
674 P m >>= k = P $ \env state -> do (state',a) <- m env state
675 unP (k a) env state'
676
677 instance MonadIO CompPipeline where
678 liftIO m = P $ \_env state -> do a <- m; return (state, a)
679
680 phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
681 phaseOutputFilename next_phase = do
682 PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
683 PipeState{maybe_loc, hsc_env} <- getPipeState
684 let dflags = hsc_dflags hsc_env
685 liftIO $ getOutputFilename stop_phase output_spec
686 src_basename dflags next_phase maybe_loc
687
688 -- ---------------------------------------------------------------------------
689 -- outer pipeline loop
690
691 -- | pipeLoop runs phases until we reach the stop phase
692 pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
693 pipeLoop phase input_fn = do
694 env <- getPipeEnv
695 dflags <- getDynFlags
696 let happensBefore' = happensBefore dflags
697 stopPhase = stop_phase env
698 case phase of
699 RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done
700 -> -- Sometimes, a compilation phase doesn't actually generate any output
701 -- (eg. the CPP phase when -fcpp is not turned on). If we end on this
702 -- stage, but we wanted to keep the output, then we have to explicitly
703 -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
704 -- further compilation stages can tell what the original filename was.
705 case output_spec env of
706 Temporary ->
707 return (dflags, input_fn)
708 output ->
709 do pst <- getPipeState
710 final_fn <- liftIO $ getOutputFilename
711 stopPhase output (src_basename env)
712 dflags stopPhase (maybe_loc pst)
713 when (final_fn /= input_fn) $ do
714 let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
715 line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
716 liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
717 return (dflags, final_fn)
718
719
720 | not (realPhase `happensBefore'` stopPhase)
721 -- Something has gone wrong. We'll try to cover all the cases when
722 -- this could happen, so if we reach here it is a panic.
723 -- eg. it might happen if the -C flag is used on a source file that
724 -- has {-# OPTIONS -fasm #-}.
725 -> panic ("pipeLoop: at phase " ++ show realPhase ++
726 " but I wanted to stop at phase " ++ show stopPhase)
727
728 _
729 -> do liftIO $ debugTraceMsg dflags 4
730 (ptext (sLit "Running phase") <+> ppr phase)
731 (next_phase, output_fn) <- runPhase phase input_fn dflags
732 r <- pipeLoop next_phase output_fn
733 case phase of
734 HscOut {} ->
735 whenGeneratingDynamicToo dflags $ do
736 setDynFlags $ dynamicTooMkDynamicDynFlags dflags
737 -- TODO shouldn't ignore result:
738 _ <- pipeLoop phase input_fn
739 return ()
740 _ ->
741 return ()
742 return r
743
744 -- -----------------------------------------------------------------------------
745 -- In each phase, we need to know into what filename to generate the
746 -- output. All the logic about which filenames we generate output
747 -- into is embodied in the following function.
748
749 getOutputFilename
750 :: Phase -> PipelineOutput -> String
751 -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
752 getOutputFilename stop_phase output basename dflags next_phase maybe_location
753 | is_last_phase, Persistent <- output = persistent_fn
754 | is_last_phase, SpecificFile <- output = case outputFile dflags of
755 Just f -> return f
756 Nothing ->
757 panic "SpecificFile: No filename"
758 | keep_this_output = persistent_fn
759 | otherwise = newTempName dflags suffix
760 where
761 hcsuf = hcSuf dflags
762 odir = objectDir dflags
763 osuf = objectSuf dflags
764 keep_hc = gopt Opt_KeepHcFiles dflags
765 keep_s = gopt Opt_KeepSFiles dflags
766 keep_bc = gopt Opt_KeepLlvmFiles dflags
767
768 myPhaseInputExt HCc = hcsuf
769 myPhaseInputExt MergeStub = osuf
770 myPhaseInputExt StopLn = osuf
771 myPhaseInputExt other = phaseInputExt other
772
773 is_last_phase = next_phase `eqPhase` stop_phase
774
775 -- sometimes, we keep output from intermediate stages
776 keep_this_output =
777 case next_phase of
778 As | keep_s -> True
779 LlvmOpt | keep_bc -> True
780 HCc | keep_hc -> True
781 _other -> False
782
783 suffix = myPhaseInputExt next_phase
784
785 -- persistent object files get put in odir
786 persistent_fn
787 | StopLn <- next_phase = return odir_persistent
788 | otherwise = return persistent
789
790 persistent = basename <.> suffix
791
792 odir_persistent
793 | Just loc <- maybe_location = ml_obj_file loc
794 | Just d <- odir = d </> persistent
795 | otherwise = persistent
796
797 data PhasePlus = RealPhase Phase
798 | HscOut HscSource ModuleName HscStatus
799
800 instance Outputable PhasePlus where
801 ppr (RealPhase p) = ppr p
802 ppr (HscOut {}) = text "HscOut"
803
804 -- -----------------------------------------------------------------------------
805 -- | Each phase in the pipeline returns the next phase to execute, and the
806 -- name of the file in which the output was placed.
807 --
808 -- We must do things dynamically this way, because we often don't know
809 -- what the rest of the phases will be until part-way through the
810 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
811 -- of a source file can change the latter stages of the pipeline from
812 -- taking the LLVM route to using the native code generator.
813 --
814 runPhase :: PhasePlus -- ^ Run this phase
815 -> FilePath -- ^ name of the input file
816 -> DynFlags -- ^ for convenience, we pass the current dflags in
817 -> CompPipeline (PhasePlus, -- next phase to run
818 FilePath) -- output filename
819
820 -- Invariant: the output filename always contains the output
821 -- Interesting case: Hsc when there is no recompilation to do
822 -- Then the output filename is still a .o file
823
824
825 -------------------------------------------------------------------------------
826 -- Unlit phase
827
828 runPhase (RealPhase (Unlit sf)) input_fn dflags
829 = do
830 output_fn <- phaseOutputFilename (Cpp sf)
831
832 let flags = [ -- The -h option passes the file name for unlit to
833 -- put in a #line directive
834 SysTools.Option "-h"
835 , SysTools.Option $ escape $ normalise input_fn
836 , SysTools.FileOption "" input_fn
837 , SysTools.FileOption "" output_fn
838 ]
839
840 liftIO $ SysTools.runUnlit dflags flags
841
842 return (RealPhase (Cpp sf), output_fn)
843 where
844 -- escape the characters \, ", and ', but don't try to escape
845 -- Unicode or anything else (so we don't use Util.charToC
846 -- here). If we get this wrong, then in
847 -- Coverage.addTicksToBinds where we check that the filename in
848 -- a SrcLoc is the same as the source filenaame, the two will
849 -- look bogusly different. See test:
850 -- libraries/hpc/tests/function/subdir/tough2.lhs
851 escape ('\\':cs) = '\\':'\\': escape cs
852 escape ('\"':cs) = '\\':'\"': escape cs
853 escape ('\'':cs) = '\\':'\'': escape cs
854 escape (c:cs) = c : escape cs
855 escape [] = []
856
857 -------------------------------------------------------------------------------
858 -- Cpp phase : (a) gets OPTIONS out of file
859 -- (b) runs cpp if necessary
860
861 runPhase (RealPhase (Cpp sf)) input_fn dflags0
862 = do
863 src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
864 (dflags1, unhandled_flags, warns)
865 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
866 setDynFlags dflags1
867 liftIO $ checkProcessArgsResult dflags1 unhandled_flags
868
869 if not (xopt Opt_Cpp dflags1) then do
870 -- we have to be careful to emit warnings only once.
871 unless (gopt Opt_Pp dflags1) $
872 liftIO $ handleFlagWarnings dflags1 warns
873
874 -- no need to preprocess CPP, just pass input file along
875 -- to the next phase of the pipeline.
876 return (RealPhase (HsPp sf), input_fn)
877 else do
878 output_fn <- phaseOutputFilename (HsPp sf)
879 liftIO $ doCpp dflags1 True{-raw-}
880 input_fn output_fn
881 -- re-read the pragmas now that we've preprocessed the file
882 -- See #2464,#3457
883 src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
884 (dflags2, unhandled_flags, warns)
885 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
886 liftIO $ checkProcessArgsResult dflags2 unhandled_flags
887 unless (gopt Opt_Pp dflags2) $
888 liftIO $ handleFlagWarnings dflags2 warns
889 -- the HsPp pass below will emit warnings
890
891 setDynFlags dflags2
892
893 return (RealPhase (HsPp sf), output_fn)
894
895 -------------------------------------------------------------------------------
896 -- HsPp phase
897
898 runPhase (RealPhase (HsPp sf)) input_fn dflags
899 = do
900 if not (gopt Opt_Pp dflags) then
901 -- no need to preprocess, just pass input file along
902 -- to the next phase of the pipeline.
903 return (RealPhase (Hsc sf), input_fn)
904 else do
905 PipeEnv{src_basename, src_suffix} <- getPipeEnv
906 let orig_fn = src_basename <.> src_suffix
907 output_fn <- phaseOutputFilename (Hsc sf)
908 liftIO $ SysTools.runPp dflags
909 ( [ SysTools.Option orig_fn
910 , SysTools.Option input_fn
911 , SysTools.FileOption "" output_fn
912 ]
913 )
914
915 -- re-read pragmas now that we've parsed the file (see #3674)
916 src_opts <- liftIO $ getOptionsFromFile dflags output_fn
917 (dflags1, unhandled_flags, warns)
918 <- liftIO $ parseDynamicFilePragma dflags src_opts
919 setDynFlags dflags1
920 liftIO $ checkProcessArgsResult dflags1 unhandled_flags
921 liftIO $ handleFlagWarnings dflags1 warns
922
923 return (RealPhase (Hsc sf), output_fn)
924
925 -----------------------------------------------------------------------------
926 -- Hsc phase
927
928 -- Compilation of a single module, in "legacy" mode (_not_ under
929 -- the direction of the compilation manager).
930 runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
931 = do -- normal Hsc mode, not mkdependHS
932
933 PipeEnv{ stop_phase=stop,
934 src_basename=basename,
935 src_suffix=suff } <- getPipeEnv
936
937 -- we add the current directory (i.e. the directory in which
938 -- the .hs files resides) to the include path, since this is
939 -- what gcc does, and it's probably what you want.
940 let current_dir = takeDirectory basename
941 paths = includePaths dflags0
942 dflags = dflags0 { includePaths = current_dir : paths }
943
944 setDynFlags dflags
945
946 -- gather the imports and module name
947 (hspp_buf,mod_name,imps,src_imps) <- liftIO $
948 case src_flavour of
949 ExtCoreFile -> do -- no explicit imports in ExtCore input.
950 m <- getCoreModuleName input_fn
951 return (Nothing, mkModuleName m, [], [])
952
953 _ -> do
954 buf <- hGetStringBuffer input_fn
955 (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
956 return (Just buf, mod_name, imps, src_imps)
957
958 -- Take -o into account if present
959 -- Very like -ohi, but we must *only* do this if we aren't linking
960 -- (If we're linking then the -o applies to the linked thing, not to
961 -- the object file for one module.)
962 -- Note the nasty duplication with the same computation in compileFile above
963 location <- getLocation src_flavour mod_name
964
965 let o_file = ml_obj_file location -- The real object file
966
967 -- Figure out if the source has changed, for recompilation avoidance.
968 --
969 -- Setting source_unchanged to True means that M.o seems
970 -- to be up to date wrt M.hs; so no need to recompile unless imports have
971 -- changed (which the compiler itself figures out).
972 -- Setting source_unchanged to False tells the compiler that M.o is out of
973 -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
974 src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
975
976 source_unchanged <- liftIO $
977 if not (isStopLn stop)
978 -- SourceModified unconditionally if
979 -- (a) recompilation checker is off, or
980 -- (b) we aren't going all the way to .o file (e.g. ghc -S)
981 then return SourceModified
982 -- Otherwise look at file modification dates
983 else do o_file_exists <- doesFileExist o_file
984 if not o_file_exists
985 then return SourceModified -- Need to recompile
986 else do t2 <- getModificationUTCTime o_file
987 if t2 > src_timestamp
988 then return SourceUnmodified
989 else return SourceModified
990
991 let extCore_filename = basename ++ ".hcr"
992
993 PipeState{hsc_env=hsc_env'} <- getPipeState
994
995 -- Tell the finder cache about this module
996 mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location
997
998 -- Make the ModSummary to hand to hscMain
999 let
1000 mod_summary = ModSummary { ms_mod = mod,
1001 ms_hsc_src = src_flavour,
1002 ms_hspp_file = input_fn,
1003 ms_hspp_opts = dflags,
1004 ms_hspp_buf = hspp_buf,
1005 ms_location = location,
1006 ms_hs_date = src_timestamp,
1007 ms_obj_date = Nothing,
1008 ms_textual_imps = imps,
1009 ms_srcimps = src_imps }
1010
1011 -- run the compiler!
1012 result <- liftIO $ hscCompileOneShot hsc_env' extCore_filename
1013 mod_summary source_unchanged
1014
1015 return (HscOut src_flavour mod_name result,
1016 panic "HscOut doesn't have an input filename")
1017
1018 runPhase (HscOut src_flavour mod_name result) _ dflags = do
1019 location <- getLocation src_flavour mod_name
1020 setModLocation location
1021
1022 let o_file = ml_obj_file location -- The real object file
1023 hsc_lang = hscTarget dflags
1024 next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
1025
1026 case result of
1027 HscNotGeneratingCode ->
1028 return (RealPhase next_phase,
1029 panic "No output filename from Hsc when no-code")
1030 HscUpToDate ->
1031 do liftIO $ touchObjectFile dflags o_file
1032 -- The .o file must have a later modification date
1033 -- than the source file (else we wouldn't get Nothing)
1034 -- but we touch it anyway, to keep 'make' happy (we think).
1035 return (RealPhase StopLn, o_file)
1036 HscUpdateBoot ->
1037 do -- In the case of hs-boot files, generate a dummy .o-boot
1038 -- stamp file for the benefit of Make
1039 liftIO $ touchObjectFile dflags o_file
1040 return (RealPhase next_phase, o_file)
1041 HscRecomp cgguts mod_summary
1042 -> do output_fn <- phaseOutputFilename next_phase
1043
1044 PipeState{hsc_env=hsc_env'} <- getPipeState
1045
1046 (outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary output_fn
1047 case mStub of
1048 Nothing -> return ()
1049 Just stub_c ->
1050 do stub_o <- liftIO $ compileStub hsc_env' stub_c
1051 setStubO stub_o
1052
1053 return (RealPhase next_phase, outputFilename)
1054
1055 -----------------------------------------------------------------------------
1056 -- Cmm phase
1057
1058 runPhase (RealPhase CmmCpp) input_fn dflags
1059 = do
1060 output_fn <- phaseOutputFilename Cmm
1061 liftIO $ doCpp dflags False{-not raw-}
1062 input_fn output_fn
1063 return (RealPhase Cmm, output_fn)
1064
1065 runPhase (RealPhase Cmm) input_fn dflags
1066 = do
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 PipeState{hsc_env} <- getPipeState
1074
1075 liftIO $ hscCompileCmmFile hsc_env input_fn output_fn
1076
1077 return (RealPhase next_phase, output_fn)
1078
1079 -----------------------------------------------------------------------------
1080 -- Cc phase
1081
1082 -- we don't support preprocessing .c files (with -E) now. Doing so introduces
1083 -- way too many hacks, and I can't say I've ever used it anyway.
1084
1085 runPhase (RealPhase cc_phase) input_fn dflags
1086 | any (cc_phase `eqPhase`) [Cc, Ccpp, HCc, Cobjc, Cobjcpp]
1087 = do
1088 let platform = targetPlatform dflags
1089 hcc = cc_phase `eqPhase` HCc
1090
1091 let cmdline_include_paths = includePaths dflags
1092
1093 -- HC files have the dependent packages stamped into them
1094 pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []
1095
1096 -- add package include paths even if we're just compiling .c
1097 -- files; this is the Value Add(TM) that using ghc instead of
1098 -- gcc gives you :)
1099 pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
1100 let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1101 (cmdline_include_paths ++ pkg_include_dirs)
1102
1103 let gcc_extra_viac_flags = extraGccViaCFlags dflags
1104 let pic_c_flags = picCCOpts dflags
1105
1106 let verbFlags = getVerbFlags dflags
1107
1108 -- cc-options are not passed when compiling .hc files. Our
1109 -- hc code doesn't not #include any header files anyway, so these
1110 -- options aren't necessary.
1111 pkg_extra_cc_opts <- liftIO $
1112 if cc_phase `eqPhase` HCc
1113 then return []
1114 else getPackageExtraCcOpts dflags pkgs
1115
1116 framework_paths <-
1117 if platformUsesFrameworks platform
1118 then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs
1119 let cmdlineFrameworkPaths = frameworkPaths dflags
1120 return $ map ("-F"++)
1121 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
1122 else return []
1123
1124 let split_objs = gopt Opt_SplitObjs dflags
1125 split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
1126 | otherwise = [ ]
1127
1128 let cc_opt | optLevel dflags >= 2 = [ "-O2" ]
1129 | optLevel dflags >= 1 = [ "-O" ]
1130 | otherwise = []
1131
1132 -- Decide next phase
1133 let next_phase = As
1134 output_fn <- phaseOutputFilename next_phase
1135
1136 let
1137 more_hcc_opts =
1138 -- on x86 the floating point regs have greater precision
1139 -- than a double, which leads to unpredictable results.
1140 -- By default, we turn this off with -ffloat-store unless
1141 -- the user specified -fexcess-precision.
1142 (if platformArch platform == ArchX86 &&
1143 not (gopt Opt_ExcessPrecision dflags)
1144 then [ "-ffloat-store" ]
1145 else []) ++
1146
1147 -- gcc's -fstrict-aliasing allows two accesses to memory
1148 -- to be considered non-aliasing if they have different types.
1149 -- This interacts badly with the C code we generate, which is
1150 -- very weakly typed, being derived from C--.
1151 ["-fno-strict-aliasing"]
1152
1153 let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++"
1154 | cc_phase `eqPhase` Cobjc = "objective-c"
1155 | cc_phase `eqPhase` Cobjcpp = "objective-c++"
1156 | otherwise = "c"
1157 liftIO $ SysTools.runCc dflags (
1158 -- force the C compiler to interpret this file as C when
1159 -- compiling .hc files, by adding the -x c option.
1160 -- Also useful for plain .c files, just in case GHC saw a
1161 -- -x c option.
1162 [ SysTools.Option "-x", SysTools.Option gcc_lang_opt
1163 , SysTools.FileOption "" input_fn
1164 , SysTools.Option "-o"
1165 , SysTools.FileOption "" output_fn
1166 ]
1167 ++ map SysTools.Option (
1168 pic_c_flags
1169
1170 -- Stub files generated for foreign exports references the runIO_closure
1171 -- and runNonIO_closure symbols, which are defined in the base package.
1172 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
1173 -- way we do the import depends on whether we're currently compiling
1174 -- the base package or not.
1175 ++ (if platformOS platform == OSMinGW32 &&
1176 thisPackage dflags == basePackageId
1177 then [ "-DCOMPILING_BASE_PACKAGE" ]
1178 else [])
1179
1180 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1181 -- instruction. Note that the user can still override this
1182 -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
1183 -- regardless of the ordering.
1184 --
1185 -- This is a temporary hack. See #2872, commit
1186 -- 5bd3072ac30216a505151601884ac88bf404c9f2
1187 ++ (if platformArch platform == ArchSPARC
1188 then ["-mcpu=v9"]
1189 else [])
1190
1191 -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
1192 ++ (if (cc_phase /= Ccpp && cc_phase /= Cobjcpp)
1193 then ["-Wimplicit"]
1194 else [])
1195
1196 ++ (if hcc
1197 then gcc_extra_viac_flags ++ more_hcc_opts
1198 else [])
1199 ++ verbFlags
1200 ++ [ "-S" ]
1201 ++ cc_opt
1202 ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1203 ++ framework_paths
1204 ++ split_opt
1205 ++ include_paths
1206 ++ pkg_extra_cc_opts
1207 ))
1208
1209 return (RealPhase next_phase, output_fn)
1210
1211 -----------------------------------------------------------------------------
1212 -- Splitting phase
1213
1214 runPhase (RealPhase Splitter) input_fn dflags
1215 = do -- tmp_pfx is the prefix used for the split .s files
1216
1217 split_s_prefix <- liftIO $ SysTools.newTempName dflags "split"
1218 let n_files_fn = split_s_prefix
1219
1220 liftIO $ SysTools.runSplit dflags
1221 [ SysTools.FileOption "" input_fn
1222 , SysTools.FileOption "" split_s_prefix
1223 , SysTools.FileOption "" n_files_fn
1224 ]
1225
1226 -- Save the number of split files for future references
1227 s <- liftIO $ readFile n_files_fn
1228 let n_files = read s :: Int
1229 dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
1230
1231 setDynFlags dflags'
1232
1233 -- Remember to delete all these files
1234 liftIO $ addFilesToClean dflags'
1235 [ split_s_prefix ++ "__" ++ show n ++ ".s"
1236 | n <- [1..n_files]]
1237
1238 return (RealPhase SplitAs,
1239 "**splitter**") -- we don't use the filename in SplitAs
1240
1241 -----------------------------------------------------------------------------
1242 -- As, SpitAs phase : Assembler
1243
1244 -- This is for calling the assembler on a regular assembly file (not split).
1245 runPhase (RealPhase As) input_fn dflags
1246 = do
1247 -- LLVM from version 3.0 onwards doesn't support the OS X system
1248 -- assembler, so we use clang as the assembler instead. (#5636)
1249 let whichAsProg | hscTarget dflags == HscLlvm &&
1250 platformOS (targetPlatform dflags) == OSDarwin
1251 = do
1252 -- be careful what options we call clang with
1253 -- see #5903 and #7617 for bugs caused by this.
1254 llvmVer <- liftIO $ figureLlvmVersion dflags
1255 return $ case llvmVer of
1256 Just n | n >= 30 -> SysTools.runClang
1257 _ -> SysTools.runAs
1258
1259 | otherwise = return SysTools.runAs
1260
1261 as_prog <- whichAsProg
1262 let cmdline_include_paths = includePaths dflags
1263
1264 next_phase <- maybeMergeStub
1265 output_fn <- phaseOutputFilename next_phase
1266
1267 -- we create directories for the object file, because it
1268 -- might be a hierarchical module.
1269 liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
1270
1271 let runAssembler inputFilename outputFilename
1272 = liftIO $ as_prog dflags
1273 ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
1274
1275 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1276 -- instruction so we have to make sure that the assembler accepts the
1277 -- instruction set. Note that the user can still override this
1278 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1279 -- regardless of the ordering.
1280 --
1281 -- This is a temporary hack.
1282 ++ (if platformArch (targetPlatform dflags) == ArchSPARC
1283 then [SysTools.Option "-mcpu=v9"]
1284 else [])
1285
1286 ++ [ SysTools.Option "-x", SysTools.Option "assembler-with-cpp"
1287 , SysTools.Option "-c"
1288 , SysTools.FileOption "" inputFilename
1289 , SysTools.Option "-o"
1290 , SysTools.FileOption "" outputFilename
1291 ])
1292
1293 liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
1294 runAssembler input_fn output_fn
1295 return (RealPhase next_phase, output_fn)
1296
1297
1298 -- This is for calling the assembler on a split assembly file (so a collection
1299 -- of assembly files)
1300 runPhase (RealPhase SplitAs) _input_fn dflags
1301 = do
1302 -- we'll handle the stub_o file in this phase, so don't MergeStub,
1303 -- just jump straight to StopLn afterwards.
1304 let next_phase = StopLn
1305 output_fn <- phaseOutputFilename next_phase
1306
1307 let base_o = dropExtension output_fn
1308 osuf = objectSuf dflags
1309 split_odir = base_o ++ "_" ++ osuf ++ "_split"
1310
1311 liftIO $ createDirectoryIfMissing True split_odir
1312
1313 -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1314 -- later and we don't want to pick up any old objects.
1315 fs <- liftIO $ getDirectoryContents split_odir
1316 liftIO $ mapM_ removeFile $
1317 map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1318
1319 let (split_s_prefix, n) = case splitInfo dflags of
1320 Nothing -> panic "No split info"
1321 Just x -> x
1322
1323 let split_s n = split_s_prefix ++ "__" ++ show n <.> "s"
1324
1325 split_obj :: Int -> FilePath
1326 split_obj n = split_odir </>
1327 takeFileName base_o ++ "__" ++ show n <.> osuf
1328
1329 let assemble_file n
1330 = SysTools.runAs dflags (
1331
1332 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1333 -- instruction so we have to make sure that the assembler accepts the
1334 -- instruction set. Note that the user can still override this
1335 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1336 -- regardless of the ordering.
1337 --
1338 -- This is a temporary hack.
1339 (if platformArch (targetPlatform dflags) == ArchSPARC
1340 then [SysTools.Option "-mcpu=v9"]
1341 else []) ++
1342
1343 [ SysTools.Option "-c"
1344 , SysTools.Option "-o"
1345 , SysTools.FileOption "" (split_obj n)
1346 , SysTools.FileOption "" (split_s n)
1347 ])
1348
1349 liftIO $ mapM_ assemble_file [1..n]
1350
1351 -- Note [pipeline-split-init]
1352 -- If we have a stub file, it may contain constructor
1353 -- functions for initialisation of this module. We can't
1354 -- simply leave the stub as a separate object file, because it
1355 -- will never be linked in: nothing refers to it. We need to
1356 -- ensure that if we ever refer to the data in this module
1357 -- that needs initialisation, then we also pull in the
1358 -- initialisation routine.
1359 --
1360 -- To that end, we make a DANGEROUS ASSUMPTION here: the data
1361 -- that needs to be initialised is all in the FIRST split
1362 -- object. See Note [codegen-split-init].
1363
1364 PipeState{maybe_stub_o} <- getPipeState
1365 case maybe_stub_o of
1366 Nothing -> return ()
1367 Just stub_o -> liftIO $ do
1368 tmp_split_1 <- newTempName dflags osuf
1369 let split_1 = split_obj 1
1370 copyFile split_1 tmp_split_1
1371 removeFile split_1
1372 joinObjectFiles dflags [tmp_split_1, stub_o] split_1
1373
1374 -- join them into a single .o file
1375 liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
1376
1377 return (RealPhase next_phase, output_fn)
1378
1379 -----------------------------------------------------------------------------
1380 -- LlvmOpt phase
1381
1382 runPhase (RealPhase LlvmOpt) input_fn dflags
1383 = do
1384 ver <- liftIO $ readIORef (llvmVersion dflags)
1385
1386 let opt_lvl = max 0 (min 2 $ optLevel dflags)
1387 -- don't specify anything if user has specified commands. We do this
1388 -- for opt but not llc since opt is very specifically for optimisation
1389 -- passes only, so if the user is passing us extra options we assume
1390 -- they know what they are doing and don't get in the way.
1391 optFlag = if null (getOpts dflags opt_lo)
1392 then map SysTools.Option $ words (llvmOpts !! opt_lvl)
1393 else []
1394 tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier
1395 | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
1396 | otherwise = "--enable-tbaa=false"
1397
1398
1399 output_fn <- phaseOutputFilename LlvmLlc
1400
1401 liftIO $ SysTools.runLlvmOpt dflags
1402 ([ SysTools.FileOption "" input_fn,
1403 SysTools.Option "-o",
1404 SysTools.FileOption "" output_fn]
1405 ++ optFlag
1406 ++ [SysTools.Option tbaa])
1407
1408 return (RealPhase LlvmLlc, output_fn)
1409 where
1410 -- we always (unless -optlo specified) run Opt since we rely on it to
1411 -- fix up some pretty big deficiencies in the code we generate
1412 llvmOpts = ["-mem2reg -globalopt", "-O1", "-O2"]
1413
1414 -----------------------------------------------------------------------------
1415 -- LlvmLlc phase
1416
1417 runPhase (RealPhase LlvmLlc) input_fn dflags
1418 = do
1419 ver <- liftIO $ readIORef (llvmVersion dflags)
1420
1421 let opt_lvl = max 0 (min 2 $ optLevel dflags)
1422 -- iOS requires external references to be loaded indirectly from the
1423 -- DATA segment or dyld traps at runtime writing into TEXT: see #7722
1424 rmodel | platformOS (targetPlatform dflags) == OSiOS = "dynamic-no-pic"
1425 | gopt Opt_PIC dflags = "pic"
1426 | not (gopt Opt_Static dflags) = "dynamic-no-pic"
1427 | otherwise = "static"
1428 tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier
1429 | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
1430 | otherwise = "--enable-tbaa=false"
1431
1432 -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
1433 let next_phase = case gopt Opt_NoLlvmMangler dflags of
1434 False -> LlvmMangle
1435 True | gopt Opt_SplitObjs dflags -> Splitter
1436 True -> As
1437
1438 output_fn <- phaseOutputFilename next_phase
1439
1440 liftIO $ SysTools.runLlvmLlc dflags
1441 ([ SysTools.Option (llvmOpts !! opt_lvl),
1442 SysTools.Option $ "-relocation-model=" ++ rmodel,
1443 SysTools.FileOption "" input_fn,
1444 SysTools.Option "-o", SysTools.FileOption "" output_fn]
1445 ++ [SysTools.Option tbaa]
1446 ++ map SysTools.Option fpOpts
1447 ++ map SysTools.Option abiOpts
1448 ++ map SysTools.Option sseOpts)
1449
1450 return (RealPhase next_phase, output_fn)
1451 where
1452 -- Bug in LLVM at O3 on OSX.
1453 llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
1454 then ["-O1", "-O2", "-O2"]
1455 else ["-O1", "-O2", "-O3"]
1456 -- On ARMv7 using LLVM, LLVM fails to allocate floating point registers
1457 -- while compiling GHC source code. It's probably due to fact that it
1458 -- does not enable VFP by default. Let's do this manually here
1459 fpOpts = case platformArch (targetPlatform dflags) of
1460 ArchARM ARMv7 ext _ -> if (elem VFPv3 ext)
1461 then ["-mattr=+v7,+vfp3"]
1462 else if (elem VFPv3D16 ext)
1463 then ["-mattr=+v7,+vfp3,+d16"]
1464 else []
1465 ArchARM ARMv6 ext _ -> if (elem VFPv2 ext)
1466 then ["-mattr=+v6,+vfp2"]
1467 else ["-mattr=+v6"]
1468 _ -> []
1469 -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still
1470 -- compiles into soft-float ABI. We need to explicitly set abi
1471 -- to hard
1472 abiOpts = case platformArch (targetPlatform dflags) of
1473 ArchARM _ _ HARD -> ["-float-abi=hard"]
1474 ArchARM _ _ _ -> []
1475 _ -> []
1476
1477 sseOpts | isSse4_2Enabled dflags = ["-mattr=+sse42"]
1478 | isSse2Enabled dflags = ["-mattr=+sse2"]
1479 | otherwise = []
1480
1481 -----------------------------------------------------------------------------
1482 -- LlvmMangle phase
1483
1484 runPhase (RealPhase LlvmMangle) input_fn dflags
1485 = do
1486 let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As
1487 output_fn <- phaseOutputFilename next_phase
1488 liftIO $ llvmFixupAsm dflags input_fn output_fn
1489 return (RealPhase next_phase, output_fn)
1490
1491 -----------------------------------------------------------------------------
1492 -- merge in stub objects
1493
1494 runPhase (RealPhase MergeStub) input_fn dflags
1495 = do
1496 PipeState{maybe_stub_o} <- getPipeState
1497 output_fn <- phaseOutputFilename StopLn
1498 case maybe_stub_o of
1499 Nothing ->
1500 panic "runPhase(MergeStub): no stub"
1501 Just stub_o -> do
1502 liftIO $ joinObjectFiles dflags [input_fn, stub_o] output_fn
1503 return (RealPhase StopLn, output_fn)
1504
1505 -- warning suppression
1506 runPhase (RealPhase other) _input_fn _dflags =
1507 panic ("runPhase: don't know how to run phase " ++ show other)
1508
1509 maybeMergeStub :: CompPipeline Phase
1510 maybeMergeStub
1511 = do
1512 PipeState{maybe_stub_o} <- getPipeState
1513 if isJust maybe_stub_o then return MergeStub else return StopLn
1514
1515 getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
1516 getLocation src_flavour mod_name = do
1517 dflags <- getDynFlags
1518
1519 PipeEnv{ src_basename=basename,
1520 src_suffix=suff } <- getPipeEnv
1521
1522 -- Build a ModLocation to pass to hscMain.
1523 -- The source filename is rather irrelevant by now, but it's used
1524 -- by hscMain for messages. hscMain also needs
1525 -- the .hi and .o filenames, and this is as good a way
1526 -- as any to generate them, and better than most. (e.g. takes
1527 -- into account the -osuf flags)
1528 location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
1529
1530 -- Boot-ify it if necessary
1531 let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
1532 | otherwise = location1
1533
1534
1535 -- Take -ohi into account if present
1536 -- This can't be done in mkHomeModuleLocation because
1537 -- it only applies to the module being compiles
1538 let ohi = outputHi dflags
1539 location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
1540 | otherwise = location2
1541
1542 -- Take -o into account if present
1543 -- Very like -ohi, but we must *only* do this if we aren't linking
1544 -- (If we're linking then the -o applies to the linked thing, not to
1545 -- the object file for one module.)
1546 -- Note the nasty duplication with the same computation in compileFile above
1547 let expl_o_file = outputFile dflags
1548 location4 | Just ofile <- expl_o_file
1549 , isNoLink (ghcLink dflags)
1550 = location3 { ml_obj_file = ofile }
1551 | otherwise = location3
1552
1553 return location4
1554
1555 -----------------------------------------------------------------------------
1556 -- MoveBinary sort-of-phase
1557 -- After having produced a binary, move it somewhere else and generate a
1558 -- wrapper script calling the binary. Currently, we need this only in
1559 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1560 -- central directory.
1561 -- This is called from linkBinary below, after linking. I haven't made it
1562 -- a separate phase to minimise interfering with other modules, and
1563 -- we don't need the generality of a phase (MoveBinary is always
1564 -- done after linking and makes only sense in a parallel setup) -- HWL
1565
1566 runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
1567 runPhase_MoveBinary dflags input_fn
1568 | WayPar `elem` ways dflags && not (gopt Opt_Static dflags) =
1569 panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
1570 | WayPar `elem` ways dflags = do
1571 let sysMan = pgm_sysman dflags
1572 pvm_root <- getEnv "PVM_ROOT"
1573 pvm_arch <- getEnv "PVM_ARCH"
1574 let
1575 pvm_executable_base = "=" ++ input_fn
1576 pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1577 -- nuke old binary; maybe use configur'ed names for cp and rm?
1578 _ <- tryIO (removeFile pvm_executable)
1579 -- move the newly created binary into PVM land
1580 copy dflags "copying PVM executable" input_fn pvm_executable
1581 -- generate a wrapper script for running a parallel prg under PVM
1582 writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1583 return True
1584 | otherwise = return True
1585
1586 mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
1587 mkExtraObj dflags extn xs
1588 = do cFile <- newTempName dflags extn
1589 oFile <- newTempName dflags "o"
1590 writeFile cFile xs
1591 let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
1592 SysTools.runCc dflags
1593 ([Option "-c",
1594 FileOption "" cFile,
1595 Option "-o",
1596 FileOption "" oFile]
1597 ++ map (FileOption "-I") (includeDirs rtsDetails))
1598 return oFile
1599
1600 -- When linking a binary, we need to create a C main() function that
1601 -- starts everything off. This used to be compiled statically as part
1602 -- of the RTS, but that made it hard to change the -rtsopts setting,
1603 -- so now we generate and compile a main() stub as part of every
1604 -- binary and pass the -rtsopts setting directly to the RTS (#5373)
1605 --
1606 mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
1607 mkExtraObjToLinkIntoBinary dflags = do
1608 when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
1609 log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
1610 (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
1611 text " Call hs_init_ghc() from your main() function to set these options.")
1612
1613 mkExtraObj dflags "c" (showSDoc dflags main)
1614
1615 where
1616 main
1617 | gopt Opt_NoHsMain dflags = empty
1618 | otherwise = vcat [
1619 ptext (sLit "#include \"Rts.h\""),
1620 ptext (sLit "extern StgClosure ZCMain_main_closure;"),
1621 ptext (sLit "int main(int argc, char *argv[])"),
1622 char '{',
1623 ptext (sLit " RtsConfig __conf = defaultRtsConfig;"),
1624 ptext (sLit " __conf.rts_opts_enabled = ")
1625 <> text (show (rtsOptsEnabled dflags)) <> semi,
1626 case rtsOpts dflags of
1627 Nothing -> empty
1628 Just opts -> ptext (sLit " __conf.rts_opts= ") <>
1629 text (show opts) <> semi,
1630 ptext (sLit " return hs_main(argc, argv, &ZCMain_main_closure,__conf);"),
1631 char '}',
1632 char '\n' -- final newline, to keep gcc happy
1633 ]
1634
1635 -- Write out the link info section into a new assembly file. Previously
1636 -- this was included as inline assembly in the main.c file but this
1637 -- is pretty fragile. gas gets upset trying to calculate relative offsets
1638 -- that span the .note section (notably .text) when debug info is present
1639 mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageId] -> IO [FilePath]
1640 mkNoteObjsToLinkIntoBinary dflags dep_packages = do
1641 link_info <- getLinkInfo dflags dep_packages
1642
1643 if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
1644 then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
1645 else return []
1646
1647 where
1648 link_opts info = hcat [
1649 text "\t.section ", text ghcLinkInfoSectionName,
1650 text ",\"\",",
1651 text elfSectionNote,
1652 text "\n",
1653
1654 text "\t.ascii \"", info', text "\"\n",
1655
1656 -- ALL generated assembly must have this section to disable
1657 -- executable stacks. See also
1658 -- compiler/nativeGen/AsmCodeGen.lhs for another instance
1659 -- where we need to do this.
1660 (if platformHasGnuNonexecStack (targetPlatform dflags)
1661 then text ".section .note.GNU-stack,\"\",@progbits\n"
1662 else empty)
1663
1664 ]
1665 where
1666 info' = text $ escape info
1667
1668 escape :: String -> String
1669 escape = concatMap (charToC.fromIntegral.ord)
1670
1671 elfSectionNote :: String
1672 elfSectionNote = case platformArch (targetPlatform dflags) of
1673 ArchARM _ _ _ -> "%note"
1674 _ -> "@note"
1675
1676 -- The "link info" is a string representing the parameters of the
1677 -- link. We save this information in the binary, and the next time we
1678 -- link, if nothing else has changed, we use the link info stored in
1679 -- the existing binary to decide whether to re-link or not.
1680 getLinkInfo :: DynFlags -> [PackageId] -> IO String
1681 getLinkInfo dflags dep_packages = do
1682 package_link_opts <- getPackageLinkOpts dflags dep_packages
1683 pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
1684 then getPackageFrameworks dflags dep_packages
1685 else return []
1686 let extra_ld_inputs = ldInputs dflags
1687 let
1688 link_info = (package_link_opts,
1689 pkg_frameworks,
1690 rtsOpts dflags,
1691 rtsOptsEnabled dflags,
1692 gopt Opt_NoHsMain dflags,
1693 map showOpt extra_ld_inputs,
1694 getOpts dflags opt_l)
1695 --
1696 return (show link_info)
1697
1698 -- generates a Perl skript starting a parallel prg under PVM
1699 mk_pvm_wrapper_script :: String -> String -> String -> String
1700 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1701 [
1702 "eval 'exec perl -S $0 ${1+\"$@\"}'",
1703 " if $running_under_some_shell;",
1704 "# =!=!=!=!=!=!=!=!=!=!=!",
1705 "# This script is automatically generated: DO NOT EDIT!!!",
1706 "# Generated by Glasgow Haskell Compiler",
1707 "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1708 "#",
1709 "$pvm_executable = '" ++ pvm_executable ++ "';",
1710 "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1711 "$SysMan = '" ++ sysMan ++ "';",
1712 "",
1713 {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1714 "# first, some magical shortcuts to run "commands" on the binary",
1715 "# (which is hidden)",
1716 "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1717 " local($cmd) = $1;",
1718 " system("$cmd $pvm_executable");",
1719 " exit(0); # all done",
1720 "}", -}
1721 "",
1722 "# Now, run the real binary; process the args first",
1723 "$ENV{'PE'} = $pvm_executable_base;", -- ++ pvm_executable_base,
1724 "$debug = '';",
1725 "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1726 "@nonPVM_args = ();",
1727 "$in_RTS_args = 0;",
1728 "",
1729 "args: while ($a = shift(@ARGV)) {",
1730 " if ( $a eq '+RTS' ) {",
1731 " $in_RTS_args = 1;",
1732 " } elsif ( $a eq '-RTS' ) {",
1733 " $in_RTS_args = 0;",
1734 " }",
1735 " if ( $a eq '-d' && $in_RTS_args ) {",
1736 " $debug = '-';",
1737 " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1738 " $nprocessors = $1;",
1739 " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1740 " $nprocessors = $1;",
1741 " } else {",
1742 " push(@nonPVM_args, $a);",
1743 " }",
1744 "}",
1745 "",
1746 "local($return_val) = 0;",
1747 "# Start the parallel execution by calling SysMan",
1748 "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1749 "$return_val = $?;",
1750 "# ToDo: fix race condition moving files and flushing them!!",
1751 "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1752 "exit($return_val);"
1753 ]
1754
1755 -----------------------------------------------------------------------------
1756 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1757
1758 getHCFilePackages :: FilePath -> IO [PackageId]
1759 getHCFilePackages filename =
1760 Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1761 l <- hGetLine h
1762 case l of
1763 '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1764 return (map stringToPackageId (words rest))
1765 _other ->
1766 return []
1767
1768 -----------------------------------------------------------------------------
1769 -- Static linking, of .o files
1770
1771 -- The list of packages passed to link is the list of packages on
1772 -- which this program depends, as discovered by the compilation
1773 -- manager. It is combined with the list of packages that the user
1774 -- specifies on the command line with -package flags.
1775 --
1776 -- In one-shot linking mode, we can't discover the package
1777 -- dependencies (because we haven't actually done any compilation or
1778 -- read any interface files), so the user must explicitly specify all
1779 -- the packages.
1780
1781 linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1782 linkBinary = linkBinary' False
1783
1784 linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageId] -> IO ()
1785 linkBinary' staticLink dflags o_files dep_packages = do
1786 let platform = targetPlatform dflags
1787 mySettings = settings dflags
1788 verbFlags = getVerbFlags dflags
1789 output_fn = exeFileName staticLink dflags
1790
1791 -- get the full list of packages to link with, by combining the
1792 -- explicit packages with the auto packages and all of their
1793 -- dependencies, and eliminating duplicates.
1794
1795 full_output_fn <- if isAbsolute output_fn
1796 then return output_fn
1797 else do d <- getCurrentDirectory
1798 return $ normalise (d </> output_fn)
1799 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1800 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1801 get_pkg_lib_path_opts l
1802 | osElfTarget (platformOS platform) &&
1803 dynLibLoader dflags == SystemDependent &&
1804 not (gopt Opt_Static dflags)
1805 = let libpath = if gopt Opt_RelativeDynlibPaths dflags
1806 then "$ORIGIN" </>
1807 (l `makeRelativeTo` full_output_fn)
1808 else l
1809 rpath = if gopt Opt_RPath dflags
1810 then ["-Wl,-rpath", "-Wl," ++ libpath]
1811 else []
1812 -- Solaris 11's linker does not support -rpath-link option. It silently
1813 -- ignores it and then complains about next option which is -l<some
1814 -- dir> as being a directory and not expected object file, E.g
1815 -- ld: elf error: file
1816 -- /tmp/ghc-src/libraries/base/dist-install/build:
1817 -- elf_begin: I/O error: region read: Is a directory
1818 rpathlink = if (platformOS platform) == OSSolaris2
1819 then []
1820 else ["-Wl,-rpath-link", "-Wl," ++ l]
1821 in ["-L" ++ l] ++ rpathlink ++ rpath
1822 | otherwise = ["-L" ++ l]
1823
1824 let lib_paths = libraryPaths dflags
1825 let lib_path_opts = map ("-L"++) lib_paths
1826
1827 extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
1828 noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
1829
1830 pkg_link_opts <- do
1831 (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages
1832 return $ if staticLink
1833 then package_hs_libs -- If building an executable really means making a static
1834 -- library (e.g. iOS), then we only keep the -l options for
1835 -- HS packages, because libtool doesn't accept other options.
1836 -- In the case of iOS these need to be added by hand to the
1837 -- final link in Xcode.
1838 else package_hs_libs ++ extra_libs ++ other_flags
1839
1840 pkg_framework_path_opts <-
1841 if platformUsesFrameworks platform
1842 then do pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1843 return $ map ("-F" ++) pkg_framework_paths
1844 else return []
1845
1846 framework_path_opts <-
1847 if platformUsesFrameworks platform
1848 then do let framework_paths = frameworkPaths dflags
1849 return $ map ("-F" ++) framework_paths
1850 else return []
1851
1852 pkg_framework_opts <-
1853 if platformUsesFrameworks platform
1854 then do pkg_frameworks <- getPackageFrameworks dflags dep_packages
1855 return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1856 else return []
1857
1858 framework_opts <-
1859 if platformUsesFrameworks platform
1860 then do let frameworks = cmdlineFrameworks dflags
1861 -- reverse because they're added in reverse order from
1862 -- the cmd line:
1863 return $ concat [ ["-framework", fw]
1864 | fw <- reverse frameworks ]
1865 else return []
1866
1867 -- probably _stub.o files
1868 let extra_ld_inputs = ldInputs dflags
1869
1870 -- Here are some libs that need to be linked at the *end* of
1871 -- the command line, because they contain symbols that are referred to
1872 -- by the RTS. We can't therefore use the ordinary way opts for these.
1873 let
1874 debug_opts | WayDebug `elem` ways dflags = [
1875 #if defined(HAVE_LIBBFD)
1876 "-lbfd", "-liberty"
1877 #endif
1878 ]
1879 | otherwise = []
1880
1881 let thread_opts
1882 | WayThreaded `elem` ways dflags =
1883 let os = platformOS (targetPlatform dflags)
1884 in if os == OSOsf3 then ["-lpthread", "-lexc"]
1885 else if os `elem` [OSMinGW32, OSFreeBSD, OSOpenBSD,
1886 OSNetBSD, OSHaiku, OSQNXNTO, OSiOS]
1887 then []
1888 else ["-lpthread"]
1889 | otherwise = []
1890
1891 rc_objs <- maybeCreateManifest dflags output_fn
1892
1893 let link = if staticLink
1894 then SysTools.runLibtool
1895 else SysTools.runLink
1896 link dflags (
1897 map SysTools.Option verbFlags
1898 ++ [ SysTools.Option "-o"
1899 , SysTools.FileOption "" output_fn
1900 ]
1901 ++ map SysTools.Option (
1902 []
1903
1904 -- Permit the linker to auto link _symbol to _imp_symbol.
1905 -- This lets us link against DLLs without needing an "import library".
1906 ++ (if platformOS platform == OSMinGW32
1907 then ["-Wl,--enable-auto-import"]
1908 else [])
1909
1910 -- '-no_compact_unwind'
1911 -- C++/Objective-C exceptions cannot use optimised
1912 -- stack unwinding code. The optimised form is the
1913 -- default in Xcode 4 on at least x86_64, and
1914 -- without this flag we're also seeing warnings
1915 -- like
1916 -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
1917 -- on x86.
1918 ++ (if sLdSupportsCompactUnwind mySettings &&
1919 not staticLink &&
1920 platformOS platform == OSDarwin &&
1921 platformArch platform `elem` [ArchX86, ArchX86_64]
1922 then ["-Wl,-no_compact_unwind"]
1923 else [])
1924
1925 -- '-Wl,-read_only_relocs,suppress'
1926 -- ld gives loads of warnings like:
1927 -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
1928 -- when linking any program. We're not sure
1929 -- whether this is something we ought to fix, but
1930 -- for now this flags silences them.
1931 ++ (if platformOS platform == OSDarwin &&
1932 platformArch platform == ArchX86 &&
1933 not staticLink
1934 then ["-Wl,-read_only_relocs,suppress"]
1935 else [])
1936
1937 ++ o_files
1938 ++ lib_path_opts)
1939 ++ extra_ld_inputs
1940 ++ map SysTools.Option (
1941 rc_objs
1942 ++ framework_path_opts
1943 ++ framework_opts
1944 ++ pkg_lib_path_opts
1945 ++ extraLinkObj:noteLinkObjs
1946 ++ pkg_link_opts
1947 ++ pkg_framework_path_opts
1948 ++ pkg_framework_opts
1949 ++ debug_opts
1950 ++ thread_opts
1951 ))
1952
1953 -- parallel only: move binary to another dir -- HWL
1954 success <- runPhase_MoveBinary dflags output_fn
1955 unless success $
1956 throwGhcExceptionIO (InstallationError ("cannot move binary"))
1957
1958
1959 exeFileName :: Bool -> DynFlags -> FilePath
1960 exeFileName staticLink dflags
1961 | Just s <- outputFile dflags =
1962 case platformOS (targetPlatform dflags) of
1963 OSMinGW32 -> s <?.> "exe"
1964 _ -> if staticLink
1965 then s <?.> "a"
1966 else s
1967 | otherwise =
1968 if platformOS (targetPlatform dflags) == OSMinGW32
1969 then "main.exe"
1970 else if staticLink
1971 then "liba.a"
1972 else "a.out"
1973 where s <?.> ext | null (takeExtension s) = s <.> ext
1974 | otherwise = s
1975
1976 maybeCreateManifest
1977 :: DynFlags
1978 -> FilePath -- filename of executable
1979 -> IO [FilePath] -- extra objects to embed, maybe
1980 maybeCreateManifest dflags exe_filename
1981 | platformOS (targetPlatform dflags) == OSMinGW32 &&
1982 gopt Opt_GenManifest dflags
1983 = do let manifest_filename = exe_filename <.> "manifest"
1984
1985 writeFile manifest_filename $
1986 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1987 " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1988 " <assemblyIdentity version=\"1.0.0.0\"\n"++
1989 " processorArchitecture=\"X86\"\n"++
1990 " name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1991 " type=\"win32\"/>\n\n"++
1992 " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1993 " <security>\n"++
1994 " <requestedPrivileges>\n"++
1995 " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1996 " </requestedPrivileges>\n"++
1997 " </security>\n"++
1998 " </trustInfo>\n"++
1999 "</assembly>\n"
2000
2001 -- Windows will find the manifest file if it is named
2002 -- foo.exe.manifest. However, for extra robustness, and so that
2003 -- we can move the binary around, we can embed the manifest in
2004 -- the binary itself using windres:
2005 if not (gopt Opt_EmbedManifest dflags) then return [] else do
2006
2007 rc_filename <- newTempName dflags "rc"
2008 rc_obj_filename <- newTempName dflags (objectSuf dflags)
2009
2010 writeFile rc_filename $
2011 "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
2012 -- magic numbers :-)
2013 -- show is a bit hackish above, but we need to escape the
2014 -- backslashes in the path.
2015
2016 runWindres dflags $ map SysTools.Option $
2017 ["--input="++rc_filename,
2018 "--output="++rc_obj_filename,
2019 "--output-format=coff"]
2020 -- no FileOptions here: windres doesn't like seeing
2021 -- backslashes, apparently
2022
2023 removeFile manifest_filename
2024
2025 return [rc_obj_filename]
2026 | otherwise = return []
2027
2028
2029 linkDynLibCheck :: DynFlags -> [String] -> [PackageId] -> IO ()
2030 linkDynLibCheck dflags o_files dep_packages
2031 = do
2032 when (haveRtsOptsFlags dflags) $ do
2033 log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
2034 (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
2035 text " Call hs_init_ghc() from your main() function to set these options.")
2036
2037 linkDynLib dflags o_files dep_packages
2038
2039 linkStaticLibCheck :: DynFlags -> [String] -> [PackageId] -> IO ()
2040 linkStaticLibCheck dflags o_files dep_packages
2041 = do
2042 when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $
2043 throwGhcExceptionIO (ProgramError "Static archive creation only supported on Darwin/OS X/iOS")
2044 linkBinary' True dflags o_files dep_packages
2045
2046 -- -----------------------------------------------------------------------------
2047 -- Running CPP
2048
2049 doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
2050 doCpp dflags raw input_fn output_fn = do
2051 let hscpp_opts = picPOpts dflags
2052 let cmdline_include_paths = includePaths dflags
2053
2054 pkg_include_dirs <- getPackageIncludePath dflags []
2055 let include_paths = foldr (\ x xs -> "-I" : x : xs) []
2056 (cmdline_include_paths ++ pkg_include_dirs)
2057
2058 let verbFlags = getVerbFlags dflags
2059
2060 let cpp_prog args | raw = SysTools.runCpp dflags args
2061 | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
2062
2063 let target_defs =
2064 [ "-D" ++ HOST_OS ++ "_BUILD_OS=1",
2065 "-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1",
2066 "-D" ++ TARGET_OS ++ "_HOST_OS=1",
2067 "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
2068 -- remember, in code we *compile*, the HOST is the same our TARGET,
2069 -- and BUILD is the same as our HOST.
2070
2071 let sse2 = isSse2Enabled dflags
2072 sse4_2 = isSse4_2Enabled dflags
2073 sse_defs =
2074 [ "-D__SSE__=1" | sse2 || sse4_2 ] ++
2075 [ "-D__SSE2__=1" | sse2 || sse4_2 ] ++
2076 [ "-D__SSE4_2__=1" | sse4_2 ]
2077
2078 backend_defs <- getBackendDefs dflags
2079
2080 cpp_prog ( map SysTools.Option verbFlags
2081 ++ map SysTools.Option include_paths
2082 ++ map SysTools.Option hsSourceCppOpts
2083 ++ map SysTools.Option target_defs
2084 ++ map SysTools.Option backend_defs
2085 ++ map SysTools.Option hscpp_opts
2086 ++ map SysTools.Option sse_defs
2087 -- Set the language mode to assembler-with-cpp when preprocessing. This
2088 -- alleviates some of the C99 macro rules relating to whitespace and the hash
2089 -- operator, which we tend to abuse. Clang in particular is not very happy
2090 -- about this.
2091 ++ [ SysTools.Option "-x"
2092 , SysTools.Option "assembler-with-cpp"
2093 , SysTools.Option input_fn
2094 -- We hackily use Option instead of FileOption here, so that the file
2095 -- name is not back-slashed on Windows. cpp is capable of
2096 -- dealing with / in filenames, so it works fine. Furthermore
2097 -- if we put in backslashes, cpp outputs #line directives
2098 -- with *double* backslashes. And that in turn means that
2099 -- our error messages get double backslashes in them.
2100 -- In due course we should arrange that the lexer deals
2101 -- with these \\ escapes properly.
2102 , SysTools.Option "-o"
2103 , SysTools.FileOption "" output_fn
2104 ])
2105
2106 getBackendDefs :: DynFlags -> IO [String]
2107 getBackendDefs dflags | hscTarget dflags == HscLlvm = do
2108 llvmVer <- figureLlvmVersion dflags
2109 return [ "-D__GLASGOW_HASKELL_LLVM__="++show llvmVer ]
2110
2111 getBackendDefs _ =
2112 return []
2113
2114 hsSourceCppOpts :: [String]
2115 -- Default CPP defines in Haskell source
2116 hsSourceCppOpts =
2117 [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
2118
2119 -- ---------------------------------------------------------------------------
2120 -- join object files into a single relocatable object file, using ld -r
2121
2122 joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
2123 joinObjectFiles dflags o_files output_fn = do
2124 let mySettings = settings dflags
2125 ldIsGnuLd = sLdIsGnuLd mySettings
2126 ld_r args = SysTools.runLink dflags ([
2127 SysTools.Option "-nostdlib",
2128 SysTools.Option "-nodefaultlibs",
2129 SysTools.Option "-Wl,-r"
2130 ]
2131 -- gcc on sparc sets -Wl,--relax implicitly, but
2132 -- -r and --relax are incompatible for ld, so
2133 -- disable --relax explicitly.
2134 ++ (if platformArch (targetPlatform dflags) == ArchSPARC
2135 && ldIsGnuLd
2136 then [SysTools.Option "-Wl,-no-relax"]
2137 else [])
2138 ++ map SysTools.Option ld_build_id
2139 ++ [ SysTools.Option "-o",
2140 SysTools.FileOption "" output_fn ]
2141 ++ args)
2142
2143 -- suppress the generation of the .note.gnu.build-id section,
2144 -- which we don't need and sometimes causes ld to emit a
2145 -- warning:
2146 ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"]
2147 | otherwise = []
2148
2149 if ldIsGnuLd
2150 then do
2151 script <- newTempName dflags "ldscript"
2152 writeFile script $ "INPUT(" ++ unwords o_files ++ ")"
2153 ld_r [SysTools.FileOption "" script]
2154 else if sLdSupportsFilelist mySettings
2155 then do
2156 filelist <- newTempName dflags "filelist"
2157 writeFile filelist $ unlines o_files
2158 ld_r [SysTools.Option "-Wl,-filelist",
2159 SysTools.FileOption "-Wl," filelist]
2160 else do
2161 ld_r (map (SysTools.FileOption "") o_files)
2162
2163 -- -----------------------------------------------------------------------------
2164 -- Misc.
2165
2166 -- | What phase to run after one of the backend code generators has run
2167 hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
2168 hscPostBackendPhase _ HsBootFile _ = StopLn
2169 hscPostBackendPhase dflags _ hsc_lang =
2170 case hsc_lang of
2171 HscC -> HCc
2172 HscAsm | gopt Opt_SplitObjs dflags -> Splitter
2173 | otherwise -> As
2174 HscLlvm -> LlvmOpt
2175 HscNothing -> StopLn
2176 HscInterpreted -> StopLn
2177
2178 touchObjectFile :: DynFlags -> FilePath -> IO ()
2179 touchObjectFile dflags path = do
2180 createDirectoryIfMissing True $ takeDirectory path
2181 SysTools.touch dflags "Touching object file" path
2182
2183 haveRtsOptsFlags :: DynFlags -> Bool
2184 haveRtsOptsFlags dflags =
2185 isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of
2186 RtsOptsSafeOnly -> False
2187 _ -> True