e7ced1802ed5a841b0b1e0cc432e56ad3b4a78d0
[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 <- getModificationTime 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 $ getModificationTime 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 . getModificationTime) 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 . getModificationTime)
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 getDynFlags :: CompPipeline DynFlags
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 $ getModificationTime (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 <- getModificationTime 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 $ createDirectoryHierarchy (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 $ createDirectoryHierarchy 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 let lo_opts = getOpts dflags opt_lo
1310 let opt_lvl = max 0 (min 2 $ optLevel dflags)
1311 -- don't specify anything if user has specified commands. We do this for
1312 -- opt but not llc since opt is very specifically for optimisation passes
1313 -- only, so if the user is passing us extra options we assume they know
1314 -- what they are doing and don't get in the way.
1315 let optFlag = if null lo_opts
1316 then [SysTools.Option (llvmOpts !! opt_lvl)]
1317 else []
1318
1319 output_fn <- phaseOutputFilename LlvmLlc
1320
1321 io $ SysTools.runLlvmOpt dflags
1322 ([ SysTools.FileOption "" input_fn,
1323 SysTools.Option "-o",
1324 SysTools.FileOption "" output_fn]
1325 ++ optFlag
1326 ++ map SysTools.Option lo_opts)
1327
1328 return (LlvmLlc, output_fn)
1329 where
1330 -- we always (unless -optlo specified) run Opt since we rely on it to
1331 -- fix up some pretty big deficiencies in the code we generate
1332 llvmOpts = ["-mem2reg", "-O1", "-O2"]
1333
1334 -----------------------------------------------------------------------------
1335 -- LlvmLlc phase
1336
1337 runPhase LlvmLlc input_fn dflags
1338 = do
1339 let lc_opts = getOpts dflags opt_lc
1340 opt_lvl = max 0 (min 2 $ optLevel dflags)
1341 rmodel | opt_PIC = "pic"
1342 | not opt_Static = "dynamic-no-pic"
1343 | otherwise = "static"
1344
1345 -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
1346 let next_phase = case dopt Opt_NoLlvmMangler dflags of
1347 False -> LlvmMangle
1348 True | dopt Opt_SplitObjs dflags -> Splitter
1349 True -> As
1350
1351 output_fn <- phaseOutputFilename next_phase
1352
1353 io $ SysTools.runLlvmLlc dflags
1354 ([ SysTools.Option (llvmOpts !! opt_lvl),
1355 SysTools.Option $ "-relocation-model=" ++ rmodel,
1356 SysTools.FileOption "" input_fn,
1357 SysTools.Option "-o", SysTools.FileOption "" output_fn]
1358 ++ map SysTools.Option lc_opts
1359 ++ map SysTools.Option fpOpts)
1360
1361 return (next_phase, output_fn)
1362 where
1363 -- Bug in LLVM at O3 on OSX.
1364 llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
1365 then ["-O1", "-O2", "-O2"]
1366 else ["-O1", "-O2", "-O3"]
1367 -- On ARMv7 using LLVM, LLVM fails to allocate floating point registers
1368 -- while compiling GHC source code. It's probably due to fact that it
1369 -- does not enable VFP by default. Let's do this manually here
1370 fpOpts = case platformArch (targetPlatform dflags) of
1371 ArchARM ARMv7 ext -> if (elem VFPv3 ext)
1372 then ["-mattr=+v7,+vfp3"]
1373 else if (elem VFPv3D16 ext)
1374 then ["-mattr=+v7,+vfp3,+d16"]
1375 else []
1376 _ -> []
1377
1378 -----------------------------------------------------------------------------
1379 -- LlvmMangle phase
1380
1381 runPhase LlvmMangle input_fn dflags
1382 = do
1383 let next_phase = if dopt Opt_SplitObjs dflags then Splitter else As
1384 output_fn <- phaseOutputFilename next_phase
1385 io $ llvmFixupAsm dflags input_fn output_fn
1386 return (next_phase, output_fn)
1387
1388 -----------------------------------------------------------------------------
1389 -- merge in stub objects
1390
1391 runPhase MergeStub input_fn dflags
1392 = do
1393 PipeState{maybe_stub_o} <- getPipeState
1394 output_fn <- phaseOutputFilename StopLn
1395 case maybe_stub_o of
1396 Nothing ->
1397 panic "runPhase(MergeStub): no stub"
1398 Just stub_o -> do
1399 io $ joinObjectFiles dflags [input_fn, stub_o] output_fn
1400 return (StopLn, output_fn)
1401
1402 -- warning suppression
1403 runPhase other _input_fn _dflags =
1404 panic ("runPhase: don't know how to run phase " ++ show other)
1405
1406 maybeMergeStub :: CompPipeline Phase
1407 maybeMergeStub
1408 = do
1409 PipeState{maybe_stub_o} <- getPipeState
1410 if isJust maybe_stub_o then return MergeStub else return StopLn
1411
1412 -----------------------------------------------------------------------------
1413 -- MoveBinary sort-of-phase
1414 -- After having produced a binary, move it somewhere else and generate a
1415 -- wrapper script calling the binary. Currently, we need this only in
1416 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1417 -- central directory.
1418 -- This is called from linkBinary below, after linking. I haven't made it
1419 -- a separate phase to minimise interfering with other modules, and
1420 -- we don't need the generality of a phase (MoveBinary is always
1421 -- done after linking and makes only sense in a parallel setup) -- HWL
1422
1423 runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
1424 runPhase_MoveBinary dflags input_fn
1425 | WayPar `elem` (wayNames dflags) && not opt_Static =
1426 panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
1427 | WayPar `elem` (wayNames dflags) = do
1428 let sysMan = pgm_sysman dflags
1429 pvm_root <- getEnv "PVM_ROOT"
1430 pvm_arch <- getEnv "PVM_ARCH"
1431 let
1432 pvm_executable_base = "=" ++ input_fn
1433 pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1434 -- nuke old binary; maybe use configur'ed names for cp and rm?
1435 _ <- tryIO (removeFile pvm_executable)
1436 -- move the newly created binary into PVM land
1437 copy dflags "copying PVM executable" input_fn pvm_executable
1438 -- generate a wrapper script for running a parallel prg under PVM
1439 writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1440 return True
1441 | otherwise = return True
1442
1443 mkExtraCObj :: DynFlags -> String -> IO FilePath
1444 mkExtraCObj dflags xs
1445 = do cFile <- newTempName dflags "c"
1446 oFile <- newTempName dflags "o"
1447 writeFile cFile xs
1448 let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
1449 SysTools.runCc dflags
1450 ([Option "-c",
1451 FileOption "" cFile,
1452 Option "-o",
1453 FileOption "" oFile]
1454 ++ map SysTools.Option (getOpts dflags opt_c) -- see #5528
1455 ++ map (FileOption "-I") (includeDirs rtsDetails))
1456 return oFile
1457
1458 -- When linking a binary, we need to create a C main() function that
1459 -- starts everything off. This used to be compiled statically as part
1460 -- of the RTS, but that made it hard to change the -rtsopts setting,
1461 -- so now we generate and compile a main() stub as part of every
1462 -- binary and pass the -rtsopts setting directly to the RTS (#5373)
1463 --
1464 mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath
1465 mkExtraObjToLinkIntoBinary dflags dep_packages = do
1466 link_info <- getLinkInfo dflags dep_packages
1467
1468 let have_rts_opts_flags =
1469 isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of
1470 RtsOptsSafeOnly -> False
1471 _ -> True
1472
1473 when (dopt Opt_NoHsMain dflags && have_rts_opts_flags) $ do
1474 hPutStrLn stderr $ "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main.\n" ++
1475 " Call hs_init_ghc() from your main() function to set these options."
1476
1477 mkExtraCObj dflags (showSDoc (vcat [main,
1478 link_opts link_info]
1479 <> char '\n')) -- final newline, to
1480 -- keep gcc happy
1481
1482 where
1483 main
1484 | dopt Opt_NoHsMain dflags = empty
1485 | otherwise = vcat [
1486 ptext (sLit "#include \"Rts.h\""),
1487 ptext (sLit "extern StgClosure ZCMain_main_closure;"),
1488 ptext (sLit "int main(int argc, char *argv[])"),
1489 char '{',
1490 ptext (sLit " RtsConfig __conf = defaultRtsConfig;"),
1491 ptext (sLit " __conf.rts_opts_enabled = ")
1492 <> text (show (rtsOptsEnabled dflags)) <> semi,
1493 case rtsOpts dflags of
1494 Nothing -> empty
1495 Just opts -> ptext (sLit " __conf.rts_opts= ") <>
1496 text (show opts) <> semi,
1497 ptext (sLit " return hs_main(argc, argv, &ZCMain_main_closure,__conf);"),
1498 char '}'
1499 ]
1500
1501 link_opts info
1502 | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
1503 = empty
1504 | otherwise = hcat [
1505 text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName,
1506 text ",\\\"\\\",",
1507 text elfSectionNote,
1508 text "\\n",
1509
1510 text "\\t.ascii \\\"", info', text "\\\"\\n\");" ]
1511 where
1512 -- we need to escape twice: once because we're inside a C string,
1513 -- and again because we're inside an asm string.
1514 info' = text $ (escape.escape) info
1515
1516 escape :: String -> String
1517 escape = concatMap (charToC.fromIntegral.ord)
1518
1519 elfSectionNote :: String
1520 elfSectionNote = case platformArch (targetPlatform dflags) of
1521 ArchARM _ _ -> "%note"
1522 _ -> "@note"
1523
1524 -- The "link info" is a string representing the parameters of the
1525 -- link. We save this information in the binary, and the next time we
1526 -- link, if nothing else has changed, we use the link info stored in
1527 -- the existing binary to decide whether to re-link or not.
1528 getLinkInfo :: DynFlags -> [PackageId] -> IO String
1529 getLinkInfo dflags dep_packages = do
1530 package_link_opts <- getPackageLinkOpts dflags dep_packages
1531 pkg_frameworks <- case platformOS (targetPlatform dflags) of
1532 OSDarwin -> getPackageFrameworks dflags dep_packages
1533 _ -> return []
1534 extra_ld_inputs <- readIORef v_Ld_inputs
1535 let
1536 link_info = (package_link_opts,
1537 pkg_frameworks,
1538 rtsOpts dflags,
1539 rtsOptsEnabled dflags,
1540 dopt Opt_NoHsMain dflags,
1541 extra_ld_inputs,
1542 getOpts dflags opt_l)
1543 --
1544 return (show link_info)
1545
1546 -- generates a Perl skript starting a parallel prg under PVM
1547 mk_pvm_wrapper_script :: String -> String -> String -> String
1548 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1549 [
1550 "eval 'exec perl -S $0 ${1+\"$@\"}'",
1551 " if $running_under_some_shell;",
1552 "# =!=!=!=!=!=!=!=!=!=!=!",
1553 "# This script is automatically generated: DO NOT EDIT!!!",
1554 "# Generated by Glasgow Haskell Compiler",
1555 "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1556 "#",
1557 "$pvm_executable = '" ++ pvm_executable ++ "';",
1558 "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1559 "$SysMan = '" ++ sysMan ++ "';",
1560 "",
1561 {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1562 "# first, some magical shortcuts to run "commands" on the binary",
1563 "# (which is hidden)",
1564 "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1565 " local($cmd) = $1;",
1566 " system("$cmd $pvm_executable");",
1567 " exit(0); # all done",
1568 "}", -}
1569 "",
1570 "# Now, run the real binary; process the args first",
1571 "$ENV{'PE'} = $pvm_executable_base;", -- ++ pvm_executable_base,
1572 "$debug = '';",
1573 "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1574 "@nonPVM_args = ();",
1575 "$in_RTS_args = 0;",
1576 "",
1577 "args: while ($a = shift(@ARGV)) {",
1578 " if ( $a eq '+RTS' ) {",
1579 " $in_RTS_args = 1;",
1580 " } elsif ( $a eq '-RTS' ) {",
1581 " $in_RTS_args = 0;",
1582 " }",
1583 " if ( $a eq '-d' && $in_RTS_args ) {",
1584 " $debug = '-';",
1585 " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1586 " $nprocessors = $1;",
1587 " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1588 " $nprocessors = $1;",
1589 " } else {",
1590 " push(@nonPVM_args, $a);",
1591 " }",
1592 "}",
1593 "",
1594 "local($return_val) = 0;",
1595 "# Start the parallel execution by calling SysMan",
1596 "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1597 "$return_val = $?;",
1598 "# ToDo: fix race condition moving files and flushing them!!",
1599 "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1600 "exit($return_val);"
1601 ]
1602
1603 -----------------------------------------------------------------------------
1604 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1605
1606 getHCFilePackages :: FilePath -> IO [PackageId]
1607 getHCFilePackages filename =
1608 Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1609 l <- hGetLine h
1610 case l of
1611 '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1612 return (map stringToPackageId (words rest))
1613 _other ->
1614 return []
1615
1616 -----------------------------------------------------------------------------
1617 -- Static linking, of .o files
1618
1619 -- The list of packages passed to link is the list of packages on
1620 -- which this program depends, as discovered by the compilation
1621 -- manager. It is combined with the list of packages that the user
1622 -- specifies on the command line with -package flags.
1623 --
1624 -- In one-shot linking mode, we can't discover the package
1625 -- dependencies (because we haven't actually done any compilation or
1626 -- read any interface files), so the user must explicitly specify all
1627 -- the packages.
1628
1629 linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1630 linkBinary dflags o_files dep_packages = do
1631 let platform = targetPlatform dflags
1632 verbFlags = getVerbFlags dflags
1633 output_fn = exeFileName dflags
1634
1635 -- get the full list of packages to link with, by combining the
1636 -- explicit packages with the auto packages and all of their
1637 -- dependencies, and eliminating duplicates.
1638
1639 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1640 let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths)
1641 get_pkg_lib_path_opts l
1642 | osElfTarget (platformOS platform) &&
1643 dynLibLoader dflags == SystemDependent &&
1644 not opt_Static
1645 = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1646 | otherwise = ["-L" ++ l]
1647
1648 let lib_paths = libraryPaths dflags
1649 let lib_path_opts = map ("-L"++) lib_paths
1650
1651 extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages
1652
1653 pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1654
1655 pkg_framework_path_opts <-
1656 case platformOS platform of
1657 OSDarwin ->
1658 do pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1659 return $ map ("-F" ++) pkg_framework_paths
1660 _ ->
1661 return []
1662
1663 framework_path_opts <-
1664 case platformOS platform of
1665 OSDarwin ->
1666 do let framework_paths = frameworkPaths dflags
1667 return $ map ("-F" ++) framework_paths
1668 _ ->
1669 return []
1670
1671 pkg_framework_opts <-
1672 case platformOS platform of
1673 OSDarwin ->
1674 do pkg_frameworks <- getPackageFrameworks dflags dep_packages
1675 return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1676 _ ->
1677 return []
1678
1679 framework_opts <-
1680 case platformOS platform of
1681 OSDarwin ->
1682 do let frameworks = cmdlineFrameworks dflags
1683 -- reverse because they're added in reverse order from
1684 -- the cmd line:
1685 return $ concat [ ["-framework", fw] | fw <- reverse frameworks ]
1686 _ ->
1687 return []
1688
1689 -- probably _stub.o files
1690 extra_ld_inputs <- readIORef v_Ld_inputs
1691
1692 -- opts from -optl-<blah> (including -l<blah> options)
1693 let extra_ld_opts = getOpts dflags opt_l
1694
1695 let ways = wayNames dflags
1696
1697 -- Here are some libs that need to be linked at the *end* of
1698 -- the command line, because they contain symbols that are referred to
1699 -- by the RTS. We can't therefore use the ordinary way opts for these.
1700 let
1701 debug_opts | WayDebug `elem` ways = [
1702 #if defined(HAVE_LIBBFD)
1703 "-lbfd", "-liberty"
1704 #endif
1705 ]
1706 | otherwise = []
1707
1708 let
1709 thread_opts | WayThreaded `elem` ways = [
1710 #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(openbsd_TARGET_OS) && !defined(netbsd_TARGET_OS) && !defined(haiku_TARGET_OS)
1711 "-lpthread"
1712 #endif
1713 #if defined(osf3_TARGET_OS)
1714 , "-lexc"
1715 #endif
1716 ]
1717 | otherwise = []
1718
1719 rc_objs <- maybeCreateManifest dflags output_fn
1720
1721 SysTools.runLink dflags (
1722 map SysTools.Option verbFlags
1723 ++ [ SysTools.Option "-o"
1724 , SysTools.FileOption "" output_fn
1725 ]
1726 ++ map SysTools.Option (
1727 []
1728
1729 -- Permit the linker to auto link _symbol to _imp_symbol.
1730 -- This lets us link against DLLs without needing an "import library".
1731 ++ (if platformOS platform == OSMinGW32
1732 then ["-Wl,--enable-auto-import"]
1733 else [])
1734
1735 -- '-no_compact_unwind'
1736 -- C++/Objective-C exceptions cannot use optimised
1737 -- stack unwinding code. The optimised form is the
1738 -- default in Xcode 4 on at least x86_64, and
1739 -- without this flag we're also seeing warnings
1740 -- like
1741 -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
1742 -- on x86.
1743 ++ (if cLdHasNoCompactUnwind == "YES" &&
1744 platformOS platform == OSDarwin &&
1745 platformArch platform `elem` [ArchX86, ArchX86_64]
1746 then ["-Wl,-no_compact_unwind"]
1747 else [])
1748
1749 -- '-Wl,-read_only_relocs,suppress'
1750 -- ld gives loads of warnings like:
1751 -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
1752 -- when linking any program. We're not sure
1753 -- whether this is something we ought to fix, but
1754 -- for now this flags silences them.
1755 ++ (if platformOS platform == OSDarwin &&
1756 platformArch platform == ArchX86
1757 then ["-Wl,-read_only_relocs,suppress"]
1758 else [])
1759
1760 ++ o_files
1761 ++ extra_ld_inputs
1762 ++ lib_path_opts
1763 ++ extra_ld_opts
1764 ++ rc_objs
1765 ++ framework_path_opts
1766 ++ framework_opts
1767 ++ pkg_lib_path_opts
1768 ++ [extraLinkObj]
1769 ++ pkg_link_opts
1770 ++ pkg_framework_path_opts
1771 ++ pkg_framework_opts
1772 ++ debug_opts
1773 ++ thread_opts
1774 ))
1775
1776 -- parallel only: move binary to another dir -- HWL
1777 success <- runPhase_MoveBinary dflags output_fn
1778 if success then return ()
1779 else ghcError (InstallationError ("cannot move binary"))
1780
1781
1782 exeFileName :: DynFlags -> FilePath
1783 exeFileName dflags
1784 | Just s <- outputFile dflags =
1785 if platformOS (targetPlatform dflags) == OSMinGW32
1786 then if null (takeExtension s)
1787 then s <.> "exe"
1788 else s
1789 else s
1790 | otherwise =
1791 if platformOS (targetPlatform dflags) == OSMinGW32
1792 then "main.exe"
1793 else "a.out"
1794
1795 maybeCreateManifest
1796 :: DynFlags
1797 -> FilePath -- filename of executable
1798 -> IO [FilePath] -- extra objects to embed, maybe
1799 maybeCreateManifest dflags exe_filename
1800 | platformOS (targetPlatform dflags) == OSMinGW32 &&
1801 dopt Opt_GenManifest dflags
1802 = do let manifest_filename = exe_filename <.> "manifest"
1803
1804 writeFile manifest_filename $
1805 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1806 " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1807 " <assemblyIdentity version=\"1.0.0.0\"\n"++
1808 " processorArchitecture=\"X86\"\n"++
1809 " name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1810 " type=\"win32\"/>\n\n"++
1811 " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1812 " <security>\n"++
1813 " <requestedPrivileges>\n"++
1814 " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1815 " </requestedPrivileges>\n"++
1816 " </security>\n"++
1817 " </trustInfo>\n"++
1818 "</assembly>\n"
1819
1820 -- Windows will find the manifest file if it is named
1821 -- foo.exe.manifest. However, for extra robustness, and so that
1822 -- we can move the binary around, we can embed the manifest in
1823 -- the binary itself using windres:
1824 if not (dopt Opt_EmbedManifest dflags) then return [] else do
1825
1826 rc_filename <- newTempName dflags "rc"
1827 rc_obj_filename <- newTempName dflags (objectSuf dflags)
1828
1829 writeFile rc_filename $
1830 "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
1831 -- magic numbers :-)
1832 -- show is a bit hackish above, but we need to escape the
1833 -- backslashes in the path.
1834
1835 let wr_opts = getOpts dflags opt_windres
1836 runWindres dflags $ map SysTools.Option $
1837 ["--input="++rc_filename,
1838 "--output="++rc_obj_filename,
1839 "--output-format=coff"]
1840 ++ wr_opts
1841 -- no FileOptions here: windres doesn't like seeing
1842 -- backslashes, apparently
1843
1844 removeFile manifest_filename
1845
1846 return [rc_obj_filename]
1847 | otherwise = return []
1848
1849
1850 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1851 linkDynLib dflags o_files dep_packages = do
1852 let verbFlags = getVerbFlags dflags
1853 let o_file = outputFile dflags
1854
1855 pkgs <- getPreloadPackagesAnd dflags dep_packages
1856
1857 let pkg_lib_paths = collectLibraryPaths pkgs
1858 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1859 get_pkg_lib_path_opts l
1860 | osElfTarget (platformOS (targetPlatform dflags)) &&
1861 dynLibLoader dflags == SystemDependent &&
1862 not opt_Static
1863 = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1864 | otherwise = ["-L" ++ l]
1865
1866 let lib_paths = libraryPaths dflags
1867 let lib_path_opts = map ("-L"++) lib_paths
1868
1869 -- We don't want to link our dynamic libs against the RTS package,
1870 -- because the RTS lib comes in several flavours and we want to be
1871 -- able to pick the flavour when a binary is linked.
1872 -- On Windows we need to link the RTS import lib as Windows does
1873 -- not allow undefined symbols.
1874 -- The RTS library path is still added to the library search path
1875 -- above in case the RTS is being explicitly linked in (see #3807).
1876 let pkgs_no_rts = case platformOS (targetPlatform dflags) of
1877 OSMinGW32 ->
1878 pkgs
1879 _ ->
1880 filter ((/= rtsPackageId) . packageConfigId) pkgs
1881 let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
1882
1883 -- probably _stub.o files
1884 extra_ld_inputs <- readIORef v_Ld_inputs
1885
1886 let extra_ld_opts = getOpts dflags opt_l
1887
1888 #if defined(mingw32_HOST_OS)
1889 -----------------------------------------------------------------------------
1890 -- Making a DLL
1891 -----------------------------------------------------------------------------
1892 let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1893
1894 SysTools.runLink dflags (
1895 map SysTools.Option verbFlags
1896 ++ [ SysTools.Option "-o"
1897 , SysTools.FileOption "" output_fn
1898 , SysTools.Option "-shared"
1899 ] ++
1900 [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1901 | dopt Opt_SharedImplib dflags
1902 ]
1903 ++ map (SysTools.FileOption "") o_files
1904 ++ map SysTools.Option (
1905
1906 -- Permit the linker to auto link _symbol to _imp_symbol
1907 -- This lets us link against DLLs without needing an "import library"
1908 ["-Wl,--enable-auto-import"]
1909
1910 ++ extra_ld_inputs
1911 ++ lib_path_opts
1912 ++ extra_ld_opts
1913 ++ pkg_lib_path_opts
1914 ++ pkg_link_opts
1915 ))
1916 #elif defined(darwin_TARGET_OS)
1917 -----------------------------------------------------------------------------
1918 -- Making a darwin dylib
1919 -----------------------------------------------------------------------------
1920 -- About the options used for Darwin:
1921 -- -dynamiclib
1922 -- Apple's way of saying -shared
1923 -- -undefined dynamic_lookup:
1924 -- Without these options, we'd have to specify the correct dependencies
1925 -- for each of the dylibs. Note that we could (and should) do without this
1926 -- for all libraries except the RTS; all we need to do is to pass the
1927 -- correct HSfoo_dyn.dylib files to the link command.
1928 -- This feature requires Mac OS X 10.3 or later; there is a similar feature,
1929 -- -flat_namespace -undefined suppress, which works on earlier versions,
1930 -- but it has other disadvantages.
1931 -- -single_module
1932 -- Build the dynamic library as a single "module", i.e. no dynamic binding
1933 -- nonsense when referring to symbols from within the library. The NCG
1934 -- assumes that this option is specified (on i386, at least).
1935 -- -install_name
1936 -- Mac OS/X stores the path where a dynamic library is (to be) installed
1937 -- in the library itself. It's called the "install name" of the library.
1938 -- Then any library or executable that links against it before it's
1939 -- installed will search for it in its ultimate install location. By
1940 -- default we set the install name to the absolute path at build time, but
1941 -- it can be overridden by the -dylib-install-name option passed to ghc.
1942 -- Cabal does this.
1943 -----------------------------------------------------------------------------
1944
1945 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1946
1947 instName <- case dylibInstallName dflags of
1948 Just n -> return n
1949 Nothing -> do
1950 pwd <- getCurrentDirectory
1951 return $ pwd `combine` output_fn
1952 SysTools.runLink dflags (
1953 map SysTools.Option verbFlags
1954 ++ [ SysTools.Option "-dynamiclib"
1955 , SysTools.Option "-o"
1956 , SysTools.FileOption "" output_fn
1957 ]
1958 ++ map SysTools.Option (
1959 o_files
1960 ++ [ "-undefined", "dynamic_lookup", "-single_module",
1961 #if !defined(x86_64_TARGET_ARCH)
1962 "-Wl,-read_only_relocs,suppress",
1963 #endif
1964 "-install_name", instName ]
1965 ++ extra_ld_inputs
1966 ++ lib_path_opts
1967 ++ extra_ld_opts
1968 ++ pkg_lib_path_opts
1969 ++ pkg_link_opts
1970 ))
1971 #else
1972 -----------------------------------------------------------------------------
1973 -- Making a DSO
1974 -----------------------------------------------------------------------------
1975
1976 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1977 let buildingRts = thisPackage dflags == rtsPackageId
1978 let bsymbolicFlag = if buildingRts
1979 then -- -Bsymbolic breaks the way we implement
1980 -- hooks in the RTS
1981 []
1982 else -- we need symbolic linking to resolve
1983 -- non-PIC intra-package-relocations
1984 ["-Wl,-Bsymbolic"]
1985
1986 SysTools.runLink dflags (
1987 map SysTools.Option verbFlags
1988 ++ [ SysTools.Option "-o"
1989 , SysTools.FileOption "" output_fn
1990 ]
1991 ++ map SysTools.Option (
1992 o_files
1993 ++ [ "-shared" ]
1994 ++ bsymbolicFlag
1995 -- Set the library soname. We use -h rather than -soname as
1996 -- Solaris 10 doesn't support the latter:
1997 ++ [ "-Wl,-h," ++ takeFileName output_fn ]
1998 ++ extra_ld_inputs
1999 ++ lib_path_opts
2000 ++ extra_ld_opts
2001 ++ pkg_lib_path_opts
2002 ++ pkg_link_opts
2003 ))
2004 #endif
2005 -- -----------------------------------------------------------------------------
2006 -- Running CPP
2007
2008 doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
2009 doCpp dflags raw include_cc_opts input_fn output_fn = do
2010 let hscpp_opts = getOpts dflags opt_P
2011 let cmdline_include_paths = includePaths dflags
2012
2013 pkg_include_dirs <- getPackageIncludePath dflags []
2014 let include_paths = foldr (\ x xs -> "-I" : x : xs) []
2015 (cmdline_include_paths ++ pkg_include_dirs)
2016
2017 let verbFlags = getVerbFlags dflags
2018
2019 let cc_opts
2020 | include_cc_opts = getOpts dflags opt_c
2021 | otherwise = []
2022
2023 let cpp_prog args | raw = SysTools.runCpp dflags args
2024 | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
2025
2026 let target_defs =
2027 [ "-D" ++ HOST_OS ++ "_BUILD_OS=1",
2028 "-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1",
2029 "-D" ++ TARGET_OS ++ "_HOST_OS=1",
2030 "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
2031 -- remember, in code we *compile*, the HOST is the same our TARGET,
2032 -- and BUILD is the same as our HOST.
2033
2034 cpp_prog ( map SysTools.Option verbFlags
2035 ++ map SysTools.Option include_paths
2036 ++ map SysTools.Option hsSourceCppOpts
2037 ++ map SysTools.Option target_defs
2038 ++ map SysTools.Option hscpp_opts
2039 ++ map SysTools.Option cc_opts
2040 ++ [ SysTools.Option "-x"
2041 , SysTools.Option "c"
2042 , SysTools.Option input_fn
2043 -- We hackily use Option instead of FileOption here, so that the file
2044 -- name is not back-slashed on Windows. cpp is capable of
2045 -- dealing with / in filenames, so it works fine. Furthermore
2046 -- if we put in backslashes, cpp outputs #line directives
2047 -- with *double* backslashes. And that in turn means that
2048 -- our error messages get double backslashes in them.
2049 -- In due course we should arrange that the lexer deals
2050 -- with these \\ escapes properly.
2051 , SysTools.Option "-o"
2052 , SysTools.FileOption "" output_fn
2053 ])
2054
2055 hsSourceCppOpts :: [String]
2056 -- Default CPP defines in Haskell source
2057 hsSourceCppOpts =
2058 [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
2059
2060 -- ---------------------------------------------------------------------------
2061 -- join object files into a single relocatable object file, using ld -r
2062
2063 joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
2064 joinObjectFiles dflags o_files output_fn = do
2065 let ld_r args = SysTools.runLink dflags ([
2066 SysTools.Option "-nostdlib",
2067 SysTools.Option "-nodefaultlibs",
2068 SysTools.Option "-Wl,-r"
2069 ]
2070 -- gcc on sparc sets -Wl,--relax implicitly, but
2071 -- -r and --relax are incompatible for ld, so
2072 -- disable --relax explicitly.
2073 ++ (if platformArch (targetPlatform dflags) == ArchSPARC
2074 then [SysTools.Option "-Wl,-no-relax"]
2075 else [])
2076 ++ [
2077 SysTools.Option ld_build_id,
2078 -- SysTools.Option ld_x_flag,
2079 SysTools.Option "-o",
2080 SysTools.FileOption "" output_fn ]
2081 ++ args)
2082
2083 -- Do *not* add the -x flag to ld, because we want to keep those
2084 -- local symbols around for the benefit of external tools. e.g.
2085 -- the 'perf report' output is much less useful if all the local
2086 -- symbols have been stripped out.
2087 --
2088 -- ld_x_flag | null cLD_X = ""
2089 -- | otherwise = "-Wl,-x"
2090
2091 -- suppress the generation of the .note.gnu.build-id section,
2092 -- which we don't need and sometimes causes ld to emit a
2093 -- warning:
2094 ld_build_id | cLdHasBuildId == "YES" = "-Wl,--build-id=none"
2095 | otherwise = ""
2096
2097 if cLdIsGNULd == "YES"
2098 then do
2099 script <- newTempName dflags "ldscript"
2100 writeFile script $ "INPUT(" ++ unwords o_files ++ ")"
2101 ld_r [SysTools.FileOption "" script]
2102 else do
2103 ld_r (map (SysTools.FileOption "") o_files)
2104
2105 -- -----------------------------------------------------------------------------
2106 -- Misc.
2107
2108 -- | What phase to run after one of the backend code generators has run
2109 hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
2110 hscPostBackendPhase _ HsBootFile _ = StopLn
2111 hscPostBackendPhase dflags _ hsc_lang =
2112 case hsc_lang of
2113 HscC -> HCc
2114 HscAsm | dopt Opt_SplitObjs dflags -> Splitter
2115 | otherwise -> As
2116 HscLlvm -> LlvmOpt
2117 HscNothing -> StopLn
2118 HscInterpreted -> StopLn
2119
2120 touchObjectFile :: DynFlags -> FilePath -> IO ()
2121 touchObjectFile dflags path = do
2122 createDirectoryHierarchy $ takeDirectory path
2123 SysTools.touch dflags "Touching object file" path
2124