X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=247df7d8ca429bc4fdbee8e56ca5a1371609133f;hp=4cb32b8a0fbf5cf367daf8dd4f3cb1f326ea074e;hb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;hpb=7f0ce617a0380339da927433dc816e45704db0be diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 4cb32b8..247df7d 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1,9 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcSimplify]{TcSimplify} - +TcSimplify \begin{code} module TcSimplify ( @@ -21,58 +21,39 @@ module TcSimplify ( #include "HsVersions.h" import {-# SOURCE #-} TcUnify( unifyType ) -import TypeRep ( Type(..) ) -import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds ) -import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp ) +import HsSyn import TcRnMonad -import Inst ( lookupInst, LookupInstResult(..), - tyVarsOfInst, fdPredsOfInsts, newDicts, - isDict, isClassDict, isLinearInst, linearInstType, - isMethodFor, isMethod, - instToId, tyVarsOfInsts, cloneDict, - ipNamesOfInsts, ipNamesOfInst, dictPred, - fdPredsOfInst, - newDictsAtLoc, tcInstClassOp, - getDictClassTys, isTyVarDict, instLoc, - zonkInst, tidyInsts, tidyMoreInsts, - pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs, - isInheritableInst, pprDictsTheta - ) -import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders, - lclEnvElts, tcMetaTy ) -import InstEnv ( lookupInstEnv, classInstances, pprInstances ) -import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType ) -import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred, - mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar, - mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys, - tyVarsOfPred, tcEqType, pprPred, mkPredTy, tcIsTyVarTy ) -import TcIface ( checkWiredInTyCon ) -import Id ( idType, mkUserLocal ) -import Var ( TyVar ) -import TyCon ( TyCon ) -import Name ( Name, getOccName, getSrcLoc ) -import NameSet ( NameSet, mkNameSet, elemNameSet ) -import Class ( classBigSig, classKey ) -import FunDeps ( oclose, grow, improve, pprEquation ) -import PrelInfo ( isNumericClass, isStandardClass ) -import PrelNames ( splitName, fstName, sndName, integerTyConName, - showClassKey, eqClassKey, ordClassKey ) -import Type ( zipTopTvSubst, substTheta, substTy ) -import TysWiredIn ( pairTyCon, doubleTy, doubleTyCon ) -import ErrUtils ( Message ) -import BasicTypes ( TopLevelFlag, isNotTopLevel ) +import Inst +import TcEnv +import InstEnv +import TcMType +import TcType +import TcIface +import Id +import Var +import TyCon +import Name +import NameSet +import Class +import FunDeps +import PrelInfo +import PrelNames +import Type +import TysWiredIn +import ErrUtils +import BasicTypes import VarSet -import VarEnv ( TidyEnv ) +import VarEnv import FiniteMap import Bag import Outputable -import ListSetOps ( equivClasses ) -import Util ( zipEqual, isSingleton ) -import List ( partition ) -import SrcLoc ( Located(..) ) -import DynFlags ( DynFlag(..) ) -import StaticFlags +import ListSetOps +import Util +import SrcLoc +import DynFlags + +import Data.List \end{code} @@ -86,6 +67,24 @@ import StaticFlags Notes on functional dependencies (a bug) -------------------------------------- +Consider this: + + class C a b | a -> b + class D a b | a -> b + + instance D a b => C a b -- Undecidable + -- (Not sure if it's crucial to this eg) + f :: C a b => a -> Bool + f _ = True + + g :: C a b => a -> Bool + g = f + +Here f typechecks, but g does not!! Reason: before doing improvement, +we reduce the (C a b1) constraint from the call of f to (D a b1). + +Here is a more complicated example: + | > class Foo a b | a->b | > | > class Bar a b | a->b @@ -257,9 +256,9 @@ any other type variables. - -------------------------------------- - Notes on ambiguity - -------------------------------------- +------------------------------------- + Note [Ambiguity] +------------------------------------- It's very hard to be certain when a type is ambiguous. Consider @@ -754,7 +753,7 @@ isFreeWhenChecking qtvs ips inst = isFreeWrtTyVars qtvs inst && isFreeWrtIPs ips inst -isFreeWrtTyVars qtvs inst = not (tyVarsOfInst inst `intersectsVarSet` qtvs) +isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst)) \end{code} @@ -922,7 +921,8 @@ Two more nasty cases are in tcSimplifySuperClasses qtvs givens sc_wanteds = ASSERT( all isSkolemTyVar qtvs ) do { (_, frees, binds1) <- tcSimplCheck doc get_qtvs NoSCs givens sc_wanteds - ; binds2 <- tc_simplify_top doc False NoSCs frees + ; ext_default <- doptM Opt_ExtendedDefaultRules + ; binds2 <- tc_simplify_top doc ext_default NoSCs frees ; return (binds1 `unionBags` binds2) } where get_qtvs = return (mkVarSet qtvs) @@ -1047,8 +1047,6 @@ tcSimplifyRestricted -- Used for restricted binding groups tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- Zonk everything in sight = mappM zonkInst wanteds `thenM` \ wanteds' -> - zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' -> - tcGetGlobalTyVars `thenM` \ gbl_tvs' -> -- 'reduceMe': Reduce as far as we can. Don't stop at -- dicts; the idea is to get rid of as many type @@ -1057,25 +1055,30 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- immediately, with no constraint on s. -- -- BUT do no improvement! See Plan D above + -- HOWEVER, some unification may take place, if we instantiate + -- a method Inst with an equality constraint reduceContextWithoutImprovement doc reduceMe wanteds' `thenM` \ (_frees, _binds, constrained_dicts) -> -- Next, figure out the tyvars we will quantify over + zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' -> + tcGetGlobalTyVars `thenM` \ gbl_tvs' -> + mappM zonkInst constrained_dicts `thenM` \ constrained_dicts' -> let - constrained_tvs = tyVarsOfInsts constrained_dicts - qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs') - `minusVarSet` constrained_tvs + constrained_tvs' = tyVarsOfInsts constrained_dicts' + qtvs' = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs') + `minusVarSet` constrained_tvs' in traceTc (text "tcSimplifyRestricted" <+> vcat [ - pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts, + pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts', ppr _binds, - ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_` + ppr constrained_tvs', ppr tau_tvs', ppr qtvs' ]) `thenM_` -- The first step may have squashed more methods than -- necessary, so try again, this time more gently, knowing the exact -- set of type variables to quantify over. -- - -- We quantify only over constraints that are captured by qtvs; + -- We quantify only over constraints that are captured by qtvs'; -- these will just be a subset of non-dicts. This in contrast -- to normal inference (using isFreeWhenInferring) in which we quantify over -- all *non-inheritable* constraints too. This implements choice @@ -1089,7 +1092,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- expose implicit parameters to the test that follows let is_nested_group = isNotTopLevel top_lvl - try_me inst | isFreeWrtTyVars qtvs inst, + try_me inst | isFreeWrtTyVars qtvs' inst, (is_nested_group || isDict inst) = Free | otherwise = ReduceMe AddSCs in @@ -1100,14 +1103,14 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- See "Notes on implicit parameters, Question 4: top level" if is_nested_group then extendLIEs frees `thenM_` - returnM (varSetElems qtvs, binds) + returnM (varSetElems qtvs', binds) else let (non_ips, bad_ips) = partition isClassDict frees in addTopIPErrs bndrs bad_ips `thenM_` extendLIEs non_ips `thenM_` - returnM (varSetElems qtvs, binds) + returnM (varSetElems qtvs', binds) \end{code} @@ -1363,23 +1366,11 @@ data Avail | Given TcId -- Used for dictionaries for which we have a binding -- e.g. those "given" in a signature - Bool -- True <=> actually consumed (splittable IPs only) | Rhs -- Used when there is a RHS (LHsExpr TcId) -- The RHS [Inst] -- Insts free in the RHS; we need these too - | Linear -- Splittable Insts only. - Int -- The Int is always 2 or more; indicates how - -- many copies are required - Inst -- The splitter - Avail -- Where the "master copy" is - - | LinRhss -- Splittable Insts only; this is used only internally - -- by extractResults, where a Linear - -- is turned into an LinRhss - [LHsExpr TcId] -- A supply of suitable RHSs - pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)] | (inst,avail) <- fmToList avails ] @@ -1388,11 +1379,8 @@ instance Outputable Avail where pprAvail IsFree = text "Free" pprAvail Irred = text "Irred" -pprAvail (Given x b) = text "Given" <+> ppr x <+> - if b then text "(used)" else empty +pprAvail (Given x) = text "Given" <+> ppr x pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs) -pprAvail (Linear n i a) = text "Linear" <+> ppr n <+> braces (ppr i) <+> ppr a -pprAvail (LinRhss rhss) = text "LinRhss" <+> ppr rhss \end{code} Extracting the bindings from a bunch of Avails. @@ -1422,8 +1410,8 @@ extractResults avails wanteds Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws Just Irred -> go (add_given avails w) binds (w:irreds) frees ws - Just (Given id _) -> go avails new_binds irreds frees ws - where + Just (Given id) -> go avails new_binds irreds frees ws + where new_binds | id == instToId w = binds | otherwise = addBind binds w (L (instSpan w) (HsVar id)) -- The sought Id can be one of the givens, via a superclass chain @@ -1433,26 +1421,7 @@ extractResults avails wanteds where new_binds = addBind binds w rhs - Just (Linear n split_inst avail) -- Transform Linear --> LinRhss - -> get_root irreds frees avail w `thenM` \ (irreds', frees', root_id) -> - split n (instToId split_inst) root_id w `thenM` \ (binds', rhss) -> - go (addToFM avails w (LinRhss rhss)) - (binds `unionBags` binds') - irreds' frees' (split_inst : w : ws) - - Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss - -> go new_avails new_binds irreds frees ws - where - new_binds = addBind binds w rhs - new_avails = addToFM avails w (LinRhss rhss) - - get_root irreds frees (Given id _) w = returnM (irreds, frees, id) - get_root irreds frees Irred w = cloneDict w `thenM` \ w' -> - returnM (w':irreds, frees, instToId w') - get_root irreds frees IsFree w = cloneDict w `thenM` \ w' -> - returnM (irreds, w':frees, instToId w') - - add_given avails w = addToFM avails w (Given (instToId w) True) + add_given avails w = addToFM avails w (Given (instToId w)) add_free avails w | isMethod w = avails | otherwise = add_given avails w @@ -1470,58 +1439,6 @@ extractResults avails wanteds -- t1=t3; but alas, the binding for t2 (which mentions t1) -- will continue to float out! -split :: Int -> TcId -> TcId -> Inst - -> TcM (TcDictBinds, [LHsExpr TcId]) --- (split n split_id root_id wanted) returns --- * a list of 'n' expressions, all of which witness 'avail' --- * a bunch of auxiliary bindings to support these expressions --- * one or zero insts needed to witness the whole lot --- (maybe be zero if the initial Inst is a Given) --- --- NB: 'wanted' is just a template - -split n split_id root_id wanted - = go n - where - ty = linearInstType wanted - pair_ty = mkTyConApp pairTyCon [ty,ty] - id = instToId wanted - occ = getOccName id - loc = getSrcLoc id - span = instSpan wanted - - go 1 = returnM (emptyBag, [L span $ HsVar root_id]) - - go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) -> - expand n rhss `thenM` \ (binds2, rhss') -> - returnM (binds1 `unionBags` binds2, rhss') - - -- (expand n rhss) - -- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings - -- e.g. expand 3 [rhs1, rhs2] - -- = ( { x = split rhs1 }, - -- [fst x, snd x, rhs2] ) - expand n rhss - | n `rem` 2 == 0 = go rhss -- n is even - | otherwise = go (tail rhss) `thenM` \ (binds', rhss') -> - returnM (binds', head rhss : rhss') - where - go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') -> - returnM (listToBag binds', concat rhss') - - do_one rhs = newUnique `thenM` \ uniq -> - tcLookupId fstName `thenM` \ fst_id -> - tcLookupId sndName `thenM` \ snd_id -> - let - x = mkUserLocal occ uniq pair_ty loc - in - returnM (L span (VarBind x (mk_app span split_id rhs)), - [mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x]) - -mk_fs_app span id ty var = L span (HsVar id) `mkHsTyApp` [ty,ty] `mkHsApp` (L span (HsVar var)) - -mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs) - addBind binds inst rhs = binds `unionBags` unitBag (L (instLocSrcSpan (instLoc inst)) (VarBind (instToId inst) rhs)) instSpan wanted = instLocSrcSpan (instLoc wanted) @@ -1715,32 +1632,27 @@ 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 -- It's the same as an existing inst, or a superclass thereof | Just avail <- isAvailable avails wanted - = if isLinearInst wanted then - addLinearAvailable avails avail wanted `thenM` \ (avails', wanteds') -> - reduceList stack try_me wanteds' avails' - else - returnM avails -- No op for non-linear things + = returnM avails | otherwise = case try_me wanted of { @@ -1791,32 +1703,6 @@ isAvailable avails wanted = lookupFM avails wanted -- *not* by unique. So -- d1::C Int == d2::C Int -addLinearAvailable :: Avails -> Avail -> Inst -> TcM (Avails, [Inst]) -addLinearAvailable avails avail wanted - -- avails currently maps [wanted -> avail] - -- Extend avails to reflect a neeed for an extra copy of avail - - | Just avail' <- split_avail avail - = returnM (addToFM avails wanted avail', []) - - | otherwise - = tcLookupId splitName `thenM` \ split_id -> - tcInstClassOp (instLoc wanted) split_id - [linearInstType wanted] `thenM` \ split_inst -> - returnM (addToFM avails wanted (Linear 2 split_inst avail), [split_inst]) - - where - split_avail :: Avail -> Maybe Avail - -- (Just av) if there's a modified version of avail that - -- we can use to replace avail in avails - -- Nothing if there isn't, so we need to create a Linear - split_avail (Linear n i a) = Just (Linear (n+1) i a) - split_avail (Given id used) | not used = Just (Given id True) - | otherwise = Nothing - split_avail Irred = Nothing - split_avail IsFree = Nothing - split_avail other = pprPanic "addLinearAvailable" (ppr avail $$ ppr wanted $$ ppr avails) - ------------------------- addFree :: Avails -> Inst -> TcM Avails -- When an Inst is tossed upstairs as 'free' we nevertheless add it @@ -1840,7 +1726,7 @@ addWanted want_scs avails wanted rhs_expr wanteds avail = Rhs rhs_expr wanteds addGiven :: Avails -> Inst -> TcM Avails -addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given) False) +addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given)) -- Always add superclasses for 'givens' -- -- No ASSERT( not (given `elemFM` avails) ) because in an instance @@ -1889,7 +1775,7 @@ addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails -- Invariant: the Inst is already in Avails. addSCs is_loop avails dict - = do { sc_dicts <- newDictsAtLoc (instLoc dict) sc_theta' + = do { sc_dicts <- newDictBndrs (instLoc dict) sc_theta' ; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) } where (clas, tys) = getDictClassTys dict @@ -1901,13 +1787,14 @@ addSCs is_loop avails dict | is_given sc_dict = return avails | otherwise = addSCs is_loop avails' sc_dict where - sc_sel_rhs = mkHsDictApp (mkHsTyApp (L (instSpan dict) (HsVar sc_sel)) tys) [instToId dict] + sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel)) + co_fn = WpApp (instToId dict) <.> mkWpTyApps tys avails' = addToFM avails sc_dict (Rhs sc_sel_rhs [dict]) is_given :: Inst -> Bool is_given sc_dict = case lookupFM avails sc_dict of - Just (Given _ _) -> True -- Given is cheaper than superclass selection - other -> False + Just (Given _) -> True -- Given is cheaper than superclass selection + other -> False \end{code} Note [SUPERCLASS-LOOP 2] @@ -2011,7 +1898,8 @@ It's OK: the final zonking stage should zap y to (), which is fine. \begin{code} tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds tcSimplifyTop wanteds - = tc_simplify_top doc False {- Not interactive loop -} AddSCs wanteds + = do { ext_default <- doptM Opt_ExtendedDefaultRules + ; tc_simplify_top doc ext_default AddSCs wanteds } where doc = text "tcSimplifyTop" @@ -2022,7 +1910,7 @@ tcSimplifyInteractive wanteds -- The TcLclEnv should be valid here, solely to improve -- error message generation for the monomorphism restriction -tc_simplify_top doc is_interactive want_scs wanteds +tc_simplify_top doc use_extended_defaulting want_scs wanteds = do { lcl_env <- getLclEnv ; traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) @@ -2045,16 +1933,16 @@ tc_simplify_top doc is_interactive want_scs wanteds -- up with one of the non-tyvar classes (default_gps, non_default_gps) = partition defaultable_group tv_groups defaultable_group ds - = not (bad_tyvars `intersectsVarSet` tyVarsOfInst (head ds)) + = (bad_tyvars `disjointVarSet` tyVarsOfInst (head ds)) && defaultable_classes (map get_clas ds) defaultable_classes clss - | is_interactive = any isInteractiveClass clss - | otherwise = all isStandardClass clss && any isNumericClass clss + | use_extended_defaulting = any isInteractiveClass clss + | otherwise = all isStandardClass clss && any isNumericClass clss isInteractiveClass cls = isNumericClass cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey]) - -- In interactive mode, we default Show a to Show () - -- to avoid graututious errors on "show []" + -- In interactive mode, or with -fextended-default-rules, + -- we default Show a to Show () to avoid graututious errors on "show []" -- Collect together all the bad guys @@ -2244,17 +2132,18 @@ a,b,c are type variables. This is required for the context of instance declarations. \begin{code} -tcSimplifyDeriv :: TyCon +tcSimplifyDeriv :: InstOrigin + -> TyCon -> [TyVar] -> ThetaType -- Wanted -> TcM ThetaType -- Needed -tcSimplifyDeriv tc tyvars theta +tcSimplifyDeriv orig tc tyvars theta = tcInstTyVars tyvars `thenM` \ (tvs, _, tenv) -> -- The main loop may do unification, and that may crash if -- it doesn't see a TcTyVar, so we have to instantiate. Sigh -- ToDo: what if two of them do get unified? - newDicts DerivOrigin (substTheta tenv theta) `thenM` \ wanteds -> + newDictBndrsO orig (substTheta tenv theta) `thenM` \ wanteds -> simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) -> ASSERT( null frees ) -- reduceMe never returns Free @@ -2300,7 +2189,7 @@ tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it -> TcM () tcSimplifyDefault theta - = newDicts DefaultOrigin theta `thenM` \ wanteds -> + = newDictBndrsO DefaultOrigin theta `thenM` \ wanteds -> simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) -> ASSERT( null frees ) -- try_me never returns Free addNoInstanceErrs Nothing [] irreds `thenM_` @@ -2450,8 +2339,8 @@ addNoInstanceErrs mb_what givens dicts ptext SLIT("to the") <+> what] ] fix2 | null instance_dicts = [] - | otherwise = [ ptext SLIT("add an instance declaration for") - <+> pprDictsTheta instance_dicts ] + | otherwise = [ sep [ptext SLIT("add an instance declaration for"), + pprDictsTheta instance_dicts] ] instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)] -- Insts for which it is worth suggesting an adding an instance declaration -- Exclude implicit parameters, and tyvar dicts @@ -2508,7 +2397,7 @@ monomorphism_fix = ptext SLIT("Probable fix:") <+> warnDefault dicts default_ty = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag -> - addInstCtxt (instLoc (head dicts)) (warnTc warn_flag warn_msg) + addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg) where -- Tidy them first (_, tidy_dicts) = tidyInsts dicts @@ -2524,7 +2413,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)