Main.hs 77.5 KB
Newer Older
1
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
2
-----------------------------------------------------------------------------
3
-- $Id: Main.hs,v 1.59 2000/09/14 08:17:54 simonpj Exp $
4
--
5
6
7
8
9
10
-- GHC Driver program
--
-- (c) Simon Marlow 2000
--
-----------------------------------------------------------------------------

rrt's avatar
rrt committed
11
12
13
-- with path so that ghc -M can find config.h
#include "../includes/config.h"

14
15
module Main (main) where

16
import GetImports
17
18
19
20
21
import Package
import Config

import RegexString
import Concurrent
rrt's avatar
rrt committed
22
#ifndef mingw32_TARGET_OS
23
import Posix
rrt's avatar
rrt committed
24
25
#endif
import Directory
26
27
28
29
30
import IOExts
import Exception
import Dynamic

import IO
31
import Monad
32
33
34
35
36
import List
import System
import Maybe
import Char

rrt's avatar
rrt committed
37
38
39
40
#ifdef mingw32_TARGET_OS
foreign import "_getpid" getProcessID :: IO Int 
#endif

41
42
43
44
45
46
47
#define GLOBAL_VAR(name,value,ty)  \
name = global (value) :: IORef (ty); \
{-# NOINLINE name #-}

-----------------------------------------------------------------------------
-- ToDo:

48
49
-- certain options in OPTIONS pragmas are persistent through subsequent compilations.
-- new mkdependHS doesn't support all the options that the old one did (-X et al.)
50
51
52
53
54
-- time commands when run with -v
-- split marker
-- mkDLL
-- java generation
-- user ways
rrt's avatar
rrt committed
55
-- Win32 support: proper signal handling
56
-- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
57
-- reading the package configuration file is too slow
58
59
60
61

-----------------------------------------------------------------------------
-- Differences vs. old driver:

62
-- No more "Enter your Haskell program, end with ^D (on a line of its own):"
63
64
65
66
67
68
69
70
-- consistency checking removed (may do this properly later)
-- removed -noC
-- no hi diffs (could be added later)
-- no -Ofile

-----------------------------------------------------------------------------
-- non-configured things

71
cHaskell1Version = "5" -- i.e., Haskell 98
72
73
74
75

-----------------------------------------------------------------------------
-- Usage Message

76
short_usage = "Usage: For basic information, try the `-help' option."
77
78
   
long_usage = do
79
80
81
  let usage_file = "ghc-usage.txt"
      usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
  usage <- readFile usage_path
82
83
84
85
86
87
88
  dump usage
  exitWith ExitSuccess
  where
     dump "" = return ()
     dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
     dump (c:s) = hPutChar stderr c >> dump s

89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
version_str = cProjectVersion

-----------------------------------------------------------------------------
-- Driver state

-- certain flags can be specified on a per-file basis, in an OPTIONS
-- pragma at the beginning of the source file.  This means that when
-- compiling mulitple files, we have to restore the global option
-- settings before compiling a new file.  
--
-- The DriverState record contains the per-file-mutable state.

data DriverState = DriverState {

	-- are we runing cpp on this file?
	cpp_flag 		:: Bool,

	-- heap/stack sizes
	specific_heap_size	:: Integer,
	specific_stack_size	:: Integer,
  
	-- misc
	stolen_x86_regs		:: Int,
	excess_precision	:: Bool,
	warning_opt		:: WarningState,
	cmdline_hc_includes	:: [String],

	-- options for a particular phase
	anti_opt_C		:: [String],
	opt_dep			:: [String],
	opt_L			:: [String],
	opt_P			:: [String],
	opt_C			:: [String],
	opt_Crts		:: [String],
	opt_c			:: [String],
	opt_a			:: [String],
	opt_m			:: [String],
	opt_l			:: [String],
	opt_dll			:: [String]
   }

initDriverState = DriverState {
	cpp_flag		= False,
	specific_heap_size	= 6 * 1000 * 1000,
	specific_stack_size	= 1000 * 1000,
	stolen_x86_regs		= 4,
	excess_precision	= False,
	warning_opt		= W_default,
	cmdline_hc_includes	= [],
	anti_opt_C		= [],
	opt_dep			= [],
	opt_L			= [],
	opt_P			= [],
	opt_C			= [],
	opt_Crts		= [],
	opt_c			= [],
	opt_a			= [],
	opt_m			= [],
	opt_l			= [],
	opt_dll			= []
   }
	
GLOBAL_VAR(driver_state, initDriverState, DriverState)

readState :: (DriverState -> a) -> IO a
readState f = readIORef driver_state >>= return . f

updateState :: (DriverState -> DriverState) -> IO ()
updateState f = readIORef driver_state >>= writeIORef driver_state . f

addAntiOpt_C a = updateState (\s -> s{anti_opt_C =  a : anti_opt_C s})
addOpt_dep   a = updateState (\s -> s{opt_dep    =  a : opt_dep    s})
addOpt_L     a = updateState (\s -> s{opt_L      =  a : opt_L      s})
addOpt_P     a = updateState (\s -> s{opt_P      =  a : opt_P      s})
addOpt_C     a = updateState (\s -> s{opt_C      =  a : opt_C      s})
addOpt_Crts  a = updateState (\s -> s{opt_Crts   =  a : opt_Crts   s})
addOpt_c     a = updateState (\s -> s{opt_c      =  a : opt_c      s})
addOpt_a     a = updateState (\s -> s{opt_a      =  a : opt_a      s})
addOpt_m     a = updateState (\s -> s{opt_m      =  a : opt_m      s})
addOpt_l     a = updateState (\s -> s{opt_l      =  a : opt_l      s})
addOpt_dll   a = updateState (\s -> s{opt_dll    =  a : opt_dll    s})

addCmdlineHCInclude a = 
   updateState (\s -> s{cmdline_hc_includes =  a : cmdline_hc_includes s})

	-- we add to the options from the front, so we need to reverse the list
getOpts :: (DriverState -> [a]) -> IO [a]
getOpts opts = readState opts >>= return . reverse

newHeapSize :: Integer -> IO ()
newHeapSize new = updateState 
   (\s -> let current = specific_heap_size s in
	  s{ specific_heap_size = if new > current then new else current })

newStackSize :: Integer -> IO ()
newStackSize new = updateState 
   (\s -> let current = specific_stack_size s in
	  s{ specific_stack_size = if new > current then new else current })
187

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
-----------------------------------------------------------------------------
-- Phases

{-
Phase of the           | Suffix saying | Flag saying   | (suffix of)
compilation system     | ``start here''| ``stop after''| output file

literate pre-processor | .lhs          | -             | -
C pre-processor (opt.) | -             | -E            | -
Haskell compiler       | .hs           | -C, -S        | .hc, .s
C compiler (opt.)      | .hc or .c     | -S            | .s
assembler              | .s  or .S     | -c            | .o
linker                 | other         | -             | a.out
-}

data Phase 
	= MkDependHS	-- haskell dependency generation
	| Unlit
	| Cpp
	| Hsc
	| Cc
	| HCc		-- Haskellised C (as opposed to vanilla C) compilation
	| Mangle	-- assembly mangling, now done by a separate script.
	| SplitMangle	-- after mangler if splitting
212
	| SplitAs
213
	| As
214
	| Ln 
215
  deriving (Eq)
216
217
218
219
220

-----------------------------------------------------------------------------
-- Errors

data BarfKind
221
  = PhaseFailed String ExitCode
222
  | Interrupted
223
224
  | UsageError String			-- prints the short usage msg after the error
  | OtherError String			-- just prints the error message
225
226
227
228
229
230
231
232
233
234
  deriving Eq

GLOBAL_VAR(prog_name, "ghc", String)

get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!

instance Show BarfKind where
  showsPrec _ e 
	= showString get_prog_name . showString ": " . showBarf e

235
236
237
238
239
showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
showBarf (OtherError str) = showString str
showBarf (PhaseFailed phase code) = 
	showString phase . showString " failed, code = " . shows code
showBarf (Interrupted) = showString "interrupted"
240

241
unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
242

243
barfKindTc = mkTyCon "BarfKind"
244
245
246
247
248
249
250
instance Typeable BarfKind where
  typeOf _ = mkAppTy barfKindTc []

-----------------------------------------------------------------------------
-- Temporary files

GLOBAL_VAR(files_to_clean, [], [String])
251
GLOBAL_VAR(keep_tmp_files, False, Bool)
252
253
254

cleanTempFiles :: IO ()
cleanTempFiles = do
255
  forget_it <- readIORef keep_tmp_files
256
  unless forget_it $ do
257

258
259
260
261
  fs <- readIORef files_to_clean
  verb <- readIORef verbose

  let blowAway f =
262
	   (do  when verb (hPutStrLn stderr ("removing: " ++ f))
263
		if '*' `elem` f then system ("rm -f " ++ f) >> return ()
rrt's avatar
rrt committed
264
			        else removeFile f)
265
	    `catchAllIO`
266
	   (\_ -> when verb (hPutStrLn stderr 
267
268
269
270
271
272
273
274
				("warning: can't remove tmp file" ++ f)))
  mapM_ blowAway fs

-----------------------------------------------------------------------------
-- Global compilation flags

	-- Cpp-related flags
hs_source_cpp_opts = global
275
	[ "-D__HASKELL1__="++cHaskell1Version
276
	, "-D__GLASGOW_HASKELL__="++cProjectVersionInt				
277
278
279
280
	, "-D__HASKELL98__"
	, "-D__CONCURRENT_HASKELL__"
	]

281
282
283
284
	-- Verbose
GLOBAL_VAR(verbose, False, Bool)
is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""

285
286
287
288
289
290
291
	-- Keep output from intermediate phases
GLOBAL_VAR(keep_hi_diffs, 	False, 		Bool)
GLOBAL_VAR(keep_hc_files,	False,		Bool)
GLOBAL_VAR(keep_s_files,	False,		Bool)
GLOBAL_VAR(keep_raw_s_files,	False,		Bool)

	-- Misc
292
GLOBAL_VAR(scale_sizes_by,      1.0,		Double)
293
294
GLOBAL_VAR(dry_run, 		False,		Bool)
GLOBAL_VAR(recomp,  		True,		Bool)
295
GLOBAL_VAR(tmpdir,		cDEFAULT_TMPDIR, String)
rrt's avatar
rrt committed
296
297
298
299
300
#if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
GLOBAL_VAR(static, 		True,		Bool)
#else
GLOBAL_VAR(static,              False,          Bool)
#endif
301
302
303
304
305
306
307
308
309
310
311
GLOBAL_VAR(collect_ghc_timing, 	False,		Bool)
GLOBAL_VAR(do_asm_mangling,	True,		Bool)

-----------------------------------------------------------------------------
-- Splitting object files (for libraries)

GLOBAL_VAR(split_object_files,	False,		Bool)
GLOBAL_VAR(split_prefix,	"",		String)
GLOBAL_VAR(n_split_files,	0,		Int)
	
can_split :: Bool
312
313
314
315
316
317
318
319
can_split =  prefixMatch "i386" cTARGETPLATFORM
	  || prefixMatch "alpha" cTARGETPLATFORM
	  || prefixMatch "hppa" cTARGETPLATFORM
	  || prefixMatch "m68k" cTARGETPLATFORM
	  || prefixMatch "mips" cTARGETPLATFORM
	  || prefixMatch "powerpc" cTARGETPLATFORM
	  || prefixMatch "rs6000" cTARGETPLATFORM
	  || prefixMatch "sparc" cTARGETPLATFORM
320
321
322
323
324
325
326
327

-----------------------------------------------------------------------------
-- Compiler output options

data HscLang
  = HscC
  | HscAsm
  | HscJava
328
  deriving Eq
329

330
GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" && 
331
332
			 (prefixMatch "i386" cTARGETPLATFORM ||
			  prefixMatch "sparc" cTARGETPLATFORM)
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
			then  HscAsm
			else  HscC, 
	   HscLang)

GLOBAL_VAR(output_dir,  Nothing, Maybe String)
GLOBAL_VAR(output_suf,  Nothing, Maybe String)
GLOBAL_VAR(output_file, Nothing, Maybe String)
GLOBAL_VAR(output_hi,   Nothing, Maybe String)

GLOBAL_VAR(ld_inputs,	[],      [String])

odir_ify :: String -> IO String
odir_ify f = do
  odir_opt <- readIORef output_dir
  case odir_opt of
	Nothing -> return f
349
	Just d  -> return (newdir d f)
350
351
352
353
354
355

osuf_ify :: String -> IO String
osuf_ify f = do
  osuf_opt <- readIORef output_suf
  case osuf_opt of
	Nothing -> return f
356
	Just s  -> return (newsuf s f)
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413

-----------------------------------------------------------------------------
-- Hi Files

GLOBAL_VAR(produceHi,    	True,	Bool)
GLOBAL_VAR(hi_on_stdout, 	False,	Bool)
GLOBAL_VAR(hi_with,      	"",	String)
GLOBAL_VAR(hi_suf,          	"hi",	String)

data HiDiffFlag = NormalHiDiffs | UsageHiDiffs | NoHiDiffs
GLOBAL_VAR(hi_diffs, NoHiDiffs, HiDiffFlag)

-----------------------------------------------------------------------------
-- Warnings & sanity checking

-- Warning packages that are controlled by -W and -Wall.  The 'standard'
-- warnings that you get all the time are
-- 	   
-- 	   -fwarn-overlapping-patterns
-- 	   -fwarn-missing-methods
--	   -fwarn-missing-fields
--	   -fwarn-deprecations
-- 	   -fwarn-duplicate-exports
-- 
-- these are turned off by -Wnot.

standardWarnings  = [ "-fwarn-overlapping-patterns"
		    , "-fwarn-missing-methods"
		    , "-fwarn-missing-fields"
		    , "-fwarn-deprecations"
		    , "-fwarn-duplicate-exports"
		    ]
minusWOpts    	  = standardWarnings ++ 
		    [ "-fwarn-unused-binds"
		    , "-fwarn-unused-matches"
		    , "-fwarn-incomplete-patterns"
		    , "-fwarn-unused-imports"
		    ]
minusWallOpts 	  = minusWOpts ++
		    [ "-fwarn-type-defaults"
		    , "-fwarn-name-shadowing"
		    , "-fwarn-missing-signatures"
		    ]

data WarningState = W_default | W_ | W_all | W_not

-----------------------------------------------------------------------------
-- Compiler optimisation options

GLOBAL_VAR(opt_level, 0, Int)

setOptLevel :: String -> IO ()
setOptLevel ""  	    = do { writeIORef opt_level 1; go_via_C }
setOptLevel "not" 	    = writeIORef opt_level 0
setOptLevel [c] | isDigit c = do
   let level = ord c - ord '0'
   writeIORef opt_level level
414
   when (level >= 1) go_via_C
415
setOptLevel s = unknownFlagErr ("-O"++s)
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519

go_via_C = do
   l <- readIORef hsc_lang
   case l of { HscAsm -> writeIORef hsc_lang HscC; 
	       _other -> return () }

GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)

GLOBAL_VAR(opt_MaxSimplifierIterations, 4, Int)
GLOBAL_VAR(opt_StgStats,    False, Bool)
GLOBAL_VAR(opt_UsageSPInf,  False, Bool)  -- Off by default

hsc_minusO2_flags = hsc_minusO_flags	-- for now

hsc_minusNoO_flags = do
  iter        <- readIORef opt_MaxSimplifierIterations
  return [ 
 	"-fignore-interface-pragmas",
	"-fomit-interface-pragmas",
	"-fsimplify",
	    "[",
	        "-fmax-simplifier-iterations" ++ show iter,
	    "]"
	]

hsc_minusO_flags = do
  iter       <- readIORef opt_MaxSimplifierIterations
  usageSP    <- readIORef opt_UsageSPInf
  stgstats   <- readIORef opt_StgStats

  return [ 
	"-ffoldr-build-on",

        "-fdo-eta-reduction",
	"-fdo-lambda-eta-expansion",
	"-fcase-of-case",
 	"-fcase-merge",
	"-flet-to-case",

	-- initial simplify: mk specialiser happy: minimum effort please

	"-fsimplify",
	  "[", 
		"-finline-phase0",
			-- Don't inline anything till full laziness has bitten
			-- In particular, inlining wrappers inhibits floating
			-- e.g. ...(case f x of ...)...
			--  ==> ...(case (case x of I# x# -> fw x#) of ...)...
			--  ==> ...(case x of I# x# -> case fw x# of ...)...
			-- and now the redex (f x) isn't floatable any more

		"-fno-rules",
			-- Similarly, don't apply any rules until after full 
			-- laziness.  Notably, list fusion can prevent floating.

		"-fno-case-of-case",
			-- Don't do case-of-case transformations.
			-- This makes full laziness work better

		"-fmax-simplifier-iterations2",
	  "]",

	-- Specialisation is best done before full laziness
	-- so that overloaded functions have all their dictionary lambdas manifest
	"-fspecialise",

	"-ffloat-outwards",
	"-ffloat-inwards",

	"-fsimplify",
	  "[", 
	  	"-finline-phase1",
		-- Want to run with inline phase 1 after the specialiser to give
		-- maximum chance for fusion to work before we inline build/augment
		-- in phase 2.  This made a difference in 'ansi' where an 
		-- overloaded function wasn't inlined till too late.
	        "-fmax-simplifier-iterations" ++ show iter,
	  "]",

	-- infer usage information here in case we need it later.
        -- (add more of these where you need them --KSW 1999-04)
        if usageSP then "-fusagesp" else "",

	"-fsimplify",
	  "[", 
		-- Need inline-phase2 here so that build/augment get 
		-- inlined.  I found that spectral/hartel/genfft lost some useful
		-- strictness in the function sumcode' if augment is not inlined
		-- before strictness analysis runs

		"-finline-phase2",
		"-fmax-simplifier-iterations2",
	  "]",

	"-fsimplify",
	  "[", 
		"-fmax-simplifier-iterations2",
		-- No -finline-phase: allow all Ids to be inlined now
		-- This gets foldr inlined before strictness analysis
	  "]",

	"-fstrictness",
	"-fcpr-analyse",
	"-fworker-wrapper",
520
	"-fglom-binds",
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575

	"-fsimplify",
	  "[", 
	        "-fmax-simplifier-iterations" ++ show iter,
		-- No -finline-phase: allow all Ids to be inlined now
	  "]",

	"-ffloat-outwards",
		-- nofib/spectral/hartel/wang doubles in speed if you
		-- do full laziness late in the day.  It only happens
		-- after fusion and other stuff, so the early pass doesn't
		-- catch it.  For the record, the redex is 
		--	  f_el22 (f_el21 r_midblock)

-- Leave out lambda lifting for now
--	  "-fsimplify",	-- Tidy up results of full laziness
--	    "[", 
--		  "-fmax-simplifier-iterations2",
--	    "]",
--	  "-ffloat-outwards-full",	

	-- We want CSE to follow the final full-laziness pass, because it may
	-- succeed in commoning up things floated out by full laziness.
	--
	-- CSE must immediately follow a simplification pass, because it relies
	-- on the no-shadowing invariant.  See comments at the top of CSE.lhs
	-- So it must NOT follow float-inwards, which can give rise to shadowing,
	-- even if its input doesn't have shadows.  Hence putting it between
	-- the two passes.
	"-fcse",	
			

	"-ffloat-inwards",

-- Case-liberation for -O2.  This should be after
-- strictness analysis and the simplification which follows it.

--	  ( ($OptLevel != 2)
--	  ? ""
--	  : "-fliberate-case -fsimplify [ $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fcase-merge -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MaxSimplifierIterations $Oopt_ShowSimplifierProgress ]" ),
--
--	  "-fliberate-case",

	-- Final clean-up simplification:
	"-fsimplify",
	  "[", 
	        "-fmax-simplifier-iterations" ++ show iter,
		-- No -finline-phase: allow all Ids to be inlined now
	  "]"

	]

-----------------------------------------------------------------------------
-- Paths & Libraries

576
split_marker = ':'   -- not configurable (ToDo)
577
578
579
580
581
582
583
584

import_paths, include_paths, library_paths :: IORef [String]
GLOBAL_VAR(import_paths,  ["."], [String])
GLOBAL_VAR(include_paths, ["."], [String])
GLOBAL_VAR(library_paths, [],	 [String])

GLOBAL_VAR(cmdline_libraries,   [], [String])

585
addToDirList :: IORef [String] -> String -> IO ()
586
addToDirList ref path
587
588
  = do paths <- readIORef ref
       writeIORef ref (paths ++ split split_marker path)
589
590
591
592

-----------------------------------------------------------------------------
-- Packages

593
594
595
596
597
598
599
600
601
602
603
GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)

listPackages :: IO ()
listPackages = do 
  details <- readIORef package_details
  hPutStr stdout (listPkgs details)
  hPutChar stdout '\n'
  exitWith ExitSuccess

newPackage :: IO ()
newPackage = do
604
605
  checkConfigAccess
  details <- readIORef package_details
606
607
608
609
  hPutStr stdout "Reading package info from stdin... "
  stuff <- getContents
  let new_pkg = read stuff :: (String,Package)
  catchAll new_pkg
610
  	(\_ -> throwDyn (OtherError "parse error in package info"))
611
  hPutStrLn stdout "done."
612
613
614
615
  if (fst new_pkg `elem` map fst details)
	then throwDyn (OtherError ("package `" ++ fst new_pkg ++ 
					"' already installed"))
	else do
616
617
618
619
620
621
  conf_file <- readIORef package_config
  savePackageConfig conf_file
  maybeRestoreOldConfig conf_file $ do
  writeNewConfig conf_file ( ++ [new_pkg])
  exitWith ExitSuccess

622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
deletePackage :: String -> IO ()
deletePackage pkg = do  
  checkConfigAccess
  details <- readIORef package_details
  if (pkg `notElem` map fst details)
	then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
	else do
  conf_file <- readIORef package_config
  savePackageConfig conf_file
  maybeRestoreOldConfig conf_file $ do
  writeNewConfig conf_file (filter ((/= pkg) . fst))
  exitWith ExitSuccess

checkConfigAccess :: IO ()
checkConfigAccess = do
  conf_file <- readIORef package_config
rrt's avatar
rrt committed
638
639
  access <- getPermissions conf_file
  unless (writable access)
rrt's avatar
rrt committed
640
	(throwDyn (OtherError "you don't have permission to modify the package configuration file"))
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
669
670
maybeRestoreOldConfig :: String -> IO () -> IO ()
maybeRestoreOldConfig conf_file io
  = catchAllIO io (\e -> do
        hPutStr stdout "\nWARNING: an error was encountered while the new \n\ 
        	       \configuration was being written.  Attempting to \n\ 
        	       \restore the old configuration... "
        system ("cp " ++ conf_file ++ ".old " ++ conf_file)
        hPutStrLn stdout "done."
	throw e
    )

writeNewConfig :: String -> ([(String,Package)] -> [(String,Package)]) -> IO ()
writeNewConfig conf_file fn = do
  hPutStr stdout "Writing new package config file... "
  old_details <- readIORef package_details
  h <- openFile conf_file WriteMode
  hPutStr h (dumpPackages (fn old_details))
  hClose h
  hPutStrLn stdout "done."

savePackageConfig :: String -> IO ()
savePackageConfig conf_file = do
  hPutStr stdout "Saving old package config file... "
    -- mv rather than cp because we've already done an hGetContents
    -- on this file so we won't be able to open it for writing
    -- unless we move the old one out of the way...
  system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
  hPutStrLn stdout "done."

671
672
673
674
675
676
677
678
679
-- package list is maintained in dependency order
packages = global ["std", "rts", "gmp"] :: IORef [String]
-- comma in value, so can't use macro, grrr
{-# NOINLINE packages #-}

addPackage :: String -> IO ()
addPackage package
  = do pkg_details <- readIORef package_details
       case lookup package pkg_details of
680
	  Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
681
682
	  Just details -> do
	    ps <- readIORef packages
683
684
685
686
	    unless (package `elem` ps) $ do
		mapM_ addPackage (package_deps details)
		ps <- readIORef packages
		writeIORef packages (package:ps)
687
688
689
690
691
692
693
694
695

getPackageImportPath   :: IO [String]
getPackageImportPath = do
  ps <- readIORef packages
  ps' <- getPackageDetails ps
  return (nub (concat (map import_dirs ps')))

getPackageIncludePath   :: IO [String]
getPackageIncludePath = do
696
  ps <- readIORef packages 
697
  ps' <- getPackageDetails ps
698
  return (nub (filter (not.null) (concatMap include_dirs ps')))
699
700
701
702
703
704

	-- includes are in reverse dependency order (i.e. rts first)
getPackageCIncludes   :: IO [String]
getPackageCIncludes = do
  ps <- readIORef packages
  ps' <- getPackageDetails ps
705
  return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
706
707
708
709
710
711
712
713
714
715
716
717
718

getPackageLibraryPath  :: IO [String]
getPackageLibraryPath = do
  ps <- readIORef packages
  ps' <- getPackageDetails ps
  return (nub (concat (map library_dirs ps')))

getPackageLibraries    :: IO [String]
getPackageLibraries = do
  ps <- readIORef packages
  ps' <- getPackageDetails ps
  tag <- readIORef build_tag
  let suffix = if null tag then "" else '_':tag
719
720
721
  return (concat (
	map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
     ))
722
723
724
725
726

getPackageExtraGhcOpts :: IO [String]
getPackageExtraGhcOpts = do
  ps <- readIORef packages
  ps' <- getPackageDetails ps
727
  return (concatMap extra_ghc_opts ps')
728
729
730
731
732

getPackageExtraCcOpts  :: IO [String]
getPackageExtraCcOpts = do
  ps <- readIORef packages
  ps' <- getPackageDetails ps
733
  return (concatMap extra_cc_opts ps')
734
735
736
737
738

getPackageExtraLdOpts  :: IO [String]
getPackageExtraLdOpts = do
  ps <- readIORef packages
  ps' <- getPackageDetails ps
739
  return (concatMap extra_ld_opts ps')
740

741
getPackageDetails :: [String] -> IO [Package]
742
743
getPackageDetails ps = do
  pkg_details <- readIORef package_details
744
  return [ pkg | p <- ps, Just pkg <- [ lookup p pkg_details ] ]
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768

GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])

-----------------------------------------------------------------------------
-- Ways

-- The central concept of a "way" is that all objects in a given
-- program must be compiled in the same "way".  Certain options change
-- parameters of the virtual machine, eg. profiling adds an extra word
-- to the object header, so profiling objects cannot be linked with
-- non-profiling objects.

-- After parsing the command-line options, we determine which "way" we
-- are building - this might be a combination way, eg. profiling+ticky-ticky.

-- We then find the "build-tag" associated with this way, and this
-- becomes the suffix used to find .hi files and libraries used in
-- this compilation.

GLOBAL_VAR(build_tag, "", String)

data WayName
  = WayProf
  | WayUnreg
rrt's avatar
rrt committed
769
  | WayDll
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
  | WayTicky
  | WayPar
  | WayGran
  | WaySMP
  | WayDebug
  | WayUser_a
  | WayUser_b
  | WayUser_c
  | WayUser_d
  | WayUser_e
  | WayUser_f
  | WayUser_g
  | WayUser_h
  | WayUser_i
  | WayUser_j
  | WayUser_k
  | WayUser_l
  | WayUser_m
  | WayUser_n
  | WayUser_o
  | WayUser_A
  | WayUser_B
  deriving (Eq,Ord)

GLOBAL_VAR(ways, [] ,[WayName])

rrt's avatar
rrt committed
796
797
-- ToDo: allow WayDll with any other allowed combination

798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
allowed_combinations = 
   [  [WayProf,WayUnreg],
      [WayProf,WaySMP]	   -- works???
   ]

findBuildTag :: IO [String]  -- new options
findBuildTag = do
  way_names <- readIORef ways
  case sort way_names of
     []  -> do  writeIORef build_tag ""
	        return []

     [w] -> do let details = lkupWay w
	       writeIORef build_tag (wayTag details)
	       return (wayOpts details)

     ws  -> if  ws `notElem` allowed_combinations
815
816
817
818
		then throwDyn (OtherError $
				"combination not supported: "  ++
   				foldr1 (\a b -> a ++ '/':b) 
				(map (wayName . lkupWay) ws))
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
		else let stuff = map lkupWay ws
			 tag   = concat (map wayTag stuff)
			 flags = map wayOpts stuff
		     in do
		     writeIORef build_tag tag
		     return (concat flags)

lkupWay w = 
   case lookup w way_details of
	Nothing -> error "findBuildTag"
	Just details -> details

data Way = Way {
  wayTag   :: String,
  wayName  :: String,
  wayOpts  :: [String]
  }

way_details :: [ (WayName, Way) ]
way_details =
  [ (WayProf, Way  "p" "Profiling"  
	[ "-fscc-profiling"
	, "-DPROFILING"
842
843
	, "-optc-DPROFILING"
	, "-fvia-C" ]),
844
845
846
847

    (WayTicky, Way  "t" "Ticky-ticky Profiling"  
	[ "-fticky-ticky"
	, "-DTICKY_TICKY"
848
849
	, "-optc-DTICKY_TICKY"
	, "-fvia-C" ]),
850
851
852
853
854

    (WayUnreg, Way  "u" "Unregisterised" 
	[ "-optc-DNO_REGS"
	, "-optc-DUSE_MINIINTERPRETER"
	, "-fno-asm-mangling"
855
856
	, "-funregisterised"
	, "-fvia-C" ]),
857

rrt's avatar
rrt committed
858
859
860
    (WayDll, Way  "dll" "DLLized"
        [ ]),

861
862
863
864
865
    (WayPar, Way  "mp" "Parallel" 
	[ "-fstack-check"
	, "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
866
867
	, "-package concurrent"
	, "-fvia-C" ]),
868
869
870
871
872
873

    (WayGran, Way  "mg" "Gransim" 
	[ "-fstack-check"
	, "-fgransim"
	, "-D__GRANSIM__"
	, "-optc-DGRAN"
874
875
	, "-package concurrent"
	, "-fvia-C" ]),
876

877
    (WaySMP, Way  "s" "SMP"
878
879
880
	[ "-fsmp"
	, "-optc-pthread"
	, "-optl-pthread"
881
882
	, "-optc-DSMP"
	, "-fvia-C" ]),
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905

    (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),	
    (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),	
    (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),	
    (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),	
    (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),	
    (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),	
    (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),	
    (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),	
    (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),	
    (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),	
    (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),	
    (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),	
    (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),	
    (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),	
    (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),	
    (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),	
    (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"]) 
  ]

-----------------------------------------------------------------------------
-- Programs for particular phases

906
GLOBAL_VAR(pgm_L,   findFile "unlit"      cGHC_UNLIT,      String)
907
GLOBAL_VAR(pgm_P,   cRAWCPP,				   String)
908
909
910
911
912
913
GLOBAL_VAR(pgm_C,   findFile "hsc"        cGHC_HSC,        String)
GLOBAL_VAR(pgm_c,   cGCC,	      	     	      	   String)
GLOBAL_VAR(pgm_m,   findFile "ghc-asm"    cGHC_MANGLER,    String)
GLOBAL_VAR(pgm_s,   findFile "ghc-split"  cGHC_SPLIT,      String)
GLOBAL_VAR(pgm_a,   cGCC,	      	     	           String)
GLOBAL_VAR(pgm_l,   cGCC,       	     	           String)
914
915
916
917
918
919
920
921
922

-----------------------------------------------------------------------------
-- Via-C compilation stuff

-- flags returned are: ( all C compilations
--		       , registerised HC compilations
--		       )

machdepCCOpts 
923
   | prefixMatch "alpha"   cTARGETPLATFORM  
924
925
	= return ( ["-static"], [] )

926
   | prefixMatch "hppa"    cTARGETPLATFORM  
927
928
929
930
        -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
        -- (very nice, but too bad the HP /usr/include files don't agree.)
	= return ( ["-static", "-D_HPUX_SOURCE"], [] )

931
   | prefixMatch "m68k"    cTARGETPLATFORM
932
933
934
935
936
937
938
939
940
941
942
      -- -fno-defer-pop : for the .hc files, we want all the pushing/
      --    popping of args to routines to be explicit; if we let things
      --    be deferred 'til after an STGJUMP, imminent death is certain!
      --
      -- -fomit-frame-pointer : *don't*
      --     It's better to have a6 completely tied up being a frame pointer
      --     rather than let GCC pick random things to do with it.
      --     (If we want to steal a6, then we would try to do things
      --     as on iX86, where we *do* steal the frame pointer [%ebp].)
	= return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )

943
   | prefixMatch "i386"    cTARGETPLATFORM  
944
945
946
947
      -- -fno-defer-pop : basically the same game as for m68k
      --
      -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
      --   the fp (%ebp) for our register maps.
948
	= do n_regs <- readState stolen_x86_regs
949
950
951
952
953
954
	     sta    <- readIORef static
	     return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
		      [ "-fno-defer-pop", "-fomit-frame-pointer",
	                "-DSTOLEN_X86_REGS="++show n_regs ]
		    )

955
   | prefixMatch "mips"    cTARGETPLATFORM
956
957
	= return ( ["static"], [] )

958
   | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
959
960
961
962
963
964
965
966
967
968
969
970
971
	= return ( ["static"], ["-finhibit-size-directive"] )

   | otherwise
	= return ( [], [] )

-----------------------------------------------------------------------------
-- Build the Hsc command line

build_hsc_opts :: IO [String]
build_hsc_opts = do
  opt_C_ <- getOpts opt_C		-- misc hsc opts

	-- warnings
972
  warn_level <- readState warning_opt
973
974
975
976
977
978
979
980
981
982
983
984
985
  let warn_opts =  case warn_level of
		  	W_default -> standardWarnings
		  	W_        -> minusWOpts
		  	W_all	  -> minusWallOpts
		  	W_not     -> []

	-- optimisation
  minus_o <- readIORef opt_level
  optimisation_opts <-
        case minus_o of
	    0 -> hsc_minusNoO_flags
	    1 -> hsc_minusO_flags
	    2 -> hsc_minusO2_flags
986
	    _ -> error "unknown opt level"
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
	    -- ToDo: -Ofile
 
	-- STG passes
  ways_ <- readIORef ways
  let stg_massage | WayProf `elem` ways_ =  "-fmassage-stg-for-profiling"
	          | otherwise            = ""

  stg_stats <- readIORef opt_StgStats
  let stg_stats_flag | stg_stats = "-dstg-stats"
		     | otherwise = ""

  let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
	-- let-no-escape always on for now

For faster browsing, not all history is shown. View entire blame