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