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