module StaticFlagParser (parseStaticFlags) where
#include "HsVersions.h"
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
import Control.Monad
import Data.Char
import Data.IORef
import Data.List
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 $ errorsToGhcException errs
way_flags <- getWayFlags
let way_flags' = map (mkGeneralLocated "in way flags") way_flags
let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
| otherwise = []
(more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags')
writeIORef v_opt_C_ready True
let cg_flags | tablesNextToCode = map (mkGeneralLocated "in cg_flags")
["-optc-DTABLES_NEXT_TO_CODE"]
| otherwise = []
let excess_prec
| opt_SimplExcessPrecision = map (mkGeneralLocated "in excess_prec")
["-fexcess-precision"]
| otherwise = []
when (not (null errs)) $ ghcError $ errorsToGhcException errs
return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
warns1 ++ warns2)
static_flags :: [Flag IO]
static_flags = [
Flag "ignore-dot-ghci" (PassFlag addOpt)
, Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci"))
, 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))
, 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)
, Flag "static" (PassFlag addOpt)
, Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn))
, Flag "rdynamic" (NoArg (return ()))
, Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
, Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats))
, Flag "fPIC" (PassFlag setPIC)
, Flag "fno-"
(PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
, 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` [
"fscc-profiling",
"fdicts-strict",
"fspec-inline-join-points",
"firrefutable-tuples",
"fparallel",
"fgransim",
"fno-hi-version-check",
"dno-black-holing",
"fno-state-hack",
"fsimple-list-literals",
"fno-ds-multi-tyvar",
"fruntime-types",
"fno-pre-inlining",
"fexcess-precision",
"static",
"fhardwire-lib-paths",
"funregisterised",
"fcpr-off",
"ferror-spans",
"fPIC",
"fhpc"
]
|| any (`isPrefixOf` f) [
"fliberate-case-threshold",
"fmax-worker-args",
"fhistory-size",
"funfolding-creation-threshold",
"funfolding-dict-threshold",
"funfolding-use-threshold",
"funfolding-fun-discount",
"funfolding-keeness-factor"
]
unregFlags :: [Located String]
unregFlags = map (mkGeneralLocated "in unregFlags")
[ "-optc-DNO_REGS"
, "-optc-DUSE_MINIINTERPRETER"
, "-fno-asm-mangling"
, "-funregisterised" ]
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 == '.'
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
foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO ()
foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()