Separate the static flag parser from the static global variables

This allows us to avoid a module import loop:
CmdLineParser -> SrcLoc -> Outputable -> StaticFlags -> CmdLineParser

diff --git a/compiler/ghc.cabal b/compiler/ghc.cabal
index 437ebc2..3c49019 100644 (file)
--- a/compiler/ghc.cabal
+++ b/compiler/ghc.cabal
@@ -284,6 +284,7 @@ Library
         ParsePkgConf
         PprTyThing
         StaticFlags
+        StaticFlagParser
         SysTools
         TidyPgm
         Ctype

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index e1210bd..19e36eb 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -245,6 +245,7 @@ import HscMain
 import HscTypes
 import DynFlags
 import StaticFlags
+import StaticFlagParser
 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                       cleanTempDirs )
 import Module

diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs
new file mode 100644 (file)
index 0000000..c0a501e
--- /dev/null
+++ b/compiler/main/StaticFlagParser.hs
@@ -0,0 +1,211 @@
+-----------------------------------------------------------------------------
+--
+-- Static flags
+--
+-- Static flags can only be set once, on the command-line.  Inside GHC,
+-- each static flag corresponds to a top-level value, usually of type Bool.
+--
+-- (c) The University of Glasgow 2005
+--
+-----------------------------------------------------------------------------
+
+module StaticFlagParser (parseStaticFlags) where
+
+#include "HsVersions.h"
+
+import StaticFlags
+import CmdLineParser
+import Config
+import Util
+import Panic
+
+import Control.Monad
+import Data.Char
+import Data.IORef
+import Data.List
+
+-----------------------------------------------------------------------------
+-- Static flags
+
+parseStaticFlags :: [String] -> IO ([String], [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))
+
+    -- deal with the way flags: the way (eg. prof) gives rise to
+    -- further flags, some of which might be static.
+  way_flags <- findBuildTag
+
+    -- 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)
+
+    -- see sanity code in staticOpts
+  writeIORef v_opt_C_ready True
+
+    -- TABLES_NEXT_TO_CODE affects the info table layout.
+    -- 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        = []
+
+    -- 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                = []
+
+  when (not (null errs)) $ ghcError (UsageError (unlines errs))
+  return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
+          warns1 ++ warns2)
+
+static_flags :: [Flag IO]
+-- All the static flags should appear in this list.  It describes how each
+-- static flag should be processed.  Two main purposes:
+-- (a) if a command-line flag doesn't appear in the list, GHC can complain
+-- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" things
+--
+-- The common (PassFlag addOpt) action puts the static flag into the bunch of
+-- things that are searched up by the top-level definitions like
+--     opt_foo = lookUp (fsLit "-dfoo")
+
+-- Note that ordering is important in the following list: any flag which
+-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
+-- flags further down the list with the same prefix.
+
+static_flags = [
+        ------- GHCi -------------------------------------------------------
+    Flag "ignore-dot-ghci" (PassFlag addOpt) Supported
+  , Flag "read-dot-ghci"   (NoArg (removeOpt "-ignore-dot-ghci")) Supported
+
+        ------- 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
+
+        ------ 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
+      -- 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
+    -- ignored for compat w/ gcc:
+  , Flag "rdynamic"       (NoArg (return ())) Supported
+
+        ----- RTS opts ------------------------------------------------------
+  , Flag "H"              (HasArg (setHeapSize . fromIntegral . decodeSize))
+         Supported
+  , Flag "Rghc-timing"    (NoArg  (enableTimingStats)) Supported
+
+        ------ Compiler flags -----------------------------------------------
+        -- 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
+  ]
+
+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",
+    "firrefutable-tuples",
+    "fparallel",
+    "fgransim",
+    "fno-hi-version-check",
+    "dno-black-holing",
+    "fno-method-sharing",
+    "fno-state-hack",
+    "fno-ds-multi-tyvar",
+    "fruntime-types",
+    "fno-pre-inlining",
+    "fexcess-precision",
+    "static",
+    "fhardwire-lib-paths",
+    "funregisterised",
+    "fext-core",
+    "fcpr-off",
+    "ferror-spans",
+    "fPIC",
+    "fhpc"
+    ]
+  || any (`isPrefixOf` f) [
+    "fliberate-case-threshold",
+    "fmax-worker-args",
+    "fhistory-size",
+    "funfolding-creation-threshold",
+    "funfolding-use-threshold",
+    "funfolding-fun-discount",
+    "funfolding-keeness-factor"
+     ]
+
+unregFlags :: [String]
+unregFlags = 
+   [ "-optc-DNO_REGS"
+   , "-optc-DUSE_MINIINTERPRETER"
+   , "-fno-asm-mangling"
+   , "-funregisterised"
+   , "-fvia-C" ]
+
+-----------------------------------------------------------------------------
+-- convert sizes like "3.5M" into integers
+
+decodeSize :: String -> Integer
+decodeSize str
+  | c == ""      = truncate n
+  | c == "K" || c == "k" = truncate (n * 1000)
+  | c == "M" || c == "m" = truncate (n * 1000 * 1000)
+  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
+  | otherwise            = ghcError (CmdLineError ("can't decode size: " ++ str))
+  where (m, c) = span pred str
+        n      = readRational m
+        pred c = isDigit c || c == '.'
+
+-----------------------------------------------------------------------------
+-- RTS Hooks
+
+foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()
+foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
+

diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index c159799..2060554 100644 (file)
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -13,7 +13,6 @@
 -----------------------------------------------------------------------------
 
 module StaticFlags (
-       parseStaticFlags,
        staticFlags,
         initStaticOpts,
 
@@ -74,12 +73,14 @@ module StaticFlags (
        opt_Unregisterised,
        opt_EmitExternalCore,
        v_Ld_inputs,
-       tablesNextToCode
+       tablesNextToCode,
+
+    -- For the parser
+    addOpt, removeOpt, addWay, findBuildTag, v_opt_C_ready
   ) where
 
 #include "HsVersions.h"
 
-import CmdLineParser
 import Config
 import FastString
 import Util
@@ -88,131 +89,14 @@ import Panic
 
 import Data.IORef
 import System.IO.Unsafe        ( unsafePerformIO )
-import Control.Monad   ( when )
-import Data.Char       ( isDigit )
 import Data.List
 
 -----------------------------------------------------------------------------
 -- Static flags
 
-parseStaticFlags :: [String] -> IO ([String], [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))
-
-    -- deal with the way flags: the way (eg. prof) gives rise to
-    -- further flags, some of which might be static.
-  way_flags <- findBuildTag
-
-    -- 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)
-
-    -- see sanity code in staticOpts
-  writeIORef v_opt_C_ready True
-
-    -- TABLES_NEXT_TO_CODE affects the info table layout.
-    -- 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        = []
-
-    -- 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                = []
-
-  when (not (null errs)) $ ghcError (UsageError (unlines errs))
-  return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
-          warns1 ++ warns2)
-
 initStaticOpts :: IO ()
 initStaticOpts = writeIORef v_opt_C_ready True
 
-static_flags :: [Flag IO]
--- All the static flags should appear in this list.  It describes how each
--- static flag should be processed.  Two main purposes:
--- (a) if a command-line flag doesn't appear in the list, GHC can complain
--- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" things
---
--- The common (PassFlag addOpt) action puts the static flag into the bunch of
--- things that are searched up by the top-level definitions like
---     opt_foo = lookUp (fsLit "-dfoo")
-
--- Note that ordering is important in the following list: any flag which
--- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
--- flags further down the list with the same prefix.
-
-static_flags = [
-        ------- GHCi -------------------------------------------------------
-    Flag "ignore-dot-ghci" (PassFlag addOpt) Supported
-  , Flag "read-dot-ghci"   (NoArg (removeOpt "-ignore-dot-ghci")) Supported
-
-        ------- 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
-
-        ------ 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
-      -- 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
-    -- ignored for compat w/ gcc:
-  , Flag "rdynamic"       (NoArg (return ())) Supported
-
-        ----- RTS opts ------------------------------------------------------
-  , Flag "H"              (HasArg (setHeapSize . fromIntegral . decodeSize))
-         Supported
-  , Flag "Rghc-timing"    (NoArg  (enableTimingStats)) Supported
-
-        ------ Compiler flags -----------------------------------------------
-        -- 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
-  ]
-
 addOpt :: String -> IO ()
 addOpt = consIORef v_opt_C
 
@@ -414,66 +298,6 @@ opt_ErrorSpans                     = lookUp (fsLit "-ferror-spans")
 -- how to do it though --SDM.
 GLOBAL_VAR(v_Ld_inputs,        [],      [String])
 
-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",
-       "firrefutable-tuples",
-       "fparallel",
-       "fgransim",
-       "fno-hi-version-check",
-       "dno-black-holing",
-       "fno-method-sharing",
-       "fno-state-hack",
-       "fno-ds-multi-tyvar",
-       "fruntime-types",
-       "fno-pre-inlining",
-       "fexcess-precision",
-       "static",
-       "fhardwire-lib-paths",
-       "funregisterised",
-       "fext-core",
-       "fcpr-off",
-       "ferror-spans",
-       "fPIC",
-       "fhpc"
-       ]
-  || any (`isPrefixOf` f) [
-       "fliberate-case-threshold",
-       "fmax-worker-args",
-       "fhistory-size",
-       "funfolding-creation-threshold",
-       "funfolding-use-threshold",
-       "funfolding-fun-discount",
-       "funfolding-keeness-factor"
-     ]
-
------------------------------------------------------------------------------
--- convert sizes like "3.5M" into integers
-
-decodeSize :: String -> Integer
-decodeSize str
-  | c == ""             = truncate n
-  | c == "K" || c == "k" = truncate (n * 1000)
-  | c == "M" || c == "m" = truncate (n * 1000 * 1000)
-  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
-  | otherwise            = ghcError (CmdLineError ("can't decode size: " ++ str))
-  where (m, c) = span pred str
-        n      = readRational m
-       pred c = isDigit c || c == '.'
-
-
------------------------------------------------------------------------------
--- RTS Hooks
-
-foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()
-foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
-
 -----------------------------------------------------------------------------
 -- Ways
 
@@ -673,10 +497,3 @@ way_details =
     (WayUser_B,  Way  "B"  False "User way 'B'"  ["$WAY_B_REAL_OPTS"]) 
   ]
 
-unregFlags :: [String]
-unregFlags = 
-   [ "-optc-DNO_REGS"
-   , "-optc-DUSE_MINIINTERPRETER"
-   , "-fno-asm-mangling"
-   , "-funregisterised"
-   , "-fvia-C" ]

diff --git a/ghc/Main.hs b/ghc/Main.hs
index 840f843..a974716 100644 (file)
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -35,6 +35,7 @@ import Packages               ( dumpPackages )
 import DriverPhases    ( Phase(..), isSourceFilename, anyHsc,
                          startPhase, isHaskellSrcFilename )
 import StaticFlags
+import StaticFlagParser
 import DynFlags
 import BasicTypes      ( failed )
 import ErrUtils