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