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