import Panic ( assertPanic )
#endif
-data OptKind m
- = NoArg (m ()) -- flag with no argument
- | HasArg (String -> m ()) -- flag has an argument (maybe prefix)
- | SepArg (String -> m ()) -- flag has a separate argument
- | Prefix (String -> m ()) -- flag is a prefix only
- | OptPrefix (String -> m ()) -- flag may be a prefix
- | AnySuffix (String -> m ()) -- flag is a prefix, pass whole arg to fn
- | PassFlag (String -> m ()) -- flag with no arg, pass flag to fn
+data OptKind m -- Suppose the flag is -f
+ = NoArg (m ()) -- -f all by itself
+ | HasArg (String -> m ()) -- -farg or -f arg
+ | SepArg (String -> m ()) -- -f arg
+ | Prefix (String -> m ()) -- -farg
+ | OptPrefix (String -> m ()) -- -f or -farg (i.e. the arg is optional)
+ | OptIntSuffix (Maybe Int -> m ()) -- -f or -f=n; pass n to fn
+ | PassFlag (String -> m ()) -- -f; pass "-f" fn
+ | AnySuffix (String -> m ()) -- -f or -farg; pass entire "-farg" to fn
| PrefixPred (String -> Bool) (String -> m ())
| AnySuffixPred (String -> Bool) (String -> m ())
process _spec [] spare errs =
return (reverse spare, reverse errs)
- process spec args@(('-':arg):args') spare errs =
+ process spec (dash_arg@('-':arg):args) spare errs =
case findArg spec arg of
Just (rest,action) ->
- case processOneArg action rest args of
- Left err -> process spec args' spare (err:errs)
- Right (action,rest) -> do
- action >> process spec rest spare errs
- Nothing ->
- process spec args' (('-':arg):spare) errs
+ case processOneArg action rest arg args of
+ Left err -> process spec args spare (err:errs)
+ Right (action,rest) -> action >> process spec rest spare errs
+ Nothing -> process spec args (dash_arg:spare) errs
process spec (arg:args) spare errs =
process spec args (arg:spare) errs
-processOneArg :: OptKind m -> String -> [String]
- -> Either String (m (), [String])
-processOneArg action rest (dash_arg@('-':arg):args) =
- case action of
+processOneArg :: OptKind m -> String -> String -> [String]
+ -> Either String (m (), [String])
+processOneArg action rest arg args
+ = let dash_arg = '-' : arg
+ in case action of
NoArg a -> ASSERT(null rest) Right (a, args)
- HasArg f ->
- if rest /= ""
- then Right (f rest, args)
- else case args of
- [] -> missingArgErr dash_arg
- (arg1:args1) -> Right (f arg1, args1)
+ HasArg f | notNull rest -> Right (f rest, args)
+ | otherwise -> case args of
+ [] -> missingArgErr dash_arg
+ (arg1:args1) -> Right (f arg1, args1)
- SepArg f ->
- case args of
+ SepArg f -> case args of
[] -> unknownFlagErr dash_arg
(arg1:args1) -> Right (f arg1, args1)
- Prefix f ->
- if rest /= ""
- then Right (f rest, args)
- else unknownFlagErr dash_arg
+ Prefix f | notNull rest -> Right (f rest, args)
+ | otherwise -> unknownFlagErr dash_arg
- PrefixPred p f ->
- if rest /= ""
- then Right (f rest, args)
- else unknownFlagErr dash_arg
+ PrefixPred p f | notNull rest -> Right (f rest, args)
+ | otherwise -> unknownFlagErr dash_arg
- OptPrefix f -> Right (f rest, args)
+ PassFlag f | notNull rest -> unknownFlagErr dash_arg
+ | otherwise -> Right (f dash_arg, args)
- AnySuffix f -> Right (f dash_arg, args)
+ OptIntSuffix f | Just n <- parseInt rest -> Right (f n, args)
+ | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
+ OptPrefix f -> Right (f rest, args)
+ AnySuffix f -> Right (f dash_arg, args)
AnySuffixPred p f -> Right (f dash_arg, args)
- PassFlag f ->
- if rest /= ""
- then unknownFlagErr dash_arg
- else Right (f dash_arg, args)
findArg :: [(String,OptKind a)] -> String -> Maybe (String,OptKind a)
arg_ok (SepArg _) rest arg = null rest
arg_ok (Prefix _) rest arg = notNull rest
arg_ok (PrefixPred p _) rest arg = notNull rest && p rest
+arg_ok (OptIntSuffix _) rest arg = True
arg_ok (OptPrefix _) rest arg = True
arg_ok (PassFlag _) rest arg = null rest
arg_ok (AnySuffix _) rest arg = True
arg_ok (AnySuffixPred p _) rest arg = p arg
+parseInt :: String -> Maybe (Maybe Int)
+-- Looks for "433" or "=342", with no trailing gubbins
+-- empty string => Just Nothing
+-- n or =n => Just (Just n)
+-- gibberish => Nothing
+parseInt s
+ | null s = Just Nothing
+ | otherwise = case reads (dropEq s) of
+ ((n,""):_) -> Just (Just n)
+ other -> Nothing
+
+dropEq :: String -> String
+-- Discards a leading equals sign
+dropEq ('=' : s) = s
+dropEq s = s
+
unknownFlagErr :: String -> Either String a
unknownFlagErr f = Left ("unrecognised flag: " ++ f)
import DriverPhases ( Phase(..), phaseInputExt )
import Config
import CmdLineParser
+import Constants ( mAX_CONTEXT_REDUCTION_DEPTH )
import Panic ( panic, GhcException(..) )
-import Util ( notNull, splitLongestPrefix, split, normalisePath )
+import Util ( notNull, splitLongestPrefix, normalisePath )
+import Maybes ( fromJust, orElse )
import SrcLoc ( SrcSpan )
import DATA_IOREF ( readIORef )
#ifdef mingw32_TARGET_OS
import Data.List ( isPrefixOf )
#endif
-import Maybe ( fromJust )
import Char ( isDigit, isUpper )
import Outputable
import System.IO ( hPutStrLn, stderr )
importPaths :: [FilePath],
mainModIs :: Module,
mainFunIs :: Maybe String,
+ ctxtStkDepth :: Int, -- Typechecker context stack depth
+
thisPackage :: PackageId,
-- ways
importPaths = ["."],
mainModIs = mAIN,
mainFunIs = Nothing,
+ ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH,
+
thisPackage = mainPackageId,
wayNames = panic "ways",
, ( "cpp" , NoArg (setDynFlag Opt_Cpp))
, ( "F" , NoArg (setDynFlag Opt_Pp))
, ( "#include" , HasArg (addCmdlineHCInclude) )
- , ( "v" , OptPrefix (setVerbosity) )
+ , ( "v" , OptIntSuffix setVerbosity )
------- Specific phases --------------------------------------------
, ( "pgmL" , HasArg (upd . setPgmL) )
, ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting))
, ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting))
, ( "dshow-passes", NoArg (do unSetDynFlag Opt_RecompChecking
- setVerbosity "2") )
+ setVerbosity (Just 2)) )
, ( "dfaststring-stats", NoArg (setDynFlag Opt_D_faststring_stats))
------ Machine dependant (-m<blah>) stuff ---------------------------
, ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) )
, ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )
+ , ( "fcontext-stack" , OptIntSuffix $ \mb_n -> upd $ \dfs ->
+ dfs{ ctxtStkDepth = mb_n `orElse` 3 })
+
-- the rest of the -f* and -fno-* flags
, ( "fno-", PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) )
, ( "f", PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) )
-- Whenver we -ddump, switch off the recompilation checker,
-- else you don't see the dump!
-setVerbosity "" = upd (\dfs -> dfs{ verbosity = 3 })
-setVerbosity n
- | all isDigit n = upd (\dfs -> dfs{ verbosity = read n })
- | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v<n>)")
+setVerbosity :: Maybe Int -> DynP ()
+setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })
addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s})
-- language opts
opt_DictsStrict,
- opt_MaxContextReductionDepth,
opt_IrrefutableTuples,
opt_Parallel,
opt_RuntimeTypes,
import Util
import Maybes ( firstJust )
import Panic ( GhcException(..), ghcError )
-import Constants ( mAX_CONTEXT_REDUCTION_DEPTH )
import EXCEPTION ( throwDyn )
import DATA_IOREF
-- language opts
opt_DictsStrict = lookUp FSLIT("-fdicts-strict")
opt_IrrefutableTuples = lookUp FSLIT("-firrefutable-tuples")
-opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
opt_Parallel = lookUp FSLIT("-fparallel")
opt_Flatten = lookUp FSLIT("-fflatten")
"fPIC"
]
|| any (flip prefixMatch f) [
- "fcontext-stack",
"fliberate-case-threshold",
"fmax-worker-args",
"fhistory-size",
#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyType )
-import TypeRep ( Type(..) )
import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
import Util ( zipEqual, isSingleton )
import List ( partition )
import SrcLoc ( Located(..) )
-import DynFlags ( DynFlag(..) )
-import StaticFlags
+import DynFlags ( DynFlags(ctxtStkDepth),
+ DynFlag( Opt_GlasgowExts, Opt_AllowUndecidableInstances, Opt_WarnTypeDefaults ) )
\end{code}
\begin{code}
reduceList (n,stack) try_me wanteds state
- | n > opt_MaxContextReductionDepth
- = failWithTc (reduceDepthErr n stack)
-
- | otherwise
- =
+ = do { dopts <- getDOpts
#ifdef DEBUG
- (if n > 8 then
- pprTrace "Interesting! Context reduction stack deeper than 8:"
- (int n $$ ifPprDebug (nest 2 (pprStack stack)))
- else (\x->x))
+ ; if n > 8 then
+ dumpTcRn (text "Interesting! Context reduction stack deeper than 8:"
+ <+> (int n $$ ifPprDebug (nest 2 (pprStack stack))))
+ else return ()
#endif
- go wanteds state
+ ; if n >= ctxtStkDepth dopts then
+ failWithTc (reduceDepthErr n stack)
+ else
+ go wanteds state }
where
- go [] state = returnM state
- go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenM` \ state' ->
- go ws state'
+ go [] state = return state
+ go (w:ws) state = do { state' <- reduce (n+1, w:stack) try_me w state
+ ; go ws state' }
-- Base case: we're done!
reduce stack try_me wanted avails
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
- ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
+ ptext SLIT("Use -fcontext-stack=N to increase stack size to N"),
nest 4 (pprStack stack)]
pprStack stack = vcat (map pprInstInFull stack)
<entry><option>-fno-arrows</option></entry>
</row>
<row>
- <entry><option>-fcontext-stack</option><replaceable>n</replaceable></entry>
+ <entry><option>-fcontext-stack=N</option><replaceable>n</replaceable></entry>
<entry>set the limit for context reduction</entry>
- <entry>static</entry>
- <entry><option>-</option></entry>
+ <entry>dynamic</entry>
+ <entry><option>20</option></entry>
</row>
<row>
<entry><option>-ffi</option> or <option>-fffi</option></entry>
<indexterm><primary><option>-fallow-incoherent-instances</option></primary></indexterm>
</term>
<term>
- <option>-fcontext-stack</option>
+ <option>-fcontext-stack=N</option>
<indexterm><primary><option>-fcontext-stack</option></primary></indexterm>
</term>
<listitem>
types in both an instance context and instance head. Termination is ensured by having a
fixed-depth recursion stack. If you exceed the stack depth you get a
sort of backtrace, and the opportunity to increase the stack depth
-with <option>-fcontext-stack</option><emphasis>N</emphasis>.
+with <option>-fcontext-stack=</option><emphasis>N</emphasis>.
</para>
</sect3>
projects / ghc-hetmet.git / commitdiff