Skip to content

GitLab

Commit bec18cb3 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Make -fcontext-stack into a dynamic flag 

  This allows you to put -fcontext-stack into an options pragma,
  as requested by Trac #829
  
  While I was at it, I added OptIntPrefix to the forms allowed
  in CmdLineParser.
parent 5edf58c1
Hide whitespace changes
Inline Side-by-side
compiler/main/CmdLineParser.hs
View file @ bec18cb3
......@@ -21,14 +21,15 @@ import Util ( maybePrefixMatch, notNull, removeSpaces )
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 ())
......@@ -44,58 +45,50 @@ processArgs spec args = process spec args [] []
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)
......@@ -113,11 +106,28 @@ arg_ok (HasArg _) rest arg = True
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)
......
compiler/main/DynFlags.hs
View file @ bec18cb3
......@@ -61,8 +61,10 @@ import {-# SOURCE #-} Packages (PackageState)
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 )
......@@ -71,7 +73,6 @@ import Monad ( when )
#ifdef mingw32_TARGET_OS
import Data.List ( isPrefixOf )
#endif
import Maybe ( fromJust )
import Char ( isDigit, isUpper )
import Outputable
import System.IO ( hPutStrLn, stderr )
......@@ -214,6 +215,8 @@ data DynFlags = DynFlags {
importPaths :: [FilePath],
mainModIs :: Module,
mainFunIs :: Maybe String,
ctxtStkDepth :: Int, -- Typechecker context stack depth
thisPackage :: PackageId,
-- ways
......@@ -349,6 +352,8 @@ defaultDynFlags =
importPaths = ["."],
mainModIs = mAIN,
mainFunIs = Nothing,
ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH,
thisPackage = mainPackageId,
wayNames = panic "ways",
......@@ -800,7 +805,7 @@ dynamic_flags = [
, ( "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) )
......@@ -929,7 +934,7 @@ dynamic_flags = [
, ( "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 ---------------------------
......@@ -970,6 +975,9 @@ dynamic_flags = [
, ( "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)) )
......@@ -1064,10 +1072,8 @@ setDumpFlag dump_flag
-- 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})
......
compiler/main/StaticFlags.hs
View file @ bec18cb3
......@@ -29,7 +29,6 @@ module StaticFlags (
-- language opts
opt_DictsStrict,
opt_MaxContextReductionDepth,
opt_IrrefutableTuples,
opt_Parallel,
opt_RuntimeTypes,
......@@ -78,7 +77,6 @@ import FastString ( FastString, mkFastString )
import Util
import Maybes ( firstJust )
import Panic ( GhcException(..), ghcError )
import Constants ( mAX_CONTEXT_REDUCTION_DEPTH )
import EXCEPTION ( throwDyn )
import DATA_IOREF
......@@ -253,7 +251,6 @@ opt_DoTickyProfiling = lookUp FSLIT("-fticky-ticky")
-- 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")
......@@ -337,7 +334,6 @@ isStaticFlag f =
"fPIC"
]
|| any (flip prefixMatch f) [
"fcontext-stack",
"fliberate-case-threshold",
"fmax-worker-args",
"fhistory-size",
......
compiler/typecheck/TcSimplify.lhs
View file @ bec18cb3
......@@ -21,7 +21,6 @@ module TcSimplify (
#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyType )
import TypeRep ( Type(..) )
import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds )
import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp )
......@@ -71,8 +70,8 @@ import ListSetOps ( equivClasses )
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}
......@@ -1715,22 +1714,21 @@ I had to produce Y, to produce Y I had to produce Z, and so on.
\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
......@@ -2524,7 +2522,7 @@ badDerivedPred pred
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)
......
docs/users_guide/flags.xml
View file @ bec18cb3
......@@ -569,10 +569,10 @@
<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>
......
docs/users_guide/glasgow_exts.xml
View file @ bec18cb3
......@@ -140,7 +140,7 @@ documentation</ulink> describes all the libraries that come with GHC.
<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>
......@@ -2090,7 +2090,7 @@ option</primary></indexterm>, you can use arbitrary
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>
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment