Super-monster patch implementing the new typechecker -- at last
[ghc-hetmet.git] / compiler / main / StaticFlagParser.hs
index c0a501e..6536a13 100644 (file)
@@ -13,9 +13,12 @@ module StaticFlagParser (parseStaticFlags) where
 
 #include "HsVersions.h"
 
-import StaticFlags
+import qualified StaticFlags as SF
+import StaticFlags ( v_opt_C_ready, getWayFlags, tablesNextToCode, WayName(..)
+                   , opt_SimplExcessPrecision )
 import CmdLineParser
 import Config
+import SrcLoc
 import Util
 import Panic
 
@@ -27,23 +30,39 @@ import Data.List
 -----------------------------------------------------------------------------
 -- Static flags
 
-parseStaticFlags :: [String] -> IO ([String], [String])
+-- | Parses GHC's static flags from a list of command line arguments.
+--
+-- These flags are static in the sense that they can be set only once and they
+-- are global, meaning that they affect every instance of GHC running;
+-- multiple GHC threads will use the same flags.
+--
+-- This function must be called before any session is started, i.e., before
+-- the first call to 'GHC.withGhc'.
+--
+-- Static flags are more of a hack and are static for more or less historical
+-- reasons.  In the long run, most static flags should eventually become
+-- dynamic flags.
+--
+-- XXX: can we add an auto-generated list of static flags here?
+--
+parseStaticFlags :: [Located String] -> IO ([Located String], [Located String])
 parseStaticFlags args = do
   ready <- readIORef v_opt_C_ready
   when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession")
 
   (leftover, errs, warns1) <- processArgs static_flags args
-  when (not (null errs)) $ ghcError (UsageError (unlines errs))
+  when (not (null errs)) $ ghcError $ errorsToGhcException errs
 
     -- deal with the way flags: the way (eg. prof) gives rise to
     -- further flags, some of which might be static.
-  way_flags <- findBuildTag
+  way_flags <- getWayFlags
+  let way_flags' = map (mkGeneralLocated "in way flags") way_flags
 
     -- if we're unregisterised, add some more flags
   let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
                  | otherwise = []
 
-  (more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags)
+  (more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags')
 
     -- see sanity code in staticOpts
   writeIORef v_opt_C_ready True
@@ -52,16 +71,19 @@ parseStaticFlags args = do
     -- Be careful to do this *after* all processArgs,
     -- because evaluating tablesNextToCode involves looking at the global
     -- static flags.  Those pesky global variables...
-  let cg_flags | tablesNextToCode = ["-optc-DTABLES_NEXT_TO_CODE"]
-              | otherwise        = []
+  let cg_flags | tablesNextToCode = map (mkGeneralLocated "in cg_flags")
+                                        ["-optc-DTABLES_NEXT_TO_CODE"]
+               | otherwise        = []
 
     -- HACK: -fexcess-precision is both a static and a dynamic flag.  If
     -- the static flag parser has slurped it, we must return it as a 
     -- leftover too.  ToDo: make -fexcess-precision dynamic only.
-  let excess_prec | opt_SimplExcessPrecision = ["-fexcess-precision"]
-                  | otherwise                = []
+  let excess_prec
+       | opt_SimplExcessPrecision = map (mkGeneralLocated "in excess_prec")
+                                        ["-fexcess-precision"]
+       | otherwise                = []
 
-  when (not (null errs)) $ ghcError (UsageError (unlines errs))
+  when (not (null errs)) $ ghcError $ errorsToGhcException errs
   return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
           warns1 ++ warns2)
 
@@ -81,73 +103,70 @@ static_flags :: [Flag IO]
 
 static_flags = [
         ------- GHCi -------------------------------------------------------
-    Flag "ignore-dot-ghci" (PassFlag addOpt) Supported
-  , Flag "read-dot-ghci"   (NoArg (removeOpt "-ignore-dot-ghci")) Supported
+    Flag "ignore-dot-ghci" (PassFlag addOpt) 
+  , Flag "read-dot-ghci"   (NoArg (removeOpt "-ignore-dot-ghci"))
 
         ------- ways --------------------------------------------------------
-  , Flag "prof"           (NoArg (addWay WayProf)) Supported
-  , Flag "ticky"          (NoArg (addWay WayTicky)) Supported
-  , Flag "parallel"       (NoArg (addWay WayPar)) Supported
-  , Flag "gransim"        (NoArg (addWay WayGran)) Supported
-  , Flag "smp"            (NoArg (addWay WayThreaded))
-         (Deprecated "Use -threaded instead")
-  , Flag "debug"          (NoArg (addWay WayDebug)) Supported
-  , Flag "ndp"            (NoArg (addWay WayNDP)) Supported
-  , Flag "threaded"       (NoArg (addWay WayThreaded)) Supported
-        -- ToDo: user ways
+  , Flag "prof"           (NoArg (addWay WayProf)) 
+  , Flag "eventlog"       (NoArg (addWay WayEventLog))
+  , Flag "parallel"       (NoArg (addWay WayPar))
+  , Flag "gransim"        (NoArg (addWay WayGran))
+  , Flag "smp"            (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead"))
+  , Flag "debug"          (NoArg (addWay WayDebug))
+  , Flag "ndp"            (NoArg (addWay WayNDP))
+  , Flag "threaded"       (NoArg (addWay WayThreaded))
+
+  , Flag "ticky"          (PassFlag (\f -> do addOpt f; addWay WayDebug))
+    -- -ticky enables ticky-ticky code generation, and also implies -debug which
+    -- is required to get the RTS ticky support.
 
         ------ Debugging ----------------------------------------------------
-  , Flag "dppr-debug"        (PassFlag addOpt) Supported
-  , Flag "dsuppress-uniques" (PassFlag addOpt) Supported
-  , Flag "dppr-user-length"  (AnySuffix addOpt) Supported
-  , Flag "dopt-fuel"         (AnySuffix addOpt) Supported
-  , Flag "dno-debug-output"  (PassFlag addOpt) Supported
+  , Flag "dppr-debug"                (PassFlag addOpt)
+  , Flag "dsuppress-uniques"         (PassFlag addOpt)
+  , Flag "dsuppress-coercions"       (PassFlag addOpt)
+  , Flag "dsuppress-module-prefixes" (PassFlag addOpt)
+  , Flag "dppr-user-length"          (AnySuffix addOpt)
+  , Flag "dopt-fuel"                 (AnySuffix addOpt)
+  , Flag "dtrace-level"              (AnySuffix addOpt)
+  , Flag "dno-debug-output"          (PassFlag addOpt)
+  , Flag "dstub-dead-values"         (PassFlag addOpt)
       -- rest of the debugging flags are dynamic
 
-        --------- Profiling --------------------------------------------------
-  , Flag "auto-all"       (NoArg (addOpt "-fauto-sccs-on-all-toplevs"))
-         Supported
-  , Flag "auto"           (NoArg (addOpt "-fauto-sccs-on-exported-toplevs"))
-         Supported
-  , Flag "caf-all"        (NoArg (addOpt "-fauto-sccs-on-individual-cafs"))
-         Supported
-         -- "ignore-sccs"  doesn't work  (ToDo)
-
-  , Flag "no-auto-all"    (NoArg (removeOpt "-fauto-sccs-on-all-toplevs"))
-         Supported
-  , Flag "no-auto"        (NoArg (removeOpt "-fauto-sccs-on-exported-toplevs"))
-         Supported
-  , Flag "no-caf-all"     (NoArg (removeOpt "-fauto-sccs-on-individual-cafs"))
-         Supported
-
         ----- Linker --------------------------------------------------------
-  , Flag "static"         (PassFlag addOpt) Supported
-  , Flag "dynamic"        (NoArg (removeOpt "-static")) Supported
+  , Flag "static"         (PassFlag addOpt)
+  , Flag "dynamic"        (NoArg (removeOpt "-static" >> addWay WayDyn))
     -- ignored for compat w/ gcc:
-  , Flag "rdynamic"       (NoArg (return ())) Supported
+  , Flag "rdynamic"       (NoArg (return ()))
 
         ----- RTS opts ------------------------------------------------------
-  , Flag "H"              (HasArg (setHeapSize . fromIntegral . decodeSize))
-         Supported
-  , Flag "Rghc-timing"    (NoArg  (enableTimingStats)) Supported
+  , Flag "H"              (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
+        
+  , Flag "Rghc-timing"    (NoArg (liftEwM enableTimingStats))
 
         ------ Compiler flags -----------------------------------------------
+
+        -- -fPIC requires extra checking: only the NCG supports it.
+        -- See also DynFlags.parseDynamicFlags.
+  , Flag "fPIC" (PassFlag setPIC)
+
         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
   , Flag "fno-"
          (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
-         Supported
+        
 
         -- Pass all remaining "-f<blah>" options to hsc
-  , Flag "f"                      (AnySuffixPred (isStaticFlag) addOpt)
-         Supported
+  , Flag "f" (AnySuffixPred isStaticFlag addOpt)
   ]
 
+setPIC :: String -> StaticP ()
+setPIC | cGhcWithNativeCodeGen == "YES" || cGhcUnregisterised == "YES"
+       = addOpt
+       | otherwise
+       = ghcError $ CmdLineError "-fPIC is not supported on this platform"
+
 isStaticFlag :: String -> Bool
 isStaticFlag f =
   f `elem` [
-    "fauto-sccs-on-all-toplevs",
-    "fauto-sccs-on-exported-toplevs",
-    "fauto-sccs-on-individual-cafs",
     "fscc-profiling",
     "fdicts-strict",
     "fspec-inline-join-points",
@@ -156,8 +175,8 @@ isStaticFlag f =
     "fgransim",
     "fno-hi-version-check",
     "dno-black-holing",
-    "fno-method-sharing",
     "fno-state-hack",
+    "fsimple-list-literals",
     "fno-ds-multi-tyvar",
     "fruntime-types",
     "fno-pre-inlining",
@@ -165,7 +184,6 @@ isStaticFlag f =
     "static",
     "fhardwire-lib-paths",
     "funregisterised",
-    "fext-core",
     "fcpr-off",
     "ferror-spans",
     "fPIC",
@@ -181,13 +199,12 @@ isStaticFlag f =
     "funfolding-keeness-factor"
      ]
 
-unregFlags :: [String]
-unregFlags = 
+unregFlags :: [Located String]
+unregFlags = map (mkGeneralLocated "in unregFlags")
    [ "-optc-DNO_REGS"
    , "-optc-DUSE_MINIINTERPRETER"
    , "-fno-asm-mangling"
-   , "-funregisterised"
-   , "-fvia-C" ]
+   , "-funregisterised" ]
 
 -----------------------------------------------------------------------------
 -- convert sizes like "3.5M" into integers
@@ -203,6 +220,18 @@ decodeSize str
         n      = readRational m
         pred c = isDigit c || c == '.'
 
+
+type StaticP = EwM IO
+
+addOpt :: String -> StaticP ()
+addOpt = liftEwM . SF.addOpt
+
+addWay :: WayName -> StaticP ()
+addWay = liftEwM . SF.addWay
+
+removeOpt :: String -> StaticP ()
+removeOpt = liftEwM . SF.removeOpt
+
 -----------------------------------------------------------------------------
 -- RTS Hooks