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