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