DriverPipeline.hs 44.6 KB
Newer Older
1
2
3
4
-----------------------------------------------------------------------------
--
-- GHC Driver
--
5
-- (c) The University of Glasgow 2002
6
7
8
9
--
-----------------------------------------------------------------------------

module DriverPipeline (
10
11
	-- Run a series of compilation steps in a pipeline
   runPipeline,
12

13
	-- Interfaces for the batch-mode driver
14
   staticLink,
15

16
17
18
19
	-- Interfaces for the compilation manager (interpreted/batch-mode)
   preprocess, 
   compile, CompResult(..), 
   link, 
20

rrt's avatar
rrt committed
21
22
        -- DLL building
   doMkDLL
23
24
25
26
  ) where

#include "HsVersions.h"

27
import Packages
28
import GetImports
29
import DriverPhases
sof's avatar
sof committed
30
import SysTools		( newTempName, addFilesToClean, getSysMan, copy )
31
import qualified SysTools	
32
import HscMain
33
import Finder
34
35
36
import HscTypes
import Outputable
import Module
37
import ErrUtils
38
39
import DynFlags
import StaticFlags	( v_Ld_inputs, opt_Static, WayName(..) )
40
import Config
41
import RdrName		( GlobalRdrEnv )
42
import Panic
43
import Util
44
import StringBuffer	( hGetStringBuffer )
45
import BasicTypes	( SuccessFlag(..) )
46
import Maybes		( expectJust )
47
import Ctype		( is_ident )
48

49
50
import ParserCoreUtils ( getCoreModuleName )

51
import EXCEPTION
52
import DATA_IOREF	( readIORef, writeIORef, IORef )
53

54
55
import Directory
import System
56
57
58
59
import IO
import Monad
import Maybe

60

61
62
-- ---------------------------------------------------------------------------
-- Pre-process
63
64
65

-- Just preprocess a file, put the result in a temp. file (used by the
-- compilation manager during the summary phase).
66
67
68
--
-- We return the augmented DynFlags, because they contain the result
-- of slurping in the OPTIONS pragmas
69

70
preprocess :: DynFlags -> FilePath -> IO (DynFlags, FilePath)
71
preprocess dflags filename =
72
  ASSERT2(isHaskellSrcFilename filename, text filename) 
73
  runPipeline anyHsc dflags
74
75
76
	False{-temporary output file-}
	Nothing{-no specific output file-}
	filename
77
	Nothing{-no ModLocation-}
78

79
80


81
82
-- ---------------------------------------------------------------------------
-- Compile
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98

-- Compile a single module, under the control of the compilation manager.
--
-- This is the interface between the compilation manager and the
-- compiler proper (hsc), where we deal with tedious details like
-- reading the OPTIONS pragma from the source file, and passing the
-- output of hsc through the C compiler.

-- The driver sits between 'compile' and 'hscMain', translating calls
-- to the former into calls to the latter, and results from the latter
-- into results from the former.  It does things like preprocessing
-- the .hs file if necessary, and compiling up the .stub_c files to
-- generate Linkables.

-- NB.  No old interface can also mean that the source has changed.

99
compile :: HscEnv
100
101
102
103
	-> ModSummary
	-> Bool			-- True <=> source unchanged
	-> Bool			-- True <=> have object
        -> Maybe ModIface       -- Old interface, if available
104
105
106
        -> IO CompResult

data CompResult
107
   = CompOK   ModDetails 		-- New details
108
109
110
111
              ModIface			-- New iface
              (Maybe Linkable)	-- New code; Nothing => compilation was not reqd
		                --			(old code is still valid)

112
   | CompErrs 
113
114


115
116
compile hsc_env mod_summary
	source_unchanged have_object old_iface = do 
117

118
   let dflags0     = hsc_dflags hsc_env
119
120
       this_mod    = ms_mod mod_summary
       src_flavour = ms_hsc_src mod_summary
121

122
   showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary)
123

124
   let verb	  = verbosity dflags0
125
   let location	  = ms_location mod_summary
126
   let input_fn   = expectJust "compile:hs" (ml_hs_file location) 
127
   let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary)
128
129
130

   when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))

131
132
133
   -- Add in the OPTIONS from the source file
   -- This is nasty: we've done this once already, in the compilation manager
   -- It might be better to cache the flags in the ml_hspp_file field,say
134
   opts <- getOptionsFromSource input_fnpp
135
   (dflags1,unhandled_flags) <- parseDynamicFlags dflags0 opts
136
   checkProcessArgsResult unhandled_flags input_fn
137

138
   let (basename, _) = splitFilename input_fn
139

140
141
142
143
  -- We add the directory in which the .hs files resides) to the import path.
  -- This is needed when we try to compile the .hc file later, if it
  -- imports a _stub.h file that we created here.
   let current_dir = directoryOf basename
144
145
       old_paths   = includePaths dflags1
       dflags      = dflags1 { includePaths = current_dir : old_paths }
146

147
   -- Figure out what lang we're generating
148
   let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (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
153
   let get_output_fn = genOutputFilenameFunc dflags next_phase 
				False Nothing basename
154
   output_fn     <- get_output_fn next_phase (Just location)
155

156
   let dflags' = dflags { hscTarget = hsc_lang,
157
				hscOutName = output_fn,
158
159
160
161
162
				hscStubCOutName = basename ++ "_stub.c",
				hscStubHOutName = basename ++ "_stub.h",
				extCoreName = basename ++ ".hcr" }

   -- -no-recomp should also work with --make
163
   let do_recomp = dopt Opt_RecompChecking dflags
164
       source_unchanged' = source_unchanged && do_recomp
165
       hsc_env' = hsc_env { hsc_dflags = dflags' }
166
167

   -- run the compiler
168
   hsc_result <- hscMain hsc_env' printErrorsAndWarnings mod_summary
169
170
171
			 source_unchanged' have_object old_iface

   case hsc_result of
172
      HscFail -> return CompErrs
173

174
      HscNoRecomp details iface -> return (CompOK details iface Nothing)
175

176
      HscRecomp details iface
177
178
179
		stub_h_exists stub_c_exists maybe_interpreted_code 

	| isHsBoot src_flavour	-- No further compilation to do
180
	-> return (CompOK details iface Nothing)
181
182
183

	| otherwise		-- Normal Haskell source files
	-> do
184
	   let 
185
	   maybe_stub_o <- compileStub dflags' stub_c_exists
186
187
188
189
190
191
192
193
194
195
196
197
	   let stub_unlinked = case maybe_stub_o of
				  Nothing -> []
				  Just stub_o -> [ DotO stub_o ]

	   (hs_unlinked, unlinked_time) <-
	     case hsc_lang of

		-- in interpreted mode, just return the compiled code
		-- as our "unlinked" object.
		HscInterpreted -> 
		    case maybe_interpreted_code of
#ifdef GHCI
198
		       Just comp_bc -> return ([BCOs comp_bc], ms_hs_date mod_summary)
199
200
201
202
203
204
			-- Why do we use the timestamp of the source file here,
			-- rather than the current time?  This works better in
			-- the case where the local clock is out of sync
			-- with the filesystem's clock.  It's just as accurate:
			-- if the source is modified, then the linkable will
			-- be out of date.
205
206
207
208
#endif
		       Nothing -> panic "compile: no interpreted code"

		-- we're in batch mode: finish the compilation pipeline.
209
210
211
		_other -> do
		   let object_filename = ml_obj_file location

212
		   runPipeline StopLn dflags
213
			       True Nothing output_fn (Just location)
214
			-- the object filename comes from the ModLocation
215
216
217

		   o_time <- getModificationTime object_filename
		   return ([DotO object_filename], o_time)
218

219
	   let linkable = LM unlinked_time this_mod
220
221
			     (hs_unlinked ++ stub_unlinked)

222
	   return (CompOK details iface (Just linkable))
223

224
-----------------------------------------------------------------------------
225
226
227
228
229
230
231
-- stub .h and .c files (for foreign export support)

compileStub dflags stub_c_exists
  | not stub_c_exists = return Nothing
  | stub_c_exists = do
	-- compile the _stub.c file w/ gcc
	let stub_c = hscStubCOutName dflags
232
	(_, stub_o) <- runPipeline StopLn dflags
233
234
235
236
			    True{-persistent output-} 
			    Nothing{-no specific output file-}
			    stub_c
			    Nothing{-no ModLocation-}
237
238
239
	return (Just stub_o)


240
241
-- ---------------------------------------------------------------------------
-- Link
242

243
link :: GhcMode			-- interactive or batch
244
245
     -> DynFlags		-- dynamic flags
     -> Bool			-- attempt linking in batch mode?
246
     -> HomePackageTable	-- what to link
247
248
249
250
251
252
253
254
255
256
     -> IO SuccessFlag

-- For the moment, in the batch linker, we don't bother to tell doLink
-- which packages to link -- it just tries all that are available.
-- batch_attempt_linking should only be *looked at* in batch mode.  It
-- should only be True if the upsweep was successful and someone
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.

#ifdef GHCI
257
258
link Interactive dflags batch_attempt_linking hpt
    = do -- Not Linking...(demand linker will do the job)
259
260
261
	 return Succeeded
#endif

262
link BatchCompile dflags batch_attempt_linking hpt
263
   | batch_attempt_linking
264
   = do 
265
266
267
268
269
270
271
272
273
274
275
276
277
	let 
	    home_mod_infos = moduleEnvElts hpt

	    -- the packages we depend on
	    pkg_deps  = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos

	    -- the linkables to link
	    linkables = map hm_linkable home_mod_infos

        when (verb >= 3) $ do
	     hPutStrLn stderr "link: linkables are ..."
             hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))

278
	-- check for the -no-link flag
279
	if isNoLink (ghcLink dflags)
280
	  then do when (verb >= 3) $
281
		    hPutStrLn stderr "link(batch): linking omitted (-c flag given)."
282
283
284
285
286
	          return Succeeded
	  else do

	when (verb >= 1) $
             hPutStrLn stderr "Linking ..."
287

288
289
290
	let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
	    obj_files = concatMap getOfiles linkables

291
	-- Don't showPass in Batch mode; doLink will do that for us.
292
        staticLink dflags obj_files pkg_deps
293
294

        when (verb >= 3) (hPutStrLn stderr "link: done")
295
296
297
298
299
300
301
302
303
304
305

	-- staticLink only returns if it succeeds
        return Succeeded

   | otherwise
   = do when (verb >= 3) $ do
	    hPutStrLn stderr "link(batch): upsweep (partially) failed OR"
            hPutStrLn stderr "   Main.main not exported; not linking."
        return Succeeded
   where
      verb = verbosity dflags
306
      
307
308
-- ---------------------------------------------------------------------------
-- Run a compilation pipeline, consisting of multiple phases.
309

310
311
312
313
-- The DynFlags can be modified by phases in the pipeline (eg. by
-- OPTIONS pragmas), and the changes affect later phases in the
-- pipeline, but we throw away the resulting DynFlags at the end.

314
runPipeline
315
316
317
318
319
320
  :: Phase		-- When to stop
  -> DynFlags		-- Dynamic flags
  -> Bool		-- Final output is persistent?
  -> Maybe FilePath	-- Where to put the output, optionally
  -> FilePath 		-- Input filename
  -> Maybe ModLocation  -- A ModLocation for this module, if we have one
321
  -> IO (DynFlags, FilePath)	-- (final flags, output filename)
322

323
runPipeline stop_phase dflags keep_output 
324
  maybe_output_filename input_fn maybe_loc
325
326
327
  = do
  let (basename, suffix) = splitFilename input_fn
      start_phase = startPhase suffix
328

329
330
331
332
333
334
  -- We want to catch cases of "you can't get there from here" before
  -- we start the pipeline, because otherwise it will just run off the
  -- end.
  --
  -- There is a partial ordering on phases, where A < B iff A occurs
  -- before B in a normal compilation pipeline.
335

336
337
  when (not (start_phase `happensBefore` stop_phase)) $
	throwDyn (UsageError 
338
339
		    ("cannot compile this file to desired target: "
		       ++ input_fn))
340
341
342

  -- generate a function which will be used to calculate output file names
  -- as we go along.
343
  let get_output_fn = genOutputFilenameFunc dflags stop_phase keep_output 
344
					 maybe_output_filename basename
345

346
  -- Execute the pipeline...
347
  (dflags', output_fn, maybe_loc) <- pipeLoop dflags start_phase stop_phase input_fn 
348
				  	      basename suffix get_output_fn maybe_loc
349

350
  -- Sometimes, a compilation phase doesn't actually generate any output
351
352
353
  -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
  -- stage, but we wanted to keep the output, then we have to explicitly
  -- copy the file.
354
  if keep_output 
355
	then do final_fn <- get_output_fn stop_phase maybe_loc
356
	        when (final_fn /= output_fn) $
357
	 	  copy dflags ("Copying `" ++ output_fn ++ "' to `" ++ final_fn
358
			++ "'") output_fn final_fn
359
	        return (dflags', final_fn)
360
	else
361
	        return (dflags', output_fn)
362
363


364
pipeLoop :: DynFlags -> Phase -> Phase 
365
366
367
368
	 -> FilePath  -> String -> Suffix
	 -> (Phase -> Maybe ModLocation -> IO FilePath)
	 -> Maybe ModLocation
	 -> IO (DynFlags, FilePath, Maybe ModLocation)
369

370
pipeLoop dflags phase stop_phase 
371
372
	 input_fn orig_basename orig_suff 
	 orig_get_output_fn maybe_loc
373

374
375
  | phase `eqPhase` stop_phase		  -- All done
  = return (dflags, input_fn, maybe_loc)
376

377
  | not (phase `happensBefore` stop_phase)
378
379
380
381
	-- Something has gone wrong.  We'll try to cover all the cases when
	-- this could happen, so if we reach here it is a panic.
	-- eg. it might happen if the -C flag is used on a source file that
	-- has {-# OPTIONS -fasm #-}.
382
383
384
385
386
  = panic ("pipeLoop: at phase " ++ show phase ++ 
	   " but I wanted to stop at phase " ++ show stop_phase)

  | otherwise 
  = do	{ (next_phase, dflags', maybe_loc, output_fn)
387
		<- runPhase phase stop_phase dflags orig_basename 
388
			    orig_suff input_fn orig_get_output_fn maybe_loc
389
	; pipeLoop dflags' next_phase stop_phase output_fn
390
391
		   orig_basename orig_suff orig_get_output_fn maybe_loc }

392
393
394
395
396
397
398
399
400
401
402
403
404
genOutputFilenameFunc :: DynFlags -> Phase -> Bool -> Maybe FilePath -> String
  -> (Phase{-next phase-} -> Maybe ModLocation -> IO FilePath)
genOutputFilenameFunc dflags stop_phase keep_final_output 
			maybe_output_filename basename
 = func
 where
	hcsuf      = hcSuf dflags
	odir       = outputDir dflags
	osuf       = objectSuf dflags
	keep_hc    = dopt Opt_KeepHcFiles dflags
	keep_raw_s = dopt Opt_KeepRawSFiles dflags
	keep_s     = dopt Opt_KeepSFiles dflags

405
406
407
        myPhaseInputExt HCc    = hcsuf
        myPhaseInputExt StopLn = osuf
        myPhaseInputExt other  = phaseInputExt other
408

409
	func next_phase maybe_location
410
411
412
		| is_last_phase, Just f <- maybe_output_filename = return f
		| is_last_phase && keep_final_output = persistent_fn
		| keep_this_output 		     = persistent_fn
413
     		| otherwise        		     = newTempName dflags suffix
414

415
	   where
416
		is_last_phase = next_phase `eqPhase` stop_phase
417
418
419
420

		-- sometimes, we keep output from intermediate stages
		keep_this_output = 
     		     case next_phase of
421
     			     StopLn              -> True
422
423
424
425
426
     			     Mangle | keep_raw_s -> True
     			     As     | keep_s     -> True
     			     HCc    | keep_hc    -> True
     			     _other              -> False

427
		suffix = myPhaseInputExt next_phase
428
429
430

		-- persistent object files get put in odir
	        persistent_fn 
431
432
		   | StopLn <- next_phase = return odir_persistent
		   | otherwise            = return persistent
433

434
		persistent = basename ++ '.':suffix
435

436
		odir_persistent
437
		   | Just loc <- maybe_location = ml_obj_file loc
438
439
440
		   | Just d <- odir = replaceFilenameDirectory persistent d
		   | otherwise      = persistent

441

442
443
444
445
446
447
448
449
450
451
-- -----------------------------------------------------------------------------
-- Each phase in the pipeline returns the next phase to execute, and the
-- name of the file in which the output was placed.
--
-- We must do things dynamically this way, because we often don't know
-- what the rest of the phases will be until part-way through the
-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
-- of a source file can change the latter stages of the pipeline from
-- taking the via-C route to using the native code generator.

452
453
runPhase :: Phase	-- Do this phase first
	 -> Phase	-- Stop just before this phase
454
455
456
457
458
	 -> DynFlags
	 -> String	-- basename of original input source
	 -> String	-- its extension
	 -> FilePath	-- name of file which contains the input to this phase.
	 -> (Phase -> Maybe ModLocation -> IO FilePath)
459
			-- how to calculate the output filename
460
	 -> Maybe ModLocation		-- the ModLocation, if we have one
461
	 -> IO (Phase,	  		-- next phase
462
463
464
		DynFlags,		-- new dynamic flags
		Maybe ModLocation,	-- the ModLocation, if we have one
		FilePath)		-- output filename
465

466
467
468
469
	-- Invariant: the output filename always contains the output
	-- Interesting case: Hsc when there is no recompilation to do
	--		     Then the output filename is still a .o file 

470
471
472
-------------------------------------------------------------------------------
-- Unlit phase 

473
runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_loc
474
  = do let unlit_flags = getOpts dflags opt_L
rrt's avatar
rrt committed
475
       -- The -h option passes the file name for unlit to put in a #line directive
476
       output_fn <- get_output_fn (Cpp sf) maybe_loc
477

478
479
       SysTools.runUnlit dflags 
		(map SysTools.Option unlit_flags ++
sof's avatar
sof committed
480
481
       			  [ SysTools.Option     "-h"
 			  , SysTools.Option     input_fn
sof's avatar
sof committed
482
483
			  , SysTools.FileOption "" input_fn
			  , SysTools.FileOption "" output_fn
sof's avatar
sof committed
484
			  ])
485

486
       return (Cpp sf, dflags, maybe_loc, output_fn)
487
488

-------------------------------------------------------------------------------
489
490
-- Cpp phase : (a) gets OPTIONS out of file
--	       (b) runs cpp if necessary
491

492
runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc
493
  = do src_opts <- getOptionsFromSource input_fn
494
       (dflags,unhandled_flags) <- parseDynamicFlags dflags0 src_opts
495
       checkProcessArgsResult unhandled_flags (basename++'.':suff)
496

497
       if not (dopt Opt_Cpp dflags) then
sof's avatar
sof committed
498
499
           -- no need to preprocess CPP, just pass input file along
	   -- to the next phase of the pipeline.
500
          return (HsPp sf, dflags, maybe_loc, input_fn)
sof's avatar
sof committed
501
	else do
502
	    output_fn <- get_output_fn (HsPp sf) maybe_loc
503
	    doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn
504
	    return (HsPp sf, dflags, maybe_loc, output_fn)
505

sof's avatar
sof committed
506
507
508
-------------------------------------------------------------------------------
-- HsPp phase 

509
runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc
510
  = do if not (dopt Opt_Pp dflags) then
sof's avatar
sof committed
511
512
           -- no need to preprocess, just pass input file along
	   -- to the next phase of the pipeline.
513
          return (Hsc sf, dflags, maybe_loc, input_fn)
sof's avatar
sof committed
514
	else do
515
	    let hspp_opts = getOpts dflags opt_F
516
	    let orig_fn = basename ++ '.':suff
517
	    output_fn <- get_output_fn (Hsc sf) maybe_loc
518
519
	    SysTools.runPp dflags
			   ( [ SysTools.Option     orig_fn
sof's avatar
sof committed
520
521
522
523
524
			     , SysTools.Option     input_fn
			     , SysTools.FileOption "" output_fn
			     ] ++
			     map SysTools.Option hspp_opts
			   )
525
	    return (Hsc sf, dflags, maybe_loc, output_fn)
526

527
528
529
-----------------------------------------------------------------------------
-- Hsc phase

530
531
-- Compilation of a single module, in "legacy" mode (_not_ under
-- the direction of the compilation manager).
532
runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _maybe_loc 
533
 = do	-- normal Hsc mode, not mkdependHS
534

535
536
537
  -- we add the current directory (i.e. the directory in which
  -- the .hs files resides) to the import path, since this is
  -- what gcc does, and it's probably what you want.
538
	let current_dir = directoryOf basename
539
	
540
541
	    paths = includePaths dflags0
	    dflags = dflags0 { includePaths = current_dir : paths }
542
	
543
  -- gather the imports and module name
544
        (hspp_buf,mod_name) <- 
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
            case src_flavour of
		ExtCoreFile -> do {  -- no explicit imports in ExtCore input.
			          ; m <- getCoreModuleName input_fn
			          ; return (Nothing, mkModule m) }

		other -> do { buf <- hGetStringBuffer input_fn
			    ; (_,_,mod_name) <- getImports dflags buf input_fn
			    ; return (Just buf, mod_name) }

  -- Build a ModLocation to pass to hscMain.
  -- The source filename is rather irrelevant by now, but it's used
  -- by hscMain for messages.  hscMain also needs 
  -- the .hi and .o filenames, and this is as good a way
  -- as any to generate them, and better than most. (e.g. takes 
  -- into accout the -osuf flags)
560
	location1 <- mkHomeModLocation2 dflags mod_name basename suff
561
562
563
564
565
566
567
568
569

  -- Boot-ify it if necessary
	let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
		      | otherwise	     = location1 
					

  -- Take -ohi into account if present
  -- This can't be done in mkHomeModuleLocation because
  -- it only applies to the module being compiles
570
571
	let ohi = outputHi dflags
	    location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
572
573
574
575
576
577
578
		      | otherwise      = location2

  -- Take -o into account if present
  -- Very like -ohi, but we must *only* do this if we aren't linking
  -- (If we're linking then the -o applies to the linked thing, not to
  -- the object file for one module.)
  -- Note the nasty duplication with the same computation in compileFile above
579
580
581
	let expl_o_file = outputFile dflags
	    location4 | Just ofile <- expl_o_file
		      , isNoLink (ghcLink dflags)
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
		      = location3 { ml_obj_file = ofile }
		      | otherwise = location3

  -- Tell the finder cache about this module
	addHomeModuleToFinder mod_name location4

  -- Make the ModSummary to hand to hscMain
	src_timestamp <- getModificationTime (basename ++ '.':suff)
	let
	    unused_field = panic "runPhase:ModSummary field"
		-- Some fields are not looked at by hscMain
	    mod_summary = ModSummary {	ms_mod 	     = mod_name, 
					ms_hsc_src   = src_flavour,
				 	ms_hspp_file = Just input_fn,
					ms_hspp_buf  = hspp_buf,
					ms_location  = location4,
					ms_hs_date   = src_timestamp,
					ms_imps	     = unused_field,
					ms_srcimps   = unused_field }

	    o_file = ml_obj_file location4 	-- The real object file


  -- Figure out if the source has changed, for recompilation avoidance.
606
  --
607
  -- Setting source_unchanged to True means that M.o seems
608
609
  -- to be up to date wrt M.hs; so no need to recompile unless imports have
  -- changed (which the compiler itself figures out).
610
  -- Setting source_unchanged to False tells the compiler that M.o is out of
611
  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
612
	let do_recomp = dopt Opt_RecompChecking dflags
613
	source_unchanged <- 
614
          if not do_recomp || not (isStopLn stop)
615
616
		-- Set source_unchanged to False unconditionally if
		--	(a) recompilation checker is off, or
617
		-- 	(b) we aren't going all the way to .o file (e.g. ghc -S)
618
619
	     then return False	
		-- Otherwise look at file modification dates
620
	     else do o_file_exists <- doesFileExist o_file
621
		     if not o_file_exists
622
		        then return False	-- Need to recompile
623
			else do t2 <- getModificationTime o_file
624
			        if t2 > src_timestamp
625
626
				  then return True
				  else return False
627

628
  -- get the DynFlags
629
630
	let hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags)
	let next_phase = hscNextPhase dflags src_flavour hsc_lang
631
	output_fn  <- get_output_fn next_phase (Just location4)
632

633
        let dflags' = dflags { hscTarget = hsc_lang,
634
635
636
637
			       hscOutName = output_fn,
		   	       hscStubCOutName = basename ++ "_stub.c",
			       hscStubHOutName = basename ++ "_stub.h",
			       extCoreName = basename ++ ".hcr" }
638

639
	hsc_env <- newHscEnv dflags'
640

641
  -- run the compiler!
642
643
644
645
	result <- hscMain hsc_env printErrorsAndWarnings
			  mod_summary source_unchanged 
			  False		-- No object file
			  Nothing	-- No iface
646

647
	case result of
648

649
	    HscFail -> throwDyn (PhaseFailed "hsc" (ExitFailure 1))
650

651
            HscNoRecomp details iface -> do
652
		SysTools.touch dflags' "Touching object file" o_file
653
		return (StopLn, dflags', Just location4, o_file)
654

655
	    HscRecomp _details _iface 
656
		      stub_h_exists stub_c_exists
657
		      _maybe_interpreted_code -> do
658

659
		-- Deal with stubs 
660
		maybe_stub_o <- compileStub dflags' stub_c_exists
661
		case maybe_stub_o of
662
		      Nothing     -> return ()
663
		      Just stub_o -> consIORef v_Ld_inputs stub_o
664
665
666
667
668
669
670
671

		-- In the case of hs-boot files, generate a dummy .o-boot 
		-- stamp file for the benefit of Make
		case src_flavour of
		  HsBootFile -> SysTools.touch dflags' "Touching object file" o_file
		  other	     -> return ()

		return (next_phase, dflags', Just location4, output_fn)
672

673
674
675
-----------------------------------------------------------------------------
-- Cmm phase

676
runPhase CmmCpp stop dflags basename suff input_fn get_output_fn maybe_loc
677
678
  = do
       output_fn <- get_output_fn Cmm maybe_loc
679
       doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn	
680
       return (Cmm, dflags, maybe_loc, output_fn)
681

682
runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc
683
  = do
684
685
	let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
	let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
686
687
	output_fn <- get_output_fn next_phase maybe_loc

688
        let dflags' = dflags { hscTarget = hsc_lang,
689
690
691
692
			       hscOutName = output_fn,
		   	       hscStubCOutName = basename ++ "_stub.c",
			       hscStubHOutName = basename ++ "_stub.h",
			       extCoreName = basename ++ ".hcr" }
693

694
	ok <- hscCmmFile dflags' input_fn
695
696
697

	when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1))

698
	return (next_phase, dflags, maybe_loc, output_fn)
699

700
701
702
703
704
705
-----------------------------------------------------------------------------
-- Cc phase

-- we don't support preprocessing .c files (with -E) now.  Doing so introduces
-- way too many hacks, and I can't say I've ever used it anyway.

706
runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc
707
   | cc_phase `eqPhase` Cc || cc_phase `eqPhase` HCc
708
   = do	let cc_opts = getOpts dflags opt_c
709
	    hcc = cc_phase `eqPhase` HCc
710

711
       	let cmdline_include_paths = includePaths dflags
712

713
714
715
716
717
718
	-- HC files have the dependent packages stamped into them
	pkgs <- if hcc then getHCFilePackages input_fn else return []

	-- add package include paths even if we're just compiling .c
	-- files; this is the Value Add(TM) that using ghc instead of
	-- gcc gives you :)
719
        pkg_include_dirs <- getPackageIncludePath dflags pkgs
rrt's avatar
rrt committed
720
721
        let include_paths = foldr (\ x xs -> "-I" : x : xs) []
			      (cmdline_include_paths ++ pkg_include_dirs)
722

723
724
	let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags
        let pic_c_flags = picCCOpts dflags
725

726
        let verb = getVerbFlag dflags
727

728
	pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs
729

730
731
	let split_objs = dopt Opt_SplitObjs dflags
	    split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
sof's avatar
sof committed
732
		      | otherwise         = [ ]
733

734
	let excessPrecision = dopt Opt_ExcessPrecision dflags
735

736
	-- Decide next phase
737
738
739
	
        let mangle = dopt Opt_DoAsmMangling dflags
            next_phase
740
741
742
743
		| hcc && mangle     = Mangle
		| otherwise         = As
	output_fn <- get_output_fn next_phase maybe_loc

744
745
	-- force the C compiler to interpret this file as C when
	-- compiling .hc files, by adding the -x c option.
746
747
	let langopt | hcc = [ SysTools.Option "-x", SysTools.Option "c"]
		    | otherwise = [ ]
748

749
	SysTools.runCc dflags (langopt ++
750
			[ SysTools.FileOption "" input_fn
sof's avatar
sof committed
751
			, SysTools.Option "-o"
sof's avatar
sof committed
752
			, SysTools.FileOption "" output_fn
sof's avatar
sof committed
753
754
755
			]
		       ++ map SysTools.Option (
		          md_c_flags
756
                       ++ pic_c_flags
757
		       ++ (if hcc && mangle
758
759
		  	     then md_regd_c_flags
		  	     else [])
760
		       ++ [ verb, "-S", "-Wimplicit", "-O" ]
761
762
		       ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
		       ++ cc_opts
sof's avatar
sof committed
763
		       ++ split_opt
764
765
766
		       ++ (if excessPrecision then [] else [ "-ffloat-store" ])
		       ++ include_paths
		       ++ pkg_extra_cc_opts
sof's avatar
sof committed
767
		       ))
768

769
	return (next_phase, dflags, maybe_loc, output_fn)
770
771
772
773
774
775

	-- ToDo: postprocess the output from gcc

-----------------------------------------------------------------------------
-- Mangle phase

776
runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc
777
   = do let mangler_opts = getOpts dflags opt_m
778
779
780
781
782
783

#if i386_TARGET_ARCH
        machdep_opts <- return [ show (stolen_x86_regs dflags) ]
#else
	machdep_opts <- return []
#endif
784

785
786
	let split = dopt Opt_SplitObjs dflags
            next_phase
787
788
		| split = SplitMangle
		| otherwise = As
789
	output_fn <- get_output_fn next_phase maybe_loc
790

791
	SysTools.runMangle dflags (map SysTools.Option mangler_opts
sof's avatar
sof committed
792
793
		          ++ [ SysTools.FileOption "" input_fn
			     , SysTools.FileOption "" output_fn
sof's avatar
sof committed
794
795
			     ]
			  ++ map SysTools.Option machdep_opts)
796

797
	return (next_phase, dflags, maybe_loc, output_fn)
798
799
800
801

-----------------------------------------------------------------------------
-- Splitting phase

802
runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_loc
803
804
  = do  -- tmp_pfx is the prefix used for the split .s files
	-- We also use it as the file to contain the no. of split .s files (sigh)
805
	split_s_prefix <- SysTools.newTempName dflags "split"
806
	let n_files_fn = split_s_prefix
807

808
809
	SysTools.runSplit dflags
			  [ SysTools.FileOption "" input_fn
sof's avatar
sof committed
810
811
			  , SysTools.FileOption "" split_s_prefix
			  , SysTools.FileOption "" n_files_fn
sof's avatar
sof committed
812
			  ]
813
814
815
816
817
818
819
820
821

	-- Save the number of split files for future references
	s <- readFile n_files_fn
	let n_files = read s :: Int
	writeIORef v_Split_info (split_s_prefix, n_files)

	-- Remember to delete all these files
	addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
			| n <- [1..n_files]]
822

823
	return (SplitAs, dflags, maybe_loc, "**splitmangle**")
824
	  -- we don't use the filename
825
826
827
828

-----------------------------------------------------------------------------
-- As phase

829
runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc
830
  = do	let as_opts =  getOpts dflags opt_a
831
        let cmdline_include_paths = includePaths dflags
832

833
	output_fn <- get_output_fn StopLn maybe_loc
834

835
836
837
838
	-- we create directories for the object file, because it
	-- might be a hierarchical module.
	createDirectoryHierarchy (directoryOf output_fn)

839
840
	SysTools.runAs dflags	
		       (map SysTools.Option as_opts
sof's avatar
sof committed
841
842
		       ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
		       ++ [ SysTools.Option "-c"
sof's avatar
sof committed
843
		          , SysTools.FileOption "" input_fn
sof's avatar
sof committed
844
			  , SysTools.Option "-o"
sof's avatar
sof committed
845
			  , SysTools.FileOption "" output_fn
sof's avatar
sof committed
846
			  ])
847

848
	return (StopLn, dflags, maybe_loc, output_fn)
849
850


851
runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc
852
  = do  let as_opts = getOpts dflags opt_a
853

854
	(split_s_prefix, n) <- readIORef v_Split_info
855

856
857
858
	let real_odir
		| Just d <- outputDir dflags = d
		| otherwise                  = basename ++ "_split"
859

860
861
	let assemble_file n
	      = do  let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
862
		    let output_o = replaceFilenameDirectory
863
					(basename ++ "__" ++ show n ++ ".o")
864
					 real_odir
865
866
		    let osuf = objectSuf dflags
		    let real_o = replaceFilenameSuffix output_o osuf
867
868
		    SysTools.runAs dflags
				 (map SysTools.Option as_opts ++
sof's avatar
sof committed
869
870
		    		    [ SysTools.Option "-c"
				    , SysTools.Option "-o"
sof's avatar
sof committed
871
872
				    , SysTools.FileOption "" real_o
				    , SysTools.FileOption "" input_s
sof's avatar
sof committed
873
				    ])
874
875
	
	mapM_ assemble_file [1..n]
876

877
878
	output_fn <- get_output_fn StopLn maybe_loc
	return (StopLn, dflags, maybe_loc, output_fn)
879

880
881
882
883
884
885
-----------------------------------------------------------------------------
-- MoveBinary sort-of-phase
-- After having produced a binary, move it somewhere else and generate a
-- wrapper script calling the binary. Currently, we need this only in 
-- a parallel way (i.e. in GUM), because PVM expects the binary in a
-- central directory.
886
-- This is called from staticLink below, after linking. I haven't made it
887
888
889
890
-- a separate phase to minimise interfering with other modules, and
-- we don't need the generality of a phase (MoveBinary is always
-- done after linking and makes only sense in a parallel setup)   -- HWL

891
runPhase_MoveBinary input_fn
892
  = do	
893
        sysMan   <- getSysMan
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927