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