DriverState.hs 26.5 KB
Newer Older
1
-----------------------------------------------------------------------------
2
-- $Id: DriverState.hs,v 1.92 2003/06/23 10:35:17 simonpj Exp $
3 4 5
--
-- Settings for the driver
--
6
-- (c) The University of Glasgow 2002
7 8 9 10 11
--
-----------------------------------------------------------------------------

module DriverState where

sof's avatar
sof committed
12
#include "../includes/config.h"
13 14
#include "HsVersions.h"

15
import ParsePkgConf	( loadPackageConfig )
16 17
import SysTools		( getTopDir )
import Packages
18
import CmdLineOpts
19
import DriverPhases
20
import DriverUtil
21
import UniqFM		( eltsUFM )
22 23
import Util
import Config
24
import Panic
25

26
import DATA_IOREF	( IORef, readIORef, writeIORef )
27 28
import EXCEPTION

29 30 31
import List
import Char  
import Monad
32 33
import Maybe		( fromJust, isJust )
import Directory	( doesDirectoryExist )
34 35 36 37 38 39

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

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

40 41 42 43 44 45 46 47 48 49
-----------------------------------------------------------------------------
-- 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 ]
sof's avatar
sof committed
50
  deriving (Eq,Show)
51

52 53 54 55 56 57 58
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
59
  when (notNull old_flag && flag /= old_flag) $
60 61 62 63
      throwDyn (UsageError 
          ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
  writeIORef v_GhcMode m
  writeIORef v_GhcModeFlag flag
64

65 66 67 68
isCompManagerMode DoMake        = True
isCompManagerMode DoInteractive = True
isCompManagerMode _             = False

69 70 71 72
-----------------------------------------------------------------------------
-- Global compilation flags

-- Cpp-related flags
73
v_Hs_source_cpp_opts = global
74 75 76 77 78
	[ "-D__HASKELL1__="++cHaskell1Version
	, "-D__GLASGOW_HASKELL__="++cProjectVersionInt				
	, "-D__HASKELL98__"
	, "-D__CONCURRENT_HASKELL__"
	]
79
{-# NOINLINE v_Hs_source_cpp_opts #-}
80

sof's avatar
sof committed
81

82
-- Keep output from intermediate phases
83 84 85 86 87
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
88 89 90 91
#ifdef ILX
GLOBAL_VAR(v_Keep_il_files,		False,		Bool)
GLOBAL_VAR(v_Keep_ilx_files,		False,		Bool)
#endif
92 93

-- Misc
94 95
GLOBAL_VAR(v_Scale_sizes_by,    	1.0,		Double)
GLOBAL_VAR(v_Static, 			True,		Bool)
96
GLOBAL_VAR(v_NoLink, 			False,		Bool)
97
GLOBAL_VAR(v_NoHsMain, 			False, 		Bool)
98 99
GLOBAL_VAR(v_MainModIs,			Nothing,	Maybe String)
GLOBAL_VAR(v_MainFunIs,			Nothing,	Maybe String)
100 101 102 103
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)
104
GLOBAL_VAR(v_Read_DotGHCi,		True,		Bool)
105

sof's avatar
sof committed
106 107 108
-- Preprocessor flags
GLOBAL_VAR(v_Hs_source_pp_opts, [], [String])

109 110 111
-----------------------------------------------------------------------------
-- Splitting object files (for libraries)

112
GLOBAL_VAR(v_Split_object_files,	False,		Bool)
113 114 115
GLOBAL_VAR(v_Split_info,		("",0),		(String,Int))
	-- The split prefix and number of files

116 117
	
can_split :: Bool
118 119 120 121 122
can_split =  prefixMatch "i386"    cTARGETPLATFORM
	  || prefixMatch "alpha"   cTARGETPLATFORM
	  || prefixMatch "hppa"    cTARGETPLATFORM
	  || prefixMatch "m68k"    cTARGETPLATFORM
	  || prefixMatch "mips"    cTARGETPLATFORM
123
	  || prefixMatch "powerpc" cTARGETPLATFORM
124 125
	  || prefixMatch "rs6000"  cTARGETPLATFORM
	  || prefixMatch "sparc"   cTARGETPLATFORM
126 127 128 129

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

130 131 132
GLOBAL_VAR(v_Output_dir,  Nothing, Maybe String)
GLOBAL_VAR(v_Output_file, Nothing, Maybe String)
GLOBAL_VAR(v_Output_hi,   Nothing, Maybe String)
133

sof's avatar
sof committed
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
-- 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.)"))

164
GLOBAL_VAR(v_Object_suf,  phaseInputExt Ln, String)
165
GLOBAL_VAR(v_HC_suf,  	  Nothing, Maybe String)
166
GLOBAL_VAR(v_Hi_dir,      Nothing, Maybe String)
167 168
GLOBAL_VAR(v_Hi_suf,      "hi",	   String)

169
GLOBAL_VAR(v_Ld_inputs,	[],      [String])
170 171 172

odir_ify :: String -> IO String
odir_ify f = do
173
  odir_opt <- readIORef v_Output_dir
174 175
  case odir_opt of
	Nothing -> return f
176
	Just d  -> return (replaceFilenameDirectory f d)
177 178 179

osuf_ify :: String -> IO String
osuf_ify f = do
180 181
  osuf <- readIORef v_Object_suf
  return (replaceFilenameSuffix f osuf)
182 183 184 185

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

186
GLOBAL_VAR(v_OptLevel, 0, Int)
187

188 189 190 191
setOptLevel :: Int -> IO ()
setOptLevel n = do
  when (n >= 1) $ setLang HscC		-- turn on -fvia-C with -O
  writeIORef v_OptLevel n
192

193 194 195
GLOBAL_VAR(v_minus_o2_for_C,            False, Bool)
GLOBAL_VAR(v_MaxSimplifierIterations,   4,     Int)
GLOBAL_VAR(v_StgStats,                  False, Bool)
196
GLOBAL_VAR(v_Strictness,  		True,  Bool)
197
GLOBAL_VAR(v_CSE,         		True,  Bool)
198
GLOBAL_VAR(v_RuleCheck,       		Nothing,  Maybe String)
199

200
-- these are the static flags you get without -O.
201 202
hsc_minusNoO_flags =
       [ 
203
 	"-fignore-interface-pragmas",
204
	"-fomit-interface-pragmas",
205 206 207 208
	"-fdo-lambda-eta-expansion",	-- This one is important for a tiresome reason:
					-- we want to make sure that the bindings for data 
					-- constructors are eta-expanded.  This is probably
					-- a good thing anyway, but it seems fragile.
209
	"-flet-no-escape"
210 211
	]

212
-- these are the static flags you get when -O is on.
213 214
hsc_minusO_flags =
  [ 
215
	"-fignore-asserts",
216 217 218 219
	"-ffoldr-build-on",
        "-fdo-eta-reduction",
	"-fdo-lambda-eta-expansion",
 	"-fcase-merge",
220 221
	"-flet-to-case",
	"-flet-no-escape"
222 223
   ]

224 225
hsc_minusO2_flags = hsc_minusO_flags	-- for now

226 227 228 229
getStaticOptimisationFlags 0 = hsc_minusNoO_flags
getStaticOptimisationFlags 1 = hsc_minusO_flags
getStaticOptimisationFlags n = hsc_minusO2_flags

230 231 232 233 234 235
buildCoreToDo :: IO [CoreToDo]
buildCoreToDo = do
   opt_level  <- readIORef v_OptLevel
   max_iter   <- readIORef v_MaxSimplifierIterations
   strictness <- readIORef v_Strictness
   cse        <- readIORef v_CSE
236
   rule_check <- readIORef v_RuleCheck
237 238 239

   if opt_level == 0 then return
      [
240
	CoreDoSimplify (SimplPhase 0) [
241
	    MaxSimplifierIterations max_iter
242
	]
243 244
      ]

245
    else {- opt_level >= 1 -} return [ 
246 247

	-- initial simplify: mk specialiser happy: minimum effort please
248 249
	CoreDoSimplify SimplGently [
			-- 	Simplify "gently"
250 251 252 253 254 255 256 257
			-- 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
			-- Similarly, don't apply any rules until after full 
			-- laziness.  Notably, list fusion can prevent floating.
258

259 260 261 262
            NoCaseOfCase,
			-- Don't do case-of-case transformations.
			-- This makes full laziness work better
	    MaxSimplifierIterations max_iter
263
	],
264 265 266 267 268

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

269
	CoreDoFloatOutwards (FloatOutSw False False),
270 271
	CoreDoFloatInwards,

272 273
	CoreDoSimplify (SimplPhase 2) [
		-- Want to run with inline phase 2 after the specialiser to give
274
		-- maximum chance for fusion to work before we inline build/augment
275
		-- in phase 1.  This made a difference in 'ansi' where an 
276 277
		-- overloaded function wasn't inlined till too late.
	   MaxSimplifierIterations max_iter
278 279
	],
	case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing },
280

281
	CoreDoSimplify (SimplPhase 1) [
282 283 284 285 286
		-- 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
	   MaxSimplifierIterations max_iter
287 288
	],
	case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing },
289

290 291
	CoreDoSimplify (SimplPhase 0) [
		-- Phase 0: allow all Ids to be inlined now
292
		-- This gets foldr inlined before strictness analysis
293 294

	   MaxSimplifierIterations 3
295 296 297 298 299 300 301
		-- At least 3 iterations because otherwise we land up with
		-- huge dead expressions because of an infelicity in the 
		-- simpifier.   
		--	let k = BIG in foldr k z xs
		-- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
		-- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
		-- Don't stop now!
302 303 304

	],
	case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
305

306
#ifdef OLD_STRICTNESS
307
	CoreDoOldStrictness
308
#endif
309
	if strictness then CoreDoStrictness else CoreDoNothing,
310 311 312
	CoreDoWorkerWrapper,
	CoreDoGlomBinds,

313
	CoreDoSimplify (SimplPhase 0) [
314
	   MaxSimplifierIterations max_iter
315
	],
316

317 318
	CoreDoFloatOutwards (FloatOutSw False	-- Not lambdas
					True),	-- Float constants
319 320 321 322 323 324
		-- 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)

325

326 327
	-- We want CSE to follow the final full-laziness pass, because it may
	-- succeed in commoning up things floated out by full laziness.
328 329
	-- CSE used to rely on the no-shadowing invariant, but it doesn't any more

330 331 332 333 334 335 336
	if cse then CoreCSE else CoreDoNothing,

	CoreDoFloatInwards,

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

337 338
	case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },

339 340 341 342
	if opt_level >= 2 then
	   CoreLiberateCase
	else
	   CoreDoNothing,
343 344 345 346
	if opt_level >= 2 then
	   CoreDoSpecConstr
	else
	   CoreDoNothing,
347 348

	-- Final clean-up simplification:
349
	CoreDoSimplify (SimplPhase 0) [
350
	  MaxSimplifierIterations max_iter
351
	]
352
     ]
353

354 355 356 357 358 359 360
buildStgToDo :: IO [ StgToDo ]
buildStgToDo = do
  stg_stats <- readIORef v_StgStats
  let flags1 | stg_stats = [ D_stg_stats ]
	     | otherwise = [ ]

	-- STG passes
361
  ways_ <- readIORef v_Ways
362 363 364 365 366
  let flags2 | WayProf `elem` ways_ = StgDoMassageForProfiling : flags1
	     | otherwise            = flags1

  return flags2

367 368 369 370 371
-----------------------------------------------------------------------------
-- Paths & Libraries

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

372 373 374 375
v_Import_paths, v_Include_paths, v_Library_paths :: IORef [String]
GLOBAL_VAR(v_Import_paths,  ["."], [String])
GLOBAL_VAR(v_Include_paths, ["."], [String])
GLOBAL_VAR(v_Library_paths, [],	 [String])
376

377 378 379 380 381
#ifdef darwin_TARGET_OS
GLOBAL_VAR(v_Framework_paths, [], [String])
GLOBAL_VAR(v_Cmdline_frameworks, [], [String])
#endif

382 383
addToDirList :: IORef [String] -> String -> IO ()
addToDirList ref path
sof's avatar
sof committed
384 385
  = do paths           <- readIORef ref
       shiny_new_ones  <- splitUp path
sof's avatar
sof committed
386
       writeIORef ref (paths ++ filter notNull shiny_new_ones)
387 388 389 390
		-- 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
391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 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
  where
    splitUp ::String -> IO [String]
#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
447

448 449
-- ----------------------------------------------------------------------------
-- Loading the package config file
450

451 452
readPackageConf :: String -> IO ()
readPackageConf conf_file = do
453 454 455
  proto_pkg_configs <- loadPackageConfig conf_file
  top_dir 	    <- getTopDir
  let pkg_configs = mungePackagePaths top_dir proto_pkg_configs
456 457 458 459 460 461 462 463 464 465 466
  extendPackageConfigMap pkg_configs

mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
-- Replace the string "$libdir" at the beginning of a path
-- with the current libdir (obtained from the -B option).
mungePackagePaths top_dir ps = map munge_pkg ps
 where 
  munge_pkg p = p{ import_dirs  = munge_paths (import_dirs p),
		   include_dirs = munge_paths (include_dirs p),
    		   library_dirs = munge_paths (library_dirs p),
		   framework_dirs = munge_paths (framework_dirs p) }
467

468
  munge_paths = map munge_path
469

470 471 472
  munge_path p 
	  | Just p' <- my_prefix_match "$libdir" p = top_dir ++ p'
	  | otherwise				   = p
473 474


475 476
-- -----------------------------------------------------------------------------
-- The list of packages requested on the command line
477

478 479 480 481
-- The package list reflects what packages were given as command-line options,
-- plus their dependent packages.  It is maintained in dependency order;
-- earlier packages may depend on later ones, but not vice versa
GLOBAL_VAR(v_ExplicitPackages, initPackageList, [PackageName])
482

483 484 485 486 487 488
initPackageList = [basePackage, rtsPackage]
	-- basePackage is part of this list entirely because of 
	-- wired-in names in GHCi.  See the notes on wired-in names in
	-- Linker.linkExpr.  By putting the base backage in initPackageList
	-- we make sure that it'll always by linked.

489 490

-- add a package requested from the command-line
491
addPackage :: String -> IO ()
492 493 494 495
addPackage package = do
  pkg_details <- getPackageConfigMap
  ps  <- readIORef v_ExplicitPackages
  ps' <- add_package pkg_details ps (mkPackageName package)
496
		-- Throws an exception if it fails
497
  writeIORef v_ExplicitPackages ps'
498

499
-- internal helper
500 501 502 503 504 505
add_package :: PackageConfigMap -> [PackageName]
	    -> PackageName -> IO [PackageName]
add_package pkg_details ps p	
  | p `elem` ps	-- Check if we've already added this package
  = return ps
  | Just details <- lookupPkg pkg_details p
506 507 508
  -- Add the package's dependents also
  = do ps' <- foldM (add_package pkg_details) ps (packageDependents details)
       return (p : ps')
509 510
  | otherwise
  = throwDyn (CmdLineError ("unknown package name: " ++ packageNameString p))
511

512 513 514 515 516 517 518 519 520 521 522 523 524

-- -----------------------------------------------------------------------------
-- Extracting information from the packages in scope

-- Many of these functions take a list of packages: in those cases,
-- the list is expected to contain the "dependent packages",
-- i.e. those packages that were found to be depended on by the
-- current module/program.  These can be auto or non-auto packages, it
-- doesn't really matter.  The list is always combined with the list
-- of explicit (command-line) packages to determine which packages to
-- use.

getPackageImportPath :: IO [String]
525
getPackageImportPath = do
526 527 528
  ps <- getExplicitAndAutoPackageConfigs
		  -- import dirs are always derived from the 'auto' 
		  -- packages as well as the explicit ones
sof's avatar
sof committed
529
  return (nub (filter notNull (concatMap import_dirs ps)))
530

531 532 533
getPackageIncludePath :: [PackageName] -> IO [String]
getPackageIncludePath pkgs = do
  ps <- getExplicitPackagesAnd pkgs
sof's avatar
sof committed
534
  return (nub (filter notNull (concatMap include_dirs ps)))
535 536

	-- includes are in reverse dependency order (i.e. rts first)
537 538 539 540 541 542 543
getPackageCIncludes :: [PackageConfig] -> IO [String]
getPackageCIncludes pkg_configs = do
  return (reverse (nub (filter notNull (concatMap c_includes pkg_configs))))

getPackageLibraryPath :: [PackageName] -> IO [String]
getPackageLibraryPath pkgs = do 
  ps <- getExplicitPackagesAnd pkgs
sof's avatar
sof committed
544
  return (nub (filter notNull (concatMap library_dirs ps)))
545

546 547 548
getPackageLinkOpts :: [PackageName] -> IO [String]
getPackageLinkOpts pkgs = do
  ps <- getExplicitPackagesAnd pkgs
549
  tag <- readIORef v_Build_tag
550 551 552 553 554 555 556 557 558
  static <- readIORef v_Static
  let 
	imp        = if static then "" else "_imp"
	suffix     = if null tag then "" else '_':tag
      	libs p     = map (++suffix) (hACK (hs_libraries p)) ++ extra_libraries p
	imp_libs p = map (++imp) (libs p)
	all_opts p = map ("-l" ++) (imp_libs p) ++ extra_ld_opts p

  return (concat (map all_opts ps))
559 560 561
  where
     -- This is a totally horrible (temporary) hack, for Win32.  Problem is
     -- that package.conf for Win32 says that the main prelude lib is 
sof's avatar
sof committed
562 563 564
     -- split into HSbase1, HSbase2 and HSbase3, which is needed due to a bug
     -- in the GNU linker (PEi386 backend). However, we still only
     -- have HSbase.a for static linking, not HSbase{1,2,3}.a
565
     -- getPackageLibraries is called to find the .a's to add to the static
sof's avatar
sof committed
566
     -- link line.  On Win32, this hACK detects HSbase{1,2,3} and 
567
     -- replaces them with HSbase, so static linking still works.
568 569
     -- Libraries needed for dynamic (GHCi) linking are discovered via
     -- different route (in InteractiveUI.linkPackage).
570
     -- See driver/PackageSrc.hs for the HSbase1/HSbase2 split definition.
571
     -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...)
572
     -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2]
573
     -- KAA 29 Mar  02: Same appalling hack for HSobjectio[1,2,3,4]
574
     hACK libs
sof's avatar
sof committed
575
#      if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
576 577
       = libs
#      else
sof's avatar
sof committed
578
       = if   "HSbase1" `elem` libs && "HSbase2" `elem` libs && "HSbase3" `elem` libs
sof's avatar
sof committed
579
         then "HSbase" : filter (not.(isPrefixOf "HSbase")) libs
580 581
         else
         if   "HSwin321" `elem` libs && "HSwin322" `elem` libs
sof's avatar
sof committed
582
         then "HSwin32" : filter (not.(isPrefixOf "HSwin32")) libs
583
         else 
584 585 586
         if   "HSobjectio1" `elem` libs && "HSobjectio2" `elem` libs && "HSobjectio3" `elem` libs && "HSobjectio4" `elem` libs
	 then "HSobjectio" : filter (not.(isPrefixOf "HSobjectio")) libs
         else 
587
         libs
588
#      endif
589 590 591

getPackageExtraGhcOpts :: IO [String]
getPackageExtraGhcOpts = do
592
  ps <- getExplicitAndAutoPackageConfigs
593
  return (concatMap extra_ghc_opts ps)
594

595 596 597
getPackageExtraCcOpts :: [PackageName] -> IO [String]
getPackageExtraCcOpts pkgs = do
  ps <- getExplicitPackagesAnd pkgs
598
  return (concatMap extra_cc_opts ps)
599

600
#ifdef darwin_TARGET_OS
601
getPackageFrameworkPath  :: [PackageName] -> IO [String]
602
getPackageFrameworkPath pkgs = do
603
  ps <- getExplicitPackagesAnd pkgs
604 605
  return (nub (filter notNull (concatMap framework_dirs ps)))

606 607 608
getPackageFrameworks  :: [PackageName] -> IO [String]
getPackageFrameworks pkgs = do
  ps <- getExplicitPackagesAnd pkgs
609 610 611
  return (concatMap extra_frameworks ps)
#endif

612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627
-- -----------------------------------------------------------------------------
-- Package Utils

getExplicitPackagesAnd :: [PackageName] -> IO [PackageConfig]
getExplicitPackagesAnd pkg_names = do
  pkg_map <- getPackageConfigMap
  expl <- readIORef v_ExplicitPackages
  all_pkgs <- foldM (add_package pkg_map) expl pkg_names
  getPackageDetails all_pkgs

-- return all packages, including both the auto packages and the explicit ones
getExplicitAndAutoPackageConfigs :: IO [PackageConfig]
getExplicitAndAutoPackageConfigs = do
  pkg_map <- getPackageConfigMap
  let auto_packages = [ mkPackageName (name p) | p <- eltsUFM pkg_map, auto p ]
  getExplicitPackagesAnd auto_packages
628

629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644
-----------------------------------------------------------------------------
-- 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.

645
GLOBAL_VAR(v_Build_tag, "", String)
646 647 648 649 650 651 652 653

data WayName
  = WayProf
  | WayUnreg
  | WayTicky
  | WayPar
  | WayGran
  | WaySMP
chak's avatar
chak committed
654
  | WayNDP
655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674
  | 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)

675
GLOBAL_VAR(v_Ways, [] ,[WayName])
676

677 678 679
allowed_combination way = way `elem` combs
  where  -- the sub-lists must be ordered according to WayName, 
         -- because findBuildTag sorts them
chak's avatar
chak committed
680 681 682
    combs                = [ [WayProf, WayUnreg], 
			     [WayProf, WaySMP]  ,
			     [WayProf, WayNDP]  ]
683 684 685

findBuildTag :: IO [String]  -- new options
findBuildTag = do
686
  way_names <- readIORef v_Ways
687
  case sort way_names of
688
     []  -> do  -- writeIORef v_Build_tag ""
689 690 691
	        return []

     [w] -> do let details = lkupWay w
692
	       writeIORef v_Build_tag (wayTag details)
693 694
	       return (wayOpts details)

695
     ws  -> if not (allowed_combination ws)
696
		then throwDyn (CmdLineError $
697 698 699 700 701 702 703
				"combination not supported: "  ++
   				foldr1 (\a b -> a ++ '/':b) 
				(map (wayName . lkupWay) ws))
		else let stuff = map lkupWay ws
			 tag   = concat (map wayTag stuff)
			 flags = map wayOpts stuff
		     in do
704
		     writeIORef v_Build_tag tag
705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732
		     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"
	, "-optc-DPROFILING"
	, "-fvia-C" ]),

    (WayTicky, Way  "t" "Ticky-ticky Profiling"  
	[ "-fticky-ticky"
	, "-DTICKY_TICKY"
	, "-optc-DTICKY_TICKY"
	, "-fvia-C" ]),

    (WayUnreg, Way  "u" "Unregisterised" 
733
	unregFlags ),
734

735
    -- optl's below to tell linker where to find the PVM library -- HWL
736 737 738 739 740
    (WayPar, Way  "mp" "Parallel" 
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-package concurrent"
741 742 743 744
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
        , "-optl-lgpvm3"
745 746
	, "-fvia-C" ]),

747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773
    -- at the moment we only change the RTS and could share compiler and libs!
    (WayPar, Way  "mt" "Parallel ticky profiling" 
	[ "-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" ]),

    (WayPar, Way  "md" "Distributed" 
	[ "-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" ]),

    (WayGran, Way  "mg" "GranSim" 
774 775 776 777 778 779 780 781 782 783 784 785 786
	[ "-fgransim"
	, "-D__GRANSIM__"
	, "-optc-DGRAN"
	, "-package concurrent"
	, "-fvia-C" ]),

    (WaySMP, Way  "s" "SMP"
	[ "-fsmp"
	, "-optc-pthread"
	, "-optl-pthread"
	, "-optc-DSMP"
	, "-fvia-C" ]),

chak's avatar
chak committed
787 788 789 790
    (WayNDP, Way  "ndp" "Nested data parallelism"
	[ "-fparr"
	, "-fflatten"]),

791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809
    (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"]) 
  ]

810 811 812 813 814 815 816
unregFlags = 
   [ "-optc-DNO_REGS"
   , "-optc-DUSE_MINIINTERPRETER"
   , "-fno-asm-mangling"
   , "-funregisterised"
   , "-fvia-C" ]

817
-----------------------------------------------------------------------------
818
-- Options for particular phases
819

820 821 822 823 824
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])
825

826 827
getStaticOpts :: IORef [String] -> IO [String]
getStaticOpts ref = readIORef ref >>= return . reverse