From bec18cb3a1dcbc70b0257a367091c9a5948da6f6 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 27 Jul 2006 08:04:22 +0000 Subject: [PATCH] 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 | 92 ++++++++++++++++++++----------------- compiler/main/DynFlags.hs | 22 +++++---- compiler/main/StaticFlags.hs | 4 -- compiler/typecheck/TcSimplify.lhs | 32 ++++++------- docs/users_guide/flags.xml | 6 +-- docs/users_guide/glasgow_exts.xml | 4 +- 6 files changed, 85 insertions(+), 75 deletions(-) diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index e34b8c0..dfe3125 100644 --- a/compiler/main/CmdLineParser.hs +++ b/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) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index bc6a0af..2a46d0e 100644 --- a/compiler/main/DynFlags.hs +++ b/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) 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)") +setVerbosity :: Maybe Int -> DynP () +setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 3e9737f..b49323b 100644 --- a/compiler/main/StaticFlags.hs +++ b/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", diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 4cb32b8..dae3c82 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/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) diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index e6e22fe..6d6ef86 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -569,10 +569,10 @@ - n + n set the limit for context reduction - static - + dynamic + or diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 9c1b2c7..7a918a8 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -140,7 +140,7 @@ documentation describes all the libraries that come with GHC. - + @@ -2090,7 +2090,7 @@ option, 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 N. +with N. -- 1.7.10.4