Commit a7f9930a authored by Jan Stolarek's avatar Jan Stolarek Committed by dterei

StaticFlags code cleanup (fixes #7595)

Function responsible for parsing the static flags, that were spread
across two modules (StaticFlags and StaticFlagParser), are now
in one file. This is analogous to dynamic flags parsing, which is
also contained within a single module.
Signed-off-by: dterei's avatarDavid Terei <davidterei@gmail.com>
parent 24644bb7
......@@ -291,7 +291,6 @@ Library
Packages
PprTyThing
StaticFlags
StaticFlagParser
SysTools
TidyPgm
Ctype
......
......@@ -119,6 +119,8 @@ module DynFlags (
mAX_PTR_TAG,
tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD,
unsafeGlobalDynFlags, setUnsafeGlobalDynFlags,
-- * SSE
isSse2Enabled,
isSse4_2Enabled,
......@@ -136,7 +138,6 @@ import Config
import CmdLineParser
import Constants
import Panic
import StaticFlags
import Util
import Maybes ( orElse )
import MonadUtils
......@@ -149,9 +150,7 @@ import Foreign.C ( CInt(..) )
#endif
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
#ifdef GHCI
import System.IO.Unsafe ( unsafePerformIO )
#endif
import Data.IORef
import Control.Monad
......@@ -3407,6 +3406,23 @@ makeDynFlagsConsistent dflags
arch = platformArch platform
os = platformOS platform
--------------------------------------------------------------------------
-- Do not use unsafeGlobalDynFlags!
--
-- unsafeGlobalDynFlags is a hack, necessary because we need to be able
-- to show SDocs when tracing, but we don't always have DynFlags
-- available.
--
-- Do not use it if you can help it. You may get the wrong value!
GLOBAL_VAR(v_unsafeGlobalDynFlags, panic "v_unsafeGlobalDynFlags: not initialised", DynFlags)
unsafeGlobalDynFlags :: DynFlags
unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags
setUnsafeGlobalDynFlags :: DynFlags -> IO ()
setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags
-- -----------------------------------------------------------------------------
-- SSE
......
......@@ -5,7 +5,7 @@ import Platform
data DynFlags
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
pprCols :: DynFlags -> Int
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
pprCols :: DynFlags -> Int
unsafeGlobalDynFlags :: DynFlags
......@@ -289,8 +289,7 @@ import DriverPhases ( Phase(..), isHaskellSrcFilename )
import Finder
import HscTypes
import DynFlags
import StaticFlagParser
import qualified StaticFlags
import StaticFlags
import SysTools
import Annotations
import Module
......@@ -446,7 +445,7 @@ initGhcMonad mb_top_dir = do
-- catch ^C
liftIO $ installSignalHandlers
liftIO $ StaticFlags.initStaticOpts
liftIO $ initStaticOpts
mySettings <- liftIO $ initSysTools mb_top_dir
dflags <- liftIO $ initDynFlags (defaultDynFlags mySettings)
......
-----------------------------------------------------------------------------
--
-- 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,
parseStaticFlagsFull,
flagsStatic
) where
#include "HsVersions.h"
import qualified StaticFlags as SF
import StaticFlags ( v_opt_C_ready )
import CmdLineParser
import SrcLoc
import Util
import Panic
import Control.Monad
import Data.Char
import Data.IORef
import Data.List
-----------------------------------------------------------------------------
-- Static flags
-- | 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 = parseStaticFlagsFull flagsStatic
-- | Parse GHC's static flags as @parseStaticFlags@ does. However it also
-- takes a list of available static flags, such that certain flags can be
-- enabled or disabled through this argument.
parseStaticFlagsFull :: [Flag IO] -> [Located String]
-> IO ([Located String], [Located String])
parseStaticFlagsFull flagsAvailable args = do
ready <- readIORef v_opt_C_ready
when ready $ throwGhcException (ProgramError "Too late for parseStaticFlags: call it before newSession")
(leftover, errs, warns) <- processArgs flagsAvailable args
when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
-- see sanity code in staticOpts
writeIORef v_opt_C_ready True
return (leftover, warns)
flagsStatic :: [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.
flagsStatic = [
------ Debugging ----------------------------------------------------
Flag "dppr-debug" (PassFlag addOpt)
, Flag "dno-debug-output" (PassFlag addOpt)
-- rest of the debugging flags are dynamic
----- RTS opts ------------------------------------------------------
, Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
, Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats))
------ 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)))
-- Pass all remaining "-f<blah>" options to hsc
, Flag "f" (AnySuffixPred isStaticFlag addOpt)
]
isStaticFlag :: String -> Bool
isStaticFlag f =
f `elem` [
"fdicts-strict",
"fspec-inline-join-points",
"fno-hi-version-check",
"dno-black-holing",
"fno-state-hack",
"fruntime-types",
"fno-opt-coercion",
"fno-flat-cache",
"fhardwire-lib-paths",
"fcpr-off"
]
|| any (`isPrefixOf` f) [
]
-----------------------------------------------------------------------------
-- 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 = throwGhcException (CmdLineError ("can't decode size: " ++ str))
where (m, c) = span pred str
n = readRational m
pred c = isDigit c || c == '.'
type StaticP = EwM IO
addOpt :: String -> StaticP ()
addOpt = liftEwM . SF.addOpt
removeOpt :: String -> StaticP ()
removeOpt = liftEwM . SF.removeOpt
-----------------------------------------------------------------------------
-- RTS Hooks
foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO ()
foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
......@@ -20,7 +20,8 @@
-----------------------------------------------------------------------------
module StaticFlags (
unsafeGlobalDynFlags, setUnsafeGlobalDynFlags,
-- entry point
parseStaticFlags,
staticFlags,
initStaticOpts,
......@@ -38,46 +39,129 @@ module StaticFlags (
opt_NoOptCoercion,
opt_NoFlatCache,
-- For the parser
addOpt, removeOpt, v_opt_C_ready,
-- For the parser
addOpt, removeOpt, v_opt_C_ready,
-- Saving/restoring globals
saveStaticFlagGlobals, restoreStaticFlagGlobals
-- Saving/restoring globals
saveStaticFlagGlobals, restoreStaticFlagGlobals
) where
#include "HsVersions.h"
import {-# SOURCE #-} DynFlags (DynFlags)
import CmdLineParser
import FastString
import SrcLoc
import Util
-- import Maybes ( firstJusts )
import Panic
import Control.Monad
import Data.Char
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
-- import Data.List
--------------------------------------------------------------------------
-- Do not use unsafeGlobalDynFlags!
-----------------------------------------------------------------------------
-- Static flags
-- | 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.
--
-- unsafeGlobalDynFlags is a hack, necessary because we need to be able
-- to show SDocs when tracing, but we don't always have DynFlags
-- available.
-- This function must be called before any session is started, i.e., before
-- the first call to 'GHC.withGhc'.
--
-- Do not use it if you can help it. You may get the wrong value!
-- 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 = parseStaticFlagsFull flagsStatic
-- | Parse GHC's static flags as @parseStaticFlags@ does. However it also
-- takes a list of available static flags, such that certain flags can be
-- enabled or disabled through this argument.
parseStaticFlagsFull :: [Flag IO] -> [Located String]
-> IO ([Located String], [Located String])
parseStaticFlagsFull flagsAvailable args = do
ready <- readIORef v_opt_C_ready
when ready $ throwGhcException (ProgramError "Too late for parseStaticFlags: call it before newSession")
GLOBAL_VAR(v_unsafeGlobalDynFlags, panic "v_unsafeGlobalDynFlags: not initialised", DynFlags)
(leftover, errs, warns) <- processArgs flagsAvailable args
when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
unsafeGlobalDynFlags :: DynFlags
unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags
-- see sanity code in staticOpts
writeIORef v_opt_C_ready True
return (leftover, warns)
-- holds the static opts while they're being collected, before
-- being unsafely read by unpacked_static_opts below.
GLOBAL_VAR(v_opt_C, [], [String])
GLOBAL_VAR(v_opt_C_ready, False, Bool)
setUnsafeGlobalDynFlags :: DynFlags -> IO ()
setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags
-----------------------------------------------------------------------------
-- Static flags
staticFlags :: [String]
staticFlags = unsafePerformIO $ do
ready <- readIORef v_opt_C_ready
if (not ready)
then panic "Static flags have not been initialised!\n Please call GHC.newSession or GHC.parseStaticFlags early enough."
else readIORef v_opt_C
-- 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.
flagsStatic :: [Flag IO]
flagsStatic = [
------ Debugging ----------------------------------------------------
Flag "dppr-debug" (PassFlag addOptEwM)
, Flag "dno-debug-output" (PassFlag addOptEwM)
-- rest of the debugging flags are dynamic
----- RTS opts ------------------------------------------------------
, Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
, Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats))
------ Compiler flags -----------------------------------------------
-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
, Flag "fno-"
(PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOptEwM ("-f"++s)))
-- Pass all remaining "-f<blah>" options to hsc
, Flag "f" (AnySuffixPred isStaticFlag addOptEwM)
]
isStaticFlag :: String -> Bool
isStaticFlag f =
f `elem` [
"fdicts-strict",
"fspec-inline-join-points",
"fno-hi-version-check",
"dno-black-holing",
"fno-state-hack",
"fruntime-types",
"fno-opt-coercion",
"fno-flat-cache",
"fhardwire-lib-paths",
"fcpr-off"
]
initStaticOpts :: IO ()
initStaticOpts = writeIORef v_opt_C_ready True
......@@ -90,24 +174,79 @@ removeOpt f = do
fs <- readIORef v_opt_C
writeIORef v_opt_C $! filter (/= f) fs
lookUp :: FastString -> Bool
type StaticP = EwM IO
-- holds the static opts while they're being collected, before
-- being unsafely read by unpacked_static_opts below.
GLOBAL_VAR(v_opt_C, [], [String])
GLOBAL_VAR(v_opt_C_ready, False, Bool)
addOptEwM :: String -> StaticP ()
addOptEwM = liftEwM . addOpt
staticFlags :: [String]
staticFlags = unsafePerformIO $ do
ready <- readIORef v_opt_C_ready
if (not ready)
then panic "Static flags have not been initialised!\n Please call GHC.newSession or GHC.parseStaticFlags early enough."
else readIORef v_opt_C
removeOptEwM :: String -> StaticP ()
removeOptEwM = liftEwM . removeOpt
packed_static_opts :: [FastString]
packed_static_opts = map mkFastString staticFlags
lookUp sw = sw `elem` packed_static_opts
lookUp :: FastString -> Bool
lookUp sw = sw `elem` packed_static_opts
-- debugging options
opt_PprStyle_Debug :: Bool
opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug")
opt_NoDebugOutput :: Bool
opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output")
-- language opts
opt_DictsStrict :: Bool
opt_DictsStrict = lookUp (fsLit "-fdicts-strict")
opt_NoStateHack :: Bool
opt_NoStateHack = lookUp (fsLit "-fno-state-hack")
-- Switch off CPR analysis in the new demand analyser
opt_CprOff :: Bool
opt_CprOff = lookUp (fsLit "-fcpr-off")
opt_NoOptCoercion :: Bool
opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion")
opt_NoFlatCache :: Bool
opt_NoFlatCache = lookUp (fsLit "-fno-flat-cache")
-----------------------------------------------------------------------------
-- 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 = throwGhcException (CmdLineError ("can't decode size: " ++ str))
where (m, c) = span pred str
n = readRational m
pred c = isDigit c || c == '.'
-----------------------------------------------------------------------------
-- Tunneling our global variables into a new instance of the GHC library
saveStaticFlagGlobals :: IO (Bool, [String])
saveStaticFlagGlobals = liftM2 (,) (readIORef v_opt_C_ready) (readIORef v_opt_C)
restoreStaticFlagGlobals :: (Bool, [String]) -> IO ()
restoreStaticFlagGlobals (c_ready, c) = do
writeIORef v_opt_C_ready c_ready
writeIORef v_opt_C c
-----------------------------------------------------------------------------
-- RTS Hooks
foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO ()
foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
{-
-- (lookup_str "foo") looks for the flag -foo=X or -fooX,
......@@ -157,39 +296,3 @@ unpacked_opts =
expandAts l = [l]
-}
-- debugging options
opt_PprStyle_Debug :: Bool
opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug")
opt_NoDebugOutput :: Bool
opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output")
-- language opts
opt_DictsStrict :: Bool
opt_DictsStrict = lookUp (fsLit "-fdicts-strict")
opt_NoStateHack :: Bool
opt_NoStateHack = lookUp (fsLit "-fno-state-hack")
opt_CprOff :: Bool
opt_CprOff = lookUp (fsLit "-fcpr-off")
-- Switch off CPR analysis in the new demand analyser
opt_NoOptCoercion :: Bool
opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion")
opt_NoFlatCache :: Bool
opt_NoFlatCache = lookUp (fsLit "-fno-flat-cache")
-----------------------------------------------------------------------------
-- Tunneling our global variables into a new instance of the GHC library
saveStaticFlagGlobals :: IO (Bool, [String])
saveStaticFlagGlobals = liftM2 (,) (readIORef v_opt_C_ready) (readIORef v_opt_C)
restoreStaticFlagGlobals :: (Bool, [String]) -> IO ()
restoreStaticFlagGlobals (c_ready, c) = do
writeIORef v_opt_C_ready c_ready
writeIORef v_opt_C c
module StaticFlags where
opt_PprStyle_Debug :: Bool
opt_NoDebugOutput :: Bool
......@@ -71,11 +71,12 @@ module Outputable (
) where
import {-# SOURCE #-} DynFlags( DynFlags,
targetPlatform, pprUserLength, pprCols )
targetPlatform, pprUserLength, pprCols,
unsafeGlobalDynFlags )
import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
import {-# SOURCE #-} Name( Name, nameModule )
import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput )
import StaticFlags
import FastString
import FastTypes
import qualified Pretty
......
......@@ -37,7 +37,6 @@ import DriverPhases ( Phase(..), isSourceFilename, anyHsc,
startPhase, isHaskellSrcFilename )
import BasicTypes ( failed )
import StaticFlags
import StaticFlagParser
import DynFlags
import ErrUtils
import FastString
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment