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