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