Merge branch 'master' of http://darcs.haskell.org/ghc
[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 (FileOutputStatus, 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 -- If we are dong -fno-code, then act as if the output is
444 -- 'Temporary'. This stops GHC trying to copy files to their
445 -- final location.
446 | HscNothing <- hscTarget dflags = Temporary
447 | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
448 -- -o foo applies to linker
449 | Just o_file <- mb_o_file = SpecificFile o_file
450 -- -o foo applies to the file we are compiling now
451 | otherwise = Persistent
452
453 stop_phase' = case stop_phase of
454 As | split -> SplitAs
455 _ -> stop_phase
456
457 ( _, out_file) <- runPipeline stop_phase' hsc_env
458 (src, mb_phase) Nothing output
459 Nothing{-no ModLocation-} Nothing
460 return out_file
461
462
463 doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
464 doLink dflags stop_phase o_files
465 | not (isStopLn stop_phase)
466 = return () -- We stopped before the linking phase
467
468 | otherwise
469 = case ghcLink dflags of
470 NoLink -> return ()
471 LinkBinary -> linkBinary dflags o_files []
472 LinkDynLib -> linkDynLibCheck dflags o_files []
473 other -> panicBadLink other
474
475
476 -- ---------------------------------------------------------------------------
477
478 data PipelineOutput
479 = Temporary
480 -- ^ Output should be to a temporary file: we're going to
481 -- run more compilation steps on this output later.
482 | Persistent
483 -- ^ We want a persistent file, i.e. a file in the current directory
484 -- derived from the input filename, but with the appropriate extension.
485 -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
486 | SpecificFile FilePath
487 -- ^ The output must go into the specified file.
488 deriving Show
489
490 -- | Run a compilation pipeline, consisting of multiple phases.
491 --
492 -- This is the interface to the compilation pipeline, which runs
493 -- a series of compilation steps on a single source file, specifying
494 -- at which stage to stop.
495 --
496 -- The DynFlags can be modified by phases in the pipeline (eg. by
497 -- OPTIONS_GHC pragmas), and the changes affect later phases in the
498 -- pipeline.
499 runPipeline
500 :: Phase -- ^ When to stop
501 -> HscEnv -- ^ Compilation environment
502 -> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix)
503 -> Maybe FilePath -- ^ original basename (if different from ^^^)
504 -> PipelineOutput -- ^ Output filename
505 -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
506 -> Maybe FilePath -- ^ stub object, if we have one
507 -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
508 runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
509 mb_basename output maybe_loc maybe_stub_o
510
511 = do let
512 dflags0 = hsc_dflags hsc_env0
513
514 -- Decide where dump files should go based on the pipeline output
515 dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
516 hsc_env = hsc_env0 {hsc_dflags = dflags}
517
518 (input_basename, suffix) = splitExtension input_fn
519 suffix' = drop 1 suffix -- strip off the .
520 basename | Just b <- mb_basename = b
521 | otherwise = input_basename
522
523 -- If we were given a -x flag, then use that phase to start from
524 start_phase = fromMaybe (startPhase suffix') mb_phase
525
526 isHaskell (Unlit _) = True
527 isHaskell (Cpp _) = True
528 isHaskell (HsPp _) = True
529 isHaskell (Hsc _) = True
530 isHaskell _ = False
531
532 isHaskellishFile = isHaskell start_phase
533
534 env = PipeEnv{ pe_isHaskellishFile = isHaskellishFile,
535 stop_phase,
536 src_filename = input_fn,
537 src_basename = basename,
538 src_suffix = suffix',
539 output_spec = output }
540
541 -- We want to catch cases of "you can't get there from here" before
542 -- we start the pipeline, because otherwise it will just run off the
543 -- end.
544 --
545 -- There is a partial ordering on phases, where A < B iff A occurs
546 -- before B in a normal compilation pipeline.
547
548 let happensBefore' = happensBefore dflags
549 when (not (start_phase `happensBefore'` stop_phase)) $
550 throwGhcExceptionIO (UsageError
551 ("cannot compile this file to desired target: "
552 ++ input_fn))
553
554 debugTraceMsg dflags 4 (text "Running the pipeline")
555 r <- runPipeline' start_phase hsc_env env input_fn
556 maybe_loc maybe_stub_o
557
558 -- If we are compiling a Haskell module, and doing
559 -- -dynamic-too, but couldn't do the -dynamic-too fast
560 -- path, then rerun the pipeline for the dyn way
561 let dflags = extractDynFlags hsc_env
562 when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
563 debugTraceMsg dflags 4
564 (text "Running the pipeline again for -dynamic-too")
565 let dflags' = doDynamicToo dflags
566 -- TODO: This should use -dyno
567 output' = case output of
568 SpecificFile fn -> SpecificFile (replaceExtension fn (objectSuf dflags'))
569 Persistent -> Persistent
570 Temporary -> Temporary
571 env' = env { output_spec = output' }
572 hsc_env' <- newHscEnv dflags'
573 _ <- runPipeline' start_phase hsc_env' env' input_fn
574 maybe_loc maybe_stub_o
575 return ()
576 return r
577
578 runPipeline'
579 :: Phase -- ^ When to start
580 -> HscEnv -- ^ Compilation environment
581 -> PipeEnv
582 -> FilePath -- ^ Input filename
583 -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
584 -> Maybe FilePath -- ^ stub object, if we have one
585 -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
586 runPipeline' start_phase hsc_env env input_fn
587 maybe_loc maybe_stub_o
588 = do
589 -- Execute the pipeline...
590 let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
591
592 evalP (pipeLoop start_phase input_fn) env state
593
594 -- -----------------------------------------------------------------------------
595 -- The pipeline uses a monad to carry around various bits of information
596
597 -- PipeEnv: invariant information passed down
598 data PipeEnv = PipeEnv {
599 pe_isHaskellishFile :: Bool,
600 stop_phase :: Phase, -- ^ Stop just before this phase
601 src_filename :: String, -- ^ basename of original input source
602 src_basename :: String, -- ^ basename of original input source
603 src_suffix :: String, -- ^ its extension
604 output_spec :: PipelineOutput -- ^ says where to put the pipeline output
605 }
606
607 -- PipeState: information that might change during a pipeline run
608 data PipeState = PipeState {
609 hsc_env :: HscEnv,
610 -- ^ only the DynFlags change in the HscEnv. The DynFlags change
611 -- at various points, for example when we read the OPTIONS_GHC
612 -- pragmas in the Cpp phase.
613 maybe_loc :: Maybe ModLocation,
614 -- ^ the ModLocation. This is discovered during compilation,
615 -- in the Hsc phase where we read the module header.
616 maybe_stub_o :: Maybe FilePath
617 -- ^ the stub object. This is set by the Hsc phase if a stub
618 -- object was created. The stub object will be joined with
619 -- the main compilation object using "ld -r" at the end.
620 }
621
622 getPipeEnv :: CompPipeline PipeEnv
623 getPipeEnv = P $ \env state -> return (state, env)
624
625 getPipeState :: CompPipeline PipeState
626 getPipeState = P $ \_env state -> return (state, state)
627
628 instance HasDynFlags CompPipeline where
629 getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
630
631 setDynFlags :: DynFlags -> CompPipeline ()
632 setDynFlags dflags = P $ \_env state ->
633 return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())
634
635 setModLocation :: ModLocation -> CompPipeline ()
636 setModLocation loc = P $ \_env state ->
637 return (state{ maybe_loc = Just loc }, ())
638
639 setStubO :: FilePath -> CompPipeline ()
640 setStubO stub_o = P $ \_env state ->
641 return (state{ maybe_stub_o = Just stub_o }, ())
642
643 newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
644
645 evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
646 evalP f env st = liftM snd $ unP f env st
647
648 instance Monad CompPipeline where
649 return a = P $ \_env state -> return (state, a)
650 P m >>= k = P $ \env state -> do (state',a) <- m env state
651 unP (k a) env state'
652
653 instance MonadIO CompPipeline where
654 liftIO m = P $ \_env state -> do a <- m; return (state, a)
655
656 phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
657 phaseOutputFilename next_phase = do
658 PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
659 PipeState{maybe_loc, hsc_env} <- getPipeState
660 let dflags = hsc_dflags hsc_env
661 liftIO $ getOutputFilename stop_phase output_spec
662 src_basename dflags next_phase maybe_loc
663
664 -- ---------------------------------------------------------------------------
665 -- outer pipeline loop
666
667 -- | pipeLoop runs phases until we reach the stop phase
668 pipeLoop :: Phase -> FilePath -> CompPipeline (DynFlags, FilePath)
669 pipeLoop phase input_fn = do
670 env <- getPipeEnv
671 dflags <- getDynFlags
672 let happensBefore' = happensBefore dflags
673 stopPhase = stop_phase env
674 case () of
675 _ | phase `eqPhase` stopPhase -- All done
676 -> -- Sometimes, a compilation phase doesn't actually generate any output
677 -- (eg. the CPP phase when -fcpp is not turned on). If we end on this
678 -- stage, but we wanted to keep the output, then we have to explicitly
679 -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
680 -- further compilation stages can tell what the original filename was.
681 case output_spec env of
682 Temporary ->
683 return (dflags, input_fn)
684 output ->
685 do pst <- getPipeState
686 final_fn <- liftIO $ getOutputFilename
687 stopPhase output (src_basename env)
688 dflags stopPhase (maybe_loc pst)
689 when (final_fn /= input_fn) $ do
690 let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
691 line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
692 liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
693 return (dflags, final_fn)
694
695
696 | not (phase `happensBefore'` stopPhase)
697 -- Something has gone wrong. We'll try to cover all the cases when
698 -- this could happen, so if we reach here it is a panic.
699 -- eg. it might happen if the -C flag is used on a source file that
700 -- has {-# OPTIONS -fasm #-}.
701 -> panic ("pipeLoop: at phase " ++ show phase ++
702 " but I wanted to stop at phase " ++ show stopPhase)
703
704 | otherwise
705 -> do liftIO $ debugTraceMsg dflags 4
706 (ptext (sLit "Running phase") <+> ppr phase)
707 (next_phase, output_fn) <- runPhase phase input_fn dflags
708 pipeLoop next_phase output_fn
709
710 -- -----------------------------------------------------------------------------
711 -- In each phase, we need to know into what filename to generate the
712 -- output. All the logic about which filenames we generate output
713 -- into is embodied in the following function.
714
715 getOutputFilename
716 :: Phase -> PipelineOutput -> String
717 -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
718 getOutputFilename stop_phase output basename dflags next_phase maybe_location
719 | is_last_phase, Persistent <- output = persistent_fn
720 | is_last_phase, SpecificFile f <- output = return f
721 | keep_this_output = persistent_fn
722 | otherwise = newTempName dflags suffix
723 where
724 hcsuf = hcSuf dflags
725 odir = objectDir dflags
726 osuf = objectSuf dflags
727 keep_hc = gopt Opt_KeepHcFiles dflags
728 keep_s = gopt Opt_KeepSFiles dflags
729 keep_bc = gopt Opt_KeepLlvmFiles dflags
730
731 myPhaseInputExt HCc = hcsuf
732 myPhaseInputExt MergeStub = osuf
733 myPhaseInputExt StopLn = osuf
734 myPhaseInputExt other = phaseInputExt other
735
736 is_last_phase = next_phase `eqPhase` stop_phase
737
738 -- sometimes, we keep output from intermediate stages
739 keep_this_output =
740 case next_phase of
741 As | keep_s -> True
742 LlvmOpt | keep_bc -> True
743 HCc | keep_hc -> True
744 _other -> False
745
746 suffix = myPhaseInputExt next_phase
747
748 -- persistent object files get put in odir
749 persistent_fn
750 | StopLn <- next_phase = return odir_persistent
751 | otherwise = return persistent
752
753 persistent = basename <.> suffix
754
755 odir_persistent
756 | Just loc <- maybe_location = ml_obj_file loc
757 | Just d <- odir = d </> persistent
758 | otherwise = persistent
759
760
761 -- -----------------------------------------------------------------------------
762 -- | Each phase in the pipeline returns the next phase to execute, and the
763 -- name of the file in which the output was placed.
764 --
765 -- We must do things dynamically this way, because we often don't know
766 -- what the rest of the phases will be until part-way through the
767 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
768 -- of a source file can change the latter stages of the pipeline from
769 -- taking the via-C route to using the native code generator.
770 --
771 runPhase :: Phase -- ^ Run this phase
772 -> FilePath -- ^ name of the input file
773 -> DynFlags -- ^ for convenience, we pass the current dflags in
774 -> CompPipeline (Phase, -- next phase to run
775 FilePath) -- output filename
776
777 -- Invariant: the output filename always contains the output
778 -- Interesting case: Hsc when there is no recompilation to do
779 -- Then the output filename is still a .o file
780
781
782 -------------------------------------------------------------------------------
783 -- Unlit phase
784
785 runPhase (Unlit sf) input_fn dflags
786 = do
787 output_fn <- phaseOutputFilename (Cpp sf)
788
789 let unlit_flags = getOpts dflags opt_L
790 flags = map SysTools.Option unlit_flags ++
791 [ -- The -h option passes the file name for unlit to
792 -- put in a #line directive
793 SysTools.Option "-h"
794 , SysTools.Option $ escape $ normalise input_fn
795 , SysTools.FileOption "" input_fn
796 , SysTools.FileOption "" output_fn
797 ]
798
799 liftIO $ SysTools.runUnlit dflags flags
800
801 return (Cpp sf, output_fn)
802 where
803 -- escape the characters \, ", and ', but don't try to escape
804 -- Unicode or anything else (so we don't use Util.charToC
805 -- here). If we get this wrong, then in
806 -- Coverage.addTicksToBinds where we check that the filename in
807 -- a SrcLoc is the same as the source filenaame, the two will
808 -- look bogusly different. See test:
809 -- libraries/hpc/tests/function/subdir/tough2.lhs
810 escape ('\\':cs) = '\\':'\\': escape cs
811 escape ('\"':cs) = '\\':'\"': escape cs
812 escape ('\'':cs) = '\\':'\'': escape cs
813 escape (c:cs) = c : escape cs
814 escape [] = []
815
816 -------------------------------------------------------------------------------
817 -- Cpp phase : (a) gets OPTIONS out of file
818 -- (b) runs cpp if necessary
819
820 runPhase (Cpp sf) input_fn dflags0
821 = do
822 src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
823 (dflags1, unhandled_flags, warns)
824 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
825 setDynFlags dflags1
826 liftIO $ checkProcessArgsResult dflags1 unhandled_flags
827
828 if not (xopt Opt_Cpp dflags1) then do
829 -- we have to be careful to emit warnings only once.
830 unless (gopt Opt_Pp dflags1) $
831 liftIO $ handleFlagWarnings dflags1 warns
832
833 -- no need to preprocess CPP, just pass input file along
834 -- to the next phase of the pipeline.
835 return (HsPp sf, input_fn)
836 else do
837 output_fn <- phaseOutputFilename (HsPp sf)
838 liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-}
839 input_fn output_fn
840 -- re-read the pragmas now that we've preprocessed the file
841 -- See #2464,#3457
842 src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
843 (dflags2, unhandled_flags, warns)
844 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
845 liftIO $ checkProcessArgsResult dflags2 unhandled_flags
846 unless (gopt Opt_Pp dflags2) $
847 liftIO $ handleFlagWarnings dflags2 warns
848 -- the HsPp pass below will emit warnings
849
850 setDynFlags dflags2
851
852 return (HsPp sf, output_fn)
853
854 -------------------------------------------------------------------------------
855 -- HsPp phase
856
857 runPhase (HsPp sf) input_fn dflags
858 = do
859 if not (gopt Opt_Pp dflags) then
860 -- no need to preprocess, just pass input file along
861 -- to the next phase of the pipeline.
862 return (Hsc sf, input_fn)
863 else do
864 let hspp_opts = getOpts dflags opt_F
865 PipeEnv{src_basename, src_suffix} <- getPipeEnv
866 let orig_fn = src_basename <.> src_suffix
867 output_fn <- phaseOutputFilename (Hsc sf)
868 liftIO $ SysTools.runPp dflags
869 ( [ SysTools.Option orig_fn
870 , SysTools.Option input_fn
871 , SysTools.FileOption "" output_fn
872 ] ++
873 map SysTools.Option hspp_opts
874 )
875
876 -- re-read pragmas now that we've parsed the file (see #3674)
877 src_opts <- liftIO $ getOptionsFromFile dflags output_fn
878 (dflags1, unhandled_flags, warns)
879 <- liftIO $ parseDynamicFilePragma dflags src_opts
880 setDynFlags dflags1
881 liftIO $ checkProcessArgsResult dflags1 unhandled_flags
882 liftIO $ handleFlagWarnings dflags1 warns
883
884 return (Hsc sf, output_fn)
885
886 -----------------------------------------------------------------------------
887 -- Hsc phase
888
889 -- Compilation of a single module, in "legacy" mode (_not_ under
890 -- the direction of the compilation manager).
891 runPhase (Hsc src_flavour) input_fn dflags0
892 = do -- normal Hsc mode, not mkdependHS
893
894 PipeEnv{ stop_phase=stop,
895 src_basename=basename,
896 src_suffix=suff } <- getPipeEnv
897
898 -- we add the current directory (i.e. the directory in which
899 -- the .hs files resides) to the include path, since this is
900 -- what gcc does, and it's probably what you want.
901 let current_dir = takeDirectory basename
902 paths = includePaths dflags0
903 dflags = dflags0 { includePaths = current_dir : paths }
904
905 setDynFlags dflags
906
907 -- gather the imports and module name
908 (hspp_buf,mod_name,imps,src_imps) <- liftIO $
909 case src_flavour of
910 ExtCoreFile -> do -- no explicit imports in ExtCore input.
911 m <- getCoreModuleName input_fn
912 return (Nothing, mkModuleName m, [], [])
913
914 _ -> do
915 buf <- hGetStringBuffer input_fn
916 (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
917 return (Just buf, mod_name, imps, src_imps)
918
919 -- Build a ModLocation to pass to hscMain.
920 -- The source filename is rather irrelevant by now, but it's used
921 -- by hscMain for messages. hscMain also needs
922 -- the .hi and .o filenames, and this is as good a way
923 -- as any to generate them, and better than most. (e.g. takes
924 -- into accout the -osuf flags)
925 location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
926
927 -- Boot-ify it if necessary
928 let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
929 | otherwise = location1
930
931
932 -- Take -ohi into account if present
933 -- This can't be done in mkHomeModuleLocation because
934 -- it only applies to the module being compiles
935 let ohi = outputHi dflags
936 location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
937 | otherwise = location2
938
939 -- Take -o into account if present
940 -- Very like -ohi, but we must *only* do this if we aren't linking
941 -- (If we're linking then the -o applies to the linked thing, not to
942 -- the object file for one module.)
943 -- Note the nasty duplication with the same computation in compileFile above
944 let expl_o_file = outputFile dflags
945 location4 | Just ofile <- expl_o_file
946 , isNoLink (ghcLink dflags)
947 = location3 { ml_obj_file = ofile }
948 | otherwise = location3
949
950 o_file = ml_obj_file location4 -- The real object file
951
952 setModLocation location4
953
954 -- Figure out if the source has changed, for recompilation avoidance.
955 --
956 -- Setting source_unchanged to True means that M.o seems
957 -- to be up to date wrt M.hs; so no need to recompile unless imports have
958 -- changed (which the compiler itself figures out).
959 -- Setting source_unchanged to False tells the compiler that M.o is out of
960 -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
961 src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
962
963 let hsc_lang = hscTarget dflags
964 source_unchanged <- liftIO $
965 if not (isStopLn stop)
966 -- SourceModified unconditionally if
967 -- (a) recompilation checker is off, or
968 -- (b) we aren't going all the way to .o file (e.g. ghc -S)
969 then return SourceModified
970 -- Otherwise look at file modification dates
971 else do o_file_exists <- doesFileExist o_file
972 if not o_file_exists
973 then return SourceModified -- Need to recompile
974 else do t2 <- getModificationUTCTime o_file
975 if t2 > src_timestamp
976 then return SourceUnmodified
977 else return SourceModified
978
979 -- get the DynFlags
980 let next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
981 output_fn <- phaseOutputFilename next_phase
982
983 let dflags' = dflags { hscOutName = output_fn,
984 extCoreName = basename ++ ".hcr" }
985
986 setDynFlags dflags'
987 PipeState{hsc_env=hsc_env'} <- getPipeState
988
989 -- Tell the finder cache about this module
990 mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4
991
992 -- Make the ModSummary to hand to hscMain
993 let
994 mod_summary = ModSummary { ms_mod = mod,
995 ms_hsc_src = src_flavour,
996 ms_hspp_file = input_fn,
997 ms_hspp_opts = dflags,
998 ms_hspp_buf = hspp_buf,
999 ms_location = location4,
1000 ms_hs_date = src_timestamp,
1001 ms_obj_date = Nothing,
1002 ms_textual_imps = imps,
1003 ms_srcimps = src_imps }
1004
1005 -- run the compiler!
1006 result <- liftIO $ hscCompileOneShot hsc_env'
1007 mod_summary source_unchanged
1008 Nothing -- No iface
1009 Nothing -- No "module i of n" progress info
1010
1011 case result of
1012 HscNoRecomp
1013 -> do liftIO $ touchObjectFile dflags' o_file
1014 -- The .o file must have a later modification date
1015 -- than the source file (else we wouldn't be in HscNoRecomp)
1016 -- but we touch it anyway, to keep 'make' happy (we think).
1017 return (StopLn, o_file)
1018 (HscRecomp hasStub mOutputFilename)
1019 -> do case hasStub of
1020 Nothing -> return ()
1021 Just stub_c ->
1022 do stub_o <- liftIO $ compileStub hsc_env' stub_c
1023 setStubO stub_o
1024 -- In the case of hs-boot files, generate a dummy .o-boot
1025 -- stamp file for the benefit of Make
1026 outputFilename <-
1027 case mOutputFilename of
1028 Just x -> return x
1029 Nothing ->
1030 if isHsBoot src_flavour
1031 then do liftIO $ touchObjectFile dflags' o_file
1032 whenGeneratingDynamicToo dflags' $ do
1033 let dyn_o_file = addBootSuffix (replaceExtension o_file (dynObjectSuf dflags'))
1034 liftIO $ touchObjectFile dflags' dyn_o_file
1035 return o_file
1036 else return $ panic "runPhase Hsc: No output filename"
1037
1038 return (next_phase, outputFilename)
1039
1040 -----------------------------------------------------------------------------
1041 -- Cmm phase
1042
1043 runPhase CmmCpp input_fn dflags
1044 = do
1045 output_fn <- phaseOutputFilename Cmm
1046 liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-}
1047 input_fn output_fn
1048 return (Cmm, output_fn)
1049
1050 runPhase Cmm input_fn dflags
1051 = do
1052 PipeEnv{src_basename} <- getPipeEnv
1053 let hsc_lang = hscTarget dflags
1054
1055 let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang
1056
1057 output_fn <- phaseOutputFilename next_phase
1058
1059 let dflags' = dflags { hscOutName = output_fn,
1060 extCoreName = src_basename ++ ".hcr" }
1061
1062 setDynFlags dflags'
1063 PipeState{hsc_env} <- getPipeState
1064
1065 liftIO $ hscCompileCmmFile hsc_env input_fn
1066
1067 return (next_phase, output_fn)
1068
1069 -----------------------------------------------------------------------------
1070 -- Cc phase
1071
1072 -- we don't support preprocessing .c files (with -E) now. Doing so introduces
1073 -- way too many hacks, and I can't say I've ever used it anyway.
1074
1075 runPhase cc_phase input_fn dflags
1076 | any (cc_phase `eqPhase`) [Cc, Ccpp, HCc, Cobjc, Cobjcpp]
1077 = do
1078 let platform = targetPlatform dflags
1079 cc_opts = getOpts dflags opt_c
1080 hcc = cc_phase `eqPhase` HCc
1081
1082 let cmdline_include_paths = includePaths dflags
1083
1084 -- HC files have the dependent packages stamped into them
1085 pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []
1086
1087 -- add package include paths even if we're just compiling .c
1088 -- files; this is the Value Add(TM) that using ghc instead of
1089 -- gcc gives you :)
1090 pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
1091 let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1092 (cmdline_include_paths ++ pkg_include_dirs)
1093
1094 let gcc_extra_viac_flags = extraGccViaCFlags dflags
1095 let pic_c_flags = picCCOpts dflags
1096
1097 let verbFlags = getVerbFlags dflags
1098
1099 -- cc-options are not passed when compiling .hc files. Our
1100 -- hc code doesn't not #include any header files anyway, so these
1101 -- options aren't necessary.
1102 pkg_extra_cc_opts <- liftIO $
1103 if cc_phase `eqPhase` HCc
1104 then return []
1105 else getPackageExtraCcOpts dflags pkgs
1106
1107 framework_paths <-
1108 if platformUsesFrameworks platform
1109 then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs
1110 let cmdlineFrameworkPaths = frameworkPaths dflags
1111 return $ map ("-F"++)
1112 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
1113 else return []
1114
1115 let split_objs = gopt Opt_SplitObjs dflags
1116 split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
1117 | otherwise = [ ]
1118
1119 let cc_opt | optLevel dflags >= 2 = "-O2"
1120 | otherwise = "-O"
1121
1122 -- Decide next phase
1123 let next_phase = As
1124 output_fn <- phaseOutputFilename next_phase
1125
1126 let
1127 more_hcc_opts =
1128 -- on x86 the floating point regs have greater precision
1129 -- than a double, which leads to unpredictable results.
1130 -- By default, we turn this off with -ffloat-store unless
1131 -- the user specified -fexcess-precision.
1132 (if platformArch platform == ArchX86 &&
1133 not (gopt Opt_ExcessPrecision dflags)
1134 then [ "-ffloat-store" ]
1135 else []) ++
1136
1137 -- gcc's -fstrict-aliasing allows two accesses to memory
1138 -- to be considered non-aliasing if they have different types.
1139 -- This interacts badly with the C code we generate, which is
1140 -- very weakly typed, being derived from C--.
1141 ["-fno-strict-aliasing"]
1142
1143 let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++"
1144 | cc_phase `eqPhase` Cobjc = "objective-c"
1145 | cc_phase `eqPhase` Cobjcpp = "objective-c++"
1146 | otherwise = "c"
1147 liftIO $ SysTools.runCc dflags (
1148 -- force the C compiler to interpret this file as C when
1149 -- compiling .hc files, by adding the -x c option.
1150 -- Also useful for plain .c files, just in case GHC saw a
1151 -- -x c option.
1152 [ SysTools.Option "-x", SysTools.Option gcc_lang_opt
1153 , SysTools.FileOption "" input_fn
1154 , SysTools.Option "-o"
1155 , SysTools.FileOption "" output_fn
1156 ]
1157 ++ map SysTools.Option (
1158 pic_c_flags
1159
1160 -- Stub files generated for foreign exports references the runIO_closure
1161 -- and runNonIO_closure symbols, which are defined in the base package.
1162 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
1163 -- way we do the import depends on whether we're currently compiling
1164 -- the base package or not.
1165 ++ (if platformOS platform == OSMinGW32 &&
1166 thisPackage dflags == basePackageId
1167 then [ "-DCOMPILING_BASE_PACKAGE" ]
1168 else [])
1169
1170 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1171 -- instruction. Note that the user can still override this
1172 -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
1173 -- regardless of the ordering.
1174 --
1175 -- This is a temporary hack. See #2872, commit
1176 -- 5bd3072ac30216a505151601884ac88bf404c9f2
1177 ++ (if platformArch platform == ArchSPARC
1178 then ["-mcpu=v9"]
1179 else [])
1180
1181 -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
1182 ++ (if (cc_phase /= Ccpp && cc_phase /= Cobjcpp)
1183 then ["-Wimplicit"]
1184 else [])
1185
1186 ++ (if hcc
1187 then gcc_extra_viac_flags ++ more_hcc_opts
1188 else [])
1189 ++ verbFlags
1190 ++ [ "-S", cc_opt ]
1191 ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1192 ++ framework_paths
1193 ++ cc_opts
1194 ++ split_opt
1195 ++ include_paths
1196 ++ pkg_extra_cc_opts
1197 ))
1198
1199 return (next_phase, output_fn)
1200
1201 -----------------------------------------------------------------------------
1202 -- Splitting phase
1203
1204 runPhase Splitter input_fn dflags
1205 = do -- tmp_pfx is the prefix used for the split .s files
1206
1207 split_s_prefix <- liftIO $ SysTools.newTempName dflags "split"
1208 let n_files_fn = split_s_prefix
1209
1210 liftIO $ SysTools.runSplit dflags
1211 [ SysTools.FileOption "" input_fn
1212 , SysTools.FileOption "" split_s_prefix
1213 , SysTools.FileOption "" n_files_fn
1214 ]
1215
1216 -- Save the number of split files for future references
1217 s <- liftIO $ readFile n_files_fn
1218 let n_files = read s :: Int
1219 dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
1220
1221 setDynFlags dflags'
1222
1223 -- Remember to delete all these files
1224 liftIO $ addFilesToClean dflags'
1225 [ split_s_prefix ++ "__" ++ show n ++ ".s"
1226 | n <- [1..n_files]]
1227
1228 return (SplitAs,
1229 "**splitter**") -- we don't use the filename in SplitAs
1230
1231 -----------------------------------------------------------------------------
1232 -- As, SpitAs phase : Assembler
1233
1234 -- This is for calling the assembler on a regular assembly file (not split).
1235 runPhase As input_fn dflags
1236 = do
1237 -- LLVM from version 3.0 onwards doesn't support the OS X system
1238 -- assembler, so we use clang as the assembler instead. (#5636)
1239 let whichAsProg | hscTarget dflags == HscLlvm &&
1240 platformOS (targetPlatform dflags) == OSDarwin
1241 = do
1242 -- be careful what options we call clang with
1243 -- see #5903 and #7617 for bugs caused by this.
1244 llvmVer <- liftIO $ figureLlvmVersion dflags
1245 return $ case llvmVer of
1246 Just n | n >= 30 -> SysTools.runClang
1247 _ -> SysTools.runAs
1248
1249 | otherwise = return SysTools.runAs
1250
1251 as_prog <- whichAsProg
1252 let as_opts = getOpts dflags opt_a
1253 cmdline_include_paths = includePaths dflags
1254
1255 next_phase <- maybeMergeStub
1256 output_fn <- phaseOutputFilename next_phase
1257
1258 -- we create directories for the object file, because it
1259 -- might be a hierarchical module.
1260 liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
1261
1262 let runAssembler inputFilename outputFilename
1263 = liftIO $ as_prog dflags
1264 (map SysTools.Option as_opts
1265 ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
1266
1267 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1268 -- instruction so we have to make sure that the assembler accepts the
1269 -- instruction set. Note that the user can still override this
1270 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1271 -- regardless of the ordering.
1272 --
1273 -- This is a temporary hack.
1274 ++ (if platformArch (targetPlatform dflags) == ArchSPARC
1275 then [SysTools.Option "-mcpu=v9"]
1276 else [])
1277
1278 ++ [ SysTools.Option "-x", SysTools.Option "assembler-with-cpp"
1279 , SysTools.Option "-c"
1280 , SysTools.FileOption "" inputFilename
1281 , SysTools.Option "-o"
1282 , SysTools.FileOption "" outputFilename
1283 ])
1284
1285 liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
1286 runAssembler input_fn output_fn
1287 -- If we're compiling a Haskell module (isHaskellishFile), and
1288 -- we're doing -dynamic-too, then we also need to assemble the
1289 -- -dyn assembly file.
1290 env <- getPipeEnv
1291 when (pe_isHaskellishFile env) $ whenGeneratingDynamicToo dflags $ do
1292 liftIO $ debugTraceMsg dflags 4
1293 (text "Running the assembler again for -dynamic-too")
1294 runAssembler (input_fn ++ "-dyn")
1295 (replaceExtension output_fn (dynObjectSuf dflags))
1296
1297 return (next_phase, output_fn)
1298
1299
1300 -- This is for calling the assembler on a split assembly file (so a collection
1301 -- of assembly files)
1302 runPhase SplitAs _input_fn dflags
1303 = do
1304 -- we'll handle the stub_o file in this phase, so don't MergeStub,
1305 -- just jump straight to StopLn afterwards.
1306 let next_phase = StopLn
1307 output_fn <- phaseOutputFilename next_phase
1308
1309 let base_o = dropExtension output_fn
1310 osuf = objectSuf dflags
1311 split_odir = base_o ++ "_" ++ osuf ++ "_split"
1312
1313 liftIO $ createDirectoryIfMissing True split_odir
1314
1315 -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1316 -- later and we don't want to pick up any old objects.
1317 fs <- liftIO $ getDirectoryContents split_odir
1318 liftIO $ mapM_ removeFile $
1319 map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1320
1321 let as_opts = getOpts dflags opt_a
1322
1323 let (split_s_prefix, n) = case splitInfo dflags of
1324 Nothing -> panic "No split info"
1325 Just x -> x
1326
1327 let split_s n = split_s_prefix ++ "__" ++ show n <.> "s"
1328
1329 split_obj :: Int -> FilePath
1330 split_obj n = split_odir </>
1331 takeFileName base_o ++ "__" ++ show n <.> osuf
1332
1333 let assemble_file n
1334 = SysTools.runAs dflags
1335 (map SysTools.Option as_opts ++
1336
1337 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1338 -- instruction so we have to make sure that the assembler accepts the
1339 -- instruction set. Note that the user can still override this
1340 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1341 -- regardless of the ordering.
1342 --
1343 -- This is a temporary hack.
1344 (if platformArch (targetPlatform dflags) == ArchSPARC
1345 then [SysTools.Option "-mcpu=v9"]
1346 else []) ++
1347
1348 [ SysTools.Option "-c"
1349 , SysTools.Option "-o"
1350 , SysTools.FileOption "" (split_obj n)
1351 , SysTools.FileOption "" (split_s n)
1352 ])
1353
1354 liftIO $ mapM_ assemble_file [1..n]
1355
1356 -- Note [pipeline-split-init]
1357 -- If we have a stub file, it may contain constructor
1358 -- functions for initialisation of this module. We can't
1359 -- simply leave the stub as a separate object file, because it
1360 -- will never be linked in: nothing refers to it. We need to
1361 -- ensure that if we ever refer to the data in this module
1362 -- that needs initialisation, then we also pull in the
1363 -- initialisation routine.
1364 --
1365 -- To that end, we make a DANGEROUS ASSUMPTION here: the data
1366 -- that needs to be initialised is all in the FIRST split
1367 -- object. See Note [codegen-split-init].
1368
1369 PipeState{maybe_stub_o} <- getPipeState
1370 case maybe_stub_o of
1371 Nothing -> return ()
1372 Just stub_o -> liftIO $ do
1373 tmp_split_1 <- newTempName dflags osuf
1374 let split_1 = split_obj 1
1375 copyFile split_1 tmp_split_1
1376 removeFile split_1
1377 joinObjectFiles dflags [tmp_split_1, stub_o] split_1
1378
1379 -- join them into a single .o file
1380 liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
1381
1382 return (next_phase, output_fn)
1383
1384 -----------------------------------------------------------------------------
1385 -- LlvmOpt phase
1386
1387 runPhase LlvmOpt input_fn dflags
1388 = do
1389 ver <- liftIO $ readIORef (llvmVersion dflags)
1390
1391 let lo_opts = getOpts dflags opt_lo
1392 opt_lvl = max 0 (min 2 $ optLevel dflags)
1393 -- don't specify anything if user has specified commands. We do this
1394 -- for opt but not llc since opt is very specifically for optimisation
1395 -- passes only, so if the user is passing us extra options we assume
1396 -- they know what they are doing and don't get in the way.
1397 optFlag = if null lo_opts
1398 then [SysTools.Option (llvmOpts !! opt_lvl)]
1399 else []
1400 tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier
1401 | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
1402 | otherwise = "--enable-tbaa=false"
1403
1404
1405 output_fn <- phaseOutputFilename LlvmLlc
1406
1407 liftIO $ SysTools.runLlvmOpt dflags
1408 ([ SysTools.FileOption "" input_fn,
1409 SysTools.Option "-o",
1410 SysTools.FileOption "" output_fn]
1411 ++ optFlag
1412 ++ [SysTools.Option tbaa]
1413 ++ map SysTools.Option lo_opts)
1414
1415 return (LlvmLlc, output_fn)
1416 where
1417 -- we always (unless -optlo specified) run Opt since we rely on it to
1418 -- fix up some pretty big deficiencies in the code we generate
1419 llvmOpts = ["-mem2reg", "-O1", "-O2"]
1420
1421 -----------------------------------------------------------------------------
1422 -- LlvmLlc phase
1423
1424 runPhase LlvmLlc input_fn dflags
1425 = do
1426 ver <- liftIO $ readIORef (llvmVersion dflags)
1427
1428 let lc_opts = getOpts dflags opt_lc
1429 opt_lvl = max 0 (min 2 $ optLevel dflags)
1430 rmodel | gopt Opt_PIC dflags = "pic"
1431 | not (gopt Opt_Static dflags) = "dynamic-no-pic"
1432 | otherwise = "static"
1433 tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier
1434 | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
1435 | otherwise = "--enable-tbaa=false"
1436
1437 -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
1438 let next_phase = case gopt Opt_NoLlvmMangler dflags of
1439 False -> LlvmMangle
1440 True | gopt Opt_SplitObjs dflags -> Splitter
1441 True -> As
1442
1443 output_fn <- phaseOutputFilename next_phase
1444
1445 liftIO $ SysTools.runLlvmLlc dflags
1446 ([ SysTools.Option (llvmOpts !! opt_lvl),
1447 SysTools.Option $ "-relocation-model=" ++ rmodel,
1448 SysTools.FileOption "" input_fn,
1449 SysTools.Option "-o", SysTools.FileOption "" output_fn]
1450 ++ map SysTools.Option lc_opts
1451 ++ [SysTools.Option tbaa]
1452 ++ map SysTools.Option fpOpts
1453 ++ map SysTools.Option abiOpts
1454 ++ map SysTools.Option sseOpts)
1455
1456 return (next_phase, output_fn)
1457 where
1458 -- Bug in LLVM at O3 on OSX.
1459 llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
1460 then ["-O1", "-O2", "-O2"]
1461 else ["-O1", "-O2", "-O3"]
1462 -- On ARMv7 using LLVM, LLVM fails to allocate floating point registers
1463 -- while compiling GHC source code. It's probably due to fact that it
1464 -- does not enable VFP by default. Let's do this manually here
1465 fpOpts = case platformArch (targetPlatform dflags) of
1466 ArchARM ARMv7 ext _ -> if (elem VFPv3 ext)
1467 then ["-mattr=+v7,+vfp3"]
1468 else if (elem VFPv3D16 ext)
1469 then ["-mattr=+v7,+vfp3,+d16"]
1470 else []
1471 ArchARM ARMv6 ext _ -> if (elem VFPv2 ext)
1472 then ["-mattr=+v6,+vfp2"]
1473 else ["-mattr=+v6"]
1474 _ -> []
1475 -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still
1476 -- compiles into soft-float ABI. We need to explicitly set abi
1477 -- to hard
1478 abiOpts = case platformArch (targetPlatform dflags) of
1479 ArchARM _ _ HARD -> ["-float-abi=hard"]
1480 ArchARM _ _ _ -> []
1481 _ -> []
1482
1483 sseOpts | isSse4_2Enabled dflags = ["-mattr=+sse42"]
1484 | isSse2Enabled dflags = ["-mattr=+sse2"]
1485 | otherwise = []
1486
1487 -----------------------------------------------------------------------------
1488 -- LlvmMangle phase
1489
1490 runPhase LlvmMangle input_fn dflags
1491 = do
1492 let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As
1493 output_fn <- phaseOutputFilename next_phase
1494 liftIO $ llvmFixupAsm dflags input_fn output_fn
1495 return (next_phase, output_fn)
1496
1497 -----------------------------------------------------------------------------
1498 -- merge in stub objects
1499
1500 runPhase MergeStub input_fn dflags
1501 = do
1502 PipeState{maybe_stub_o} <- getPipeState
1503 output_fn <- phaseOutputFilename StopLn
1504 case maybe_stub_o of
1505 Nothing ->
1506 panic "runPhase(MergeStub): no stub"
1507 Just stub_o -> do
1508 liftIO $ joinObjectFiles dflags [input_fn, stub_o] output_fn
1509 whenGeneratingDynamicToo dflags $ do
1510 liftIO $ debugTraceMsg dflags 4
1511 (text "Merging stub again for -dynamic-too")
1512 let dyn_input_fn = replaceExtension input_fn (dynObjectSuf dflags)
1513 dyn_output_fn = replaceExtension output_fn (dynObjectSuf dflags)
1514 liftIO $ joinObjectFiles dflags [dyn_input_fn, stub_o] dyn_output_fn
1515 return (StopLn, output_fn)
1516
1517 -- warning suppression
1518 runPhase other _input_fn _dflags =
1519 panic ("runPhase: don't know how to run phase " ++ show other)
1520
1521 maybeMergeStub :: CompPipeline Phase
1522 maybeMergeStub
1523 = do
1524 PipeState{maybe_stub_o} <- getPipeState
1525 if isJust maybe_stub_o then return MergeStub else return StopLn
1526
1527 -----------------------------------------------------------------------------
1528 -- MoveBinary sort-of-phase
1529 -- After having produced a binary, move it somewhere else and generate a
1530 -- wrapper script calling the binary. Currently, we need this only in
1531 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1532 -- central directory.
1533 -- This is called from linkBinary below, after linking. I haven't made it
1534 -- a separate phase to minimise interfering with other modules, and
1535 -- we don't need the generality of a phase (MoveBinary is always
1536 -- done after linking and makes only sense in a parallel setup) -- HWL
1537
1538 runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
1539 runPhase_MoveBinary dflags input_fn
1540 | WayPar `elem` ways dflags && not (gopt Opt_Static dflags) =
1541 panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
1542 | WayPar `elem` ways dflags = do
1543 let sysMan = pgm_sysman dflags
1544 pvm_root <- getEnv "PVM_ROOT"
1545 pvm_arch <- getEnv "PVM_ARCH"
1546 let
1547 pvm_executable_base = "=" ++ input_fn
1548 pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1549 -- nuke old binary; maybe use configur'ed names for cp and rm?
1550 _ <- tryIO (removeFile pvm_executable)
1551 -- move the newly created binary into PVM land
1552 copy dflags "copying PVM executable" input_fn pvm_executable
1553 -- generate a wrapper script for running a parallel prg under PVM
1554 writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1555 return True
1556 | otherwise = return True
1557
1558 mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
1559 mkExtraObj dflags extn xs
1560 = do cFile <- newTempName dflags extn
1561 oFile <- newTempName dflags "o"
1562 writeFile cFile xs
1563 let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
1564 SysTools.runCc dflags
1565 ([Option "-c",
1566 FileOption "" cFile,
1567 Option "-o",
1568 FileOption "" oFile]
1569 ++ map SysTools.Option (getOpts dflags opt_c) -- see #5528
1570 ++ map (FileOption "-I") (includeDirs rtsDetails))
1571 return oFile
1572
1573 -- When linking a binary, we need to create a C main() function that
1574 -- starts everything off. This used to be compiled statically as part
1575 -- of the RTS, but that made it hard to change the -rtsopts setting,
1576 -- so now we generate and compile a main() stub as part of every
1577 -- binary and pass the -rtsopts setting directly to the RTS (#5373)
1578 --
1579 mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
1580 mkExtraObjToLinkIntoBinary dflags = do
1581 when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
1582 log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
1583 (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
1584 text " Call hs_init_ghc() from your main() function to set these options.")
1585
1586 mkExtraObj dflags "c" (showSDoc dflags main)
1587
1588 where
1589 main
1590 | gopt Opt_NoHsMain dflags = empty
1591 | otherwise = vcat [
1592 ptext (sLit "#include \"Rts.h\""),
1593 ptext (sLit "extern StgClosure ZCMain_main_closure;"),
1594 ptext (sLit "int main(int argc, char *argv[])"),
1595 char '{',
1596 ptext (sLit " RtsConfig __conf = defaultRtsConfig;"),
1597 ptext (sLit " __conf.rts_opts_enabled = ")
1598 <> text (show (rtsOptsEnabled dflags)) <> semi,
1599 case rtsOpts dflags of
1600 Nothing -> empty
1601 Just opts -> ptext (sLit " __conf.rts_opts= ") <>
1602 text (show opts) <> semi,
1603 ptext (sLit " return hs_main(argc, argv, &ZCMain_main_closure,__conf);"),
1604 char '}',
1605 char '\n' -- final newline, to keep gcc happy
1606 ]
1607
1608 -- Write out the link info section into a new assembly file. Previously
1609 -- this was included as inline assembly in the main.c file but this
1610 -- is pretty fragile. gas gets upset trying to calculate relative offsets
1611 -- that span the .note section (notably .text) when debug info is present
1612 mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageId] -> IO [FilePath]
1613 mkNoteObjsToLinkIntoBinary dflags dep_packages = do
1614 link_info <- getLinkInfo dflags dep_packages
1615
1616 if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
1617 then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
1618 else return []
1619
1620 where
1621 link_opts info = hcat [
1622 text "\t.section ", text ghcLinkInfoSectionName,
1623 text ",\"\",",
1624 text elfSectionNote,
1625 text "\n",
1626
1627 text "\t.ascii \"", info', text "\"\n" ]
1628 where
1629 info' = text $ escape info
1630
1631 escape :: String -> String
1632 escape = concatMap (charToC.fromIntegral.ord)
1633
1634 elfSectionNote :: String
1635 elfSectionNote = case platformArch (targetPlatform dflags) of
1636 ArchARM _ _ _ -> "%note"
1637 _ -> "@note"
1638
1639 -- The "link info" is a string representing the parameters of the
1640 -- link. We save this information in the binary, and the next time we
1641 -- link, if nothing else has changed, we use the link info stored in
1642 -- the existing binary to decide whether to re-link or not.
1643 getLinkInfo :: DynFlags -> [PackageId] -> IO String
1644 getLinkInfo dflags dep_packages = do
1645 package_link_opts <- getPackageLinkOpts dflags dep_packages
1646 pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
1647 then getPackageFrameworks dflags dep_packages
1648 else return []
1649 let extra_ld_inputs = ldInputs dflags
1650 let
1651 link_info = (package_link_opts,
1652 pkg_frameworks,
1653 rtsOpts dflags,
1654 rtsOptsEnabled dflags,
1655 gopt Opt_NoHsMain dflags,
1656 extra_ld_inputs,
1657 getOpts dflags opt_l)
1658 --
1659 return (show link_info)
1660
1661 -- generates a Perl skript starting a parallel prg under PVM
1662 mk_pvm_wrapper_script :: String -> String -> String -> String
1663 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1664 [
1665 "eval 'exec perl -S $0 ${1+\"$@\"}'",
1666 " if $running_under_some_shell;",
1667 "# =!=!=!=!=!=!=!=!=!=!=!",
1668 "# This script is automatically generated: DO NOT EDIT!!!",
1669 "# Generated by Glasgow Haskell Compiler",
1670 "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1671 "#",
1672 "$pvm_executable = '" ++ pvm_executable ++ "';",
1673 "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1674 "$SysMan = '" ++ sysMan ++ "';",
1675 "",
1676 {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1677 "# first, some magical shortcuts to run "commands" on the binary",
1678 "# (which is hidden)",
1679 "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1680 " local($cmd) = $1;",
1681 " system("$cmd $pvm_executable");",
1682 " exit(0); # all done",
1683 "}", -}
1684 "",
1685 "# Now, run the real binary; process the args first",
1686 "$ENV{'PE'} = $pvm_executable_base;", -- ++ pvm_executable_base,
1687 "$debug = '';",
1688 "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1689 "@nonPVM_args = ();",
1690 "$in_RTS_args = 0;",
1691 "",
1692 "args: while ($a = shift(@ARGV)) {",
1693 " if ( $a eq '+RTS' ) {",
1694 " $in_RTS_args = 1;",
1695 " } elsif ( $a eq '-RTS' ) {",
1696 " $in_RTS_args = 0;",
1697 " }",
1698 " if ( $a eq '-d' && $in_RTS_args ) {",
1699 " $debug = '-';",
1700 " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1701 " $nprocessors = $1;",
1702 " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1703 " $nprocessors = $1;",
1704 " } else {",
1705 " push(@nonPVM_args, $a);",
1706 " }",
1707 "}",
1708 "",
1709 "local($return_val) = 0;",
1710 "# Start the parallel execution by calling SysMan",
1711 "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1712 "$return_val = $?;",
1713 "# ToDo: fix race condition moving files and flushing them!!",
1714 "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1715 "exit($return_val);"
1716 ]
1717
1718 -----------------------------------------------------------------------------
1719 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1720
1721 getHCFilePackages :: FilePath -> IO [PackageId]
1722 getHCFilePackages filename =
1723 Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1724 l <- hGetLine h
1725 case l of
1726 '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1727 return (map stringToPackageId (words rest))
1728 _other ->
1729 return []
1730
1731 -----------------------------------------------------------------------------
1732 -- Static linking, of .o files
1733
1734 -- The list of packages passed to link is the list of packages on
1735 -- which this program depends, as discovered by the compilation
1736 -- manager. It is combined with the list of packages that the user
1737 -- specifies on the command line with -package flags.
1738 --
1739 -- In one-shot linking mode, we can't discover the package
1740 -- dependencies (because we haven't actually done any compilation or
1741 -- read any interface files), so the user must explicitly specify all
1742 -- the packages.
1743
1744 linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1745 linkBinary dflags o_files dep_packages = do
1746 let platform = targetPlatform dflags
1747 mySettings = settings dflags
1748 verbFlags = getVerbFlags dflags
1749 output_fn = exeFileName dflags
1750
1751 -- get the full list of packages to link with, by combining the
1752 -- explicit packages with the auto packages and all of their
1753 -- dependencies, and eliminating duplicates.
1754
1755 full_output_fn <- if isAbsolute output_fn
1756 then return output_fn
1757 else do d <- getCurrentDirectory
1758 return $ normalise (d </> output_fn)
1759 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1760 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1761 get_pkg_lib_path_opts l
1762 | osElfTarget (platformOS platform) &&
1763 dynLibLoader dflags == SystemDependent &&
1764 not (gopt Opt_Static dflags)
1765 = let libpath = if gopt Opt_RelativeDynlibPaths dflags
1766 then "$ORIGIN" </>
1767 (l `makeRelativeTo` full_output_fn)
1768 else l
1769 rpath = if gopt Opt_RPath dflags
1770 then ["-Wl,-rpath", "-Wl," ++ libpath]
1771 else []
1772 -- Solaris 11's linker does not support -rpath-link option. It silently
1773 -- ignores it and then complains about next option which is -l<some
1774 -- dir> as being a directory and not expected object file, E.g
1775 -- ld: elf error: file
1776 -- /tmp/ghc-src/libraries/base/dist-install/build:
1777 -- elf_begin: I/O error: region read: Is a directory
1778 rpathlink = if (platformOS platform) == OSSolaris2
1779 then []
1780 else ["-Wl,-rpath-link", "-Wl," ++ l]
1781 in ["-L" ++ l] ++ rpathlink ++ rpath
1782 | otherwise = ["-L" ++ l]
1783
1784 let lib_paths = libraryPaths dflags
1785 let lib_path_opts = map ("-L"++) lib_paths
1786
1787 extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
1788 noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
1789
1790 pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1791
1792 pkg_framework_path_opts <-
1793 if platformUsesFrameworks platform
1794 then do pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1795 return $ map ("-F" ++) pkg_framework_paths
1796 else return []
1797
1798 framework_path_opts <-
1799 if platformUsesFrameworks platform
1800 then do let framework_paths = frameworkPaths dflags
1801 return $ map ("-F" ++) framework_paths
1802 else return []
1803
1804 pkg_framework_opts <-
1805 if platformUsesFrameworks platform
1806 then do pkg_frameworks <- getPackageFrameworks dflags dep_packages
1807 return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1808 else return []
1809
1810 framework_opts <-
1811 if platformUsesFrameworks platform
1812 then do let frameworks = cmdlineFrameworks dflags
1813 -- reverse because they're added in reverse order from
1814 -- the cmd line:
1815 return $ concat [ ["-framework", fw]
1816 | fw <- reverse frameworks ]
1817 else 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