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