X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FStaticFlagParser.hs;h=6536a13c49227df68dba8706938cc1ef4256a4b9;hp=c0a501e8e31c647fec0e98956ed8ce46b4b7cf9e;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=fb9d3922c8ccc9b3f7138a821ffb635e6c65b149 diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index c0a501e..6536a13 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -13,9 +13,12 @@ module StaticFlagParser (parseStaticFlags) where #include "HsVersions.h" -import StaticFlags +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 @@ -27,23 +30,39 @@ import Data.List ----------------------------------------------------------------------------- -- Static flags -parseStaticFlags :: [String] -> IO ([String], [String]) +-- | 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 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)) + when (not (null errs)) $ ghcError $ errorsToGhcException errs -- deal with the way flags: the way (eg. prof) gives rise to -- further flags, some of which might be static. - way_flags <- findBuildTag + way_flags <- getWayFlags + let way_flags' = map (mkGeneralLocated "in way flags") way_flags -- 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) + (more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags') -- see sanity code in staticOpts writeIORef v_opt_C_ready True @@ -52,16 +71,19 @@ parseStaticFlags args = do -- 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 = [] + let cg_flags | tablesNextToCode = map (mkGeneralLocated "in cg_flags") + ["-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 = [] + let excess_prec + | opt_SimplExcessPrecision = map (mkGeneralLocated "in excess_prec") + ["-fexcess-precision"] + | otherwise = [] - when (not (null errs)) $ ghcError (UsageError (unlines errs)) + when (not (null errs)) $ ghcError $ errorsToGhcException errs return (excess_prec ++ cg_flags ++ more_leftover ++ leftover, warns1 ++ warns2) @@ -81,73 +103,70 @@ static_flags :: [Flag IO] static_flags = [ ------- GHCi ------------------------------------------------------- - Flag "ignore-dot-ghci" (PassFlag addOpt) Supported - , Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) Supported + Flag "ignore-dot-ghci" (PassFlag addOpt) + , Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) ------- 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 + , 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)) + -- -ticky enables ticky-ticky code generation, and also implies -debug which + -- is required to get the RTS ticky support. ------ 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 + , 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) -- 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 + , Flag "static" (PassFlag addOpt) + , Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) -- ignored for compat w/ gcc: - , Flag "rdynamic" (NoArg (return ())) Supported + , Flag "rdynamic" (NoArg (return ())) ----- RTS opts ------------------------------------------------------ - , Flag "H" (HasArg (setHeapSize . fromIntegral . decodeSize)) - Supported - , Flag "Rghc-timing" (NoArg (enableTimingStats)) Supported + , Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s))))) + + , Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats)) ------ Compiler flags ----------------------------------------------- + + -- -fPIC requires extra checking: only the NCG supports it. + -- See also DynFlags.parseDynamicFlags. + , Flag "fPIC" (PassFlag setPIC) + -- 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 + , 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` [ - "fauto-sccs-on-all-toplevs", - "fauto-sccs-on-exported-toplevs", - "fauto-sccs-on-individual-cafs", "fscc-profiling", "fdicts-strict", "fspec-inline-join-points", @@ -156,8 +175,8 @@ isStaticFlag f = "fgransim", "fno-hi-version-check", "dno-black-holing", - "fno-method-sharing", "fno-state-hack", + "fsimple-list-literals", "fno-ds-multi-tyvar", "fruntime-types", "fno-pre-inlining", @@ -165,7 +184,6 @@ isStaticFlag f = "static", "fhardwire-lib-paths", "funregisterised", - "fext-core", "fcpr-off", "ferror-spans", "fPIC", @@ -181,13 +199,12 @@ isStaticFlag f = "funfolding-keeness-factor" ] -unregFlags :: [String] -unregFlags = +unregFlags :: [Located String] +unregFlags = map (mkGeneralLocated "in unregFlags") [ "-optc-DNO_REGS" , "-optc-DUSE_MINIINTERPRETER" , "-fno-asm-mangling" - , "-funregisterised" - , "-fvia-C" ] + , "-funregisterised" ] ----------------------------------------------------------------------------- -- convert sizes like "3.5M" into integers @@ -203,6 +220,18 @@ decodeSize 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 + ----------------------------------------------------------------------------- -- RTS Hooks