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