main/StaticFlags.hs

    {-# LANGUAGE CPP, TupleSections #-}
    {-# OPTIONS_GHC -fno-cse #-}
    -- -fno-cse is needed for GLOBAL_VAR's to behave properly

    -----------------------------------------------------------------------------
    --
    -- 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 StaticFlags (
            -- entry point
            parseStaticFlags,

            staticFlags,
            initStaticOpts,
            discardStaticFlags,

            -- Output style options
            opt_PprStyle_Debug,
            opt_NoDebugOutput,

            -- optimisation opts
            opt_NoStateHack,
            opt_CprOff,
            opt_NoOptCoercion,

            -- For the parser
            addOpt, removeOpt, v_opt_C_ready,

            -- For options autocompletion
            flagsStatic, flagsStaticNames
      ) where

    #include "HsVersions.h"

    import CmdLineParser
    import FastString
    import SrcLoc
    import Util
    -- import Maybes                ( firstJusts )
    import Panic

    import Control.Monad
    import Data.IORef
    import System.IO.Unsafe ( unsafePerformIO )

    -----------------------------------------------------------------------------
    -- 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 $ throwGhcExceptionIO (ProgramError "Too late for parseStaticFlags: call it before runGhc or runGhcT")

      (leftover, errs, warns) <- processArgs flagsAvailable args

      -- See Note [Handling errors when parsing commandline flags]
      unless (null errs) $ throwGhcExceptionIO $
          errorsToGhcException . map (("on the commandline", ) . unLoc) $ errs

        -- 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)

    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.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.

    -- see Note [Updating flag description in the User's Guide] in DynFlags
    flagsStatic :: [Flag IO]
    flagsStatic = [
      ------ Debugging ----------------------------------------------------
        defFlag "dppr-debug"       (PassFlag addOptEwM)
      , defFlag "dno-debug-output" (PassFlag addOptEwM)
      -- rest of the debugging flags are dynamic

      ------ Compiler flags -----------------------------------------------
      -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
      , defFlag "fno-"
             (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOptEwM ("-f"++s)))

      -- Pass all remaining "-f<blah>" options to hsc
      , defFlag "f" (AnySuffixPred isStaticFlag addOptEwM)
      ]

    isStaticFlag :: String -> Bool
    isStaticFlag f = f `elem` flagsStaticNames

    -- see Note [Updating flag description in the User's Guide] in DynFlags
    flagsStaticNames :: [String]
    flagsStaticNames = [
        "fno-state-hack",
        "fno-opt-coercion",
        "fcpr-off"
        ]

    -- We specifically need to discard static flags for clients of the
    -- GHC API, since they can't be safely reparsed or reinitialized. In general,
    -- the existing flags do nothing other than control debugging and some low-level
    -- optimizer phases, so for the most part this is OK.
    --
    -- See GHC issue #8276: http://ghc.haskell.org/trac/ghc/ticket/8276#comment:37
    discardStaticFlags :: [String] -> [String]
    discardStaticFlags = filter (\x -> x `notElem` flags)
      where flags = [ "-fno-state-hack"
                    , "-fno-opt-coercion"
                    , "-fcpr-off"
                    , "-dppr-debug"
                    , "-dno-debug-output"
                    ]

    initStaticOpts :: IO ()
    initStaticOpts = writeIORef v_opt_C_ready True

    addOpt :: String -> IO ()
    addOpt = consIORef v_opt_C

    removeOpt :: String -> IO ()
    removeOpt f = do
      fs <- readIORef v_opt_C
      writeIORef v_opt_C $! filter (/= f) fs

    type StaticP = EwM IO

    addOptEwM :: String -> StaticP ()
    addOptEwM = liftEwM . addOpt

    removeOptEwM :: String -> StaticP ()
    removeOptEwM = liftEwM . removeOpt

    packed_static_opts :: [FastString]
    packed_static_opts   = map mkFastString staticFlags

    lookUp :: FastString -> Bool
    lookUp sw = sw `elem` packed_static_opts

    -- debugging options

    -- see Note [Updating flag description in the User's Guide] in DynFlags

    opt_PprStyle_Debug :: Bool
    opt_PprStyle_Debug = lookUp  (fsLit "-dppr-debug")

    opt_NoDebugOutput  :: Bool
    opt_NoDebugOutput  = lookUp  (fsLit "-dno-debug-output")

    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")

    {-
    -- (lookup_str "foo") looks for the flag -foo=X or -fooX,
    -- and returns the string X
    lookup_str       :: String -> Maybe String
    lookup_str sw
       = case firstJusts (map (stripPrefix sw) staticFlags) of
            Just ('=' : str) -> Just str
            Just str         -> Just str
            Nothing          -> Nothing

    lookup_def_int   :: String -> Int -> Int
    lookup_def_int sw def = case (lookup_str sw) of
                                Nothing -> def              -- Use default
                                Just xx -> try_read sw xx

    lookup_def_float :: String -> Float -> Float
    lookup_def_float sw def = case (lookup_str sw) of
                                Nothing -> def              -- Use default
                                Just xx -> try_read sw xx

    try_read :: Read a => String -> String -> a
    -- (try_read sw str) tries to read s; if it fails, it
    -- bleats about flag sw
    try_read sw str
      = case reads str of
            ((x,_):_) -> x  -- Be forgiving: ignore trailing goop, and alternative parses
            []        -> throwGhcException (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
                            -- ToDo: hack alert. We should really parse the arguments
                            --       and announce errors in a more civilised way.
    -}