DriverState.hs 14.7 KB
Newer Older
1
2
3
4
-----------------------------------------------------------------------------
--
-- Settings for the driver
--
5
-- (c) The University of Glasgow 2002
6
7
8
9
10
--
-----------------------------------------------------------------------------

module DriverState where

11
#include "../includes/ghcconfig.h"
12
13
14
#include "HsVersions.h"

import CmdLineOpts
15
import DriverPhases
16
17
18
import DriverUtil
import Util
import Config
19
import Panic
20

21
import DATA_IOREF	( IORef, readIORef, writeIORef )
22
23
import EXCEPTION

24
25
26
import List
import Char  
import Monad
27
28
import Maybe		( fromJust, isJust )
import Directory	( doesDirectoryExist )
29
30
31
32
33
34

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

cHaskell1Version = "5" -- i.e., Haskell 98

35
36
37
38
39
40
41
42
43
44
-----------------------------------------------------------------------------
-- GHC modes of operation

data GhcMode
  = DoMkDependHS			-- ghc -M
  | DoMkDLL				-- ghc --mk-dll
  | StopBefore Phase			-- ghc -E | -C | -S | -c
  | DoMake				-- ghc --make
  | DoInteractive			-- ghc --interactive
  | DoLink				-- [ the default ]
45
  | DoEval String			-- ghc -e
sof's avatar
sof committed
46
  deriving (Eq,Show)
47

48
49
50
51
52
53
54
GLOBAL_VAR(v_GhcMode,     DoLink, GhcMode)
GLOBAL_VAR(v_GhcModeFlag, "",     String)

setMode :: GhcMode -> String -> IO ()
setMode m flag = do
  old_mode <- readIORef v_GhcMode
  old_flag <- readIORef v_GhcModeFlag
sof's avatar
sof committed
55
  when (notNull old_flag && flag /= old_flag) $
56
57
58
59
      throwDyn (UsageError 
          ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
  writeIORef v_GhcMode m
  writeIORef v_GhcModeFlag flag
60

61
62
isCompManagerMode DoMake        = True
isCompManagerMode DoInteractive = True
63
isCompManagerMode (DoEval _)    = True
64
65
isCompManagerMode _             = False

66
67
68
-----------------------------------------------------------------------------
-- Global compilation flags

69
70
-- Default CPP defines in Haskell source
hsSourceCppOpts =
71
72
73
74
75
76
	[ "-D__HASKELL1__="++cHaskell1Version
	, "-D__GLASGOW_HASKELL__="++cProjectVersionInt				
	, "-D__HASKELL98__"
	, "-D__CONCURRENT_HASKELL__"
	]

sof's avatar
sof committed
77

78
-- Keep output from intermediate phases
79
80
81
82
83
GLOBAL_VAR(v_Keep_hi_diffs, 		False, 		Bool)
GLOBAL_VAR(v_Keep_hc_files,		False,		Bool)
GLOBAL_VAR(v_Keep_s_files,		False,		Bool)
GLOBAL_VAR(v_Keep_raw_s_files,		False,		Bool)
GLOBAL_VAR(v_Keep_tmp_files, 		False, 		Bool)
sof's avatar
sof committed
84
85
86
87
#ifdef ILX
GLOBAL_VAR(v_Keep_il_files,		False,		Bool)
GLOBAL_VAR(v_Keep_ilx_files,		False,		Bool)
#endif
88
89

-- Misc
90
91
GLOBAL_VAR(v_Scale_sizes_by,    	1.0,		Double)
GLOBAL_VAR(v_Static, 			True,		Bool)
92
GLOBAL_VAR(v_NoLink, 			False,		Bool)
93
GLOBAL_VAR(v_NoHsMain, 			False, 		Bool)
94
95
GLOBAL_VAR(v_MainModIs,			Nothing,	Maybe String)
GLOBAL_VAR(v_MainFunIs,			Nothing,	Maybe String)
96
97
98
99
GLOBAL_VAR(v_Recomp,  			True,		Bool)
GLOBAL_VAR(v_Collect_ghc_timing, 	False,		Bool)
GLOBAL_VAR(v_Do_asm_mangling,		True,		Bool)
GLOBAL_VAR(v_Excess_precision,		False,		Bool)
100
GLOBAL_VAR(v_Read_DotGHCi,		True,		Bool)
101

sof's avatar
sof committed
102
103
104
-- Preprocessor flags
GLOBAL_VAR(v_Hs_source_pp_opts, [], [String])

105
106
107
-----------------------------------------------------------------------------
-- Splitting object files (for libraries)

108
GLOBAL_VAR(v_Split_object_files,	False,		Bool)
109
110
111
GLOBAL_VAR(v_Split_info,		("",0),		(String,Int))
	-- The split prefix and number of files

112
113
	
can_split :: Bool
114
115
116
117
118
can_split =  prefixMatch "i386"    cTARGETPLATFORM
	  || prefixMatch "alpha"   cTARGETPLATFORM
	  || prefixMatch "hppa"    cTARGETPLATFORM
	  || prefixMatch "m68k"    cTARGETPLATFORM
	  || prefixMatch "mips"    cTARGETPLATFORM
119
	  || prefixMatch "powerpc" cTARGETPLATFORM
120
121
	  || prefixMatch "rs6000"  cTARGETPLATFORM
	  || prefixMatch "sparc"   cTARGETPLATFORM
122
123
124
125

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

126
127
128
GLOBAL_VAR(v_Output_dir,  Nothing, Maybe String)
GLOBAL_VAR(v_Output_file, Nothing, Maybe String)
GLOBAL_VAR(v_Output_hi,   Nothing, Maybe String)
129

sof's avatar
sof committed
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
-- called to verify that the output files & directories
-- point somewhere valid. 
--
-- The assumption is that the directory portion of these output
-- options will have to exist by the time 'verifyOutputFiles'
-- is invoked.
-- 
verifyOutputFiles :: IO ()
verifyOutputFiles = do
  odir <- readIORef v_Output_dir
  when (isJust odir) $ do
     let dir = fromJust odir
     flg <- doesDirectoryExist dir
     when (not flg) (nonExistentDir "-odir" dir)
  ofile <- readIORef v_Output_file
  when (isJust ofile) $ do
     let fn = fromJust ofile
     flg <- doesDirNameExist fn
     when (not flg) (nonExistentDir "-o" fn)
  ohi <- readIORef v_Output_hi
  when (isJust ohi) $ do
     let hi = fromJust ohi
     flg <- doesDirNameExist hi
     when (not flg) (nonExistentDir "-ohi" hi)
 where
   nonExistentDir flg dir = 
     throwDyn (CmdLineError ("error: directory portion of " ++ 
                             show dir ++ " does not exist (used with " ++ 
			     show flg ++ " option.)"))

160
GLOBAL_VAR(v_Object_suf,  phaseInputExt Ln, String)
161
GLOBAL_VAR(v_HC_suf,  	  Nothing, Maybe String)
162
GLOBAL_VAR(v_Hi_dir,      Nothing, Maybe String)
163
164
GLOBAL_VAR(v_Hi_suf,      "hi",	   String)

165
GLOBAL_VAR(v_Ld_inputs,	[],      [String])
166
167
168

odir_ify :: String -> IO String
odir_ify f = do
169
  odir_opt <- readIORef v_Output_dir
170
171
  case odir_opt of
	Nothing -> return f
172
	Just d  -> return (replaceFilenameDirectory f d)
173
174
175

osuf_ify :: String -> IO String
osuf_ify f = do
176
177
  osuf <- readIORef v_Object_suf
  return (replaceFilenameSuffix f osuf)
178

179
GLOBAL_VAR(v_StgStats,                  False, Bool)
180

181
182
183
184
185
186
187
buildStgToDo :: IO [ StgToDo ]
buildStgToDo = do
  stg_stats <- readIORef v_StgStats
  let flags1 | stg_stats = [ D_stg_stats ]
	     | otherwise = [ ]

	-- STG passes
188
  ways_ <- readIORef v_Ways
189
190
191
192
193
  let flags2 | WayProf `elem` ways_ = StgDoMassageForProfiling : flags1
	     | otherwise            = flags1

  return flags2

194
195
196
197
198
-----------------------------------------------------------------------------
-- Paths & Libraries

split_marker = ':'   -- not configurable (ToDo)

199
v_Include_paths, v_Library_paths :: IORef [String]
200
GLOBAL_VAR(v_Include_paths, [], [String])
201
GLOBAL_VAR(v_Library_paths, [],	 [String])
202

203
204
205
206
207
#ifdef darwin_TARGET_OS
GLOBAL_VAR(v_Framework_paths, [], [String])
GLOBAL_VAR(v_Cmdline_frameworks, [], [String])
#endif

208
209
addToDirList :: IORef [String] -> String -> IO ()
addToDirList ref path
sof's avatar
sof committed
210
  = do paths           <- readIORef ref
211
212
213
214
215
216
       shiny_new_ones  <- splitPathList path
       writeIORef ref (paths ++ shiny_new_ones)


splitPathList :: String -> IO [String]
splitPathList s = do ps <- splitUp s; return (filter notNull ps)
217
218
219
220
		-- empty paths are ignored: there might be a trailing
		-- ':' in the initial list, for example.  Empty paths can
		-- cause confusion when they are translated into -I options
		-- for passing to gcc.
sof's avatar
sof committed
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
  where
#ifdef mingw32_TARGET_OS
     -- 'hybrid' support for DOS-style paths in directory lists.
     -- 
     -- That is, if "foo:bar:baz" is used, this interpreted as
     -- consisting of three entries, 'foo', 'bar', 'baz'.
     -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted
     -- as four elts, "c:/foo", "c:\\foo", "x", and "/bar" --
     -- *provided* c:/foo exists and x:/bar doesn't.
     --
     -- Notice that no attempt is made to fully replace the 'standard'
     -- split marker ':' with the Windows / DOS one, ';'. The reason being
     -- that this will cause too much breakage for users & ':' will
     -- work fine even with DOS paths, if you're not insisting on being silly.
     -- So, use either.
    splitUp []         = return []
    splitUp (x:':':div:xs) 
      | div `elem` dir_markers = do
          let (p,rs) = findNextPath xs
          ps  <- splitUp rs
           {-
             Consult the file system to check the interpretation
             of (x:':':div:p) -- this is arguably excessive, we
             could skip this test & just say that it is a valid
             dir path.
           -}
          flg <- doesDirectoryExist (x:':':div:p)
          if flg then
             return ((x:':':div:p):ps)
           else
             return ([x]:(div:p):ps)
    splitUp xs = do
      let (p,rs) = findNextPath xs
      ps <- splitUp rs
      return (cons p ps)
    
    cons "" xs = xs
    cons x  xs = x:xs

    -- will be called either when we've consumed nought or the "<Drive>:/" part of
    -- a DOS path, so splitting is just a Q of finding the next split marker.
    findNextPath xs = 
        case break (`elem` split_markers) xs of
	   (p, d:ds) -> (p, ds)
	   (p, xs)   -> (p, xs)

    split_markers :: [Char]
    split_markers = [':', ';']

    dir_markers :: [Char]
    dir_markers = ['/', '\\']

#else
    splitUp xs = return (split split_marker xs)
#endif
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292

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

293
GLOBAL_VAR(v_Build_tag, "", String)
294

295
296
297
298
-- The RTS has its own build tag, because there are some ways that
-- affect the RTS only.
GLOBAL_VAR(v_RTS_Build_tag, "", String)

299
data WayName
300
301
302
  = WayThreaded
  | WayDebug
  | WayProf
303
304
305
306
307
  | WayUnreg
  | WayTicky
  | WayPar
  | WayGran
  | WaySMP
chak's avatar
chak committed
308
  | WayNDP
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
  | 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)

328
GLOBAL_VAR(v_Ways, [] ,[WayName])
329

330
331
332
allowed_combination way = and [ x `allowedWith` y 
			      | x <- way, y <- way, x < y ]
  where
333
334
335
336
	-- Note ordering in these tests: the left argument is
	-- <= the right argument, according to the Ord instance
	-- on Way above.

337
338
339
340
	-- debug is allowed with everything
	_ `allowedWith` WayDebug		= True
	WayDebug `allowedWith` _		= True

341
	WayThreaded `allowedWith` WayProf	= True
342
343
344
	WayProf `allowedWith` WayUnreg		= True
	WayProf `allowedWith` WaySMP		= True
	WayProf `allowedWith` WayNDP		= True
345
	_ `allowedWith` _ 			= False
346

347
348
349

findBuildTag :: IO [String]  -- new options
findBuildTag = do
350
  way_names <- readIORef v_Ways
351
352
353
354
355
356
  let ws = sort way_names
  if not (allowed_combination ws)
      then throwDyn (CmdLineError $
      		    "combination not supported: "  ++
      		    foldr1 (\a b -> a ++ '/':b) 
      		    (map (wayName . lkupWay) ws))
357
358
359
360
      else let ways    = map lkupWay ws
      	       tag     = mkBuildTag (filter (not.wayRTSOnly) ways)
      	       rts_tag = mkBuildTag ways
      	       flags   = map wayOpts ways
361
362
363
364
      	   in do
      	   writeIORef v_Build_tag tag
      	   writeIORef v_RTS_Build_tag rts_tag
      	   return (concat flags)
365

366
367
368
mkBuildTag :: [Way] -> String
mkBuildTag ways = concat (intersperse "_" (map wayTag ways))

369
370
371
372
373
374
lkupWay w = 
   case lookup w way_details of
	Nothing -> error "findBuildTag"
	Just details -> details

data Way = Way {
375
376
377
378
  wayTag     :: String,
  wayRTSOnly :: Bool,
  wayName    :: String,
  wayOpts    :: [String]
379
380
381
382
  }

way_details :: [ (WayName, Way) ]
way_details =
383
384
  [ (WayThreaded, Way "thr" True "Threaded" [
#if defined(freebsd_TARGET_OS)
385
386
	  "-optc-pthread"
        , "-optl-pthread"
387
388
389
390
391
392
#endif
	] ),

    (WayDebug, Way "debug" True "Debug" [] ),

    (WayProf, Way  "p" False "Profiling"
393
394
395
396
397
	[ "-fscc-profiling"
	, "-DPROFILING"
	, "-optc-DPROFILING"
	, "-fvia-C" ]),

398
    (WayTicky, Way  "t" False "Ticky-ticky Profiling"  
399
400
401
402
403
	[ "-fticky-ticky"
	, "-DTICKY_TICKY"
	, "-optc-DTICKY_TICKY"
	, "-fvia-C" ]),

404
    (WayUnreg, Way  "u" False "Unregisterised" 
405
	unregFlags ),
406

407
    -- optl's below to tell linker where to find the PVM library -- HWL
408
    (WayPar, Way  "mp" False "Parallel" 
409
410
411
412
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-package concurrent"
413
414
415
416
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
        , "-optl-lgpvm3"
417
418
	, "-fvia-C" ]),

419
    -- at the moment we only change the RTS and could share compiler and libs!
420
    (WayPar, Way  "mt" False "Parallel ticky profiling" 
421
422
423
424
425
426
427
428
429
430
431
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-optc-DPAR_TICKY"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
        , "-optl-lgpvm3"
	, "-fvia-C" ]),

432
    (WayPar, Way  "md" False "Distributed" 
433
434
435
436
437
438
439
440
441
442
443
444
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-D__DISTRIBUTED_HASKELL__"
	, "-optc-DPAR"
	, "-optc-DDIST"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
        , "-optl-lgpvm3"
	, "-fvia-C" ]),

445
    (WayGran, Way  "mg" False "GranSim"
446
447
448
449
450
451
	[ "-fgransim"
	, "-D__GRANSIM__"
	, "-optc-DGRAN"
	, "-package concurrent"
	, "-fvia-C" ]),

452
    (WaySMP, Way  "s" False "SMP"
453
454
	[ "-fsmp"
	, "-optc-pthread"
455
#ifndef freebsd_TARGET_OS
456
	, "-optl-pthread"
457
#endif
458
459
460
	, "-optc-DSMP"
	, "-fvia-C" ]),

461
    (WayNDP, Way  "ndp" False "Nested data parallelism"
chak's avatar
chak committed
462
463
464
	[ "-fparr"
	, "-fflatten"]),

465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
    (WayUser_a,  Way  "a"  False "User way 'a'"  ["$WAY_a_REAL_OPTS"]),	
    (WayUser_b,  Way  "b"  False "User way 'b'"  ["$WAY_b_REAL_OPTS"]),	
    (WayUser_c,  Way  "c"  False "User way 'c'"  ["$WAY_c_REAL_OPTS"]),	
    (WayUser_d,  Way  "d"  False "User way 'd'"  ["$WAY_d_REAL_OPTS"]),	
    (WayUser_e,  Way  "e"  False "User way 'e'"  ["$WAY_e_REAL_OPTS"]),	
    (WayUser_f,  Way  "f"  False "User way 'f'"  ["$WAY_f_REAL_OPTS"]),	
    (WayUser_g,  Way  "g"  False "User way 'g'"  ["$WAY_g_REAL_OPTS"]),	
    (WayUser_h,  Way  "h"  False "User way 'h'"  ["$WAY_h_REAL_OPTS"]),	
    (WayUser_i,  Way  "i"  False "User way 'i'"  ["$WAY_i_REAL_OPTS"]),	
    (WayUser_j,  Way  "j"  False "User way 'j'"  ["$WAY_j_REAL_OPTS"]),	
    (WayUser_k,  Way  "k"  False "User way 'k'"  ["$WAY_k_REAL_OPTS"]),	
    (WayUser_l,  Way  "l"  False "User way 'l'"  ["$WAY_l_REAL_OPTS"]),	
    (WayUser_m,  Way  "m"  False "User way 'm'"  ["$WAY_m_REAL_OPTS"]),	
    (WayUser_n,  Way  "n"  False "User way 'n'"  ["$WAY_n_REAL_OPTS"]),	
    (WayUser_o,  Way  "o"  False "User way 'o'"  ["$WAY_o_REAL_OPTS"]),	
    (WayUser_A,  Way  "A"  False "User way 'A'"  ["$WAY_A_REAL_OPTS"]),	
    (WayUser_B,  Way  "B"  False "User way 'B'"  ["$WAY_B_REAL_OPTS"]) 
482
483
  ]

484
485
486
487
488
489
490
unregFlags = 
   [ "-optc-DNO_REGS"
   , "-optc-DUSE_MINIINTERPRETER"
   , "-fno-asm-mangling"
   , "-funregisterised"
   , "-fvia-C" ]

491
-----------------------------------------------------------------------------
492
-- Options for particular phases
493

494
495
496
497
498
GLOBAL_VAR(v_Opt_dep,    [], [String])
GLOBAL_VAR(v_Anti_opt_C, [], [String])
GLOBAL_VAR(v_Opt_C,      [], [String])
GLOBAL_VAR(v_Opt_l,      [], [String])
GLOBAL_VAR(v_Opt_dll,    [], [String])
499

500
501
getStaticOpts :: IORef [String] -> IO [String]
getStaticOpts ref = readIORef ref >>= return . reverse