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

9
#include "../includes/ghcconfig.h"
rrt's avatar
rrt committed
10

11
module DriverPipeline (
12

13
	-- Interfaces for the batch-mode driver
14
   runPipeline, 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
30
31
import DriverState
import DriverUtil
import DriverMkDepend
32
import DriverPhases
33
import DriverFlags
sof's avatar
sof committed
34
import SysTools		( newTempName, addFilesToClean, getSysMan, copy )
35
import qualified SysTools	
36
import HscMain
37
import Finder
38
39
40
import HscTypes
import Outputable
import Module
41
import ErrUtils
42
import CmdLineOpts
43
import Config
44
import RdrName		( GlobalRdrEnv )
45
import Panic
46
import Util
47
import StringBuffer	( hGetStringBuffer )
48
import BasicTypes	( SuccessFlag(..) )
49
import Maybes		( expectJust )
50

51
52
import ParserCoreUtils ( getCoreModuleName )

53
54
55
import EXCEPTION
import DATA_IOREF	( readIORef, writeIORef )

56
import Time 		( ClockTime )
57
58
import Directory
import System
59
60
61
62
import IO
import Monad
import Maybe

63

64
65
-- ---------------------------------------------------------------------------
-- Pre-process
66
67
68
69

-- Just preprocess a file, put the result in a temp. file (used by the
-- compilation manager during the summary phase).

70
71
preprocess :: DynFlags -> FilePath -> IO FilePath
preprocess dflags filename =
72
  ASSERT(isHaskellSrcFilename filename) 
73
  do runPipeline (StopBefore Hsc) dflags ("preprocess") 
74
75
76
	False{-temporary output file-}
	Nothing{-no specific output file-}
	filename
77
	Nothing{-no ModLocation-}
78

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

-- 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.

97
compile :: HscEnv
98
99
	-> Module
	-> ModLocation
100
	-> ClockTime		   -- timestamp of original source file
101
102
103
104
105
106
	-> Bool			   -- True <=> source unchanged
	-> Bool			   -- True <=> have object
        -> Maybe ModIface          -- old interface, if available
        -> IO CompResult

data CompResult
107
108
109
110
   = CompOK   ModDetails 		-- New details
	      (Maybe GlobalRdrEnv)	-- Lexical environment for the module
					-- (Maybe because we may have loaded it from
					--  its precompiled interface)
111
112
113
114
              ModIface			-- New iface
              (Maybe Linkable)	-- New code; Nothing => compilation was not reqd
		                --			(old code is still valid)

115
   | CompErrs 
116
117


118
compile hsc_env this_mod location src_timestamp
119
	source_unchanged have_object 
120
	old_iface = do 
121

122
   let dyn_flags = hsc_dflags hsc_env
123

124
   showPass dyn_flags
125
126
127
128
129
130
131
132
	(showSDoc (text "Compiling" <+> ppr this_mod))

   let verb	  = verbosity dyn_flags
   let input_fn   = expectJust "compile:hs" (ml_hs_file location) 
   let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location)

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

133
   -- add in the OPTIONS from the source file
134
   opts <- getOptionsFromSource input_fnpp
135
136
   (dyn_flags,unhandled_flags) <- processDynamicFlags opts dyn_flags
   checkProcessArgsResult unhandled_flags input_fn
137

138
   let (basename, _) = splitFilename input_fn
139

140
141
142
143
144
145
146
147
148
  -- 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
   old_paths <- readIORef v_Include_paths
   writeIORef v_Include_paths (current_dir : old_paths)
   -- put back the old include paths afterward.
   later (writeIORef v_Include_paths old_paths) $ do

149
150
151
152
153
154
   -- figure out what lang we're generating
   hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
   -- figure out what the next phase should be
   next_phase <- hscNextPhase hsc_lang
   -- figure out what file to generate the output into
   get_output_fn <- genOutputFilenameFunc False Nothing next_phase basename
155
   output_fn <- get_output_fn next_phase (Just location)
156
157
158

   let dyn_flags' = dyn_flags { hscLang = hsc_lang,
				hscOutName = output_fn,
159
160
161
162
163
164
165
				hscStubCOutName = basename ++ "_stub.c",
				hscStubHOutName = basename ++ "_stub.h",
				extCoreName = basename ++ ".hcr" }

   -- -no-recomp should also work with --make
   do_recomp <- readIORef v_Recomp
   let source_unchanged' = source_unchanged && do_recomp
166
       hsc_env' = hsc_env { hsc_dflags = dyn_flags' }
167
168

   -- run the compiler
169
   hsc_result <- hscMain hsc_env' printErrorsAndWarnings this_mod location
170
171
172
			 source_unchanged' have_object old_iface

   case hsc_result of
173
      HscFail -> return CompErrs
174

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

177
      HscRecomp details rdr_env iface
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
	stub_h_exists stub_c_exists maybe_interpreted_code -> do
	   let 
	   maybe_stub_o <- compileStub dyn_flags' stub_c_exists
	   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
193
194
195
196
197
198
199
		       Just comp_bc -> return ([BCOs comp_bc], src_timestamp)
			-- 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.
200
201
202
203
#endif
		       Nothing -> panic "compile: no interpreted code"

		-- we're in batch mode: finish the compilation pipeline.
204
205
206
		_other -> do
		   let object_filename = ml_obj_file location

207
		   runPipeline (StopBefore Ln) dyn_flags ""
208
209
			True Nothing output_fn (Just location)
			-- the object filename comes from the ModLocation
210
211
212

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

214
	   let linkable = LM unlinked_time this_mod
215
216
			     (hs_unlinked ++ stub_unlinked)

217
	   return (CompOK details rdr_env iface (Just linkable))
218

219
-----------------------------------------------------------------------------
220
221
222
223
224
225
226
-- 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
227
	stub_o <- runPipeline (StopBefore Ln) dflags "stub-compile"
228
229
230
			True{-persistent output-} 
			Nothing{-no specific output file-}
			stub_c
231
			Nothing{-no ModLocation-}
232
233
234
	return (Just stub_o)


235
236
-- ---------------------------------------------------------------------------
-- Link
237
238
239
240

link :: GhciMode		-- interactive or batch
     -> DynFlags		-- dynamic flags
     -> Bool			-- attempt linking in batch mode?
241
     -> HomePackageTable	-- what to link
242
243
244
245
246
247
248
249
250
251
     -> 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
252
253
link Interactive dflags batch_attempt_linking hpt
    = do -- Not Linking...(demand linker will do the job)
254
255
256
	 return Succeeded
#endif

257
link Batch dflags batch_attempt_linking hpt
258
   | batch_attempt_linking
259
   = do 
260
261
262
263
264
265
266
267
268
269
270
271
272
	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)))

273
274
275
276
277
278
279
280
281
282
	-- check for the -no-link flag
	omit_linking <- readIORef v_NoLink
	if omit_linking 
	  then do when (verb >= 3) $
		    hPutStrLn stderr "link(batch): linking omitted (-no-link flag given)."
	          return Succeeded
	  else do

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

284
285
286
	let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
	    obj_files = concatMap getOfiles linkables

287
	-- Don't showPass in Batch mode; doLink will do that for us.
288
        staticLink dflags obj_files pkg_deps
289
290

        when (verb >= 3) (hPutStrLn stderr "link: done")
291
292
293
294
295
296
297
298
299
300
301

	-- 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
302
      
303
304
-- ---------------------------------------------------------------------------
-- Run a compilation pipeline, consisting of multiple phases.
305

306
307
308
309
-- 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.

310
311
runPipeline
  :: GhcMode		-- when to stop
312
  -> DynFlags		-- dynamic flags
313
314
315
316
  -> String		-- "stop after" flag
  -> Bool		-- final output is persistent?
  -> Maybe FilePath	-- where to put the output, optionally
  -> FilePath 		-- input filename
317
  -> Maybe ModLocation  -- a ModLocation for this module, if we have one
318
319
  -> IO FilePath	-- output filename

320
321
runPipeline todo dflags stop_flag keep_output 
  maybe_output_filename input_fn maybe_loc
322
323
324
325
  = do
  split <- readIORef v_Split_object_files
  let (basename, suffix) = splitFilename input_fn
      start_phase = startPhase suffix
326

327
328
329
330
331
332
      stop_phase = case todo of 
			StopBefore As | split -> SplitAs
			StopBefore phase      -> phase
			DoMkDependHS	      -> Ln
			DoLink                -> Ln
			DoMkDLL               -> Ln
333

334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
  -- 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.
  --
  when (not (start_phase `happensBefore` stop_phase)) $
	throwDyn (UsageError 
		    ("flag `" ++ stop_flag
		     ++ "' is incompatible with source file `"
		     ++ input_fn ++ "'"))

  -- generate a function which will be used to calculate output file names
  -- as we go along.
  get_output_fn <- genOutputFilenameFunc keep_output maybe_output_filename
			stop_phase basename

  -- and execute the pipeline...
353
  (output_fn, maybe_loc) <- 
354
	pipeLoop dflags start_phase stop_phase input_fn basename suffix 
355
		 get_output_fn maybe_loc
356
357
358
359
360
361

  -- sometimes, a compilation phase doesn't actually generate any output
  -- (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.
  if keep_output
362
	then do final_fn <- get_output_fn stop_phase maybe_loc
363
	        when (final_fn /= output_fn) $
364
	 	  copy dflags ("Copying `" ++ output_fn ++ "' to `" ++ final_fn
365
366
367
368
369
370
			++ "'") output_fn final_fn
	        return final_fn
	else
	     return output_fn


371
pipeLoop :: DynFlags -> Phase -> Phase -> FilePath -> String -> Suffix
372
373
  -> (Phase -> Maybe ModLocation -> IO FilePath)
  -> Maybe ModLocation -> IO (FilePath, Maybe ModLocation)
374

375
pipeLoop dflags phase stop_phase input_fn orig_basename orig_suff 
376
377
378
	get_output_fn maybe_loc

  | phase == stop_phase  =  return (input_fn, maybe_loc)  -- all done
379
380
381
382
383
384
385
386
387

  | not (phase `happensBefore` stop_phase)  = 
	-- 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 #-}.
	panic ("pipeLoop: at phase " ++ show phase ++ 
		" but I wanted to stop at phase " ++ show stop_phase)

388
  | otherwise = do
389
390
	maybe_next_phase <- runPhase phase dflags orig_basename 
				orig_suff input_fn get_output_fn maybe_loc
391
	case maybe_next_phase of
392
	  (Nothing, dflags, maybe_loc, output_fn) -> do
393
394
		-- we stopped early, but return the *final* filename
		-- (it presumably already exists)
395
396
		final_fn <- get_output_fn stop_phase maybe_loc
		return (final_fn, maybe_loc)
397
398
	  (Just next_phase, dflags', maybe_loc, output_fn) ->
		pipeLoop dflags' next_phase stop_phase output_fn
399
			orig_basename orig_suff get_output_fn maybe_loc
400
401
402

  
genOutputFilenameFunc :: Bool -> Maybe FilePath -> Phase -> String
403
  -> IO (Phase{-next phase-} -> Maybe ModLocation -> IO FilePath)
404
405
genOutputFilenameFunc keep_final_output maybe_output_filename 
		stop_phase basename
406
 = do
407
   hcsuf      <- readIORef v_HC_suf
408
   odir       <- readIORef v_Output_dir
409
   osuf       <- readIORef v_Object_suf
410
   keep_hc    <- readIORef v_Keep_hc_files
sof's avatar
sof committed
411
#ifdef ILX
rrt's avatar
rrt committed
412
   keep_il    <- readIORef v_Keep_il_files
sof's avatar
sof committed
413
414
   keep_ilx   <- readIORef v_Keep_ilx_files
#endif
415
416
   keep_raw_s <- readIORef v_Keep_raw_s_files
   keep_s     <- readIORef v_Keep_s_files
417
   let
418
419
420
421
        myPhaseInputExt HCc | Just s <- hcsuf = s
        myPhaseInputExt Ln    = osuf
        myPhaseInputExt other = phaseInputExt other

422
	func next_phase maybe_location
423
424
425
426
427
		| is_last_phase, Just f <- maybe_output_filename = return f
		| is_last_phase && keep_final_output = persistent_fn
		| keep_this_output 		     = persistent_fn
     		| otherwise        		     = newTempName suffix

428
	   where
429
430
431
432
433
434
435
436
437
438
439
		is_last_phase = next_phase == stop_phase

		-- sometimes, we keep output from intermediate stages
		keep_this_output = 
     		     case next_phase of
     			     Ln                  -> True
     			     Mangle | keep_raw_s -> True
     			     As     | keep_s     -> True
     			     HCc    | keep_hc    -> True
     			     _other              -> False

440
		suffix = myPhaseInputExt next_phase
441
442
443
444
445
446

		-- persistent object files get put in odir
	        persistent_fn 
		   | Ln <- next_phase  = return odir_persistent
		   | otherwise         = return persistent

447
		persistent = basename ++ '.':suffix
448

449
		odir_persistent
450
		   | Just loc <- maybe_location = ml_obj_file loc
451
452
453
		   | Just d <- odir = replaceFilenameDirectory persistent d
		   | otherwise      = persistent

454
   return func
455
456


457
458
459
460
461
462
463
464
465
466
467
-- -----------------------------------------------------------------------------
-- 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.

runPhase :: Phase
468
469
470
471
472
	 -> 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)
473
			-- how to calculate the output filename
474
475
476
477
478
	 -> Maybe ModLocation		-- the ModLocation, if we have one
	 -> IO (Maybe Phase,  		-- next phase
		DynFlags,		-- new dynamic flags
		Maybe ModLocation,	-- the ModLocation, if we have one
		FilePath)		-- output filename
479
480
481
482

-------------------------------------------------------------------------------
-- Unlit phase 

483
484
runPhase Unlit dflags _basename _suff input_fn get_output_fn maybe_loc
  = do let unlit_flags = getOpts dflags opt_L
rrt's avatar
rrt committed
485
       -- The -h option passes the file name for unlit to put in a #line directive
486
       output_fn <- get_output_fn Cpp maybe_loc
487

488
489
       SysTools.runUnlit dflags 
		(map SysTools.Option unlit_flags ++
sof's avatar
sof committed
490
491
       			  [ SysTools.Option     "-h"
 			  , SysTools.Option     input_fn
sof's avatar
sof committed
492
493
			  , SysTools.FileOption "" input_fn
			  , SysTools.FileOption "" output_fn
sof's avatar
sof committed
494
			  ])
495

496
       return (Just Cpp, dflags, maybe_loc, output_fn)
497
498
499
500

-------------------------------------------------------------------------------
-- Cpp phase 

501
runPhase Cpp dflags basename suff input_fn get_output_fn maybe_loc
502
  = do src_opts <- getOptionsFromSource input_fn
503
504
       (dflags,unhandled_flags) <- processDynamicFlags src_opts dflags
       checkProcessArgsResult unhandled_flags (basename++'.':suff)
505

506
       if not (cppFlag dflags) then
sof's avatar
sof committed
507
508
           -- no need to preprocess CPP, just pass input file along
	   -- to the next phase of the pipeline.
509
          return (Just HsPp, dflags, maybe_loc, input_fn)
sof's avatar
sof committed
510
	else do
511
	    output_fn <- get_output_fn HsPp maybe_loc
512
513
	    doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn
	    return (Just HsPp, dflags, maybe_loc, output_fn)
514

sof's avatar
sof committed
515
516
517
-------------------------------------------------------------------------------
-- HsPp phase 

518
519
runPhase HsPp dflags basename suff input_fn get_output_fn maybe_loc
  = do if not (ppFlag dflags) then
sof's avatar
sof committed
520
521
           -- no need to preprocess, just pass input file along
	   -- to the next phase of the pipeline.
522
          return (Just Hsc, dflags, maybe_loc, input_fn)
sof's avatar
sof committed
523
	else do
524
	    let hspp_opts = getOpts dflags opt_F
sof's avatar
sof committed
525
       	    hs_src_pp_opts <- readIORef v_Hs_source_pp_opts
526
	    let orig_fn = basename ++ '.':suff
527
	    output_fn <- get_output_fn Hsc maybe_loc
528
529
	    SysTools.runPp dflags
			   ( [ SysTools.Option     orig_fn
sof's avatar
sof committed
530
531
532
533
534
535
			     , SysTools.Option     input_fn
			     , SysTools.FileOption "" output_fn
			     ] ++
			     map SysTools.Option hs_src_pp_opts ++
			     map SysTools.Option hspp_opts
			   )
536
	    return (Just Hsc, dflags, maybe_loc, output_fn)
537

538
539
540
-----------------------------------------------------------------------------
-- Hsc phase

541
542
-- Compilation of a single module, in "legacy" mode (_not_ under
-- the direction of the compilation manager).
543
runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do
544
545
  todo <- readIORef v_GhcMode
  if todo == DoMkDependHS then do
546
547
       locn <- doMkDependHSPhase dflags basename suff input_fn
       return (Nothing, dflags, Just locn, input_fn)  -- Ln is a dummy stop phase 
548
549
550
551

   else do
      -- normal Hsc mode, not mkdependHS

552
553
554
  -- 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.
555
	let current_dir = directoryOf basename
556
	
557
558
	paths <- readIORef v_Include_paths
	writeIORef v_Include_paths (current_dir : paths)
559
	
560
  -- gather the imports and module name
561
        (hspp_buf,mod_name) <- 
562
            if isExtCoreFilename ('.':suff)
563
564
565
	     then do
               -- no explicit imports in ExtCore input.
	       m <- getCoreModuleName input_fn
566
567
568
569
570
	       return (Nothing, mkModule m)
	     else do
	       buf <- hGetStringBuffer input_fn
  	       (_,_,mod_name) <- getImports dflags buf input_fn
	       return (Just buf, mod_name)
571

572
  -- build a ModLocation to pass to hscMain.
573
	location' <- mkHomeModLocation mod_name (basename ++ '.':suff)
574
575
576
577
578
579

  -- take -ohi into account if present
	ohi <- readIORef v_Output_hi
	let location | Just fn <- ohi = location'{ ml_hi_file = fn }
		     | otherwise      = location'

580
581
582
583
  -- figure out if the source has changed, for recompilation avoidance.
  -- only do this if we're eventually going to generate a .o file.
  -- (ToDo: do when generating .hc files too?)
  --
584
  -- Setting source_unchanged to True means that M.o seems
585
586
  -- to be up to date wrt M.hs; so no need to recompile unless imports have
  -- changed (which the compiler itself figures out).
587
  -- Setting source_unchanged to False tells the compiler that M.o is out of
588
  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
sof's avatar
sof committed
589
590
	do_recomp   <- readIORef v_Recomp
	expl_o_file <- readIORef v_Output_file
591
592
593
594
595

	let o_file -- if the -o option is given and IT IS THE OBJECT FILE FOR
		   -- THIS COMPILATION, then use that to determine if the 
		   -- source is unchanged.
		| Just x <- expl_o_file, todo == StopBefore Ln  =  x
596
		| otherwise = ml_obj_file location
597

598
599
	source_unchanged <- 
          if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
600
	     then return False
601
602
603
	     else do t1 <- getModificationTime (basename ++ '.':suff)
		     o_file_exists <- doesFileExist o_file
		     if not o_file_exists
604
		        then return False	-- Need to recompile
605
606
			else do t2 <- getModificationTime o_file
			        if t2 > t1
607
608
				  then return True
				  else return False
609

610
  -- get the DynFlags
611
	hsc_lang <- hscMaybeAdjustLang (hscLang dflags)
612
	next_phase <- hscNextPhase hsc_lang
613
	output_fn <- get_output_fn next_phase (Just location)
614

615
616
617
618
619
620
        let dflags' = dflags { hscLang = hsc_lang,
			       hscOutName = output_fn,
		   	       hscStubCOutName = basename ++ "_stub.c",
			       hscStubHOutName = basename ++ "_stub.h",
			       extCoreName = basename ++ ".hcr" }
	hsc_env <- newHscEnv OneShot dflags'
621

622
  -- run the compiler!
623
	result <- hscMain hsc_env printErrorsAndWarnings mod_name
624
625
			  location{ ml_hspp_file = Just input_fn,
				    ml_hspp_buf  = hspp_buf }
626
			  source_unchanged
627
			  False
628
			  Nothing	 -- no iface
629

630
	case result of
631

632
	    HscFail -> throwDyn (PhaseFailed "hsc" (ExitFailure 1))
633

634
            HscNoRecomp details iface -> do
635
636
		SysTools.touch dflags' "Touching object file" o_file
		return (Nothing, dflags', Just location, output_fn)
637

638
639
	    HscRecomp _details _rdr_env _iface 
		      stub_h_exists stub_c_exists
640
		      _maybe_interpreted_code -> do
641

642
		-- deal with stubs
643
		maybe_stub_o <- compileStub dflags' stub_c_exists
644
645
646
		case maybe_stub_o of
		      Nothing -> return ()
		      Just stub_o -> add v_Ld_inputs stub_o
647
648
649
		case hscLang dflags' of
                      HscNothing -> return (Nothing, dflags', Just location, output_fn)
		      _ -> return (Just next_phase, dflags', Just location, output_fn)
650

651
652
653
-----------------------------------------------------------------------------
-- Cmm phase

654
runPhase CmmCpp dflags basename suff input_fn get_output_fn maybe_loc
655
656
  = do
       output_fn <- get_output_fn Cmm maybe_loc
657
658
       doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn	
       return (Just Cmm, dflags, maybe_loc, output_fn)
659

660
runPhase Cmm dflags basename suff input_fn get_output_fn maybe_loc
661
  = do
662
	hsc_lang <- hscMaybeAdjustLang (hscLang dflags)
663
664
665
	next_phase <- hscNextPhase hsc_lang
	output_fn <- get_output_fn next_phase maybe_loc

666
667
668
669
670
        let dflags' = dflags { hscLang = hsc_lang,
			       hscOutName = output_fn,
		   	       hscStubCOutName = basename ++ "_stub.c",
			       hscStubHOutName = basename ++ "_stub.h",
			       extCoreName = basename ++ ".hcr" }
671

672
	ok <- hscCmmFile dflags' input_fn
673
674
675

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

676
	return (Just next_phase, dflags, maybe_loc, output_fn)
677

678
679
680
681
682
683
-----------------------------------------------------------------------------
-- 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.

684
runPhase cc_phase dflags basename suff input_fn get_output_fn maybe_loc
685
   | cc_phase == Cc || cc_phase == HCc
686
   = do	let cc_opts = getOpts dflags opt_c
rrt's avatar
rrt committed
687
       	cmdline_include_paths <- readIORef v_Include_paths
688

689
690
691
	split  <- readIORef v_Split_object_files
	mangle <- readIORef v_Do_asm_mangling

692
693
        let hcc = cc_phase == HCc

694
695
696
697
	    next_phase
		| hcc && mangle     = Mangle
		| otherwise         = As

698
	output_fn <- get_output_fn next_phase maybe_loc
699

700
701
702
703
704
705
	-- 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 :)
706
        pkg_include_dirs <- getPackageIncludePath dflags pkgs
rrt's avatar
rrt committed
707
708
        let include_paths = foldr (\ x xs -> "-I" : x : xs) []
			      (cmdline_include_paths ++ pkg_include_dirs)
709

710
	mangle <- readIORef v_Do_asm_mangling
711
	(md_c_flags, md_regd_c_flags) <- machdepCCOpts dflags
712

713
        let verb = getVerbFlag dflags
714

715
	pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs
716

717
	split_objs <- readIORef v_Split_object_files
sof's avatar
sof committed
718
719
	let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
		      | otherwise         = [ ]
720

721
	excessPrecision <- readIORef v_Excess_precision
722
723
724
725
726
727
728

	-- force the C compiler to interpret this file as C when
	-- compiling .hc files, by adding the -x c option.
	let langopt
		| cc_phase == HCc = [ SysTools.Option "-x", SysTools.Option "c"]
		| otherwise       = [ ]

729
	SysTools.runCc dflags (langopt ++
730
			[ SysTools.FileOption "" input_fn
sof's avatar
sof committed
731
			, SysTools.Option "-o"
sof's avatar
sof committed
732
			, SysTools.FileOption "" output_fn
sof's avatar
sof committed
733
734
735
			]
		       ++ map SysTools.Option (
		          md_c_flags
736
737
738
		       ++ (if cc_phase == HCc && mangle
		  	     then md_regd_c_flags
		  	     else [])
739
		       ++ [ verb, "-S", "-Wimplicit", "-O" ]
740
741
		       ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
		       ++ cc_opts
sof's avatar
sof committed
742
		       ++ split_opt
743
744
745
		       ++ (if excessPrecision then [] else [ "-ffloat-store" ])
		       ++ include_paths
		       ++ pkg_extra_cc_opts
sof's avatar
sof committed
746
		       ))
747

748
	return (Just next_phase, dflags, maybe_loc, output_fn)
749
750
751
752
753
754

	-- ToDo: postprocess the output from gcc

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

755
756
runPhase Mangle dflags _basename _suff input_fn get_output_fn maybe_loc
   = do let mangler_opts = getOpts dflags opt_m
757
        machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
758
			  then do let n_regs = stolen_x86_regs dflags
759
760
761
762
763
764
765
			          return [ show n_regs ]
		          else return []

	split <- readIORef v_Split_object_files
	let next_phase
		| split = SplitMangle
		| otherwise = As
766
	output_fn <- get_output_fn next_phase maybe_loc
767

768
	SysTools.runMangle dflags (map SysTools.Option mangler_opts
sof's avatar
sof committed
769
770
		          ++ [ SysTools.FileOption "" input_fn
			     , SysTools.FileOption "" output_fn
sof's avatar
sof committed
771
772
			     ]
			  ++ map SysTools.Option machdep_opts)
773

774
	return (Just next_phase, dflags, maybe_loc, output_fn)
775
776
777
778

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

779
runPhase SplitMangle dflags _basename _suff input_fn get_output_fn maybe_loc
780
781
782
783
  = 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)
	split_s_prefix <- SysTools.newTempName "split"
	let n_files_fn = split_s_prefix
784

785
786
	SysTools.runSplit dflags
			  [ SysTools.FileOption "" input_fn
sof's avatar
sof committed
787
788
			  , SysTools.FileOption "" split_s_prefix
			  , SysTools.FileOption "" n_files_fn
sof's avatar
sof committed
789
			  ]
790
791
792
793
794
795
796
797
798

	-- 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]]
799

800
	return (Just SplitAs, dflags, maybe_loc, "**splitmangle**")
801
	  -- we don't use the filename
802
803
804
805

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

806
807
runPhase As dflags _basename _suff input_fn get_output_fn maybe_loc
  = do	let as_opts =  getOpts dflags opt_a
808
        cmdline_include_paths <- readIORef v_Include_paths
809

810
	output_fn <- get_output_fn Ln maybe_loc
811

812
813
814
815
	-- we create directories for the object file, because it
	-- might be a hierarchical module.
	createDirectoryHierarchy (directoryOf output_fn)

816
817
	SysTools.runAs dflags	
		       (map SysTools.Option as_opts
sof's avatar
sof committed
818
819
		       ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
		       ++ [ SysTools.Option "-c"
sof's avatar
sof committed
820
		          , SysTools.FileOption "" input_fn
sof's avatar
sof committed
821
			  , SysTools.Option "-o"
sof's avatar
sof committed
822
			  , SysTools.FileOption "" output_fn
sof's avatar
sof committed
823
			  ])
824

825
	return (Just Ln, dflags, maybe_loc, output_fn)
826
827


828
829
runPhase SplitAs dflags basename _suff _input_fn get_output_fn maybe_loc
  = do  let as_opts = getOpts dflags opt_a
830

831
	(split_s_prefix, n) <- readIORef v_Split_info
832

833
	odir <- readIORef v_Output_dir
834
	let real_odir = case odir of
835
				Nothing -> basename ++ "_split"
836
837
				Just d  -> d

838
839
	let assemble_file n
	      = do  let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
840
		    let output_o = replaceFilenameDirectory
841
					(basename ++ "__" ++ show n ++ ".o")
842
					 real_odir
843
		    real_o <- osuf_ify output_o
844
845
		    SysTools.runAs dflags
				 (map SysTools.Option as_opts ++
sof's avatar
sof committed
846
847
		    		    [ SysTools.Option "-c"
				    , SysTools.Option "-o"
sof's avatar
sof committed
848
849
				    , SysTools.FileOption "" real_o
				    , SysTools.FileOption "" input_s
sof's avatar
sof committed
850
				    ])
851
852
	
	mapM_ assemble_file [1..n]
853

854
	output_fn <- get_output_fn Ln maybe_loc
855
	return (Just Ln, dflags, maybe_loc, output_fn)
856

rrt's avatar
rrt committed
857
858
859
860
861
#ifdef ILX
-----------------------------------------------------------------------------
-- Ilx2Il phase
-- Run ilx2il over the ILX output, getting an IL file

862
863
runPhase Ilx2Il dflags _basename _suff input_fn get_output_fn maybe_loc
  = do	let ilx2il_opts = getOpts dflags opt_I
rrt's avatar
rrt committed
864
865
866
867
        SysTools.runIlx2il (map SysTools.Option ilx2il_opts
                           ++ [ SysTools.Option "--no-add-suffix-to-assembly",
				SysTools.Option "mscorlib",
				SysTools.Option "-o",
sof's avatar
sof committed
868
869
				SysTools.FileOption "" output_fn,
				SysTools.FileOption "" input_fn ])
870
	return True
rrt's avatar
rrt committed
871
872
873
874
875

-----------------------------------------------------------------------------
-- Ilasm phase
-- Run ilasm over the IL, getting a DLL

876
877
runPhase Ilasm dflags _basename _suff input_fn get_output_fn maybe_loc
  = do	let ilasm_opts = getOpts dflags opt_i
rrt's avatar
rrt committed
878
879
880
        SysTools.runIlasm (map SysTools.Option ilasm_opts
		           ++ [ SysTools.Option "/QUIET",
				SysTools.Option "/DLL",
sof's avatar
sof committed
881
882
				SysTools.FileOption "/OUT=" output_fn,
				SysTools.FileOption "" input_fn ])
883
	return True
rrt's avatar
rrt committed
884

ross's avatar
ross committed
885
#endif /* ILX */
rrt's avatar
rrt committed
886

887
888
889
890
891
892
-----------------------------------------------------------------------------
-- 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.
893
-- This is called from staticLink below, after linking. I haven't made it
894
895
896
897
-- 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

898
runPhase_MoveBinary input_fn
899
  = do	
900
        sysMan   <- getSysMan
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
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
        pvm_root <- getEnv "PVM_ROOT"
        pvm_arch <- getEnv "PVM_ARCH"
        let 
           pvm_executable_base = "=" ++ input_fn
           pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
        -- nuke old binary; maybe use configur'ed names for cp and rm?
        system ("rm -f " ++ pvm_executable)
        -- move the newly created binary into PVM land
        system ("cp -p " ++ input_fn ++ " " ++ pvm_executable)
        -- generate a wrapper script for running a parallel prg under PVM
        writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
	return True

-- generates a Perl skript starting a parallel prg under PVM
mk_pvm_wrapper_script :: String -> String -> String -> String
mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
 [
  "eval 'exec perl -S $0 ${1+\"$@\"}'", 
  "  if $running_under_some_shell;",
  "# =!=!=!=!=!=!=!=!=!=!=!",
  "# This script is automatically generated: DO NOT EDIT!!!",
  "# Generated by Glasgow Haskell Compiler",
  "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
  "#",
  "$pvm_executable      = '" ++ pvm_executable ++ "';",
  "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
  "$SysMan = '" ++ sysMan ++ "';",
  "",
  {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
  "# first, some magical shortcuts to run "commands" on the binary",
  "# (which is hidden)",
  "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
  "    local($cmd) = $1;",
  "    system("$cmd $pvm_executable");",
  "    exit(0); # all done",
  "}", -}
  "",
  "# Now, run the real binary; process the args first",
  "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
  "$debug = '';",
  "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
  "@nonPVM_args = ();",
  "$in_RTS_args = 0;",
  "",
  "args: while ($a = shift(@ARGV)) {",
  "    if ( $a eq '+RTS' ) {",
  "	$in_RTS_args = 1;",
  "    } elsif ( $a eq '-RTS' ) {",
  "	$in_RTS_args = 0;",
  "    }",
  "    if ( $a eq '-d' && $in_RTS_args ) {",
  "	$debug = '-';",
  "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
  "	$nprocessors = $1;",
  "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
  "	$nprocessors = $1;",
  "    } else {",
  "	push(@nonPVM_args, $a);",
  "    }",
  "}",
  "",
  "local($return_val) = 0;",
  "# Start the parallel execution by calling SysMan",
  "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
  "$return_val = $?;",
  "# ToDo: fix race condition moving files and flushing them!!",
  "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
  "exit($return_val);"
 ]

971
972
973
-----------------------------------------------------------------------------
-- Complain about non-dynamic flags in OPTIONS pragmas

974
checkProcessArgsResult flags filename
sof's avatar
sof committed
975
  = do when (notNull flags) (throwDyn (ProgramError (
976
	  showSDoc (hang (text filename <> char ':')
977
978
979
980
981
982
983
		      4 (text "unknown flags in  {-# OPTIONS #-} pragma:" <+>
			  hsep (map text flags)))
	)))

-----------------------------------------------------------------------------
-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file

984
getHCFilePackages :: FilePath -> IO [PackageId]
985
986
987
988
989
getHCFilePackages filename =
  EXCEPTION.bracket (openFile filename ReadMode) hClose $ \h -> do
    l <- hGetLine h
    case l of
      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
990
	  return (map stringToPackageId (words rest))
991
992
      _other ->
	  return []
993

994
-----------------------------------------------------------------------------
995
-- Static linking, of .o files
996

997
998
999
1000
1001
1002
1003
1004
1005
1006
-- The list of packages passed to link is the list of packages on
-- which this program depends, as discovered by the compilation
-- manager.  It is combined with the list of packages that the user
-- specifies on the command line with -package flags.  
--
-- In one-shot linking mode, we can't discover the package
-- dependencies (because we haven't actually done any compilation or
-- read any interface files), so the user must explicitly specify all
-- the packages.

1007
1008
1009
staticLink :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
staticLink dflags o_files dep_packages = do
    let verb = getVerbFlag dflags
1010
    static     <- readIORef v_Static
1011
1012
    no_hs_main <- readIORef v_NoHsMain

1013
1014
1015
1016
    -- get the full list of packages to link with, by combining the
    -- explicit packages with the auto packages and all of their
    -- dependencies, and eliminating duplicates.

1017
    o_file <- readIORef v_Output_file
1018
1019
1020
#if defined(mingw32_HOST_OS)
    let output_fn = case o_file of { Just s -> s; Nothing -> "main.exe"; }
#else
1021
    let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1022
#endif
1023

1024
    pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1025
1026
    let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths

1027
    lib_paths <- readIORef v_Library_paths
1028
1029
    let lib_path_opts = map ("-L"++) lib_paths

1030
    pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1031

1032
#ifdef darwin_TARGET_OS
1033
    pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1034
1035
1036
1037
1038
    let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths

    framework_paths <- readIORef v_Framework_paths
    let framework_path_opts = map ("-F"++) framework_paths

1039
    pkg_frameworks <- getPackageFrameworks dflags dep_packages
1040
    let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1041
1042

    frameworks <- readIORef v_Cmdline_frameworks
1043
    let framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1044