DriverPipeline.hs 41.1 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 BasicTypes	( SuccessFlag(..) )
48
import Maybes		( expectJust )
49

50
51
import ParserCoreUtils ( getCoreModuleName )

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

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

62

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

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

preprocess :: FilePath -> IO FilePath
preprocess filename =
71
  ASSERT(isHaskellSrcFilename filename) 
72
  do restoreDynFlags	-- Restore to state of last save
73
74
75
76
     runPipeline (StopBefore Hsc) ("preprocess") 
	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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

   dyn_flags <- restoreDynFlags		-- Restore to the state of the last save

   showPass dyn_flags 
	(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)
   let mod_name   = moduleName this_mod

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

   opts <- getOptionsFromSource input_fnpp
   processArgs dynamic_flags opts []
   dyn_flags <- getDynFlags

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
207
		_other -> do
		   let object_filename = ml_obj_file location

		   runPipeline (StopBefore Ln) ""
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
215
216

	   let linkable = LM unlinked_time mod_name
			     (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
228
229
230
	stub_o <- runPipeline (StopBefore Ln) "stub-compile"
			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
289
290
        staticLink obj_files pkg_deps

        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
310
311
runPipeline
  :: GhcMode		-- when to stop
  -> String		-- "stop after" flag
  -> Bool		-- final output is persistent?
  -> Maybe FilePath	-- where to put the output, optionally
  -> FilePath 		-- input filename
312
  -> Maybe ModLocation  -- a ModLocation for this module, if we have one
313
314
  -> IO FilePath	-- output filename

315
runPipeline todo stop_flag keep_output maybe_output_filename input_fn maybe_loc
316
317
318
319
  = do
  split <- readIORef v_Split_object_files
  let (basename, suffix) = splitFilename input_fn
      start_phase = startPhase suffix
320

321
322
323
324
325
326
      stop_phase = case todo of 
			StopBefore As | split -> SplitAs
			StopBefore phase      -> phase
			DoMkDependHS	      -> Ln
			DoLink                -> Ln
			DoMkDLL               -> Ln
327

328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
  -- 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...
347
348
349
  (output_fn, maybe_loc) <- 
	pipeLoop start_phase stop_phase input_fn basename suffix 
		 get_output_fn maybe_loc
350
351
352
353
354
355

  -- 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
356
	then do final_fn <- get_output_fn stop_phase maybe_loc
357
358
359
360
361
362
363
364
365
	        when (final_fn /= output_fn) $
	 	  copy ("Copying `" ++ output_fn ++ "' to `" ++ final_fn
			++ "'") output_fn final_fn
	        return final_fn
	else
	     return output_fn


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

369
370
371
372
pipeLoop phase stop_phase input_fn orig_basename orig_suff 
	get_output_fn maybe_loc

  | phase == stop_phase  =  return (input_fn, maybe_loc)  -- all done
373
374
375
376
377
378
379
380
381

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

382
383
  | otherwise = do
	maybe_next_phase <- runPhase phase orig_basename orig_suff input_fn
384
				get_output_fn maybe_loc
385
	case maybe_next_phase of
386
	  (Nothing, maybe_loc, output_fn) -> do
387
388
		-- we stopped early, but return the *final* filename
		-- (it presumably already exists)
389
390
391
		final_fn <- get_output_fn stop_phase maybe_loc
		return (final_fn, maybe_loc)
	  (Just next_phase, maybe_loc, output_fn) ->
392
		pipeLoop next_phase stop_phase output_fn
393
			orig_basename orig_suff get_output_fn maybe_loc
394
395
396

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

416
	func next_phase maybe_location
417
418
419
420
421
		| 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

422
	   where
423
424
425
426
427
428
429
430
431
432
433
		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

434
		suffix = myPhaseInputExt next_phase
435
436
437
438
439
440

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

441
		persistent = basename ++ '.':suffix
442

443
		odir_persistent
444
		   | Just loc <- maybe_location = ml_obj_file loc
445
446
447
		   | Just d <- odir = replaceFilenameDirectory persistent d
		   | otherwise      = persistent

448
   return func
449
450


451
452
453
454
455
456
457
458
459
460
461
462
463
464
-- -----------------------------------------------------------------------------
-- 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
	  -> String	-- basename of original input source
	  -> String	-- its extension
	  -> FilePath	-- name of file which contains the input to this phase.
465
466
467
468
469
470
	  -> (Phase -> Maybe ModLocation -> IO FilePath)
			-- how to calculate the output filename
	  -> Maybe ModLocation		-- the ModLocation, if we have one
	  -> IO (Maybe Phase,  		-- next phase
		 Maybe ModLocation,	-- the ModLocation, if we have one
		 FilePath)		-- output filename
471
472
473
474

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

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

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

487
       return (Just Cpp, maybe_loc, output_fn)
488
489
490
491

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

492
runPhase Cpp basename suff input_fn get_output_fn maybe_loc
493
  = do src_opts <- getOptionsFromSource input_fn
494
       unhandled_flags <- processArgs dynamic_flags src_opts []
495
       checkProcessArgsResult unhandled_flags basename suff
496

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

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

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

530
531
532
-----------------------------------------------------------------------------
-- Hsc phase

533
534
-- Compilation of a single module, in "legacy" mode (_not_ under
-- the direction of the compilation manager).
535
runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do
536
537
  todo <- readIORef v_GhcMode
  if todo == DoMkDependHS then do
538
539
       locn <- doMkDependHSPhase basename suff input_fn
       return (Nothing, Just locn, input_fn)  -- Ln is a dummy stop phase 
540
541
542
543

   else do
      -- normal Hsc mode, not mkdependHS

544
545
546
  -- 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.
547
	let current_dir = directoryOf basename
548
	
549
550
	paths <- readIORef v_Include_paths
	writeIORef v_Include_paths (current_dir : paths)
551
	
552
  -- gather the imports and module name
553
        (_,_,mod_name) <- 
554
            if isExtCoreFilename ('.':suff)
555
556
557
558
559
560
	     then do
               -- no explicit imports in ExtCore input.
	       m <- getCoreModuleName input_fn
	       return ([], [], mkModuleName m)
	     else 
  	       getImportsFromFile input_fn
561

562
  -- build a ModLocation to pass to hscMain.
563
	(mod, location') <- mkHomeModLocation mod_name (basename ++ '.':suff)
564
565
566
567
568
569

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

570
571
572
573
  -- 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?)
  --
574
  -- Setting source_unchanged to True means that M.o seems
575
576
  -- to be up to date wrt M.hs; so no need to recompile unless imports have
  -- changed (which the compiler itself figures out).
577
  -- Setting source_unchanged to False tells the compiler that M.o is out of
578
  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
sof's avatar
sof committed
579
580
	do_recomp   <- readIORef v_Recomp
	expl_o_file <- readIORef v_Output_file
581
582
583
584
585

	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
586
		| otherwise = ml_obj_file location
587

588
589
	source_unchanged <- 
          if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
590
	     then return False
591
592
593
	     else do t1 <- getModificationTime (basename ++ '.':suff)
		     o_file_exists <- doesFileExist o_file
		     if not o_file_exists
594
		        then return False	-- Need to recompile
595
596
			else do t2 <- getModificationTime o_file
			        if t2 > t1
597
598
				  then return True
				  else return False
599

600
  -- get the DynFlags
601
        dyn_flags <- getDynFlags
602
603
	hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
	next_phase <- hscNextPhase hsc_lang
604
	output_fn <- get_output_fn next_phase (Just location)
605

606
607
        let dyn_flags' = dyn_flags { hscLang = hsc_lang,
				     hscOutName = output_fn,
608
		   		     hscStubCOutName = basename ++ "_stub.c",
apt's avatar
apt committed
609
				     hscStubHOutName = basename ++ "_stub.h",
apt's avatar
apt committed
610
				     extCoreName = basename ++ ".hcr" }
611
	hsc_env <- newHscEnv OneShot dyn_flags'
612

613
  -- run the compiler!
614
	result <- hscMain hsc_env printErrorsAndWarnings mod
615
			  location{ ml_hspp_file=Just input_fn }
616
			  source_unchanged
617
			  False
618
			  Nothing	 -- no iface
619

620
	case result of
621

622
	    HscFail -> throwDyn (PhaseFailed "hsc" (ExitFailure 1))
623

624
            HscNoRecomp details iface -> do
625
		SysTools.touch "Touching object file" o_file
626
		return (Nothing, Just location, output_fn)
627

628
629
	    HscRecomp _details _rdr_env _iface 
		      stub_h_exists stub_c_exists
630
		      _maybe_interpreted_code -> do
631

632
633
634
635
636
637
		-- deal with stubs
		maybe_stub_o <- compileStub dyn_flags' stub_c_exists
		case maybe_stub_o of
		      Nothing -> return ()
		      Just stub_o -> add v_Ld_inputs stub_o
		case hscLang dyn_flags of
638
639
                      HscNothing -> return (Nothing, Just location, output_fn)
		      _ -> return (Just next_phase, Just location, output_fn)
640

641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
-----------------------------------------------------------------------------
-- Cmm phase

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

runPhase Cmm basename suff input_fn get_output_fn maybe_loc
  = do
        dyn_flags <- getDynFlags
	hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
	next_phase <- hscNextPhase hsc_lang
	output_fn <- get_output_fn next_phase maybe_loc

        let dyn_flags' = dyn_flags { hscLang = hsc_lang,
				     hscOutName = output_fn,
		   		     hscStubCOutName = basename ++ "_stub.c",
				     hscStubHOutName = basename ++ "_stub.h",
				     extCoreName = basename ++ ".hcr" }

	ok <- hscCmmFile dyn_flags' input_fn

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

	return (Just next_phase, maybe_loc, output_fn)

669
670
671
672
673
674
-----------------------------------------------------------------------------
-- 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.

675
runPhase cc_phase basename suff input_fn get_output_fn maybe_loc
676
   | cc_phase == Cc || cc_phase == HCc
677
   = do	cc_opts <- getOpts opt_c
rrt's avatar
rrt committed
678
       	cmdline_include_paths <- readIORef v_Include_paths
679

680
681
682
	split  <- readIORef v_Split_object_files
	mangle <- readIORef v_Do_asm_mangling

683
684
        let hcc = cc_phase == HCc

685
686
687
688
	    next_phase
		| hcc && mangle     = Mangle
		| otherwise         = As

689
	output_fn <- get_output_fn next_phase maybe_loc
690

691
692
693
694
695
696
697
	-- 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 :)
        pkg_include_dirs <- getPackageIncludePath pkgs
rrt's avatar
rrt committed
698
699
        let include_paths = foldr (\ x xs -> "-I" : x : xs) []
			      (cmdline_include_paths ++ pkg_include_dirs)
700

701
	mangle <- readIORef v_Do_asm_mangling
702
703
	(md_c_flags, md_regd_c_flags) <- machdepCCOpts

704
        verb <- getVerbFlag
705

706
	pkg_extra_cc_opts <- getPackageExtraCcOpts pkgs
707

708
	split_objs <- readIORef v_Split_object_files
sof's avatar
sof committed
709
710
	let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
		      | otherwise         = [ ]
711

712
	excessPrecision <- readIORef v_Excess_precision
713
714
715
716
717
718
719
720
721

	-- 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       = [ ]

	SysTools.runCc (langopt ++
			[ SysTools.FileOption "" input_fn
sof's avatar
sof committed
722
			, SysTools.Option "-o"
sof's avatar
sof committed
723
			, SysTools.FileOption "" output_fn
sof's avatar
sof committed
724
725
726
			]
		       ++ map SysTools.Option (
		          md_c_flags
727
728
729
		       ++ (if cc_phase == HCc && mangle
		  	     then md_regd_c_flags
		  	     else [])
730
		       ++ [ verb, "-S", "-Wimplicit", "-O" ]
731
732
		       ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
		       ++ cc_opts
sof's avatar
sof committed
733
		       ++ split_opt
734
735
736
		       ++ (if excessPrecision then [] else [ "-ffloat-store" ])
		       ++ include_paths
		       ++ pkg_extra_cc_opts
sof's avatar
sof committed
737
		       ))
738

739
	return (Just next_phase, maybe_loc, output_fn)
740
741
742
743
744
745

	-- ToDo: postprocess the output from gcc

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

746
runPhase Mangle _basename _suff input_fn get_output_fn maybe_loc
747
748
749
750
751
752
753
754
755
756
   = do mangler_opts <- getOpts opt_m
        machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
			  then do n_regs <- dynFlag stolen_x86_regs
			          return [ show n_regs ]
		          else return []

	split <- readIORef v_Split_object_files
	let next_phase
		| split = SplitMangle
		| otherwise = As
757
	output_fn <- get_output_fn next_phase maybe_loc
758

759
	SysTools.runMangle (map SysTools.Option mangler_opts
sof's avatar
sof committed
760
761
		          ++ [ SysTools.FileOption "" input_fn
			     , SysTools.FileOption "" output_fn
sof's avatar
sof committed
762
763
			     ]
			  ++ map SysTools.Option machdep_opts)
764

765
	return (Just next_phase, maybe_loc, output_fn)
766
767
768
769

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

770
runPhase SplitMangle _basename _suff input_fn get_output_fn maybe_loc
771
772
773
774
  = 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
775

sof's avatar
sof committed
776
777
778
	SysTools.runSplit [ SysTools.FileOption "" input_fn
			  , SysTools.FileOption "" split_s_prefix
			  , SysTools.FileOption "" n_files_fn
sof's avatar
sof committed
779
			  ]
780
781
782
783
784
785
786
787
788

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

790
791
	return (Just SplitAs, maybe_loc, "**splitmangle**")
	  -- we don't use the filename
792
793
794
795

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

796
runPhase As _basename _suff input_fn get_output_fn maybe_loc
797
  = do	as_opts		      <- getOpts opt_a
798
        cmdline_include_paths <- readIORef v_Include_paths
799

800
	output_fn <- get_output_fn Ln maybe_loc
801

802
803
804
805
	-- we create directories for the object file, because it
	-- might be a hierarchical module.
	createDirectoryHierarchy (directoryOf output_fn)

sof's avatar
sof committed
806
807
808
	SysTools.runAs (map SysTools.Option as_opts
		       ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
		       ++ [ SysTools.Option "-c"
sof's avatar
sof committed
809
		          , SysTools.FileOption "" input_fn
sof's avatar
sof committed
810
			  , SysTools.Option "-o"
sof's avatar
sof committed
811
			  , SysTools.FileOption "" output_fn
sof's avatar
sof committed
812
			  ])
813

814
	return (Just Ln, maybe_loc, output_fn)
815
816


817
runPhase SplitAs basename _suff _input_fn get_output_fn maybe_loc
818
  = do  as_opts <- getOpts opt_a
819

820
	(split_s_prefix, n) <- readIORef v_Split_info
821

822
	odir <- readIORef v_Output_dir
823
	let real_odir = case odir of
824
				Nothing -> basename ++ "_split"
825
826
				Just d  -> d

827
828
	let assemble_file n
	      = do  let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
829
		    let output_o = replaceFilenameDirectory
830
					(basename ++ "__" ++ show n ++ ".o")
831
					 real_odir
832
		    real_o <- osuf_ify output_o
sof's avatar
sof committed
833
834
835
		    SysTools.runAs (map SysTools.Option as_opts ++
		    		    [ SysTools.Option "-c"
				    , SysTools.Option "-o"
sof's avatar
sof committed
836
837
				    , SysTools.FileOption "" real_o
				    , SysTools.FileOption "" input_s
sof's avatar
sof committed
838
				    ])
839
840
	
	mapM_ assemble_file [1..n]
841

842
843
	output_fn <- get_output_fn Ln maybe_loc
	return (Just Ln, maybe_loc, output_fn)
844

rrt's avatar
rrt committed
845
846
847
848
849
#ifdef ILX
-----------------------------------------------------------------------------
-- Ilx2Il phase
-- Run ilx2il over the ILX output, getting an IL file

850
runPhase Ilx2Il _basename _suff input_fn get_output_fn maybe_loc
rrt's avatar
rrt committed
851
  = do	ilx2il_opts <- getOpts opt_I
rrt's avatar
rrt committed
852
853
854
855
        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
856
857
				SysTools.FileOption "" output_fn,
				SysTools.FileOption "" input_fn ])
858
	return True
rrt's avatar
rrt committed
859
860
861
862
863

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

864
runPhase Ilasm _basename _suff input_fn get_output_fn maybe_loc
rrt's avatar
rrt committed
865
  = do	ilasm_opts <- getOpts opt_i
rrt's avatar
rrt committed
866
867
868
        SysTools.runIlasm (map SysTools.Option ilasm_opts
		           ++ [ SysTools.Option "/QUIET",
				SysTools.Option "/DLL",
sof's avatar
sof committed
869
870
				SysTools.FileOption "/OUT=" output_fn,
				SysTools.FileOption "" input_fn ])
871
	return True
rrt's avatar
rrt committed
872

ross's avatar
ross committed
873
#endif /* ILX */
rrt's avatar
rrt committed
874

875
876
877
878
879
880
-----------------------------------------------------------------------------
-- 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.
881
-- This is called from staticLink below, after linking. I haven't made it
882
883
884
885
-- 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

886
runPhase_MoveBinary input_fn
887
  = do	
888
        sysMan   <- getSysMan
889
890
891
892
893
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
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
        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);"
 ]

959
960
961
962
-----------------------------------------------------------------------------
-- Complain about non-dynamic flags in OPTIONS pragmas

checkProcessArgsResult flags basename suff
sof's avatar
sof committed
963
  = do when (notNull flags) (throwDyn (ProgramError (
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
	  showSDoc (hang (text basename <> text ('.':suff) <> char ':')
		      4 (text "unknown flags in  {-# OPTIONS #-} pragma:" <+>
			  hsep (map text flags)))
	)))

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

getHCFilePackages :: FilePath -> IO [PackageName]
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 ->
	  return (map mkPackageName (words rest))
      _other ->
	  return []
981

982
-----------------------------------------------------------------------------
983
-- Static linking, of .o files
984

985
986
987
988
989
990
991
992
993
994
995
996
-- 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.

staticLink :: [FilePath] -> [PackageName] -> IO ()
staticLink o_files dep_packages = do
997
998
    verb       <- getVerbFlag
    static     <- readIORef v_Static
999
1000
    no_hs_main <- readIORef v_NoHsMain

1001
1002
1003
1004
    -- 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.

1005
    o_file <- readIORef v_Output_file
1006
1007
1008
#if defined(mingw32_HOST_OS)
    let output_fn = case o_file of { Just s -> s; Nothing -> "main.exe"; }
#else
1009
    let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1010
#endif
1011

1012
    pkg_lib_paths <- getPackageLibraryPath dep_packages
1013
1014
    let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths

1015
    lib_paths <- readIORef v_Library_paths
1016
1017
    let lib_path_opts = map ("-L"++) lib_paths

1018
    pkg_link_opts <- getPackageLinkOpts dep_packages
1019

1020
#ifdef darwin_TARGET_OS
1021
    pkg_framework_paths <- getPackageFrameworkPath dep_packages
1022
1023
1024
1025
1026
    let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths

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

1027
    pkg_frameworks <- getPackageFrameworks dep_packages
1028
    let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1029
1030

    frameworks <- readIORef v_Cmdline_frameworks
1031
    let framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1032
1033
1034
	 -- reverse because they're added in reverse order from the cmd line
#endif

1035
	-- probably _stub.o files
1036
    extra_ld_inputs <- readIORef v_Ld_inputs
1037

1038
	-- opts from -optl-<blah> (including -l<blah> options)
1039
    extra_ld_opts <- getStaticOpts v_Opt_l
1040

1041
    [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage]
1042

1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
    ways <- readIORef v_Ways

    -- Here are some libs that need to be linked at the *end* of
    -- the command line, because they contain symbols that are referred to
    -- by the RTS.  We can't therefore use the ordinary way opts for these.
    let
	debug_opts | WayDebug `elem` ways = [ 
#if defined(HAVE_LIBBFD)
			"-lbfd", "-liberty"
#endif
			 ]
		   | otherwise            = []

    let
	thread_opts | WayThreaded `elem` ways = [ 
#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS)
			"-lpthread"
#endif
#if defined(osf3_TARGET_OS)
			, "-lexc"
#endif
			]
		    | otherwise               = []

1067
1068
    let extra_os = if static || no_hs_main
                   then []
1069
1070
                   else [ head (libraryDirs rts_pkg) ++ "/Main.dll_o",
                          head (libraryDirs std_pkg) ++ "/PrelMain.dll_o" ]
1071

1072
    (md_c_flags, _) <- machdepCCOpts
sof's avatar
sof committed
1073
1074
    SysTools.runLink ( [ SysTools.Option verb
    		       , SysTools.Option "-o"
sof's avatar
sof committed
1075
		       , SysTools.FileOption "" output_fn
sof's avatar
sof committed
1076
1077
1078
		       ]
		      ++ map SysTools.Option (
		         md_c_flags
1079
1080
1081
1082
	 	      ++ o_files
		      ++ extra_os
		      ++ extra_ld_inputs
	 	      ++ lib_path_opts
1083
	 	      ++ extra_ld_opts
1084
1085
1086
1087
#ifdef darwin_TARGET_OS
	 	      ++ framework_path_opts
	 	      ++ framework_opts
#endif
1088
	 	      ++ pkg_lib_path_opts
1089
	 	      ++ pkg_link_opts
1090
1091
1092
1093
#ifdef darwin_TARGET_OS
	 	      ++ pkg_framework_path_opts
	 	      ++ pkg_framework_opts
#endif
1094
1095
		      ++ debug_opts
		      ++ thread_opts
1096
		    ))
simonpj's avatar