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

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

Conflicts:
	compiler/types/Coercion.lhs
parents 677144b8 9c6dd15b
......@@ -367,11 +367,23 @@ AC_DEFUN([GET_ARM_ISA],
#endif]
)],
[AC_DEFINE(arm_HOST_ARCH_PRE_ARMv7, 1, [ARM pre v7])
changequote(, )dnl
ARM_ISA=ARMv6
ARM_ISA_EXT="[]"
changequote([, ])dnl
],
AC_COMPILE_IFELSE([
AC_LANG_PROGRAM(
[],
[#if defined(__VFP_FP__)
return 0;
#else
no vfp
#endif]
)],
[changequote(, )dnl
ARM_ISA_EXT="[VFPv2]"
changequote([, ])dnl],
[changequote(, )dnl
ARM_ISA_EXT="[]"
changequote([, ])dnl]
)],
[changequote(, )dnl
ARM_ISA=ARMv7
ARM_ISA_EXT="[VFPv3,NEON]"
......
......@@ -358,10 +358,13 @@ pprExpr e = case e of
CmmRegOff reg 0 -> pprCastReg reg
CmmRegOff reg i
| i > 0 -> pprRegOff (char '+') i
| otherwise -> pprRegOff (char '-') (-i)
| i < 0 && negate_ok -> pprRegOff (char '-') (-i)
| otherwise -> pprRegOff (char '+') i
where
pprRegOff op i' = pprCastReg reg <> op <> int i'
negate_ok = negate (fromIntegral i :: Integer) <
fromIntegral (maxBound::Int)
-- overflow is undefined; see #7620
CmmMachOp mop args -> pprMachOpApp mop args
......
......@@ -1329,8 +1329,9 @@ isRuntimeVar = isId
isRuntimeArg :: CoreExpr -> Bool
isRuntimeArg = isValArg
-- | Returns @False@ iff the expression is a 'Type' or 'Coercion'
-- expression at its top level
-- | Returns @True@ for value arguments, false for type args
-- NB: coercions are value arguments (zero width, to be sure,
-- like State#, but still value args).
isValArg :: Expr b -> Bool
isValArg e = not (isTypeArg e)
......
......@@ -24,7 +24,8 @@ import CoreSyn
import CoreArity
import Id
import IdInfo
import TcType( tidyType, tidyCo, tidyTyVarBndr )
import Type( tidyType, tidyTyVarBndr )
import Coercion( tidyCo )
import Var
import VarEnv
import UniqFM
......
......@@ -291,7 +291,6 @@ Library
Packages
PprTyThing
StaticFlags
StaticFlagParser
SysTools
TidyPgm
Ctype
......
......@@ -22,7 +22,8 @@ import Name
import Var hiding ( varName )
import VarSet
import UniqSupply
import TcType
import Type
import Kind
import GHC
import Outputable
import PprTyThing
......@@ -207,7 +208,7 @@ pprTypeAndContents id = do
dflags <- GHC.getSessionDynFlags
let pefas = gopt Opt_PrintExplicitForalls dflags
pcontents = gopt Opt_PrintBindContents dflags
pprdId = (pprTyThing pefas . AnId) id
pprdId = (PprTyThing.pprTyThing pefas . AnId) id
if pcontents
then do
let depthBound = 100
......
......@@ -652,9 +652,12 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
= maybeParen ctxt_prec pREC_CON $
hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty]
ppr_mono_ty ctxt_prec (HsOpTy ty1 (wrapper, op) ty2)
ppr_mono_ty ctxt_prec (HsOpTy ty1 (_wrapper, L _ op) ty2)
= maybeParen ctxt_prec pREC_OP $
ppr_mono_lty pREC_OP ty1 <+> ppr_mono_ty pREC_CON (HsWrapTy wrapper (HsTyVar (unLoc op))) <+> ppr_mono_lty pREC_OP ty2
sep [ ppr_mono_lty pREC_OP ty1
, sep [pprInfixOcc op, ppr_mono_lty pREC_OP ty2 ] ]
-- Don't print the wrapper (= kind applications)
-- c.f. HsWrapTy
ppr_mono_ty _ (HsParTy ty)
= parens (ppr_mono_lty pREC_TOP ty)
......
......@@ -1426,13 +1426,6 @@ instance Binary IfaceAT where
defs <- get bh
return (IfaceAT dec defs)
instance Binary IfaceATDefault where
put_ bh (IfaceATD tvs pat_tys ty) = do
put_ bh tvs
put_ bh pat_tys
put_ bh ty
get bh = liftM3 IfaceATD (get bh) (get bh) (get bh)
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
put_ bh (occNameFS n)
......
......@@ -14,7 +14,7 @@
module IfaceSyn (
module IfaceType,
IfaceDecl(..), IfaceClassOp(..), IfaceAT(..), IfaceATDefault(..),
IfaceDecl(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..),
......@@ -118,15 +118,13 @@ data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
-- Just False => ordinary polymorphic default method
-- Just True => generic default method
data IfaceAT = IfaceAT IfaceDecl [IfaceATDefault]
data IfaceAT = IfaceAT IfaceDecl [IfaceAxBranch]
-- Nothing => no default associated type instance
-- Just ds => default associated type instance from these templates
data IfaceATDefault = IfaceATD [IfaceTvBndr] [IfaceType] IfaceType
-- Each associated type default template is a triple of:
-- 1. TyVars of the RHS and family arguments (including the class TVs)
-- 3. The instantiated family arguments
-- 2. The RHS of the synonym
instance Outputable IfaceAxBranch where
ppr (IfaceAxBranch { ifaxbTyVars = tvs, ifaxbLHS = pat_tys, ifaxbRHS = ty })
= ppr tvs <+> hsep (map ppr pat_tys) <+> char '=' <+> ppr ty
-- this is just like CoAxBranch
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
......@@ -538,11 +536,10 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches })
= hang (ptext (sLit "axiom") <+> ppr name <> colon)
2 (vcat $ map (pprIfaceAxBranch tycon) branches)
pprIfaceAxBranch :: IfaceTyCon -> IfaceAxBranch -> SDoc
pprIfaceAxBranch tc (IfaceAxBranch { ifaxbTyVars = tyvars, ifaxbLHS = lhs, ifaxbRHS = rhs })
= pprIfaceTvBndrs tyvars <> dot <+> ppr (IfaceTyConApp tc lhs) <+> text "~#" <+> ppr rhs
2 (vcat $ map ppr_branch branches)
where
ppr_branch (IfaceAxBranch { ifaxbTyVars = tyvars, ifaxbLHS = lhs, ifaxbRHS = rhs })
= pprIfaceTvBndrs tyvars <> dot <+> ppr (IfaceTyConApp tycon lhs) <+> text "~#" <+> ppr rhs
pprCType :: Maybe CType -> SDoc
pprCType Nothing = ptext (sLit "No C type associated")
......@@ -561,9 +558,6 @@ instance Outputable IfaceClassOp where
instance Outputable IfaceAT where
ppr (IfaceAT d defs) = hang (ppr d) 2 (vcat (map ppr defs))
instance Outputable IfaceATDefault where
ppr (IfaceATD tvs pat_tys ty) = ppr tvs <+> hsep (map ppr pat_tys) <+> char '=' <+> ppr ty
pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
pprIfaceDeclHead context thing tyvars
= hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
......@@ -837,12 +831,7 @@ freeNamesIfContext = fnList freeNamesIfType
freeNamesIfAT :: IfaceAT -> NameSet
freeNamesIfAT (IfaceAT decl defs)
= freeNamesIfDecl decl &&&
fnList fn_at_def defs
where
fn_at_def (IfaceATD tvs pat_tys ty)
= freeNamesIfTvBndrs tvs &&&
fnList freeNamesIfType pat_tys &&&
freeNamesIfType ty
fnList freeNamesIfAxBranch defs
freeNamesIfClsSig :: IfaceClassOp -> NameSet
freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
......
......@@ -63,6 +63,7 @@ import FlagChecker
import Id
import IdInfo
import Demand
import Coercion( tidyCo )
import Annotations
import CoreSyn
import CoreFVs
......@@ -1444,18 +1445,18 @@ coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches })
= IfaceAxiom { ifName = name
, ifTyCon = toIfaceTyCon tycon
, ifAxBranches = brListMap coAxBranchToIfaceBranch branches }
, ifAxBranches = brListMap (coAxBranchToIfaceBranch emptyTidyEnv) branches }
where
name = getOccName ax
coAxBranchToIfaceBranch :: CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs })
coAxBranchToIfaceBranch :: TidyEnv -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch env0 (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs })
= IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
, ifaxbLHS = map (tidyToIfaceType env) lhs
, ifaxbRHS = tidyToIfaceType env rhs }
, ifaxbLHS = map (tidyToIfaceType env1) lhs
, ifaxbRHS = tidyToIfaceType env1 rhs }
where
(env, tv_bndrs) = tidyTyVarBndrs emptyTidyEnv tvs
(env1, tv_bndrs) = tidyTyVarBndrs env0 tvs
-----------------
tyConToIfaceDecl :: TidyEnv -> TyCon -> IfaceDecl
......@@ -1549,14 +1550,7 @@ classToIfaceDecl env clas
toIfaceAT :: ClassATItem -> IfaceAT
toIfaceAT (tc, defs)
= IfaceAT (tyConToIfaceDecl env1 tc) (map to_if_at_def defs)
where
to_if_at_def (ATD tvs pat_tys ty _loc)
= IfaceATD (toIfaceTvBndrs tvs')
(map (tidyToIfaceType env2) pat_tys)
(tidyToIfaceType env2 ty)
where
(env2, tvs') = tidyTyClTyVarBndrs env1 tvs
= IfaceAT (tyConToIfaceDecl env1 tc) (map (coAxBranchToIfaceBranch env1) defs)
toIfaceClassOp (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
......
......@@ -525,14 +525,9 @@ tc_iface_decl _parent ignore_prags
tc_at cls (IfaceAT tc_decl defs_decls)
= do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
defs <- mapM tc_iface_at_def defs_decls
defs <- mapM tc_ax_branch defs_decls
return (tc, defs)
tc_iface_at_def (IfaceATD tvs pat_tys ty) =
bindIfaceTyVars_AT tvs $
\tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan)
(mapM tcIfaceType pat_tys) (tcIfaceType ty)
mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
......@@ -547,23 +542,23 @@ tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
tc_iface_decl _ _ (IfaceAxiom {ifName = ax_occ, ifTyCon = tc, ifAxBranches = branches})
= do { tc_name <- lookupIfaceTop ax_occ
; tc_tycon <- tcIfaceTyCon tc
; tc_branches <- mapM tc_branch branches
; tc_branches <- mapM tc_ax_branch branches
; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
, co_ax_name = tc_name
, co_ax_tc = tc_tycon
, co_ax_branches = toBranchList tc_branches
, co_ax_implicit = False }
; return (ACoAxiom axiom) }
where tc_branch :: IfaceAxBranch -> IfL CoAxBranch
tc_branch (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs })
= bindIfaceTyVars tv_bndrs $ \ tvs -> do
{ tc_lhs <- mapM tcIfaceType lhs
; tc_rhs <- tcIfaceType rhs
; let branch = CoAxBranch { cab_loc = noSrcSpan
, cab_tvs = tvs
, cab_lhs = tc_lhs
, cab_rhs = tc_rhs }
; return branch }
tc_ax_branch :: IfaceAxBranch -> IfL CoAxBranch
tc_ax_branch (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs })
= bindIfaceTyVars tv_bndrs $ \ tvs -> do -- Variables will all be fresh
{ tc_lhs <- mapM tcIfaceType lhs
; tc_rhs <- tcIfaceType rhs
; return (CoAxBranch { cab_loc = noSrcSpan
, cab_tvs = tvs
, cab_lhs = tc_lhs
, cab_rhs = tc_rhs } ) }
tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon _ if_cons
......
......@@ -1454,14 +1454,17 @@ runPhase LlvmLlc input_fn dflags
else if (elem VFPv3D16 ext)
then ["-mattr=+v7,+vfp3,+d16"]
else []
ArchARM ARMv6 ext _ -> if (elem VFPv2 ext)
then ["-mattr=+v6,+vfp2"]
else ["-mattr=+v6"]
_ -> []
-- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still
-- compiles into soft-float ABI. We need to explicitly set abi
-- to hard
abiOpts = case platformArch (targetPlatform dflags) of
ArchARM ARMv7 _ HARD -> ["-float-abi=hard"]
ArchARM ARMv7 _ _ -> []
_ -> []
ArchARM _ _ HARD -> ["-float-abi=hard"]
ArchARM _ _ _ -> []
_ -> []
sseOpts | isSse4_2Enabled dflags = ["-mattr=+sse42"]
| isSse2Enabled dflags = ["-mattr=+sse2"]
......
......@@ -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)
......
......@@ -71,6 +71,7 @@ import Outputable
import FastString
import MonadUtils
import System.Mem.Weak
import System.Directory
import Data.Dynamic
import Data.Either
......@@ -415,9 +416,19 @@ sandboxIO dflags statusMVar thing =
-- * clients of the GHC API can terminate a runStmt in progress
-- without knowing the ThreadId of the sandbox thread (#1381)
--
-- NB. use a weak pointer to the thread, so that the thread can still
-- be considered deadlocked by the RTS and sent a BlockedIndefinitely
-- exception. A symptom of getting this wrong is that conc033(ghci)
-- will hang.
--
redirectInterrupts :: ThreadId -> IO a -> IO a
redirectInterrupts target wait
= wait `catch` \e -> do throwTo target (e :: SomeException); wait
= do wtid <- mkWeakThreadId target
wait `catch` \e -> do
m <- deRefWeak wtid
case m of
Nothing -> wait
Just target -> do throwTo target (e :: SomeException); wait
-- We want to turn ^C into a break when -fbreak-on-exception is on,
-- but it's an async exception and we only break for sync exceptions.
......
......@@ -230,14 +230,14 @@ readPackageConfig dflags conf_file = do
else do
isfile <- doesFileExist conf_file
when (not isfile) $
throwGhcException $ InstallationError $
throwGhcExceptionIO $ InstallationError $
"can't find a package database at " ++ conf_file
debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
str <- readFile conf_file
case reads str of
[(configs, rest)]
| all isSpace rest -> return (map installedPackageInfoToPackageConfig configs)
_ -> throwGhcException $ InstallationError $
_ -> throwGhcExceptionIO $ InstallationError $
"invalid package database file " ++ conf_file
let
......@@ -410,12 +410,13 @@ packageFlagErr :: DynFlags
-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg
= throwGhcException (CmdLineError (showSDoc dflags $ dph_err))
= throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
where dph_err = text "the " <> text pkg <> text " package is not installed."
$$ text "To install it: \"cabal install dph\"."
is_dph_package pkg = "dph" `isPrefixOf` pkg
packageFlagErr dflags flag reasons = throwGhcException (CmdLineError (showSDoc dflags $ err))
packageFlagErr dflags flag reasons
= throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
where err = text "cannot satisfy " <> ppr_flag <>
(if null reasons then empty else text ": ") $$
nest 4 (ppr_reasons $$
......@@ -983,7 +984,7 @@ closeDeps dflags pkg_map ipid_map ps
throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
throwErr dflags m
= case m of
Failed e -> throwGhcException (CmdLineError (showSDoc dflags e))
Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
Succeeded r -> return r
closeDepsErr :: PackageConfigMap
......@@ -1017,7 +1018,7 @@ add_package pkg_db ipid_map ps (p, mb_parent)
missingPackageErr :: DynFlags -> String -> IO a
missingPackageErr dflags p
= throwGhcException (CmdLineError (showSDoc dflags (missingPackageMsg p)))
= throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p)))
missingPackageMsg :: String -> SDoc
missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
......
......@@ -31,6 +31,7 @@ import Id
import TyCon
import Coercion( pprCoAxiom )
import HscTypes( tyThingParent_maybe )
import Type( tidyTopType, tidyOpenType )
import TcType
import Name
import VarEnv( emptyTidyEnv )
......
-----------------------------------------------------------------------------
--
-- 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 == '.'