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