From fb9d3922c8ccc9b3f7138a821ffb635e6c65b149 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Tue, 26 Aug 2008 15:56:12 +0000 Subject: [PATCH] Separate the static flag parser from the static global variables This allows us to avoid a module import loop: CmdLineParser -> SrcLoc -> Outputable -> StaticFlags -> CmdLineParser --- compiler/ghc.cabal | 1 + compiler/main/GHC.hs | 1 + compiler/main/StaticFlagParser.hs | 211 +++++++++++++++++++++++++++++++++++++ compiler/main/StaticFlags.hs | 191 +-------------------------------- ghc/Main.hs | 1 + 5 files changed, 218 insertions(+), 187 deletions(-) create mode 100644 compiler/main/StaticFlagParser.hs diff --git a/compiler/ghc.cabal b/compiler/ghc.cabal index 437ebc2..3c49019 100644 --- 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 --- 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 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-" options cancel out "-f" on the hsc cmdline + , Flag "fno-" + (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s))) + Supported + + -- Pass all remaining "-f" 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 --- 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-" options cancel out "-f" on the hsc cmdline - , Flag "fno-" - (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s))) - Supported - - -- Pass all remaining "-f" 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 --- 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 -- 1.7.10.4