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