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