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