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