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.

compiler/main/CmdLineParser.hs

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

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

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

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

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

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