ghc/compiler/main/DriverFlags.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverFlags.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
   3 --
   4 -- Driver flags
   5 --
   6 -- (c) Simon Marlow 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module DriverFlags where
  11
  12 #include "HsVersions.h"
  13
  14 import PackageMaintenance
  15 import DriverState
  16 import DriverUtil
  17 import CmdLineOpts
  18 import Config
  19 import Util
  20 import CmdLineOpts
  21
  22 import Exception
  23 import IOExts
  24 import IO
  25 import System
  26 import Char
  27
  28 -----------------------------------------------------------------------------
  29 -- Flags
  30
  31 -- Flag parsing is now done in stages:
  32 --
  33 --     * parse the initial list of flags and remove any flags understood
  34 --       by the driver only.  Determine whether we're in multi-compilation
  35 --       or single-compilation mode.
  36 --
  37 --     * gather the list of "static" hsc flags, and assign them to the global
  38 --       static hsc flags variable.
  39 --
  40 --     * build the inital DynFlags from the remaining flags.
  41 --
  42 --     * complain if we've got any flags left over.
  43 --
  44 --     * for each source file: grab the OPTIONS, and build a new DynFlags
  45 --       to pass to the compiler.
  46
  47 -----------------------------------------------------------------------------
  48 -- Process command-line
  49
  50 data OptKind
  51         = NoArg (IO ())                     -- flag with no argument
  52         | HasArg (String -> IO ())          -- flag has an argument (maybe prefix)
  53         | SepArg (String -> IO ())          -- flag has a separate argument
  54         | Prefix (String -> IO ())          -- flag is a prefix only
  55         | OptPrefix (String -> IO ())       -- flag may be a prefix
  56         | AnySuffix (String -> IO ())       -- flag is a prefix, pass whole arg to fn
  57         | PassFlag  (String -> IO ())       -- flag with no arg, pass flag to fn
  58         | PrefixPred (String -> Bool) (String -> IO ())
  59         | AnySuffixPred (String -> Bool) (String -> IO ())
  60
  61 processArgs :: [(String,OptKind)] -> [String] -> [String]
  62    -> IO [String]  -- returns spare args
  63 processArgs _spec [] spare = return (reverse spare)
  64 processArgs spec args@(arg@('-':_):args') spare = do
  65   case findArg spec arg of
  66     Just (rest,action) ->
  67       do args' <- processOneArg action rest args
  68          processArgs spec args' spare
  69     Nothing ->
  70       processArgs spec args' (arg:spare)
  71 processArgs spec (arg:args) spare =
  72   processArgs spec args (arg:spare)
  73
  74 processOneArg :: OptKind -> String -> [String] -> IO [String]
  75 processOneArg action rest (dash_arg@('-':arg):args) =
  76   case action of
  77         NoArg  io ->
  78                 if rest == ""
  79                         then io >> return args
  80                         else unknownFlagErr dash_arg
  81
  82         HasArg fio ->
  83                 if rest /= ""
  84                         then fio rest >> return args
  85                         else case args of
  86                                 [] -> unknownFlagErr dash_arg
  87                                 (arg1:args1) -> fio arg1 >> return args1
  88
  89         SepArg fio ->
  90                 case args of
  91                         [] -> unknownFlagErr dash_arg
  92                         (arg1:args1) -> fio arg1 >> return args1
  93
  94         Prefix fio ->
  95                 if rest /= ""
  96                         then fio rest >> return args
  97                         else unknownFlagErr dash_arg
  98
  99         PrefixPred p fio ->
 100                 if rest /= ""
 101                         then fio rest >> return args
 102                         else unknownFlagErr dash_arg
 103
 104         OptPrefix fio       -> fio rest >> return args
 105
 106         AnySuffix fio       -> fio dash_arg >> return args
 107
 108         AnySuffixPred p fio -> fio dash_arg >> return args
 109
 110         PassFlag fio  ->
 111                 if rest /= ""
 112                         then unknownFlagErr dash_arg
 113                         else fio dash_arg >> return args
 114
 115 findArg :: [(String,OptKind)] -> String -> Maybe (String,OptKind)
 116 findArg spec arg
 117   = case [ (remove_spaces rest, k)
 118          | (pat,k) <- spec, Just rest <- [my_prefix_match pat arg],
 119            arg_ok k arg rest ]
 120     of
 121         []      -> Nothing
 122         (one:_) -> Just one
 123
 124 arg_ok (NoArg _)            rest arg = null rest
 125 arg_ok (HasArg _)           rest arg = True
 126 arg_ok (SepArg _)           rest arg = null rest
 127 arg_ok (Prefix _)           rest arg = not (null rest)
 128 arg_ok (PrefixPred p _)     rest arg = not (null rest) && p rest
 129 arg_ok (OptPrefix _)        rest arg = True
 130 arg_ok (PassFlag _)         rest arg = null rest
 131 arg_ok (AnySuffix _)        rest arg = not (null rest)
 132 arg_ok (AnySuffixPred p _)  rest arg = not (null rest) && p arg
 133
 134 -----------------------------------------------------------------------------
 135 -- Static flags
 136
 137 -- note that ordering is important in the following list: any flag which
 138 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
 139 -- flags further down the list with the same prefix.
 140
 141 static_flags =
 142   [  ------- help -------------------------------------------------------
 143      ( "?"              , NoArg long_usage)
 144   ,  ( "-help"          , NoArg long_usage)
 145
 146
 147       ------- version ----------------------------------------------------
 148   ,  ( "-version"        , NoArg (do hPutStrLn stdout (cProjectName
 149                                       ++ ", version " ++ version_str)
 150                                      exitWith ExitSuccess))
 151   ,  ( "-numeric-version", NoArg (do hPutStrLn stdout version_str
 152                                      exitWith ExitSuccess))
 153
 154       ------- verbosity ----------------------------------------------------
 155   ,  ( "v"              , NoArg (writeIORef verbose True) )
 156   ,  ( "n"              , NoArg (writeIORef dry_run True) )
 157
 158         ------- recompilation checker --------------------------------------
 159   ,  ( "recomp"         , NoArg (writeIORef recomp True) )
 160   ,  ( "no-recomp"      , NoArg (writeIORef recomp False) )
 161
 162         ------- ways --------------------------------------------------------
 163   ,  ( "prof"           , NoArg (addNoDups ways WayProf) )
 164   ,  ( "unreg"          , NoArg (addNoDups ways WayUnreg) )
 165   ,  ( "dll"            , NoArg (addNoDups ways WayDll) )
 166   ,  ( "ticky"          , NoArg (addNoDups ways WayTicky) )
 167   ,  ( "parallel"       , NoArg (addNoDups ways WayPar) )
 168   ,  ( "gransim"        , NoArg (addNoDups ways WayGran) )
 169   ,  ( "smp"            , NoArg (addNoDups ways WaySMP) )
 170   ,  ( "debug"          , NoArg (addNoDups ways WayDebug) )
 171         -- ToDo: user ways
 172
 173         ------ Debugging ----------------------------------------------------
 174   ,  ( "dppr-noprags",     PassFlag (add opt_C) )
 175   ,  ( "dppr-debug",       PassFlag (add opt_C) )
 176   ,  ( "dppr-user-length", AnySuffix (add opt_C) )
 177       -- rest of the debugging flags are dynamic
 178
 179         ------- Interface files ---------------------------------------------
 180   ,  ( "hi"             , NoArg (writeIORef produceHi True) )
 181   ,  ( "nohi"           , NoArg (writeIORef produceHi False) )
 182
 183         --------- Profiling --------------------------------------------------
 184   ,  ( "auto-dicts"     , NoArg (add opt_C "-fauto-sccs-on-dicts") )
 185   ,  ( "auto-all"       , NoArg (add opt_C "-fauto-sccs-on-all-toplevs") )
 186   ,  ( "auto"           , NoArg (add opt_C "-fauto-sccs-on-exported-toplevs") )
 187   ,  ( "caf-all"        , NoArg (add opt_C "-fauto-sccs-on-individual-cafs") )
 188          -- "ignore-sccs"  doesn't work  (ToDo)
 189
 190   ,  ( "no-auto-dicts"  , NoArg (add anti_opt_C "-fauto-sccs-on-dicts") )
 191   ,  ( "no-auto-all"    , NoArg (add anti_opt_C "-fauto-sccs-on-all-toplevs") )
 192   ,  ( "no-auto"        , NoArg (add anti_opt_C "-fauto-sccs-on-exported-toplevs") )
 193   ,  ( "no-caf-all"     , NoArg (add anti_opt_C "-fauto-sccs-on-individual-cafs") )
 194
 195         ------- Miscellaneous -----------------------------------------------
 196   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
 197
 198         ------- Output Redirection ------------------------------------------
 199   ,  ( "odir"           , HasArg (writeIORef output_dir  . Just) )
 200   ,  ( "o"              , SepArg (writeIORef output_file . Just) )
 201   ,  ( "osuf"           , HasArg (writeIORef output_suf  . Just) )
 202   ,  ( "hisuf"          , HasArg (writeIORef hi_suf) )
 203   ,  ( "tmpdir"         , HasArg (writeIORef v_TmpDir . (++ "/")) )
 204   ,  ( "ohi"            , HasArg (\s -> case s of
 205                                           "-" -> writeIORef hi_on_stdout True
 206                                           _   -> writeIORef output_hi (Just s)) )
 207         -- -odump?
 208
 209   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef keep_hc_files True) )
 210   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef keep_s_files  True) )
 211   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files  True) )
 212   ,  ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef keep_tmp_files True) )
 213
 214   ,  ( "split-objs"     , NoArg (if can_split
 215                                     then do writeIORef split_object_files True
 216                                             add opt_C "-fglobalise-toplev-names"
 217 -- TODO!!!!!                                add opt_c "-DUSE_SPLIT_MARKERS"
 218                                     else hPutStrLn stderr
 219                                             "warning: don't know how to  split \
 220                                             \object files on this architecture"
 221                                 ) )
 222
 223         ------- Include/Import Paths ----------------------------------------
 224   ,  ( "i"              , OptPrefix (addToDirList import_paths) )
 225   ,  ( "I"              , Prefix    (addToDirList include_paths) )
 226
 227         ------- Libraries ---------------------------------------------------
 228   ,  ( "L"              , Prefix (addToDirList library_paths) )
 229   ,  ( "l"              , Prefix (add cmdline_libraries) )
 230
 231         ------- Packages ----------------------------------------------------
 232   ,  ( "package-name"   , HasArg (\s -> add opt_C ("-inpackage="++s)) )
 233
 234   ,  ( "package"        , HasArg (addPackage) )
 235   ,  ( "syslib"         , HasArg (addPackage) ) -- for compatibility w/ old vsns
 236
 237   ,  ( "-list-packages"  , NoArg (listPackages) )
 238   ,  ( "-add-package"    , NoArg (newPackage) )
 239   ,  ( "-delete-package" , SepArg (deletePackage) )
 240
 241         ------- Specific phases  --------------------------------------------
 242   ,  ( "pgmL"           , HasArg (writeIORef pgm_L) )
 243   ,  ( "pgmP"           , HasArg (writeIORef pgm_P) )
 244   ,  ( "pgmC"           , HasArg (writeIORef pgm_C) )
 245   ,  ( "pgmc"           , HasArg (writeIORef pgm_c) )
 246   ,  ( "pgmm"           , HasArg (writeIORef pgm_m) )
 247   ,  ( "pgms"           , HasArg (writeIORef pgm_s) )
 248   ,  ( "pgma"           , HasArg (writeIORef pgm_a) )
 249   ,  ( "pgml"           , HasArg (writeIORef pgm_l) )
 250
 251   ,  ( "optdep"         , HasArg (add opt_dep) )
 252   ,  ( "optl"           , HasArg (add opt_l) )
 253   ,  ( "optdll"         , HasArg (add opt_dll) )
 254
 255         ------ Warning opts -------------------------------------------------
 256   ,  ( "W"              , NoArg (writeIORef warning_opt W_) )
 257   ,  ( "Wall"           , NoArg (writeIORef warning_opt W_all) )
 258   ,  ( "Wnot"           , NoArg (writeIORef warning_opt W_not) )
 259   ,  ( "w"              , NoArg (writeIORef warning_opt W_not) )
 260
 261         ----- Linker --------------------------------------------------------
 262   ,  ( "static"         , NoArg (writeIORef static True) )
 263
 264         ------ Compiler flags -----------------------------------------------
 265   ,  ( "O2-for-C"          , NoArg (writeIORef opt_minus_o2_for_C True) )
 266   ,  ( "O"                 , OptPrefix (setOptLevel) )
 267
 268   ,  ( "fasm"              , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
 269
 270   ,  ( "fvia-c"            , NoArg (writeIORef hsc_lang HscC) )
 271   ,  ( "fvia-C"            , NoArg (writeIORef hsc_lang HscC) )
 272
 273   ,  ( "fno-asm-mangling"  , NoArg (writeIORef do_asm_mangling False) )
 274
 275   ,  ( "fmax-simplifier-iterations",
 276                 Prefix (writeIORef opt_MaxSimplifierIterations . read) )
 277
 278   ,  ( "fusagesp"          , NoArg (do writeIORef opt_UsageSPInf True
 279                                        add opt_C "-fusagesp-on") )
 280
 281   ,  ( "fexcess-precision" , NoArg (do writeIORef excess_precision True
 282                                        add opt_C "-fexcess-precision"))
 283
 284         -- flags that are "active negatives"
 285   ,  ( "fno-implicit-prelude"   , PassFlag (add opt_C) )
 286   ,  ( "fno-prune-tydecls"      , PassFlag (add opt_C) )
 287   ,  ( "fno-prune-instdecls"    , PassFlag (add opt_C) )
 288   ,  ( "fno-pre-inlining"       , PassFlag (add opt_C) )
 289
 290         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
 291   ,  ( "fno-",                  PrefixPred (\s -> isStaticHscFlag ("f"++s))
 292                                     (\s -> add anti_opt_C ("-f"++s)) )
 293
 294         -- Pass all remaining "-f<blah>" options to hsc
 295   ,  ( "f",                     AnySuffixPred (isStaticHscFlag) (add opt_C) )
 296   ]
 297
 298 -----------------------------------------------------------------------------
 299 -- parse the dynamic arguments
 300
 301 GLOBAL_VAR(dynFlags, error "no dynFlags", DynFlags)
 302
 303 setDynFlag f = do
 304    dfs <- readIORef dynFlags
 305    writeIORef dynFlags dfs{ flags = f : flags dfs }
 306
 307 unSetDynFlag f = do
 308    dfs <- readIORef dynFlags
 309    writeIORef dynFlags dfs{ flags = filter (/= f) (flags dfs) }
 310
 311 dynamic_flags = [
 312
 313      ( "cpp",           NoArg  (updateState (\s -> s{ cpp_flag = True })) )
 314   ,  ( "#include",      HasArg (addCmdlineHCInclude) )
 315
 316   ,  ( "optL",          HasArg (addOpt_L) )
 317   ,  ( "optP",          HasArg (addOpt_P) )
 318   ,  ( "optc",          HasArg (addOpt_c) )
 319   ,  ( "optm",          HasArg (addOpt_m) )
 320   ,  ( "opta",          HasArg (addOpt_a) )
 321
 322         ------ HsCpp opts ---------------------------------------------------
 323   ,  ( "D",             Prefix (\s -> addOpt_P ("-D'"++s++"'") ) )
 324   ,  ( "U",             Prefix (\s -> addOpt_P ("-U'"++s++"'") ) )
 325
 326         ------ Debugging ----------------------------------------------------
 327   ,  ( "dstg-stats",    NoArg (writeIORef opt_StgStats True) )
 328
 329   ,  ( "ddump_all",              NoArg (setDynFlag Opt_D_dump_all) )
 330   ,  ( "ddump_most",             NoArg (setDynFlag Opt_D_dump_most) )
 331   ,  ( "ddump_absC",             NoArg (setDynFlag Opt_D_dump_absC) )
 332   ,  ( "ddump_asm",              NoArg (setDynFlag Opt_D_dump_asm) )
 333   ,  ( "ddump_cpranal",          NoArg (setDynFlag Opt_D_dump_cpranal) )
 334   ,  ( "ddump_deriv",            NoArg (setDynFlag Opt_D_dump_deriv) )
 335   ,  ( "ddump_ds",               NoArg (setDynFlag Opt_D_dump_ds) )
 336   ,  ( "ddump_flatC",            NoArg (setDynFlag Opt_D_dump_flatC) )
 337   ,  ( "ddump_foreign",          NoArg (setDynFlag Opt_D_dump_foreign) )
 338   ,  ( "ddump_inlinings",        NoArg (setDynFlag Opt_D_dump_inlinings) )
 339   ,  ( "ddump_occur_anal",       NoArg (setDynFlag Opt_D_dump_occur_anal) )
 340   ,  ( "ddump_parsed",           NoArg (setDynFlag Opt_D_dump_parsed) )
 341   ,  ( "ddump_realC",            NoArg (setDynFlag Opt_D_dump_realC) )
 342   ,  ( "ddump_rn",               NoArg (setDynFlag Opt_D_dump_rn) )
 343   ,  ( "ddump_simpl",            NoArg (setDynFlag Opt_D_dump_simpl) )
 344   ,  ( "ddump_simpl_iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) )
 345   ,  ( "ddump_spec",             NoArg (setDynFlag Opt_D_dump_spec) )
 346   ,  ( "ddump_stg",              NoArg (setDynFlag Opt_D_dump_stg) )
 347   ,  ( "ddump_stranal",          NoArg (setDynFlag Opt_D_dump_stranal) )
 348   ,  ( "ddump_tc",               NoArg (setDynFlag Opt_D_dump_tc) )
 349   ,  ( "ddump_types",            NoArg (setDynFlag Opt_D_dump_types) )
 350   ,  ( "ddump_rules",            NoArg (setDynFlag Opt_D_dump_rules) )
 351   ,  ( "ddump_usagesp",          NoArg (setDynFlag Opt_D_dump_usagesp) )
 352   ,  ( "ddump_cse",              NoArg (setDynFlag Opt_D_dump_cse) )
 353   ,  ( "ddump_worker_wrapper",   NoArg (setDynFlag Opt_D_dump_worker_wrapper) )
 354   ,  ( "dshow_passes",           NoArg (setDynFlag Opt_D_show_passes) )
 355   ,  ( "ddump_rn_trace",         NoArg (setDynFlag Opt_D_dump_rn_trace) )
 356   ,  ( "ddump_rn_stats",         NoArg (setDynFlag Opt_D_dump_rn_stats) )
 357   ,  ( "ddump_stix",             NoArg (setDynFlag Opt_D_dump_stix) )
 358   ,  ( "ddump_simpl_stats",      NoArg (setDynFlag Opt_D_dump_simpl_stats) )
 359   ,  ( "dsource_stats",          NoArg (setDynFlag Opt_D_source_stats) )
 360   ,  ( "dverbose_core2core",     NoArg (setDynFlag Opt_D_verbose_core2core) )
 361   ,  ( "dverbose_stg2stg",       NoArg (setDynFlag Opt_D_verbose_stg2stg) )
 362   ,  ( "ddump_hi_diffs",         NoArg (setDynFlag Opt_D_dump_hi_diffs) )
 363   ,  ( "ddump_minimal_imports",  NoArg (setDynFlag Opt_D_dump_minimal_imports) )
 364   ,  ( "DoCoreLinting",          NoArg (setDynFlag Opt_DoCoreLinting) )
 365   ,  ( "DoStgLinting",           NoArg (setDynFlag Opt_DoStgLinting) )
 366   ,  ( "DoUSPLinting",           NoArg (setDynFlag Opt_DoUSPLinting) )
 367
 368         ------ Machine dependant (-m<blah>) stuff ---------------------------
 369
 370   ,  ( "monly-2-regs",  NoArg (updateState (\s -> s{stolen_x86_regs = 2}) ))
 371   ,  ( "monly-3-regs",  NoArg (updateState (\s -> s{stolen_x86_regs = 3}) ))
 372   ,  ( "monly-4-regs",  NoArg (updateState (\s -> s{stolen_x86_regs = 4}) ))
 373
 374         ------ Compiler flags -----------------------------------------------
 375
 376   ,  ( "fglasgow-exts", NoArg (setDynFlag Opt_GlasgowExts) )
 377
 378   ,  ( "fallow-overlapping-instances",
 379                 NoArg (setDynFlag Opt_AllowOverlappingInstances) )
 380
 381   ,  ( "fallow-undecidable-instances",
 382                 NoArg (setDynFlag Opt_AllowUndecidableInstances) )
 383  ]
 384
 385 -----------------------------------------------------------------------------
 386 -- convert sizes like "3.5M" into integers
 387
 388 decodeSize :: String -> Integer
 389 decodeSize str
 390   | c == ""              = truncate n
 391   | c == "K" || c == "k" = truncate (n * 1000)
 392   | c == "M" || c == "m" = truncate (n * 1000 * 1000)
 393   | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
 394   | otherwise            = throwDyn (OtherError ("can't decode size: " ++ str))
 395   where (m, c) = span pred str
 396         n      = read m  :: Double
 397         pred c = isDigit c || c == '.'
 398
 399 floatOpt :: IORef Double -> String -> IO ()
 400 floatOpt ref str
 401   = writeIORef ref (read str :: Double)