Commit 59438868 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents d79c0c48 a7f9930a
......@@ -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