Rationalise GhcMode, HscTarget and GhcLink
[ghc.git] / compiler / main / DriverPipeline.hs
1 -----------------------------------------------------------------------------
2 --
3 -- GHC Driver
4 --
5 -- (c) The University of Glasgow 2005
6 --
7 -----------------------------------------------------------------------------
8
9 module DriverPipeline (
10 -- Run a series of compilation steps in a pipeline, for a
11 -- collection of source files.
12 oneShot, compileFile,
13
14 -- Interfaces for the batch-mode driver
15 staticLink,
16
17 -- Interfaces for the compilation manager (interpreted/batch-mode)
18 preprocess,
19 compile, CompResult(..),
20 link,
21
22 -- DLL building
23 doMkDLL,
24
25 ) where
26
27 #include "HsVersions.h"
28
29 import Packages
30 import HeaderInfo
31 import DriverPhases
32 import SysTools
33 import qualified 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_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 ( unLoc )
51 import SrcLoc ( Located(..) )
52
53 import Control.Exception as Exception
54 import Data.IORef ( readIORef, writeIORef, IORef )
55 import GHC.Exts ( Int(..) )
56 import System.Directory
57 import System.IO
58 import SYSTEM_IO_ERROR as IO
59 import Control.Monad
60 import Data.List ( isSuffixOf )
61 import Data.Maybe
62 import System.Exit
63 import System.Cmd
64 import System.Environment
65
66 -- ---------------------------------------------------------------------------
67 -- Pre-process
68
69 -- Just preprocess a file, put the result in a temp. file (used by the
70 -- compilation manager during the summary phase).
71 --
72 -- We return the augmented DynFlags, because they contain the result
73 -- of slurping in the OPTIONS pragmas
74
75 preprocess :: DynFlags -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath)
76 preprocess dflags (filename, mb_phase) =
77 ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
78 runPipeline anyHsc dflags (filename, mb_phase)
79 Nothing Temporary Nothing{-no ModLocation-}
80
81 -- ---------------------------------------------------------------------------
82 -- Compile
83
84 -- Compile a single module, under the control of the compilation manager.
85 --
86 -- This is the interface between the compilation manager and the
87 -- compiler proper (hsc), where we deal with tedious details like
88 -- reading the OPTIONS pragma from the source file, and passing the
89 -- output of hsc through the C compiler.
90
91 -- NB. No old interface can also mean that the source has changed.
92
93 compile :: HscEnv
94 -> ModSummary
95 -> Maybe Linkable -- Just linkable <=> source unchanged
96 -> Maybe ModIface -- Old interface, if available
97 -> Int -> Int
98 -> IO CompResult
99
100 data CompResult
101 = CompOK ModDetails -- New details
102 ModIface -- New iface
103 (Maybe Linkable) -- a Maybe, for the same reasons as hm_linkable
104
105 | CompErrs
106
107
108 compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do
109
110 let dflags0 = ms_hspp_opts mod_summary
111 this_mod = ms_mod mod_summary
112 src_flavour = ms_hsc_src mod_summary
113
114 have_object
115 | Just l <- maybe_old_linkable, isObjectLinkable l = True
116 | otherwise = False
117
118 -- FIXME: We need to know whether or not we're recompiling the file. Move this to HscMain?
119 --showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary)
120
121 let location = ms_location mod_summary
122 let input_fn = expectJust "compile:hs" (ml_hs_file location)
123 let input_fnpp = ms_hspp_file mod_summary
124
125 debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
126
127 let (basename, _) = splitFilename input_fn
128
129 -- We add the directory in which the .hs files resides) to the import path.
130 -- This is needed when we try to compile the .hc file later, if it
131 -- imports a _stub.h file that we created here.
132 let current_dir = directoryOf basename
133 old_paths = includePaths dflags0
134 dflags = dflags0 { includePaths = current_dir : old_paths }
135
136 -- Figure out what lang we're generating
137 let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags)
138 -- ... and what the next phase should be
139 let next_phase = hscNextPhase dflags src_flavour hsc_lang
140 -- ... and what file to generate the output into
141 output_fn <- getOutputFilename next_phase
142 Temporary basename dflags next_phase (Just location)
143
144 let dflags' = dflags { hscTarget = hsc_lang,
145 hscOutName = output_fn,
146 extCoreName = basename ++ ".hcr" }
147
148 -- -no-recomp should also work with --make
149 let force_recomp = dopt Opt_ForceRecomp dflags
150 source_unchanged = isJust maybe_old_linkable && not force_recomp
151 hsc_env' = hsc_env { hsc_dflags = dflags' }
152 object_filename = ml_obj_file location
153
154 let getStubLinkable False = return []
155 getStubLinkable True
156 = do stub_o <- compileStub dflags' this_mod location
157 return [ DotO stub_o ]
158
159 handleBatch (HscNoRecomp, iface, details)
160 = ASSERT (isJust maybe_old_linkable)
161 return (CompOK details iface maybe_old_linkable)
162 handleBatch (HscRecomp hasStub, iface, details)
163 | isHsBoot src_flavour
164 = return (CompOK details iface Nothing)
165 | otherwise
166 = do stub_unlinked <- getStubLinkable hasStub
167 (hs_unlinked, unlinked_time) <-
168 case hsc_lang of
169 HscNothing
170 -> return ([], ms_hs_date mod_summary)
171 -- We're in --make mode: finish the compilation pipeline.
172 _other
173 -> do runPipeline StopLn dflags (output_fn,Nothing)
174 (Just basename)
175 Persistent
176 (Just location)
177 -- The object filename comes from the ModLocation
178 o_time <- getModificationTime object_filename
179 return ([DotO object_filename], o_time)
180 let linkable = LM unlinked_time this_mod
181 (hs_unlinked ++ stub_unlinked)
182 return (CompOK details iface (Just linkable))
183
184 handleInterpreted (InteractiveNoRecomp, iface, details)
185 = ASSERT (isJust maybe_old_linkable)
186 return (CompOK details iface maybe_old_linkable)
187 handleInterpreted (InteractiveRecomp hasStub comp_bc, iface, details)
188 = do stub_unlinked <- getStubLinkable hasStub
189 let hs_unlinked = [BCOs comp_bc]
190 unlinked_time = ms_hs_date mod_summary
191 -- Why do we use the timestamp of the source file here,
192 -- rather than the current time? This works better in
193 -- the case where the local clock is out of sync
194 -- with the filesystem's clock. It's just as accurate:
195 -- if the source is modified, then the linkable will
196 -- be out of date.
197 let linkable = LM unlinked_time this_mod
198 (hs_unlinked ++ stub_unlinked)
199 return (CompOK details iface (Just linkable))
200
201 let runCompiler compiler handle
202 = do mbResult <- compiler hsc_env' mod_summary
203 source_unchanged old_iface
204 (Just (mod_index, nmods))
205 case mbResult of
206 Nothing -> return CompErrs
207 Just result -> handle result
208 -- run the compiler
209 case hsc_lang of
210 HscInterpreted | not (isHsBoot src_flavour) -- We can't compile boot files to
211 -- bytecode so don't even try.
212 -> runCompiler hscCompileInteractive handleInterpreted
213 HscNothing
214 -> runCompiler hscCompileNothing handleBatch
215 _other
216 -> runCompiler hscCompileBatch handleBatch
217
218 -----------------------------------------------------------------------------
219 -- stub .h and .c files (for foreign export support)
220
221 -- The _stub.c file is derived from the haskell source file, possibly taking
222 -- into account the -stubdir option.
223 --
224 -- Consequently, we derive the _stub.o filename from the haskell object
225 -- filename.
226 --
227 -- This isn't necessarily the same as the object filename we
228 -- would get if we just compiled the _stub.c file using the pipeline.
229 -- For example:
230 --
231 -- ghc src/A.hs -odir obj
232 --
233 -- results in obj/A.o, and src/A_stub.c. If we compile src/A_stub.c with
234 -- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want
235 -- obj/A_stub.o.
236
237 compileStub :: DynFlags -> Module -> ModLocation -> IO FilePath
238 compileStub dflags mod location = do
239 let (o_base, o_ext) = splitFilename (ml_obj_file location)
240 stub_o = o_base ++ "_stub" `joinFileExt` o_ext
241
242 -- compile the _stub.c file w/ gcc
243 let (stub_c,_) = mkStubPaths dflags (moduleName mod) location
244 runPipeline StopLn dflags (stub_c,Nothing) Nothing
245 (SpecificFile stub_o) Nothing{-no ModLocation-}
246
247 return stub_o
248
249
250 -- ---------------------------------------------------------------------------
251 -- Link
252
253 link :: GhcLink -- interactive or batch
254 -> DynFlags -- dynamic flags
255 -> Bool -- attempt linking in batch mode?
256 -> HomePackageTable -- what to link
257 -> IO SuccessFlag
258
259 -- For the moment, in the batch linker, we don't bother to tell doLink
260 -- which packages to link -- it just tries all that are available.
261 -- batch_attempt_linking should only be *looked at* in batch mode. It
262 -- should only be True if the upsweep was successful and someone
263 -- exports main, i.e., we have good reason to believe that linking
264 -- will succeed.
265
266 #ifdef GHCI
267 link LinkInMemory dflags batch_attempt_linking hpt
268 = do -- Not Linking...(demand linker will do the job)
269 return Succeeded
270 #endif
271
272 link NoLink dflags batch_attempt_linking hpt
273 = return Succeeded
274
275 link LinkBinary dflags batch_attempt_linking hpt
276 | batch_attempt_linking
277 = do
278 let
279 home_mod_infos = eltsUFM hpt
280
281 -- the packages we depend on
282 pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos
283
284 -- the linkables to link
285 linkables = map (expectJust "link".hm_linkable) home_mod_infos
286
287 debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
288
289 -- check for the -no-link flag
290 if isNoLink (ghcLink dflags)
291 then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
292 return Succeeded
293 else do
294
295 let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
296 obj_files = concatMap getOfiles linkables
297
298 exe_file = exeFileName dflags
299
300 -- if the modification time on the executable is later than the
301 -- modification times on all of the objects, then omit linking
302 -- (unless the -no-recomp flag was given).
303 e_exe_time <- IO.try $ getModificationTime exe_file
304 let linking_needed
305 | Left _ <- e_exe_time = True
306 | Right t <- e_exe_time =
307 any (t <) (map linkableTime linkables)
308
309 if not (dopt Opt_ForceRecomp dflags) && not linking_needed
310 then do debugTraceMsg dflags 2 (text exe_file <+> ptext SLIT("is up to date, linking not required."))
311 return Succeeded
312 else do
313
314 debugTraceMsg dflags 1 (ptext SLIT("Linking") <+> text exe_file
315 <+> text "...")
316
317 -- Don't showPass in Batch mode; doLink will do that for us.
318 let link = case ghcLink dflags of
319 MkDLL -> doMkDLL
320 LinkBinary -> staticLink
321 link dflags obj_files pkg_deps
322
323 debugTraceMsg dflags 3 (text "link: done")
324
325 -- staticLink only returns if it succeeds
326 return Succeeded
327
328 | otherwise
329 = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
330 text " Main.main not exported; not linking.")
331 return Succeeded
332
333
334 -- -----------------------------------------------------------------------------
335 -- Compile files in one-shot mode.
336
337 oneShot :: DynFlags -> Phase -> [(String, Maybe Phase)] -> IO ()
338 oneShot dflags stop_phase srcs = do
339 o_files <- mapM (compileFile dflags stop_phase) srcs
340 doLink dflags stop_phase o_files
341
342 compileFile :: DynFlags -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
343 compileFile dflags stop_phase (src, mb_phase) = do
344 exists <- doesFileExist src
345 when (not exists) $
346 throwDyn (CmdLineError ("does not exist: " ++ src))
347
348 let
349 split = dopt Opt_SplitObjs dflags
350 mb_o_file = outputFile dflags
351 ghc_link = ghcLink dflags -- Set by -c or -no-link
352
353 -- When linking, the -o argument refers to the linker's output.
354 -- otherwise, we use it as the name for the pipeline's output.
355 output
356 | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
357 -- -o foo applies to linker
358 | Just o_file <- mb_o_file = SpecificFile o_file
359 -- -o foo applies to the file we are compiling now
360 | otherwise = Persistent
361
362 stop_phase' = case stop_phase of
363 As | split -> SplitAs
364 other -> stop_phase
365
366 (_, out_file) <- runPipeline stop_phase' dflags
367 (src, mb_phase) Nothing output
368 Nothing{-no ModLocation-}
369 return out_file
370
371
372 doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
373 doLink dflags stop_phase o_files
374 | not (isStopLn stop_phase)
375 = return () -- We stopped before the linking phase
376
377 | otherwise
378 = case ghcLink dflags of
379 NoLink -> return ()
380 LinkBinary -> staticLink dflags o_files link_pkgs
381 MkDLL -> doMkDLL dflags o_files link_pkgs
382 where
383 -- Always link in the haskell98 package for static linking. Other
384 -- packages have to be specified via the -package flag.
385 link_pkgs = [haskell98PackageId]
386
387
388 -- ---------------------------------------------------------------------------
389 -- Run a compilation pipeline, consisting of multiple phases.
390
391 -- This is the interface to the compilation pipeline, which runs
392 -- a series of compilation steps on a single source file, specifying
393 -- at which stage to stop.
394
395 -- The DynFlags can be modified by phases in the pipeline (eg. by
396 -- GHC_OPTIONS pragmas), and the changes affect later phases in the
397 -- pipeline.
398
399 data PipelineOutput
400 = Temporary
401 -- output should be to a temporary file: we're going to
402 -- run more compilation steps on this output later
403 | Persistent
404 -- we want a persistent file, i.e. a file in the current directory
405 -- derived from the input filename, but with the appropriate extension.
406 -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
407 | SpecificFile FilePath
408 -- the output must go into the specified file.
409
410 runPipeline
411 :: Phase -- When to stop
412 -> DynFlags -- Dynamic flags
413 -> (FilePath,Maybe Phase) -- Input filename (and maybe -x suffix)
414 -> Maybe FilePath -- original basename (if different from ^^^)
415 -> PipelineOutput -- Output filename
416 -> Maybe ModLocation -- A ModLocation, if this is a Haskell module
417 -> IO (DynFlags, FilePath) -- (final flags, output filename)
418
419 runPipeline stop_phase dflags (input_fn, mb_phase) mb_basename output maybe_loc
420 = do
421 let (input_basename, suffix) = splitFilename input_fn
422 basename | Just b <- mb_basename = b
423 | otherwise = input_basename
424
425 -- If we were given a -x flag, then use that phase to start from
426 start_phase = fromMaybe (startPhase suffix) mb_phase
427
428 -- We want to catch cases of "you can't get there from here" before
429 -- we start the pipeline, because otherwise it will just run off the
430 -- end.
431 --
432 -- There is a partial ordering on phases, where A < B iff A occurs
433 -- before B in a normal compilation pipeline.
434
435 when (not (start_phase `happensBefore` stop_phase)) $
436 throwDyn (UsageError
437 ("cannot compile this file to desired target: "
438 ++ input_fn))
439
440 -- this is a function which will be used to calculate output file names
441 -- as we go along (we partially apply it to some of its inputs here)
442 let get_output_fn = getOutputFilename stop_phase output basename
443
444 -- Execute the pipeline...
445 (dflags', output_fn, maybe_loc) <-
446 pipeLoop dflags start_phase stop_phase input_fn
447 basename suffix get_output_fn maybe_loc
448
449 -- Sometimes, a compilation phase doesn't actually generate any output
450 -- (eg. the CPP phase when -fcpp is not turned on). If we end on this
451 -- stage, but we wanted to keep the output, then we have to explicitly
452 -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
453 -- further compilation stages can tell what the original filename was.
454 case output of
455 Temporary ->
456 return (dflags', output_fn)
457 _other ->
458 do final_fn <- get_output_fn dflags' stop_phase maybe_loc
459 when (final_fn /= output_fn) $ do
460 let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
461 line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
462 copyWithHeader dflags msg line_prag output_fn final_fn
463 return (dflags', final_fn)
464
465
466
467 pipeLoop :: DynFlags -> Phase -> Phase
468 -> FilePath -> String -> Suffix
469 -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
470 -> Maybe ModLocation
471 -> IO (DynFlags, FilePath, Maybe ModLocation)
472
473 pipeLoop dflags phase stop_phase
474 input_fn orig_basename orig_suff
475 orig_get_output_fn maybe_loc
476
477 | phase `eqPhase` stop_phase -- All done
478 = return (dflags, input_fn, maybe_loc)
479
480 | not (phase `happensBefore` stop_phase)
481 -- Something has gone wrong. We'll try to cover all the cases when
482 -- this could happen, so if we reach here it is a panic.
483 -- eg. it might happen if the -C flag is used on a source file that
484 -- has {-# OPTIONS -fasm #-}.
485 = panic ("pipeLoop: at phase " ++ show phase ++
486 " but I wanted to stop at phase " ++ show stop_phase)
487
488 | otherwise
489 = do { (next_phase, dflags', maybe_loc, output_fn)
490 <- runPhase phase stop_phase dflags orig_basename
491 orig_suff input_fn orig_get_output_fn maybe_loc
492 ; pipeLoop dflags' next_phase stop_phase output_fn
493 orig_basename orig_suff orig_get_output_fn maybe_loc }
494
495 getOutputFilename
496 :: Phase -> PipelineOutput -> String
497 -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
498 getOutputFilename stop_phase output basename
499 = func
500 where
501 func dflags next_phase maybe_location
502 | is_last_phase, Persistent <- output = persistent_fn
503 | is_last_phase, SpecificFile f <- output = return f
504 | keep_this_output = persistent_fn
505 | otherwise = newTempName dflags suffix
506 where
507 hcsuf = hcSuf dflags
508 odir = objectDir dflags
509 osuf = objectSuf dflags
510 keep_hc = dopt Opt_KeepHcFiles dflags
511 keep_raw_s = dopt Opt_KeepRawSFiles dflags
512 keep_s = dopt Opt_KeepSFiles dflags
513
514 myPhaseInputExt HCc = hcsuf
515 myPhaseInputExt StopLn = osuf
516 myPhaseInputExt other = phaseInputExt other
517
518 is_last_phase = next_phase `eqPhase` stop_phase
519
520 -- sometimes, we keep output from intermediate stages
521 keep_this_output =
522 case next_phase of
523 StopLn -> True
524 Mangle | keep_raw_s -> True
525 As | keep_s -> True
526 HCc | keep_hc -> True
527 _other -> False
528
529 suffix = myPhaseInputExt next_phase
530
531 -- persistent object files get put in odir
532 persistent_fn
533 | StopLn <- next_phase = return odir_persistent
534 | otherwise = return persistent
535
536 persistent = basename `joinFileExt` suffix
537
538 odir_persistent
539 | Just loc <- maybe_location = ml_obj_file loc
540 | Just d <- odir = d `joinFileName` persistent
541 | otherwise = persistent
542
543
544 -- -----------------------------------------------------------------------------
545 -- Each phase in the pipeline returns the next phase to execute, and the
546 -- name of the file in which the output was placed.
547 --
548 -- We must do things dynamically this way, because we often don't know
549 -- what the rest of the phases will be until part-way through the
550 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
551 -- of a source file can change the latter stages of the pipeline from
552 -- taking the via-C route to using the native code generator.
553
554 runPhase :: Phase -- Do this phase first
555 -> Phase -- Stop just before this phase
556 -> DynFlags
557 -> String -- basename of original input source
558 -> String -- its extension
559 -> FilePath -- name of file which contains the input to this phase.
560 -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
561 -- how to calculate the output filename
562 -> Maybe ModLocation -- the ModLocation, if we have one
563 -> IO (Phase, -- next phase
564 DynFlags, -- new dynamic flags
565 Maybe ModLocation, -- the ModLocation, if we have one
566 FilePath) -- output filename
567
568 -- Invariant: the output filename always contains the output
569 -- Interesting case: Hsc when there is no recompilation to do
570 -- Then the output filename is still a .o file
571
572 -------------------------------------------------------------------------------
573 -- Unlit phase
574
575 runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_loc
576 = do let unlit_flags = getOpts dflags opt_L
577 -- The -h option passes the file name for unlit to put in a #line directive
578 output_fn <- get_output_fn dflags (Cpp sf) maybe_loc
579
580 SysTools.runUnlit dflags
581 (map SysTools.Option unlit_flags ++
582 [ SysTools.Option "-h"
583 , SysTools.Option input_fn
584 , SysTools.FileOption "" input_fn
585 , SysTools.FileOption "" output_fn
586 ])
587
588 return (Cpp sf, dflags, maybe_loc, output_fn)
589
590 -------------------------------------------------------------------------------
591 -- Cpp phase : (a) gets OPTIONS out of file
592 -- (b) runs cpp if necessary
593
594 runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc
595 = do src_opts <- getOptionsFromFile input_fn
596 (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts)
597 checkProcessArgsResult unhandled_flags (basename `joinFileExt` suff)
598
599 if not (dopt Opt_Cpp dflags) then
600 -- no need to preprocess CPP, just pass input file along
601 -- to the next phase of the pipeline.
602 return (HsPp sf, dflags, maybe_loc, input_fn)
603 else do
604 output_fn <- get_output_fn dflags (HsPp sf) maybe_loc
605 doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn
606 return (HsPp sf, dflags, maybe_loc, output_fn)
607
608 -------------------------------------------------------------------------------
609 -- HsPp phase
610
611 runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc
612 = do if not (dopt Opt_Pp dflags) then
613 -- no need to preprocess, just pass input file along
614 -- to the next phase of the pipeline.
615 return (Hsc sf, dflags, maybe_loc, input_fn)
616 else do
617 let hspp_opts = getOpts dflags opt_F
618 let orig_fn = basename `joinFileExt` suff
619 output_fn <- get_output_fn dflags (Hsc sf) maybe_loc
620 SysTools.runPp dflags
621 ( [ SysTools.Option orig_fn
622 , SysTools.Option input_fn
623 , SysTools.FileOption "" output_fn
624 ] ++
625 map SysTools.Option hspp_opts
626 )
627 return (Hsc sf, dflags, maybe_loc, output_fn)
628
629 -----------------------------------------------------------------------------
630 -- Hsc phase
631
632 -- Compilation of a single module, in "legacy" mode (_not_ under
633 -- the direction of the compilation manager).
634 runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _maybe_loc
635 = do -- normal Hsc mode, not mkdependHS
636
637 -- we add the current directory (i.e. the directory in which
638 -- the .hs files resides) to the import path, since this is
639 -- what gcc does, and it's probably what you want.
640 let current_dir = directoryOf basename
641
642 paths = includePaths dflags0
643 dflags = dflags0 { includePaths = current_dir : paths }
644
645 -- gather the imports and module name
646 (hspp_buf,mod_name) <-
647 case src_flavour of
648 ExtCoreFile -> do { -- no explicit imports in ExtCore input.
649 ; m <- getCoreModuleName input_fn
650 ; return (Nothing, mkModuleName m) }
651
652 other -> do { buf <- hGetStringBuffer input_fn
653 ; (_,_,L _ mod_name) <- getImports dflags buf input_fn
654 ; return (Just buf, mod_name) }
655
656 -- Build a ModLocation to pass to hscMain.
657 -- The source filename is rather irrelevant by now, but it's used
658 -- by hscMain for messages. hscMain also needs
659 -- the .hi and .o filenames, and this is as good a way
660 -- as any to generate them, and better than most. (e.g. takes
661 -- into accout the -osuf flags)
662 location1 <- mkHomeModLocation2 dflags mod_name basename suff
663
664 -- Boot-ify it if necessary
665 let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
666 | otherwise = location1
667
668
669 -- Take -ohi into account if present
670 -- This can't be done in mkHomeModuleLocation because
671 -- it only applies to the module being compiles
672 let ohi = outputHi dflags
673 location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
674 | otherwise = location2
675
676 -- Take -o into account if present
677 -- Very like -ohi, but we must *only* do this if we aren't linking
678 -- (If we're linking then the -o applies to the linked thing, not to
679 -- the object file for one module.)
680 -- Note the nasty duplication with the same computation in compileFile above
681 let expl_o_file = outputFile dflags
682 location4 | Just ofile <- expl_o_file
683 , isNoLink (ghcLink dflags)
684 = location3 { ml_obj_file = ofile }
685 | otherwise = location3
686
687 o_file = ml_obj_file location4 -- The real object file
688
689
690 -- Figure out if the source has changed, for recompilation avoidance.
691 --
692 -- Setting source_unchanged to True means that M.o seems
693 -- to be up to date wrt M.hs; so no need to recompile unless imports have
694 -- changed (which the compiler itself figures out).
695 -- Setting source_unchanged to False tells the compiler that M.o is out of
696 -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
697 src_timestamp <- getModificationTime (basename `joinFileExt` suff)
698
699 let force_recomp = dopt Opt_ForceRecomp dflags
700 source_unchanged <-
701 if force_recomp || not (isStopLn stop)
702 -- Set source_unchanged to False unconditionally if
703 -- (a) recompilation checker is off, or
704 -- (b) we aren't going all the way to .o file (e.g. ghc -S)
705 then return False
706 -- Otherwise look at file modification dates
707 else do o_file_exists <- doesFileExist o_file
708 if not o_file_exists
709 then return False -- Need to recompile
710 else do t2 <- getModificationTime o_file
711 if t2 > src_timestamp
712 then return True
713 else return False
714
715 -- get the DynFlags
716 let hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags)
717 let next_phase = hscNextPhase dflags src_flavour hsc_lang
718 output_fn <- get_output_fn dflags next_phase (Just location4)
719
720 let dflags' = dflags { hscTarget = hsc_lang,
721 hscOutName = output_fn,
722 extCoreName = basename ++ ".hcr" }
723
724 hsc_env <- newHscEnv dflags'
725
726 -- Tell the finder cache about this module
727 mod <- addHomeModuleToFinder hsc_env mod_name location4
728
729 -- Make the ModSummary to hand to hscMain
730 let
731 unused_field = panic "runPhase:ModSummary field"
732 -- Some fields are not looked at by hscMain
733 mod_summary = ModSummary { ms_mod = mod,
734 ms_hsc_src = src_flavour,
735 ms_hspp_file = input_fn,
736 ms_hspp_opts = dflags,
737 ms_hspp_buf = hspp_buf,
738 ms_location = location4,
739 ms_hs_date = src_timestamp,
740 ms_obj_date = Nothing,
741 ms_imps = unused_field,
742 ms_srcimps = unused_field }
743
744 -- run the compiler!
745 mbResult <- hscCompileOneShot hsc_env
746 mod_summary source_unchanged
747 Nothing -- No iface
748 Nothing -- No "module i of n" progress info
749
750 case mbResult of
751 Nothing -> throwDyn (PhaseFailed "hsc" (ExitFailure 1))
752 Just HscNoRecomp
753 -> do SysTools.touch dflags' "Touching object file" o_file
754 -- The .o file must have a later modification date
755 -- than the source file (else we wouldn't be in HscNoRecomp)
756 -- but we touch it anyway, to keep 'make' happy (we think).
757 return (StopLn, dflags', Just location4, o_file)
758 Just (HscRecomp hasStub)
759 -> do when hasStub $
760 do stub_o <- compileStub dflags' mod location4
761 consIORef v_Ld_inputs stub_o
762 -- In the case of hs-boot files, generate a dummy .o-boot
763 -- stamp file for the benefit of Make
764 when (isHsBoot src_flavour) $
765 SysTools.touch dflags' "Touching object file" o_file
766 return (next_phase, dflags', Just location4, output_fn)
767
768 -----------------------------------------------------------------------------
769 -- Cmm phase
770
771 runPhase CmmCpp stop dflags basename suff input_fn get_output_fn maybe_loc
772 = do
773 output_fn <- get_output_fn dflags Cmm maybe_loc
774 doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
775 return (Cmm, dflags, maybe_loc, output_fn)
776
777 runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc
778 = do
779 let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
780 let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
781 output_fn <- get_output_fn dflags next_phase maybe_loc
782
783 let dflags' = dflags { hscTarget = hsc_lang,
784 hscOutName = output_fn,
785 extCoreName = basename ++ ".hcr" }
786
787 ok <- hscCmmFile dflags' input_fn
788
789 when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1))
790
791 return (next_phase, dflags, maybe_loc, output_fn)
792
793 -----------------------------------------------------------------------------
794 -- Cc phase
795
796 -- we don't support preprocessing .c files (with -E) now. Doing so introduces
797 -- way too many hacks, and I can't say I've ever used it anyway.
798
799 runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc
800 | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
801 = do let cc_opts = getOpts dflags opt_c
802 hcc = cc_phase `eqPhase` HCc
803
804 let cmdline_include_paths = includePaths dflags
805
806 -- HC files have the dependent packages stamped into them
807 pkgs <- if hcc then getHCFilePackages input_fn else return []
808
809 -- add package include paths even if we're just compiling .c
810 -- files; this is the Value Add(TM) that using ghc instead of
811 -- gcc gives you :)
812 pkg_include_dirs <- getPackageIncludePath dflags pkgs
813 let include_paths = foldr (\ x xs -> "-I" : x : xs) []
814 (cmdline_include_paths ++ pkg_include_dirs)
815
816 let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags
817 let pic_c_flags = picCCOpts dflags
818
819 let verb = getVerbFlag dflags
820
821 pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs
822
823 let split_objs = dopt Opt_SplitObjs dflags
824 split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
825 | otherwise = [ ]
826
827 let excessPrecision = dopt Opt_ExcessPrecision dflags
828
829 let cc_opt | optLevel dflags >= 2 = "-O2"
830 | otherwise = "-O"
831
832 -- Decide next phase
833
834 let mangle = dopt Opt_DoAsmMangling dflags
835 next_phase
836 | hcc && mangle = Mangle
837 | otherwise = As
838 output_fn <- get_output_fn dflags next_phase maybe_loc
839
840 let
841 more_hcc_opts =
842 #if i386_TARGET_ARCH
843 -- on x86 the floating point regs have greater precision
844 -- than a double, which leads to unpredictable results.
845 -- By default, we turn this off with -ffloat-store unless
846 -- the user specified -fexcess-precision.
847 (if excessPrecision then [] else [ "-ffloat-store" ]) ++
848 #endif
849 -- gcc's -fstrict-aliasing allows two accesses to memory
850 -- to be considered non-aliasing if they have different types.
851 -- This interacts badly with the C code we generate, which is
852 -- very weakly typed, being derived from C--.
853 ["-fno-strict-aliasing"]
854
855
856
857 SysTools.runCc dflags (
858 -- force the C compiler to interpret this file as C when
859 -- compiling .hc files, by adding the -x c option.
860 -- Also useful for plain .c files, just in case GHC saw a
861 -- -x c option.
862 [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
863 then SysTools.Option "c++" else SysTools.Option "c"] ++
864 [ SysTools.FileOption "" input_fn
865 , SysTools.Option "-o"
866 , SysTools.FileOption "" output_fn
867 ]
868 ++ map SysTools.Option (
869 md_c_flags
870 ++ pic_c_flags
871 #ifdef sparc_TARGET_ARCH
872 -- We only support SparcV9 and better because V8 lacks an atomic CAS
873 -- instruction. Note that the user can still override this
874 -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
875 -- regardless of the ordering.
876 --
877 -- This is a temporary hack.
878 ++ ["-mcpu=v9"]
879 #endif
880 ++ (if hcc && mangle
881 then md_regd_c_flags
882 else [])
883 ++ (if hcc
884 then more_hcc_opts
885 else [])
886 ++ [ verb, "-S", "-Wimplicit", cc_opt ]
887 ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
888 ++ cc_opts
889 ++ split_opt
890 ++ include_paths
891 ++ pkg_extra_cc_opts
892 #ifdef HAVE_GCC_HAS_WRAPV
893 -- We need consistent integer overflow (trac #952)
894 ++ ["-fwrapv"]
895 #endif
896 ))
897
898 return (next_phase, dflags, maybe_loc, output_fn)
899
900 -- ToDo: postprocess the output from gcc
901
902 -----------------------------------------------------------------------------
903 -- Mangle phase
904
905 runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc
906 = do let mangler_opts = getOpts dflags opt_m
907
908 #if i386_TARGET_ARCH
909 machdep_opts <- return [ show (stolen_x86_regs dflags) ]
910 #else
911 machdep_opts <- return []
912 #endif
913
914 let split = dopt Opt_SplitObjs dflags
915 next_phase
916 | split = SplitMangle
917 | otherwise = As
918 output_fn <- get_output_fn dflags next_phase maybe_loc
919
920 SysTools.runMangle dflags (map SysTools.Option mangler_opts
921 ++ [ SysTools.FileOption "" input_fn
922 , SysTools.FileOption "" output_fn
923 ]
924 ++ map SysTools.Option machdep_opts)
925
926 return (next_phase, dflags, maybe_loc, output_fn)
927
928 -----------------------------------------------------------------------------
929 -- Splitting phase
930
931 runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_loc
932 = do -- tmp_pfx is the prefix used for the split .s files
933 -- We also use it as the file to contain the no. of split .s files (sigh)
934 split_s_prefix <- SysTools.newTempName dflags "split"
935 let n_files_fn = split_s_prefix
936
937 SysTools.runSplit dflags
938 [ SysTools.FileOption "" input_fn
939 , SysTools.FileOption "" split_s_prefix
940 , SysTools.FileOption "" n_files_fn
941 ]
942
943 -- Save the number of split files for future references
944 s <- readFile n_files_fn
945 let n_files = read s :: Int
946 writeIORef v_Split_info (split_s_prefix, n_files)
947
948 -- Remember to delete all these files
949 addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
950 | n <- [1..n_files]]
951
952 return (SplitAs, dflags, maybe_loc, "**splitmangle**")
953 -- we don't use the filename
954
955 -----------------------------------------------------------------------------
956 -- As phase
957
958 runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc
959 = do let as_opts = getOpts dflags opt_a
960 let cmdline_include_paths = includePaths dflags
961
962 output_fn <- get_output_fn dflags StopLn maybe_loc
963
964 -- we create directories for the object file, because it
965 -- might be a hierarchical module.
966 createDirectoryHierarchy (directoryOf output_fn)
967
968 SysTools.runAs dflags
969 (map SysTools.Option as_opts
970 ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
971 #ifdef sparc_TARGET_ARCH
972 -- We only support SparcV9 and better because V8 lacks an atomic CAS
973 -- instruction so we have to make sure that the assembler accepts the
974 -- instruction set. Note that the user can still override this
975 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
976 -- regardless of the ordering.
977 --
978 -- This is a temporary hack.
979 ++ [ SysTools.Option "-mcpu=v9" ]
980 #endif
981 ++ [ SysTools.Option "-c"
982 , SysTools.FileOption "" input_fn
983 , SysTools.Option "-o"
984 , SysTools.FileOption "" output_fn
985 ])
986
987 return (StopLn, dflags, maybe_loc, output_fn)
988
989
990 runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc
991 = do
992 output_fn <- get_output_fn dflags StopLn maybe_loc
993
994 let (base_o, _) = splitFilename output_fn
995 split_odir = base_o ++ "_split"
996 osuf = objectSuf dflags
997
998 createDirectoryHierarchy split_odir
999
1000 -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1001 -- later and we don't want to pick up any old objects.
1002 fs <- getDirectoryContents split_odir
1003 mapM_ removeFile $ map (split_odir `joinFileName`)
1004 $ filter (osuf `isSuffixOf`) fs
1005
1006 let as_opts = getOpts dflags opt_a
1007
1008 (split_s_prefix, n) <- readIORef v_Split_info
1009
1010 let split_s n = split_s_prefix ++ "__" ++ show n `joinFileExt` "s"
1011 split_obj n = split_odir `joinFileName`
1012 filenameOf base_o ++ "__" ++ show n
1013 `joinFileExt` osuf
1014
1015 let assemble_file n
1016 = SysTools.runAs dflags
1017 (map SysTools.Option as_opts ++
1018 [ SysTools.Option "-c"
1019 , SysTools.Option "-o"
1020 , SysTools.FileOption "" (split_obj n)
1021 , SysTools.FileOption "" (split_s n)
1022 ])
1023
1024 mapM_ assemble_file [1..n]
1025
1026 -- and join the split objects into a single object file:
1027 let ld_r args = SysTools.runLink dflags ([
1028 SysTools.Option "-nostdlib",
1029 SysTools.Option "-nodefaultlibs",
1030 SysTools.Option "-Wl,-r",
1031 SysTools.Option ld_x_flag,
1032 SysTools.Option "-o",
1033 SysTools.FileOption "" output_fn ] ++ args)
1034 ld_x_flag | null cLD_X = ""
1035 | otherwise = "-Wl,-x"
1036
1037 if cLdIsGNULd == "YES"
1038 then do
1039 let script = split_odir `joinFileName` "ld.script"
1040 writeFile script $
1041 "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
1042 ld_r [SysTools.FileOption "" script]
1043 else do
1044 ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
1045
1046 return (StopLn, dflags, maybe_loc, output_fn)
1047
1048
1049 -----------------------------------------------------------------------------
1050 -- MoveBinary sort-of-phase
1051 -- After having produced a binary, move it somewhere else and generate a
1052 -- wrapper script calling the binary. Currently, we need this only in
1053 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1054 -- central directory.
1055 -- This is called from staticLink below, after linking. I haven't made it
1056 -- a separate phase to minimise interfering with other modules, and
1057 -- we don't need the generality of a phase (MoveBinary is always
1058 -- done after linking and makes only sense in a parallel setup) -- HWL
1059
1060 runPhase_MoveBinary dflags input_fn
1061 = do
1062 let sysMan = pgm_sysman dflags
1063 pvm_root <- getEnv "PVM_ROOT"
1064 pvm_arch <- getEnv "PVM_ARCH"
1065 let
1066 pvm_executable_base = "=" ++ input_fn
1067 pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1068 -- nuke old binary; maybe use configur'ed names for cp and rm?
1069 Panic.try (removeFile pvm_executable)
1070 -- move the newly created binary into PVM land
1071 copy dflags "copying PVM executable" input_fn pvm_executable
1072 -- generate a wrapper script for running a parallel prg under PVM
1073 writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1074 return True
1075
1076 -- generates a Perl skript starting a parallel prg under PVM
1077 mk_pvm_wrapper_script :: String -> String -> String -> String
1078 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1079 [
1080 "eval 'exec perl -S $0 ${1+\"$@\"}'",
1081 " if $running_under_some_shell;",
1082 "# =!=!=!=!=!=!=!=!=!=!=!",
1083 "# This script is automatically generated: DO NOT EDIT!!!",
1084 "# Generated by Glasgow Haskell Compiler",
1085 "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1086 "#",
1087 "$pvm_executable = '" ++ pvm_executable ++ "';",
1088 "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1089 "$SysMan = '" ++ sysMan ++ "';",
1090 "",
1091 {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1092 "# first, some magical shortcuts to run "commands" on the binary",
1093 "# (which is hidden)",
1094 "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1095 " local($cmd) = $1;",
1096 " system("$cmd $pvm_executable");",
1097 " exit(0); # all done",
1098 "}", -}
1099 "",
1100 "# Now, run the real binary; process the args first",
1101 "$ENV{'PE'} = $pvm_executable_base;", -- ++ pvm_executable_base,
1102 "$debug = '';",
1103 "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1104 "@nonPVM_args = ();",
1105 "$in_RTS_args = 0;",
1106 "",
1107 "args: while ($a = shift(@ARGV)) {",
1108 " if ( $a eq '+RTS' ) {",
1109 " $in_RTS_args = 1;",
1110 " } elsif ( $a eq '-RTS' ) {",
1111 " $in_RTS_args = 0;",
1112 " }",
1113 " if ( $a eq '-d' && $in_RTS_args ) {",
1114 " $debug = '-';",
1115 " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1116 " $nprocessors = $1;",
1117 " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1118 " $nprocessors = $1;",
1119 " } else {",
1120 " push(@nonPVM_args, $a);",
1121 " }",
1122 "}",
1123 "",
1124 "local($return_val) = 0;",
1125 "# Start the parallel execution by calling SysMan",
1126 "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1127 "$return_val = $?;",
1128 "# ToDo: fix race condition moving files and flushing them!!",
1129 "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1130 "exit($return_val);"
1131 ]
1132
1133 -----------------------------------------------------------------------------
1134 -- Complain about non-dynamic flags in OPTIONS pragmas
1135
1136 checkProcessArgsResult flags filename
1137 = do when (notNull flags) (throwDyn (ProgramError (
1138 showSDoc (hang (text filename <> char ':')
1139 4 (text "unknown flags in {-# OPTIONS #-} pragma:" <+>
1140 hsep (map text flags)))
1141 )))
1142
1143 -----------------------------------------------------------------------------
1144 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1145
1146 getHCFilePackages :: FilePath -> IO [PackageId]
1147 getHCFilePackages filename =
1148 Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1149 l <- hGetLine h
1150 case l of
1151 '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1152 return (map stringToPackageId (words rest))
1153 _other ->
1154 return []
1155
1156 -----------------------------------------------------------------------------
1157 -- Static linking, of .o files
1158
1159 -- The list of packages passed to link is the list of packages on
1160 -- which this program depends, as discovered by the compilation
1161 -- manager. It is combined with the list of packages that the user
1162 -- specifies on the command line with -package flags.
1163 --
1164 -- In one-shot linking mode, we can't discover the package
1165 -- dependencies (because we haven't actually done any compilation or
1166 -- read any interface files), so the user must explicitly specify all
1167 -- the packages.
1168
1169 staticLink :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1170 staticLink dflags o_files dep_packages = do
1171 let verb = getVerbFlag dflags
1172 output_fn = exeFileName dflags
1173
1174 -- get the full list of packages to link with, by combining the
1175 -- explicit packages with the auto packages and all of their
1176 -- dependencies, and eliminating duplicates.
1177
1178 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1179 let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1180
1181 let lib_paths = libraryPaths dflags
1182 let lib_path_opts = map ("-L"++) lib_paths
1183
1184 pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1185
1186 #ifdef darwin_TARGET_OS
1187 pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1188 let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1189
1190 let framework_paths = frameworkPaths dflags
1191 framework_path_opts = map ("-F"++) framework_paths
1192
1193 pkg_frameworks <- getPackageFrameworks dflags dep_packages
1194 let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1195
1196 let frameworks = cmdlineFrameworks dflags
1197 framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1198 -- reverse because they're added in reverse order from the cmd line
1199 #endif
1200
1201 -- probably _stub.o files
1202 extra_ld_inputs <- readIORef v_Ld_inputs
1203
1204 -- opts from -optl-<blah> (including -l<blah> options)
1205 let extra_ld_opts = getOpts dflags opt_l
1206
1207 let ways = wayNames dflags
1208
1209 -- Here are some libs that need to be linked at the *end* of
1210 -- the command line, because they contain symbols that are referred to
1211 -- by the RTS. We can't therefore use the ordinary way opts for these.
1212 let
1213 debug_opts | WayDebug `elem` ways = [
1214 #if defined(HAVE_LIBBFD)
1215 "-lbfd", "-liberty"
1216 #endif
1217 ]
1218 | otherwise = []
1219
1220 let
1221 thread_opts | WayThreaded `elem` ways = [
1222 #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS)
1223 "-lpthread"
1224 #endif
1225 #if defined(osf3_TARGET_OS)
1226 , "-lexc"
1227 #endif
1228 ]
1229 | otherwise = []
1230
1231 let (md_c_flags, _) = machdepCCOpts dflags
1232 SysTools.runLink dflags (
1233 [ SysTools.Option verb
1234 , SysTools.Option "-o"
1235 , SysTools.FileOption "" output_fn
1236 ]
1237 ++ map SysTools.Option (
1238 md_c_flags
1239 ++ o_files
1240 ++ extra_ld_inputs
1241 ++ lib_path_opts
1242 ++ extra_ld_opts
1243 #ifdef darwin_TARGET_OS
1244 ++ framework_path_opts
1245 ++ framework_opts
1246 #endif
1247 ++ pkg_lib_path_opts
1248 ++ pkg_link_opts
1249 #ifdef darwin_TARGET_OS
1250 ++ pkg_framework_path_opts
1251 ++ pkg_framework_opts
1252 #endif
1253 ++ debug_opts
1254 ++ thread_opts
1255 ))
1256
1257 -- parallel only: move binary to another dir -- HWL
1258 when (WayPar `elem` ways)
1259 (do success <- runPhase_MoveBinary dflags output_fn
1260 if success then return ()
1261 else throwDyn (InstallationError ("cannot move binary to PVM dir")))
1262
1263
1264 exeFileName :: DynFlags -> FilePath
1265 exeFileName dflags
1266 | Just s <- outputFile dflags =
1267 #if defined(mingw32_HOST_OS)
1268 if null (suffixOf s)
1269 then s `joinFileExt` "exe"
1270 else s
1271 #else
1272 s
1273 #endif
1274 | otherwise =
1275 #if defined(mingw32_HOST_OS)
1276 "main.exe"
1277 #else
1278 "a.out"
1279 #endif
1280
1281 -----------------------------------------------------------------------------
1282 -- Making a DLL (only for Win32)
1283
1284 doMkDLL :: DynFlags -> [String] -> [PackageId] -> IO ()
1285 doMkDLL dflags o_files dep_packages = do
1286 let verb = getVerbFlag dflags
1287 let static = opt_Static
1288 let no_hs_main = dopt Opt_NoHsMain dflags
1289 let o_file = outputFile dflags
1290 let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1291
1292 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1293 let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1294
1295 let lib_paths = libraryPaths dflags
1296 let lib_path_opts = map ("-L"++) lib_paths
1297
1298 pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1299
1300 -- probably _stub.o files
1301 extra_ld_inputs <- readIORef v_Ld_inputs
1302
1303 -- opts from -optdll-<blah>
1304 let extra_ld_opts = getOpts dflags opt_dll
1305
1306 let pstate = pkgState dflags
1307 rts_pkg = getPackageDetails pstate rtsPackageId
1308 base_pkg = getPackageDetails pstate basePackageId
1309
1310 let extra_os = if static || no_hs_main
1311 then []
1312 else [ head (libraryDirs rts_pkg) ++ "/Main.dll_o",
1313 head (libraryDirs base_pkg) ++ "/PrelMain.dll_o" ]
1314
1315 let (md_c_flags, _) = machdepCCOpts dflags
1316 SysTools.runMkDLL dflags
1317 ([ SysTools.Option verb
1318 , SysTools.Option "-o"
1319 , SysTools.FileOption "" output_fn
1320 ]
1321 ++ map SysTools.Option (
1322 md_c_flags
1323 ++ o_files
1324 ++ extra_os
1325 ++ [ "--target=i386-mingw32" ]
1326 ++ extra_ld_inputs
1327 ++ lib_path_opts
1328 ++ extra_ld_opts
1329 ++ pkg_lib_path_opts
1330 ++ pkg_link_opts
1331 ++ (if "--def" `elem` (concatMap words extra_ld_opts)
1332 then [ "" ]
1333 else [ "--export-all" ])
1334 ))
1335
1336 -- -----------------------------------------------------------------------------
1337 -- Running CPP
1338
1339 doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
1340 doCpp dflags raw include_cc_opts input_fn output_fn = do
1341 let hscpp_opts = getOpts dflags opt_P
1342 let cmdline_include_paths = includePaths dflags
1343
1344 pkg_include_dirs <- getPackageIncludePath dflags []
1345 let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1346 (cmdline_include_paths ++ pkg_include_dirs)
1347
1348 let verb = getVerbFlag dflags
1349
1350 let cc_opts
1351 | not include_cc_opts = []
1352 | otherwise = (optc ++ md_c_flags)
1353 where
1354 optc = getOpts dflags opt_c
1355 (md_c_flags, _) = machdepCCOpts dflags
1356
1357 let cpp_prog args | raw = SysTools.runCpp dflags args
1358 | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
1359
1360 let target_defs =
1361 [ "-D" ++ HOST_OS ++ "_BUILD_OS=1",
1362 "-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1",
1363 "-D" ++ TARGET_OS ++ "_HOST_OS=1",
1364 "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
1365 -- remember, in code we *compile*, the HOST is the same our TARGET,
1366 -- and BUILD is the same as our HOST.
1367
1368 cpp_prog ([SysTools.Option verb]
1369 ++ map SysTools.Option include_paths
1370 ++ map SysTools.Option hsSourceCppOpts
1371 ++ map SysTools.Option hscpp_opts
1372 ++ map SysTools.Option cc_opts
1373 ++ map SysTools.Option target_defs
1374 ++ [ SysTools.Option "-x"
1375 , SysTools.Option "c"
1376 , SysTools.Option input_fn
1377 -- We hackily use Option instead of FileOption here, so that the file
1378 -- name is not back-slashed on Windows. cpp is capable of
1379 -- dealing with / in filenames, so it works fine. Furthermore
1380 -- if we put in backslashes, cpp outputs #line directives
1381 -- with *double* backslashes. And that in turn means that
1382 -- our error messages get double backslashes in them.
1383 -- In due course we should arrange that the lexer deals
1384 -- with these \\ escapes properly.
1385 , SysTools.Option "-o"
1386 , SysTools.FileOption "" output_fn
1387 ])
1388
1389 cHaskell1Version = "5" -- i.e., Haskell 98
1390
1391 -- Default CPP defines in Haskell source
1392 hsSourceCppOpts =
1393 [ "-D__HASKELL1__="++cHaskell1Version
1394 , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
1395 , "-D__HASKELL98__"
1396 , "-D__CONCURRENT_HASKELL__"
1397 ]
1398
1399
1400 -- -----------------------------------------------------------------------------
1401 -- Misc.
1402
1403 hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
1404 hscNextPhase dflags HsBootFile hsc_lang = StopLn
1405 hscNextPhase dflags other hsc_lang =
1406 case hsc_lang of
1407 HscC -> HCc
1408 HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
1409 | otherwise -> As
1410 HscNothing -> StopLn
1411 HscInterpreted -> StopLn
1412 _other -> StopLn
1413
1414
1415 hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
1416 hscMaybeAdjustTarget dflags stop HsBootFile current_hsc_lang
1417 = HscNothing -- No output (other than Foo.hi-boot) for hs-boot files
1418 hscMaybeAdjustTarget dflags stop other current_hsc_lang
1419 = hsc_lang
1420 where
1421 keep_hc = dopt Opt_KeepHcFiles dflags
1422 hsc_lang
1423 -- don't change the lang if we're interpreting
1424 | current_hsc_lang == HscInterpreted = current_hsc_lang
1425
1426 -- force -fvia-C if we are being asked for a .hc file
1427 | HCc <- stop = HscC
1428 | keep_hc = HscC
1429 -- otherwise, stick to the plan
1430 | otherwise = current_hsc_lang
1431
1432 GLOBAL_VAR(v_Split_info, ("",0), (String,Int))
1433 -- The split prefix and number of files