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