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