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