ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Settings for the driver
   4 --
   5 -- (c) The University of Glasgow 2002
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module DriverState where
  10
  11 #include "HsVersions.h"
  12
  13 import CmdLineOpts
  14 import DriverPhases
  15 import DriverUtil
  16 import Util
  17 import Config
  18 import Panic
  19
  20 import DATA_IOREF       ( IORef, readIORef, writeIORef )
  21 import EXCEPTION
  22
  23 import List
  24 import Char
  25 import Monad
  26 import Maybe            ( fromJust, isJust )
  27 import Directory        ( doesDirectoryExist )
  28
  29 -----------------------------------------------------------------------------
  30 -- non-configured things
  31
  32 cHaskell1Version = "5" -- i.e., Haskell 98
  33
  34 -----------------------------------------------------------------------------
  35 -- GHC modes of operation
  36
  37 data GhcMode
  38   = DoMkDependHS                        -- ghc -M
  39   | StopBefore Phase                    -- ghc -E | -C | -S
  40                                         -- StopBefore StopLn is the default
  41   | DoMake                              -- ghc --make
  42   | DoInteractive                       -- ghc --interactive
  43   | DoEval String                       -- ghc -e
  44   deriving (Show)
  45
  46 data GhcLink    -- What to do in the link step
  47   =             -- Only relevant for modes
  48                 --      DoMake and StopBefore StopLn
  49     NoLink              -- Don't link at all
  50   | StaticLink          -- Ordinary linker [the default]
  51   | MkDLL               -- Make a DLL
  52
  53 GLOBAL_VAR(v_GhcMode,     StopBefore StopLn,    GhcMode)
  54 GLOBAL_VAR(v_GhcModeFlag, "",                   String)
  55 GLOBAL_VAR(v_GhcLink,     StaticLink,           GhcLink)
  56
  57 setMode :: GhcMode -> String -> IO ()
  58 setMode m flag = do
  59   old_mode <- readIORef v_GhcMode
  60   old_flag <- readIORef v_GhcModeFlag
  61   when (notNull old_flag && flag /= old_flag) $
  62       throwDyn (UsageError
  63           ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
  64   writeIORef v_GhcMode m
  65   writeIORef v_GhcModeFlag flag
  66
  67 isInteractiveMode, isInterpretiveMode     :: GhcMode -> Bool
  68 isMakeMode, isLinkMode, isCompManagerMode :: GhcMode -> Bool
  69
  70 isInteractiveMode DoInteractive = True
  71 isInteractiveMode _             = False
  72
  73 -- isInterpretiveMode: byte-code compiler involved
  74 isInterpretiveMode DoInteractive = True
  75 isInterpretiveMode (DoEval _)    = True
  76 isInterpretiveMode _             = False
  77
  78 isMakeMode DoMake = True
  79 isMakeMode _      = False
  80
  81 -- True if we are going to attempt to link in this mode.
  82 -- (we might not actually link, depending on the GhcLink flag)
  83 isLinkMode (StopBefore StopLn) = True
  84 isLinkMode DoMake              = True
  85 isLinkMode _                   = False
  86
  87 isCompManagerMode DoMake        = True
  88 isCompManagerMode DoInteractive = True
  89 isCompManagerMode (DoEval _)    = True
  90 isCompManagerMode _             = False
  91
  92 isNoLink :: GhcLink -> Bool
  93 isNoLink NoLink = True
  94 isNoLink other  = False
  95
  96 -----------------------------------------------------------------------------
  97 -- Global compilation flags
  98
  99 -- Default CPP defines in Haskell source
 100 hsSourceCppOpts =
 101         [ "-D__HASKELL1__="++cHaskell1Version
 102         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
 103         , "-D__HASKELL98__"
 104         , "-D__CONCURRENT_HASKELL__"
 105         ]
 106
 107
 108 -- Keep output from intermediate phases
 109 GLOBAL_VAR(v_Keep_hi_diffs,             False,          Bool)
 110 GLOBAL_VAR(v_Keep_hc_files,             False,          Bool)
 111 GLOBAL_VAR(v_Keep_s_files,              False,          Bool)
 112 GLOBAL_VAR(v_Keep_raw_s_files,          False,          Bool)
 113 GLOBAL_VAR(v_Keep_tmp_files,            False,          Bool)
 114 #ifdef ILX
 115 GLOBAL_VAR(v_Keep_il_files,             False,          Bool)
 116 GLOBAL_VAR(v_Keep_ilx_files,            False,          Bool)
 117 #endif
 118
 119 -- Misc
 120 GLOBAL_VAR(v_Scale_sizes_by,            1.0,            Double)
 121 GLOBAL_VAR(v_Static,                    True,           Bool)
 122 GLOBAL_VAR(v_NoHsMain,                  False,          Bool)
 123 GLOBAL_VAR(v_MainModIs,                 Nothing,        Maybe String)
 124 GLOBAL_VAR(v_MainFunIs,                 Nothing,        Maybe String)
 125 GLOBAL_VAR(v_Collect_ghc_timing,        False,          Bool)
 126 GLOBAL_VAR(v_Do_asm_mangling,           True,           Bool)
 127 GLOBAL_VAR(v_Excess_precision,          False,          Bool)
 128 GLOBAL_VAR(v_Read_DotGHCi,              True,           Bool)
 129
 130 -- Preprocessor flags
 131 GLOBAL_VAR(v_Hs_source_pp_opts, [], [String])
 132
 133 -----------------------------------------------------------------------------
 134 -- Splitting object files (for libraries)
 135
 136 GLOBAL_VAR(v_Split_object_files,        False,          Bool)
 137 GLOBAL_VAR(v_Split_info,                ("",0),         (String,Int))
 138         -- The split prefix and number of files
 139
 140
 141 can_split :: Bool
 142 can_split =
 143 #if    defined(i386_TARGET_ARCH)     \
 144     || defined(alpha_TARGET_ARCH)    \
 145     || defined(hppa_TARGET_ARCH)     \
 146     || defined(m68k_TARGET_ARCH)     \
 147     || defined(mips_TARGET_ARCH)     \
 148     || defined(powerpc_TARGET_ARCH)  \
 149     || defined(rs6000_TARGET_ARCH)   \
 150     || defined(sparc_TARGET_ARCH)
 151    True
 152 #else
 153    False
 154 #endif
 155
 156 -----------------------------------------------------------------------------
 157 -- Compiler output options
 158
 159 GLOBAL_VAR(v_Output_dir,  Nothing, Maybe String)
 160 GLOBAL_VAR(v_Output_file, Nothing, Maybe String)
 161 GLOBAL_VAR(v_Output_hi,   Nothing, Maybe String)
 162
 163 -- called to verify that the output files & directories
 164 -- point somewhere valid.
 165 --
 166 -- The assumption is that the directory portion of these output
 167 -- options will have to exist by the time 'verifyOutputFiles'
 168 -- is invoked.
 169 --
 170 verifyOutputFiles :: IO ()
 171 verifyOutputFiles = do
 172   odir <- readIORef v_Output_dir
 173   when (isJust odir) $ do
 174      let dir = fromJust odir
 175      flg <- doesDirectoryExist dir
 176      when (not flg) (nonExistentDir "-odir" dir)
 177   ofile <- readIORef v_Output_file
 178   when (isJust ofile) $ do
 179      let fn = fromJust ofile
 180      flg <- doesDirNameExist fn
 181      when (not flg) (nonExistentDir "-o" fn)
 182   ohi <- readIORef v_Output_hi
 183   when (isJust ohi) $ do
 184      let hi = fromJust ohi
 185      flg <- doesDirNameExist hi
 186      when (not flg) (nonExistentDir "-ohi" hi)
 187  where
 188    nonExistentDir flg dir =
 189      throwDyn (CmdLineError ("error: directory portion of " ++
 190                              show dir ++ " does not exist (used with " ++
 191                              show flg ++ " option.)"))
 192
 193 GLOBAL_VAR(v_Object_suf,  phaseInputExt StopLn, String)
 194 GLOBAL_VAR(v_HC_suf,      phaseInputExt HCc,    String)
 195 GLOBAL_VAR(v_Hi_dir,      Nothing, Maybe String)
 196 GLOBAL_VAR(v_Hi_suf,      "hi",    String)
 197
 198 GLOBAL_VAR(v_Ld_inputs, [],      [String])
 199
 200 odir_ify :: String -> IO String
 201 odir_ify f = do
 202   odir_opt <- readIORef v_Output_dir
 203   case odir_opt of
 204         Nothing -> return f
 205         Just d  -> return (replaceFilenameDirectory f d)
 206
 207 osuf_ify :: String -> IO String
 208 osuf_ify f = do
 209   osuf <- readIORef v_Object_suf
 210   return (replaceFilenameSuffix f osuf)
 211
 212 GLOBAL_VAR(v_StgStats,                  False, Bool)
 213
 214 buildStgToDo :: IO [ StgToDo ]
 215 buildStgToDo = do
 216   stg_stats <- readIORef v_StgStats
 217   let flags1 | stg_stats = [ D_stg_stats ]
 218              | otherwise = [ ]
 219
 220         -- STG passes
 221   ways_ <- readIORef v_Ways
 222   let flags2 | WayProf `elem` ways_ = StgDoMassageForProfiling : flags1
 223              | otherwise            = flags1
 224
 225   return flags2
 226
 227 -----------------------------------------------------------------------------
 228 -- Paths & Libraries
 229
 230 split_marker = ':'   -- not configurable (ToDo)
 231
 232 v_Include_paths, v_Library_paths :: IORef [String]
 233 GLOBAL_VAR(v_Include_paths, [], [String])
 234 GLOBAL_VAR(v_Library_paths, [],  [String])
 235
 236 #ifdef darwin_TARGET_OS
 237 GLOBAL_VAR(v_Framework_paths, [], [String])
 238 GLOBAL_VAR(v_Cmdline_frameworks, [], [String])
 239 #endif
 240
 241 addToDirList :: IORef [String] -> String -> IO ()
 242 addToDirList ref path
 243   = do paths           <- readIORef ref
 244        shiny_new_ones  <- splitPathList path
 245        writeIORef ref (paths ++ shiny_new_ones)
 246
 247
 248 splitPathList :: String -> IO [String]
 249 splitPathList s = do ps <- splitUp s; return (filter notNull ps)
 250                 -- empty paths are ignored: there might be a trailing
 251                 -- ':' in the initial list, for example.  Empty paths can
 252                 -- cause confusion when they are translated into -I options
 253                 -- for passing to gcc.
 254   where
 255 #ifdef mingw32_TARGET_OS
 256      -- 'hybrid' support for DOS-style paths in directory lists.
 257      --
 258      -- That is, if "foo:bar:baz" is used, this interpreted as
 259      -- consisting of three entries, 'foo', 'bar', 'baz'.
 260      -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted
 261      -- as four elts, "c:/foo", "c:\\foo", "x", and "/bar" --
 262      -- *provided* c:/foo exists and x:/bar doesn't.
 263      --
 264      -- Notice that no attempt is made to fully replace the 'standard'
 265      -- split marker ':' with the Windows / DOS one, ';'. The reason being
 266      -- that this will cause too much breakage for users & ':' will
 267      -- work fine even with DOS paths, if you're not insisting on being silly.
 268      -- So, use either.
 269     splitUp []         = return []
 270     splitUp (x:':':div:xs)
 271       | div `elem` dir_markers = do
 272           let (p,rs) = findNextPath xs
 273           ps  <- splitUp rs
 274            {-
 275              Consult the file system to check the interpretation
 276              of (x:':':div:p) -- this is arguably excessive, we
 277              could skip this test & just say that it is a valid
 278              dir path.
 279            -}
 280           flg <- doesDirectoryExist (x:':':div:p)
 281           if flg then
 282              return ((x:':':div:p):ps)
 283            else
 284              return ([x]:(div:p):ps)
 285     splitUp xs = do
 286       let (p,rs) = findNextPath xs
 287       ps <- splitUp rs
 288       return (cons p ps)
 289
 290     cons "" xs = xs
 291     cons x  xs = x:xs
 292
 293     -- will be called either when we've consumed nought or the "<Drive>:/" part of
 294     -- a DOS path, so splitting is just a Q of finding the next split marker.
 295     findNextPath xs =
 296         case break (`elem` split_markers) xs of
 297            (p, d:ds) -> (p, ds)
 298            (p, xs)   -> (p, xs)
 299
 300     split_markers :: [Char]
 301     split_markers = [':', ';']
 302
 303     dir_markers :: [Char]
 304     dir_markers = ['/', '\\']
 305
 306 #else
 307     splitUp xs = return (split split_marker xs)
 308 #endif
 309
 310 -----------------------------------------------------------------------------
 311 -- Ways
 312
 313 -- The central concept of a "way" is that all objects in a given
 314 -- program must be compiled in the same "way".  Certain options change
 315 -- parameters of the virtual machine, eg. profiling adds an extra word
 316 -- to the object header, so profiling objects cannot be linked with
 317 -- non-profiling objects.
 318
 319 -- After parsing the command-line options, we determine which "way" we
 320 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 321
 322 -- We then find the "build-tag" associated with this way, and this
 323 -- becomes the suffix used to find .hi files and libraries used in
 324 -- this compilation.
 325
 326 GLOBAL_VAR(v_Build_tag, "", String)
 327
 328 -- The RTS has its own build tag, because there are some ways that
 329 -- affect the RTS only.
 330 GLOBAL_VAR(v_RTS_Build_tag, "", String)
 331
 332 data WayName
 333   = WayThreaded
 334   | WayDebug
 335   | WayProf
 336   | WayUnreg
 337   | WayTicky
 338   | WayPar
 339   | WayGran
 340   | WaySMP
 341   | WayNDP
 342   | WayUser_a
 343   | WayUser_b
 344   | WayUser_c
 345   | WayUser_d
 346   | WayUser_e
 347   | WayUser_f
 348   | WayUser_g
 349   | WayUser_h
 350   | WayUser_i
 351   | WayUser_j
 352   | WayUser_k
 353   | WayUser_l
 354   | WayUser_m
 355   | WayUser_n
 356   | WayUser_o
 357   | WayUser_A
 358   | WayUser_B
 359   deriving (Eq,Ord)
 360
 361 GLOBAL_VAR(v_Ways, [] ,[WayName])
 362
 363 allowed_combination way = and [ x `allowedWith` y
 364                               | x <- way, y <- way, x < y ]
 365   where
 366         -- Note ordering in these tests: the left argument is
 367         -- <= the right argument, according to the Ord instance
 368         -- on Way above.
 369
 370         -- debug is allowed with everything
 371         _ `allowedWith` WayDebug                = True
 372         WayDebug `allowedWith` _                = True
 373
 374         WayThreaded `allowedWith` WayProf       = True
 375         WayProf `allowedWith` WayUnreg          = True
 376         WayProf `allowedWith` WaySMP            = True
 377         WayProf `allowedWith` WayNDP            = True
 378         _ `allowedWith` _                       = False
 379
 380
 381 findBuildTag :: IO [String]  -- new options
 382 findBuildTag = do
 383   way_names <- readIORef v_Ways
 384   let ws = sort way_names
 385   if not (allowed_combination ws)
 386       then throwDyn (CmdLineError $
 387                     "combination not supported: "  ++
 388                     foldr1 (\a b -> a ++ '/':b)
 389                     (map (wayName . lkupWay) ws))
 390       else let ways    = map lkupWay ws
 391                tag     = mkBuildTag (filter (not.wayRTSOnly) ways)
 392                rts_tag = mkBuildTag ways
 393                flags   = map wayOpts ways
 394            in do
 395            writeIORef v_Build_tag tag
 396            writeIORef v_RTS_Build_tag rts_tag
 397            return (concat flags)
 398
 399 mkBuildTag :: [Way] -> String
 400 mkBuildTag ways = concat (intersperse "_" (map wayTag ways))
 401
 402 lkupWay w =
 403    case lookup w way_details of
 404         Nothing -> error "findBuildTag"
 405         Just details -> details
 406
 407 data Way = Way {
 408   wayTag     :: String,
 409   wayRTSOnly :: Bool,
 410   wayName    :: String,
 411   wayOpts    :: [String]
 412   }
 413
 414 way_details :: [ (WayName, Way) ]
 415 way_details =
 416   [ (WayThreaded, Way "thr" True "Threaded" [
 417 #if defined(freebsd_TARGET_OS)
 418           "-optc-pthread"
 419         , "-optl-pthread"
 420 #endif
 421         ] ),
 422
 423     (WayDebug, Way "debug" True "Debug" [] ),
 424
 425     (WayProf, Way  "p" False "Profiling"
 426         [ "-fscc-profiling"
 427         , "-DPROFILING"
 428         , "-optc-DPROFILING"
 429         , "-fvia-C" ]),
 430
 431     (WayTicky, Way  "t" False "Ticky-ticky Profiling"
 432         [ "-fticky-ticky"
 433         , "-DTICKY_TICKY"
 434         , "-optc-DTICKY_TICKY"
 435         , "-fvia-C" ]),
 436
 437     (WayUnreg, Way  "u" False "Unregisterised"
 438         unregFlags ),
 439
 440     -- optl's below to tell linker where to find the PVM library -- HWL
 441     (WayPar, Way  "mp" False "Parallel"
 442         [ "-fparallel"
 443         , "-D__PARALLEL_HASKELL__"
 444         , "-optc-DPAR"
 445         , "-package concurrent"
 446         , "-optc-w"
 447         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 448         , "-optl-lpvm3"
 449         , "-optl-lgpvm3"
 450         , "-fvia-C" ]),
 451
 452     -- at the moment we only change the RTS and could share compiler and libs!
 453     (WayPar, Way  "mt" False "Parallel ticky profiling"
 454         [ "-fparallel"
 455         , "-D__PARALLEL_HASKELL__"
 456         , "-optc-DPAR"
 457         , "-optc-DPAR_TICKY"
 458         , "-package concurrent"
 459         , "-optc-w"
 460         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 461         , "-optl-lpvm3"
 462         , "-optl-lgpvm3"
 463         , "-fvia-C" ]),
 464
 465     (WayPar, Way  "md" False "Distributed"
 466         [ "-fparallel"
 467         , "-D__PARALLEL_HASKELL__"
 468         , "-D__DISTRIBUTED_HASKELL__"
 469         , "-optc-DPAR"
 470         , "-optc-DDIST"
 471         , "-package concurrent"
 472         , "-optc-w"
 473         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 474         , "-optl-lpvm3"
 475         , "-optl-lgpvm3"
 476         , "-fvia-C" ]),
 477
 478     (WayGran, Way  "mg" False "GranSim"
 479         [ "-fgransim"
 480         , "-D__GRANSIM__"
 481         , "-optc-DGRAN"
 482         , "-package concurrent"
 483         , "-fvia-C" ]),
 484
 485     (WaySMP, Way  "s" False "SMP"
 486         [ "-fsmp"
 487         , "-optc-pthread"
 488 #ifndef freebsd_TARGET_OS
 489         , "-optl-pthread"
 490 #endif
 491         , "-optc-DSMP"
 492         , "-fvia-C" ]),
 493
 494     (WayNDP, Way  "ndp" False "Nested data parallelism"
 495         [ "-fparr"
 496         , "-fflatten"]),
 497
 498     (WayUser_a,  Way  "a"  False "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 499     (WayUser_b,  Way  "b"  False "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 500     (WayUser_c,  Way  "c"  False "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 501     (WayUser_d,  Way  "d"  False "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 502     (WayUser_e,  Way  "e"  False "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 503     (WayUser_f,  Way  "f"  False "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 504     (WayUser_g,  Way  "g"  False "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 505     (WayUser_h,  Way  "h"  False "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 506     (WayUser_i,  Way  "i"  False "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 507     (WayUser_j,  Way  "j"  False "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 508     (WayUser_k,  Way  "k"  False "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 509     (WayUser_l,  Way  "l"  False "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 510     (WayUser_m,  Way  "m"  False "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 511     (WayUser_n,  Way  "n"  False "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 512     (WayUser_o,  Way  "o"  False "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 513     (WayUser_A,  Way  "A"  False "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 514     (WayUser_B,  Way  "B"  False "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 515   ]
 516
 517 unregFlags =
 518    [ "-optc-DNO_REGS"
 519    , "-optc-DUSE_MINIINTERPRETER"
 520    , "-fno-asm-mangling"
 521    , "-funregisterised"
 522    , "-fvia-C" ]
 523
 524 -----------------------------------------------------------------------------
 525 -- Options for particular phases
 526
 527 GLOBAL_VAR(v_Opt_dep,    [], [String])
 528 GLOBAL_VAR(v_Anti_opt_C, [], [String])
 529 GLOBAL_VAR(v_Opt_C,      [], [String])
 530 GLOBAL_VAR(v_Opt_l,      [], [String])
 531 GLOBAL_VAR(v_Opt_dll,    [], [String])
 532
 533 getStaticOpts :: IORef [String] -> IO [String]
 534 getStaticOpts ref = readIORef ref >>= return . reverse