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