X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=f1467ba4548f368e4970c45cb8ddf3b8e68d2c6f;hb=8ddfc3c10a9d08e11812b5564da291d7024d5fc8;hp=e2892012f1e8fb94a9524a6460ef9a74de5ee3fb;hpb=ba013704bfb94aa133fb28f342e0d432698a5d6d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index e289201..f1467ba 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcSimplify]{TcSimplify} @@ -116,54 +116,56 @@ and hence the default mechanism would resolve the "a". \begin{code} module TcSimplify ( - tcSimplify, tcSimplifyAndCheck, + tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts, tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, - bindInstsOfLocalFuns + bindInstsOfLocalFuns, partitionPredsOfLIE ) where #include "HsVersions.h" -import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds ) -import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr, +import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults ) +import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList ) +import TcHsSyn ( TcExpr, TcId, TcMonoBinds, TcDictBinds ) import TcMonad import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), - tyVarsOfInst, - isDict, isStdClassTyVarDict, isMethodFor, + tyVarsOfInst, tyVarsOfInsts, + isDict, isClassDict, isStdClassTyVarDict, + isMethodFor, notFunDep, instToId, instBindingRequired, instCanBeGeneralised, newDictFromOld, - instLoc, getDictClassTys, - pprInst, zonkInst, - Inst, LIE, pprInsts, pprInstsInFull, mkLIE, - InstOrigin, pprOrigin + getDictClassTys, getIPs, + getDictPred_maybe, getMethodTheta_maybe, + instLoc, pprInst, zonkInst, tidyInst, tidyInsts, + Inst, LIE, pprInsts, pprInstsInFull, + mkLIE, emptyLIE, unitLIE, consLIE, plusLIE, + lieToList, listToLIE ) -import TcEnv ( TcIdOcc(..), tcGetGlobalTyVars ) -import TcType ( TcType, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta ) -import Unify ( unifyTauTy ) -import Id ( mkIdSet ) - -import Bag ( Bag, bagToList, snocBag ) -import Class ( Class, ClassInstEnv, classBigSig, classInstEnv ) -import PrelInfo ( isNumericClass, isCreturnableClass ) - -import Maybes ( maybeToBool ) -import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar, - isTyVarTy, instantiateThetaTy +import TcEnv ( tcGetGlobalTyVars ) +import TcType ( TcType, TcTyVarSet, typeToTcType ) +import TcUnify ( unifyTauTy ) +import Id ( idType ) +import Class ( Class, classBigSig, classInstEnv ) +import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) + +import Type ( Type, ThetaType, TauType, ClassContext, + mkTyVarTy, getTyVar, + isTyVarTy, splitSigmaTy, tyVarsOfTypes ) +import InstEnv ( InstEnv ) +import Subst ( mkTopTyVarSubst, substClasses ) import PprType ( pprConstraint ) import TysWiredIn ( unitTy ) -import TyVar ( intersectTyVarSets, unionManyTyVarSets, minusTyVarSet, - isEmptyTyVarSet, tyVarSetToList, unionTyVarSets, - zipTyVarEnv, emptyTyVarEnv - ) +import VarSet import FiniteMap import BasicTypes ( TopLevelFlag(..) ) -import Unique ( Unique ) +import CmdLineOpts ( opt_GlasgowExts ) import Outputable import Util import List ( partition ) +import Maybes ( maybeToBool ) \end{code} @@ -183,15 +185,21 @@ float them out if poss, after inlinings are sorted out. \begin{code} tcSimplify :: SDoc - -> TopLevelFlag - -> TcTyVarSet s -- ``Local'' type variables + -> TcTyVarSet -- ``Local'' type variables -- ASSERT: this tyvar set is already zonked - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - TcDictBinds s, -- Bindings - LIE s) -- Remaining wanteds; no dups + -> LIE -- Wanted + -> TcM s (LIE, -- Free + TcDictBinds, -- Bindings + LIE) -- Remaining wanteds; no dups -tcSimplify str top_lvl local_tvs wanted_lie +tcSimplify str local_tvs wanted_lie +{- this is just an optimization, and interferes with implicit params, + disable it for now. same goes for tcSimplifyAndCheck + | isEmptyVarSet local_tvs + = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE) + + | otherwise +-} = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) -> -- Check for non-generalisable insts @@ -208,14 +216,14 @@ tcSimplify str top_lvl local_tvs wanted_lie -- But we can get stuck with -- C a b -- where "a" is one of the local_tvs, but "b" is unconstrained. - -- Then we must yell about the ambiguous b. + -- Then we must yell about the ambiguous b -- But we must only do so if "b" really is unconstrained; so -- we must grab the global tyvars to answer that question tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> let - avail_tvs = local_tvs `unionTyVarSets` global_tvs - (irreds', bad_guys) = partition (isEmptyTyVarSet . ambig_tv_fn) irreds - ambig_tv_fn dict = tyVarsOfInst dict `minusTyVarSet` avail_tvs + avail_tvs = local_tvs `unionVarSet` global_tvs + (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds + ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs in addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_` @@ -223,11 +231,22 @@ tcSimplify str top_lvl local_tvs wanted_lie -- Finished returnTc (mkLIE frees, binds, mkLIE irreds') where - wanteds = bagToList wanted_lie + -- the idea behind filtering out the dependencies here is that + -- they've already served their purpose, and can be reconstructed + -- at a later point from the retained class predicates. + -- however, there *is* the possibility that a dependency + -- out-lives the predicate from which it arose. + -- I don't have any examples of this, but if they show up, + -- we'd want to consider the possibility of saving the + -- dependencies as hidden constraints (i.e. they'd only + -- show up in interface files) -- or maybe they'd be useful + -- as first class predicates... + wanteds = filter notFunDep (lieToList wanted_lie) try_me inst -- Does not constrain a local tyvar - | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs) + | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) + && null (getIPs inst) = -- if is_top_level then -- FreeIfTautological -- Special case for inference on -- -- top-level defns @@ -236,7 +255,7 @@ tcSimplify str top_lvl local_tvs wanted_lie -- We're infering (not checking) the type, and -- the inst constrains a local type variable - | isDict inst = DontReduce -- Dicts + | isDict inst = DontReduceUnlessConstant -- Dicts | otherwise = ReduceMe AddToIrreds -- Lits and Methods \end{code} @@ -247,14 +266,22 @@ some of constant insts, which have to be resolved finally at the end. \begin{code} tcSimplifyAndCheck :: SDoc - -> TcTyVarSet s -- ``Local'' type variables - -- ASSERT: this tyvar set is already zonked - -> LIE s -- Given; constrain only local tyvars - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - TcDictBinds s) -- Bindings + -> TcTyVarSet -- ``Local'' type variables + -- ASSERT: this tyvar set is already zonked + -> LIE -- Given; constrain only local tyvars + -> LIE -- Wanted + -> TcM s (LIE, -- Free + TcDictBinds) -- Bindings tcSimplifyAndCheck str local_tvs given_lie wanted_lie +{- + | isEmptyVarSet local_tvs + -- This can happen quite legitimately; for example in + -- instance Num Int where ... + = returnTc (wanted_lie, EmptyMonoBinds) + + | otherwise +-} = reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) -> -- Complain about any irreducible ones @@ -263,12 +290,15 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie -- Done returnTc (mkLIE frees, binds) where - givens = bagToList given_lie - wanteds = bagToList wanted_lie + givens = lieToList given_lie + -- see comment on wanteds in tcSimplify + wanteds = filter notFunDep (lieToList wanted_lie) + given_dicts = filter isClassDict givens try_me inst -- Does not constrain a local tyvar - | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs) + | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) + && (isDict inst || null (getIPs inst)) = Free -- When checking against a given signature we always reduce @@ -277,7 +307,88 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie = ReduceMe AddToIrreds complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens -> - addNoInstanceErr str givens dict + addNoInstanceErr str given_dicts dict +\end{code} + +On the LHS of transformation rules we only simplify methods and constants, +getting dictionaries. We want to keep all of them unsimplified, to serve +as the available stuff for the RHS of the rule. + +The same thing is used for specialise pragmas. Consider + + f :: Num a => a -> a + {-# SPECIALISE f :: Int -> Int #-} + f = ... + +The type checker generates a binding like: + + f_spec = (f :: Int -> Int) + +and we want to end up with + + f_spec = _inline_me_ (f Int dNumInt) + +But that means that we must simplify the Method for f to (f Int dNumInt)! +So tcSimplifyToDicts squeezes out all Methods. + +\begin{code} +tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds) +tcSimplifyToDicts wanted_lie + = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) -> + ASSERT( null frees ) + returnTc (mkLIE irreds, binds) + where + -- see comment on wanteds in tcSimplify + -- ZZ waitaminute - doesn't appear that any funDeps should even be here... + -- wanteds = filter notFunDep (lieToList wanted_lie) + wanteds = lieToList wanted_lie + + -- Reduce methods and lits only; stop as soon as we get a dictionary + try_me inst | isDict inst = DontReduce + | otherwise = ReduceMe AddToIrreds +\end{code} + +The following function partitions a LIE by a predicate defined +over `Pred'icates (an unfortunate overloading of terminology!). +This means it sometimes has to split up `Methods', in which case +a binding is generated. + +It is used in `with' bindings to extract from the LIE the implicit +parameters being bound. + +\begin{code} +partitionPredsOfLIE pred lie + = foldlTc (partPreds pred) (emptyLIE, emptyLIE, EmptyMonoBinds) insts + where insts = lieToList lie + +-- warning: the term `pred' is overloaded here! +partPreds pred (lie1, lie2, binds) inst + | maybeToBool maybe_pred + = if pred p then + returnTc (consLIE inst lie1, lie2, binds) + else + returnTc (lie1, consLIE inst lie2, binds) + where maybe_pred = getDictPred_maybe inst + Just p = maybe_pred + +-- the assumption is that those satisfying `pred' are being extracted, +-- so we leave the method untouched when nothing satisfies `pred' +partPreds pred (lie1, lie2, binds1) inst + | maybeToBool maybe_theta + = if any pred theta then + zonkInst inst `thenTc` \ inst' -> + tcSimplifyToDicts (unitLIE inst') `thenTc` \ (lie3, binds2) -> + partitionPredsOfLIE pred lie3 `thenTc` \ (lie1', lie2', EmptyMonoBinds) -> + returnTc (lie1 `plusLIE` lie1', + lie2 `plusLIE` lie2', + binds1 `AndMonoBinds` binds2) + else + returnTc (lie1, consLIE inst lie2, binds1) + where maybe_theta = getMethodTheta_maybe inst + Just theta = maybe_theta + +partPreds pred (lie1, lie2, binds) inst + = returnTc (lie1, consLIE inst lie2, binds) \end{code} @@ -294,12 +405,22 @@ data WhatToDo = ReduceMe -- Try to reduce this NoInstanceAction -- What to do if there's no such instance - | DontReduce -- Return as irreducible + | DontReduce -- Return as irreducible + + | DontReduceUnlessConstant -- Return as irreducible unless it can + -- be reduced to a constant in one step | Free -- Return as free | FreeIfTautological -- Return as free iff it's tautological; -- if not, return as irreducible + -- The FreeIfTautological case is to allow the possibility + -- of generating functions with types like + -- f :: C Int => Int -> Int + -- Here, the C Int isn't a tautology presumably because Int + -- isn't an instance of C in this module; but perhaps it will + -- be at f's call site(s). Haskell doesn't allow this at + -- present. data NoInstanceAction = Stop -- Fail; no error message @@ -315,26 +436,26 @@ data NoInstanceAction \begin{code} type RedState s = (Avails s, -- What's available - [Inst s], -- Insts for which try_me returned Free - [Inst s] -- Insts for which try_me returned DontReduce + [Inst], -- Insts for which try_me returned Free + [Inst] -- Insts for which try_me returned DontReduce ) -type Avails s = FiniteMap (Inst s) (Avail s) +type Avails s = FiniteMap Inst Avail -data Avail s +data Avail = Avail - (TcIdOcc s) -- The "main Id"; that is, the Id for the Inst that + TcId -- The "main Id"; that is, the Id for the Inst that -- caused this avail to be put into the finite map in the first place -- It is this Id that is bound to the RHS. - (RHS s) -- The RHS: an expression whose value is that Inst. + RHS -- The RHS: an expression whose value is that Inst. -- The main Id should be bound to this RHS - [TcIdOcc s] -- Extra Ids that must all be bound to the main Id. + [TcId] -- Extra Ids that must all be bound to the main Id. -- At the end we generate a list of bindings -- { i1 = main_id; i2 = main_id; i3 = main_id; ... } -data RHS s +data RHS = NoRhs -- Used for irreducible dictionaries, -- which are going to be lambda bound, or for those that are -- suppplied as "given" when checking againgst a signature. @@ -343,7 +464,7 @@ data RHS s -- where no witness is required. | Rhs -- Used when there is a RHS - (TcExpr s) + TcExpr Bool -- True => the RHS simply selects a superclass dictionary -- from a subclass dictionary. -- False => not so. @@ -355,8 +476,8 @@ data RHS s -- an (Ord t) dictionary; then we put an (Eq t) entry in -- the finite map, with an PassiveScSel. Then if the -- the (Eq t) binding is ever *needed* we make it an Rhs - (TcExpr s) - [Inst s] -- List of Insts that are free in the RHS. + TcExpr + [Inst] -- List of Insts that are free in the RHS. -- If the main Id is subsequently needed, we toss this list into -- the needed-inst pool so that we make sure their bindings -- will actually be produced. @@ -364,10 +485,13 @@ data RHS s -- Invariant: these Insts are already in the finite mapping -pprAvails avails = vcat (map pp (eltsFM avails)) - where - pp (Avail main_id rhs ids) - = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs +pprAvails avails = vcat (map pprAvail (eltsFM avails)) + +pprAvail (Avail main_id rhs ids) + = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs + +instance Outputable Avail where + ppr = pprAvail pprRhs NoRhs = text "" pprRhs (Rhs rhs b) = ppr rhs @@ -384,12 +508,12 @@ pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs The main entry point for context reduction is @reduceContext@: \begin{code} -reduceContext :: SDoc -> (Inst s -> WhatToDo) - -> [Inst s] -- Given - -> [Inst s] -- Wanted - -> TcM s (TcDictBinds s, - [Inst s], -- Free - [Inst s]) -- Irreducible +reduceContext :: SDoc -> (Inst -> WhatToDo) + -> [Inst] -- Given + -> [Inst] -- Wanted + -> TcM s (TcDictBinds, + [Inst], -- Free + [Inst]) -- Irreducible reduceContext str try_me givens wanteds = -- Zonking first @@ -409,7 +533,7 @@ reduceContext str try_me givens wanteds foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails -> -- Do the real work - reduce try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) -> + reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) -> -- Extract the bindings from avails let @@ -429,15 +553,15 @@ reduceContext str try_me givens wanteds | otherwise = binds in {- - pprTrace ("reduceContext1") (vcat [ + pprTrace ("reduceContext end") (vcat [ text "----------------------", str, text "given" <+> ppr givens, text "wanted" <+> ppr wanteds, text "----", text "avails" <+> pprAvails avails, - text "free" <+> ppr frees, - text "irreds" <+> ppr irreds, + text "frees" <+> ppr frees, + text "irreds" <+> ppr irreds, text "----------------------" ]) $ -} @@ -447,10 +571,12 @@ reduceContext str try_me givens wanteds The main context-reduction function is @reduce@. Here's its game plan. \begin{code} -reduce :: (Inst s -> WhatToDo) - -> [Inst s] - -> RedState s - -> TcM s (RedState s) +reduceList :: (Int,[Inst]) -- Stack (for err msgs) + -- along with its depth + -> (Inst -> WhatToDo) + -> [Inst] + -> RedState s + -> TcM s (RedState s) \end{code} @reduce@ is passed @@ -462,80 +588,99 @@ reduce :: (Inst s -> WhatToDo) wanteds: The list of insts to reduce state: An accumulating parameter of type RedState that contains the state of the algorithm - + It returns a RedState. +The (n,stack) pair is just used for error reporting. +n is always the depth of the stack. +The stack is the stack of Insts being reduced: to produce X +I had to produce Y, to produce Y I had to produce Z, and so on. \begin{code} - -- Base case: we're done! -reduce try_me [] state = returnTc state +reduceList (n,stack) try_me wanteds state + | n > opt_MaxContextReductionDepth + = failWithTc (reduceDepthErr n stack) -reduce try_me (wanted:wanteds) state@(avails, frees, irreds) + | otherwise + = +#ifdef DEBUG + (if n > 8 then + pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack) + else (\x->x)) +#endif + go wanteds state + where + go [] state = returnTc state + go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' -> + go ws state' + -- Base case: we're done! +reduce stack try_me wanted state@(avails, frees, irreds) -- It's the same as an existing inst, or a superclass thereof | wanted `elemFM` avails - = reduce try_me wanteds (activate avails wanted, frees, irreds) - - -- It should be reduced - | case try_me_result of { ReduceMe _ -> True; _ -> False } - = lookupInst wanted `thenNF_Tc` \ lookup_result -> - - case lookup_result of - GenInst wanteds' rhs -> use_instance wanteds' rhs - SimpleInst rhs -> use_instance [] rhs - - NoInstance -> -- No such instance! - -- Decide what to do based on the no_instance_action requested - case no_instance_action of - Stop -> failTc -- Fail - AddToIrreds -> add_to_irreds -- Add the offending insts to the irreds - - -- It's free and this isn't a top-level binding, so just chuck it upstairs - | case try_me_result of { Free -> True; _ -> False } - = -- First, see if the inst can be reduced to a constant in one step - lookupInst wanted `thenNF_Tc` \ lookup_result -> - case lookup_result of - SimpleInst rhs -> use_instance [] rhs - other -> add_to_frees - - -- It's free and this is a top level binding, so - -- check whether it's a tautology or not - | case try_me_result of { FreeIfTautological -> True; _ -> False } - = -- Try for tautology - tryTc - -- If tautology trial fails, add to irreds - (addGiven avails wanted `thenNF_Tc` \ avails' -> - returnTc (avails', frees, wanted:irreds)) + = returnTc (activate avails wanted, frees, irreds) + + | otherwise + = case try_me wanted of { + + ReduceMe no_instance_action -> -- It should be reduced + lookupInst wanted `thenNF_Tc` \ lookup_result -> + case lookup_result of + GenInst wanteds' rhs -> use_instance wanteds' rhs + SimpleInst rhs -> use_instance [] rhs + + NoInstance -> -- No such instance! + case no_instance_action of + Stop -> failTc + AddToIrreds -> add_to_irreds + ; + Free -> -- It's free and this isn't a top-level binding, so just chuck it upstairs + -- First, see if the inst can be reduced to a constant in one step + lookupInst wanted `thenNF_Tc` \ lookup_result -> + case lookup_result of + SimpleInst rhs -> use_instance [] rhs + other -> add_to_frees + + + + ; + FreeIfTautological -> -- It's free and this is a top level binding, so + -- check whether it's a tautology or not + tryTc_ + add_to_irreds -- If tautology trial fails, add to irreds -- If tautology succeeds, just add to frees - (reduce try_me_taut [wanted] (avails, [], []) `thenTc_` + (reduce stack try_me_taut wanted (avails, [], []) `thenTc_` returnTc (avails, wanted:frees, irreds)) - `thenTc` \ state' -> - reduce try_me wanteds state' - -- It's irreducible (or at least should not be reduced) - | otherwise - = ASSERT( case try_me_result of { DontReduce -> True; other -> False } ) - -- See if the inst can be reduced to a constant in one step - lookupInst wanted `thenNF_Tc` \ lookup_result -> - case lookup_result of - SimpleInst rhs -> use_instance [] rhs - other -> add_to_irreds + ; + + DontReduce -> add_to_irreds + ; + DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced) + -- See if the inst can be reduced to a constant in one step + lookupInst wanted `thenNF_Tc` \ lookup_result -> + case lookup_result of + SimpleInst rhs -> use_instance [] rhs + other -> add_to_irreds + } where -- The three main actions - add_to_frees = reduce try_me wanteds (avails, wanted:frees, irreds) + add_to_frees = let + avails' = addFree avails wanted + -- Add the thing to the avails set so any identical Insts + -- will be commoned up with it right here + in + returnTc (avails', wanted:frees, irreds) add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' -> - reduce try_me wanteds (avails', frees, wanted:irreds) + returnTc (avails', frees, wanted:irreds) use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' -> - reduce try_me (wanteds' ++ wanteds) (avails', frees, irreds) - + reduceList stack try_me wanteds' (avails', frees, irreds) - try_me_result = try_me wanted - ReduceMe no_instance_action = try_me_result -- The try-me to use when trying to identify tautologies -- It blunders on reducing as much as possible @@ -544,7 +689,7 @@ reduce try_me (wanted:wanteds) state@(avails, frees, irreds) \begin{code} -activate :: Avails s -> Inst s -> Avails s +activate :: Avails s -> Inst -> Avails s -- Activate the binding for Inst, ensuring that a binding for the -- wanted Inst will be generated. -- (Activate its parent if necessary, recursively). @@ -586,41 +731,73 @@ addWanted avails wanted rhs_expr rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection | otherwise = NoRhs -addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s) +addFree :: Avails s -> Inst -> (Avails s) + -- When an Inst is tossed upstairs as 'free' we nevertheless add it + -- to avails, so that any other equal Insts will be commoned up right + -- here rather than also being tossed upstairs. This is really just + -- an optimisation, and perhaps it is more trouble that it is worth, + -- as the following comments show! + -- + -- NB1: do *not* add superclasses. If we have + -- df::Floating a + -- dn::Num a + -- but a is not bound here, then we *don't* want to derive + -- dn from df here lest we lose sharing. + -- + -- NB2: do *not* add the Inst to avails at all if it's a method. + -- The following situation shows why this is bad: + -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b + -- From an application (truncate f i) we get + -- t1 = truncate at f + -- t2 = t1 at i + -- If we have also have a secon occurrence of truncate, we get + -- t3 = truncate at f + -- t4 = t3 at i + -- When simplifying with i,f free, we might still notice that + -- t1=t3; but alas, the binding for t2 (which mentions t1) + -- will continue to float out! + -- Solution: never put methods in avail till they are captured + -- in which case addFree isn't used +addFree avails free + | isDict free = addToFM avails free (Avail (instToId free) NoRhs []) + | otherwise = avails + +addGiven :: Avails s -> Inst -> NF_TcM s (Avails s) addGiven avails given = -- ASSERT( not (given `elemFM` avails) ) - -- This assertion isn' necessarily true. It's permitted + -- This assertion isn't necessarily true. It's permitted -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...) -- and when typechecking instance decls we generate redundant "givens" too. - addAvail avails given avail + -- addAvail avails given avail + addAvail avails given avail `thenNF_Tc` \av -> + zonkInst given `thenNF_Tc` \given' -> + returnNF_Tc av where avail = Avail (instToId given) NoRhs [] addAvail avails wanted avail = addSuperClasses (addToFM avails wanted avail) wanted -addSuperClasses :: Avails s -> Inst s -> NF_TcM s (Avails s) +addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s) -- Add all the superclasses of the Inst to Avails -- Invariant: the Inst is already in Avails. addSuperClasses avails dict - | not (isDict dict) + | not (isClassDict dict) = returnNF_Tc avails | otherwise -- It is a dictionary - = tcInstTheta env sc_theta `thenNF_Tc` \ sc_theta' -> - foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) + = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) where (clas, tys) = getDictClassTys dict - (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas - env = zipTyVarEnv tyvars tys + (tyvars, sc_theta, sc_sels, _) = classBigSig clas + sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta add_sc avails ((super_clas, super_tys), sc_sel) = newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict -> let - sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel)) - tys) + sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict] in case lookupFM avails super_dict of @@ -665,16 +842,22 @@ a,b,c are type variables. This is required for the context of instance declarations. \begin{code} -tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv - -> ThetaType -- Wanted - -> TcM s ThetaType -- Needed; of the form C a b c - -- where a,b,c are type variables +tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv + -> ClassContext -- Wanted + -> TcM s ClassContext -- Needed tcSimplifyThetas inst_mapper wanteds = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds -> let - -- Check that the returned dictionaries are of the form (C a b c) - bad_guys = [ct | ct@(clas,tys) <- irreds, not (all isTyVarTy tys)] + -- For multi-param Haskell, check that the returned dictionaries + -- don't have any of the form (C Int Bool) for which + -- we expect an instance here + -- For Haskell 98, check that all the constraints are of the form C a, + -- where a is a type variable + bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds, + isEmptyVarSet (tyVarsOfTypes tys)] + | otherwise = [ct | ct@(clas,tys) <- irreds, + not (all isTyVarTy tys)] in if null bad_guys then returnTc irreds @@ -688,8 +871,8 @@ used with \tr{default} declarations. We are only interested in whether it worked or not. \begin{code} -tcSimplifyCheckThetas :: ThetaType -- Given - -> ThetaType -- Wanted +tcSimplifyCheckThetas :: ClassContext -- Given + -> ClassContext -- Wanted -> TcM s () tcSimplifyCheckThetas givens wanteds @@ -703,64 +886,69 @@ tcSimplifyCheckThetas givens wanteds \begin{code} -type AvailsSimple = FiniteMap (Class, [TauType]) Bool +type AvailsSimple = FiniteMap (Class,[Type]) Bool -- True => irreducible -- False => given, or can be derived from a given or from an irreducible -reduceSimple :: (Class -> ClassInstEnv) - -> ThetaType -- Given - -> ThetaType -- Wanted - -> NF_TcM s ThetaType -- Irreducible +reduceSimple :: (Class -> InstEnv) + -> ClassContext -- Given + -> ClassContext -- Wanted + -> NF_TcM s ClassContext -- Irreducible reduceSimple inst_mapper givens wanteds - = reduce_simple inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' -> + = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' -> returnNF_Tc [ct | (ct,True) <- fmToList givens_fm'] where givens_fm = foldl addNonIrred emptyFM givens -reduce_simple :: (Class -> ClassInstEnv) +reduce_simple :: (Int,ClassContext) -- Stack + -> (Class -> InstEnv) -> AvailsSimple - -> ThetaType + -> ClassContext -> NF_TcM s AvailsSimple -reduce_simple inst_mapper givens [] - = -- Finished, so pull out the needed ones - returnNF_Tc givens +reduce_simple (n,stack) inst_mapper avails wanteds + = go avails wanteds + where + go avails [] = returnNF_Tc avails + go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' -> + go avails' ws -reduce_simple inst_mapper givens (wanted@(clas,tys) : wanteds) +reduce_simple_help stack inst_mapper givens wanted@(clas,tys) | wanted `elemFM` givens - = reduce_simple inst_mapper givens wanteds + = returnNF_Tc givens | otherwise = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta -> case maybe_theta of - Nothing -> reduce_simple inst_mapper (addIrred givens wanted) wanteds - Just theta -> reduce_simple inst_mapper (addNonIrred givens wanted) (theta ++ wanteds) + Nothing -> returnNF_Tc (addIrred givens wanted) + Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta -addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple -addIrred givens ct +addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple +addIrred givens ct@(clas,tys) = addSCs (addToFM givens ct True) ct -addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple -addNonIrred givens ct +addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple +addNonIrred givens ct@(clas,tys) = addSCs (addToFM givens ct False) ct addSCs givens ct@(clas,tys) = foldl add givens sc_theta where - (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas - sc_theta = instantiateThetaTy (zipTyVarEnv tyvars tys) sc_theta_tmpl + (tyvars, sc_theta_tmpl, _, _) = classBigSig clas + sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl - add givens ct = case lookupFM givens ct of - Nothing -> -- Add it and its superclasses - addSCs (addToFM givens ct False) ct + add givens ct@(clas, tys) + = case lookupFM givens ct of + Nothing -> -- Add it and its superclasses + addSCs (addToFM givens ct False) ct - Just True -> -- Set its flag to False; superclasses already done - addToFM givens ct False + Just True -> -- Set its flag to False; superclasses already done + addToFM givens ct False - Just False -> -- Already done - givens + Just False -> -- Already done + givens \end{code} @@ -790,19 +978,33 @@ For each method @Inst@ in the @init_lie@ that mentions one of the @LIE@), as well as the @HsBinds@ generated. \begin{code} -bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s) +bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds) bindInstsOfLocalFuns init_lie local_ids + | null overloaded_ids || null lie_for_here + -- Common case + = returnTc (init_lie, EmptyMonoBinds) + + | otherwise = reduceContext (text "bindInsts" <+> ppr local_ids) - try_me [] (bagToList init_lie) `thenTc` \ (binds, frees, irreds) -> + try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) -> ASSERT( null irreds ) - returnTc (mkLIE frees, binds) + returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds) where - local_id_set = mkIdSet local_ids -- There can occasionally be a lot of them - -- so it's worth building a set, so that - -- lookup (in isMethodFor) is faster - try_me inst | isMethodFor local_id_set inst = ReduceMe AddToIrreds - | otherwise = Free + overloaded_ids = filter is_overloaded local_ids + is_overloaded id = case splitSigmaTy (idType id) of + (_, theta, _) -> not (null theta) + + overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them + -- so it's worth building a set, so that + -- lookup (in isMethodFor) is faster + + -- No sense in repeatedly zonking lots of + -- constant constraints so filter them out here + (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set) + (lieToList init_lie) + try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds + | otherwise = Free \end{code} @@ -847,7 +1049,7 @@ variable, and using @disambigOne@ to do the real business. all the constant and ambiguous Insts. \begin{code} -tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s) +tcSimplifyTop :: LIE -> TcM s TcDictBinds tcSimplifyTop wanted_lie = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) -> ASSERT( null frees ) @@ -865,8 +1067,8 @@ tcSimplifyTop wanted_lie -- Have a try at disambiguation -- if the type variable isn't bound -- up with one of the non-standard classes - worth_a_try group@(d:_) = isEmptyTyVarSet (tyVarsOfInst d `intersectTyVarSets` non_std_tyvars) - non_std_tyvars = unionManyTyVarSets (map tyVarsOfInst non_stds) + worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars) + non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds) -- Collect together all the bad guys bad_guys = non_stds ++ concat std_bads @@ -878,15 +1080,17 @@ tcSimplifyTop wanted_lie -- And complain about the ones that don't mapNF_Tc complain bad_guys `thenNF_Tc_` - returnTc (binds1 `AndMonoBinds` andMonoBinds binds_ambig) + returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig) where - wanteds = bagToList wanted_lie + -- see comment on wanteds in tcSimplify + wanteds = filter notFunDep (lieToList wanted_lie) try_me inst = ReduceMe AddToIrreds d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 - complain d | isEmptyTyVarSet (tyVarsOfInst d) = addTopInstanceErr d - | otherwise = addAmbigErr tyVarsOfInst d + complain d | not (null (getIPs d)) = addTopIPErr d + | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d + | otherwise = addAmbigErr tyVarsOfInst d get_tv d = case getDictClassTys d of (clas, [ty]) -> getTyVar "tcSimplifyTop" ty @@ -907,11 +1111,15 @@ Since we're not using the result of @foo@, the result if (presumably) @void@. \begin{code} -disambigGroup :: [Inst s] -- All standard classes of form (C a) - -> TcM s (TcDictBinds s) +disambigGroup :: [Inst] -- All standard classes of form (C a) + -> TcM s TcDictBinds disambigGroup dicts - | any isNumericClass classes -- Guaranteed all standard classes + | any isNumericClass classes -- Guaranteed all standard classes + -- see comment at the end of function for reasons as to + -- why the defaulting mechanism doesn't apply to groups that + -- include CCallable or CReturnable dicts. + && not (any isCcallishClass classes) = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT -- SO, TRY DEFAULT TYPES IN ORDER @@ -925,7 +1133,7 @@ disambigGroup dicts = failTc try_default (default_ty : default_tys) - = tryTc (try_default default_tys) $ -- If default_ty fails, we try + = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try -- default_tys instead tcSimplifyCheckThetas [] thetas `thenTc` \ _ -> returnTc default_ty @@ -939,11 +1147,14 @@ disambigGroup dicts try_default default_tys `thenTc` \ chosen_default_ty -> -- Bind the type variable and reduce the context, for real this time - tcInstType emptyTyVarEnv chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome! + let + chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome! + in unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_` reduceContext (text "disambig" <+> ppr dicts) - try_me [] dicts `thenTc` \ (binds, frees, ambigs) -> + try_me [] dicts `thenTc` \ (binds, frees, ambigs) -> ASSERT( null frees && null ambigs ) + warnDefault dicts chosen_default_ty `thenTc_` returnTc binds | all isCreturnableClass classes @@ -963,7 +1174,37 @@ disambigGroup dicts classes = map get_clas dicts \end{code} - +[Aside - why the defaulting mechanism is turned off when + dealing with arguments and results to ccalls. + +When typechecking _ccall_s, TcExpr ensures that the external +function is only passed arguments (and in the other direction, +results) of a restricted set of 'native' types. This is +implemented via the help of the pseudo-type classes, +@CReturnable@ (CR) and @CCallable@ (CC.) + +The interaction between the defaulting mechanism for numeric +values and CC & CR can be a bit puzzling to the user at times. +For example, + + x <- _ccall_ f + if (x /= 0) then + _ccall_ g x + else + return () + +What type has 'x' got here? That depends on the default list +in operation, if it is equal to Haskell 98's default-default +of (Integer, Double), 'x' has type Double, since Integer +is not an instance of CR. If the default list is equal to +Haskell 1.4's default-default of (Int, Double), 'x' has type +Int. + +To try to minimise the potential for surprises here, the +defaulting mechanism is turned off in the presence of +CCallable and CReturnable. + +] Errors and contexts ~~~~~~~~~~~~~~~~~~~ @@ -980,36 +1221,78 @@ genCantGenErr insts -- Can't generalise these Insts addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts addAmbigErr ambig_tv_fn dict - = tcAddSrcLoc (instLoc dict) $ - addErrTc (sep [text "Ambiguous type variable(s)", - hsep (punctuate comma (map (quotes . ppr) ambig_tvs)), - nest 4 (text "in the constraint" <+> quotes (pprInst dict)), - nest 4 (pprOrigin dict)]) + = addInstErrTcM (instLoc dict) + (tidy_env, + sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs, + nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))]) where - ambig_tvs = tyVarSetToList (ambig_tv_fn dict) + ambig_tvs = varSetElems (ambig_tv_fn tidy_dict) + (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict + +warnDefault dicts default_ty + | not opt_WarnTypeDefaults + = returnNF_Tc () + + | otherwise + = warnTc True msg + where + msg | length dicts > 1 + = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) + $$ pprInstsInFull tidy_dicts + | otherwise + = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+> + ptext SLIT("to type") <+> quotes (ppr default_ty) + + (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts + +addRuleLhsErr dict + = addInstErrTcM (instLoc dict) + (tidy_env, + vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict), + nest 4 (ptext SLIT("LHS of a rule must have no overloading"))]) + where + (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict + +addTopIPErr dict + = addInstErrTcM (instLoc dict) + (tidy_env, + ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict)) + where + (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict -- Used for top-level irreducibles addTopInstanceErr dict - = tcAddSrcLoc (instLoc dict) $ - addErrTc (sep [ptext SLIT("No instance for") <+> quotes (pprInst dict), - nest 4 $ parens $ pprOrigin dict]) + = addInstErrTcM (instLoc dict) + (tidy_env, + ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict)) + where + (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict addNoInstanceErr str givens dict - = tcAddSrcLoc (instLoc dict) $ - addErrTc (sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst dict), - nest 4 $ parens $ pprOrigin dict], - nest 4 $ ptext SLIT("from the context") <+> pprInsts givens] - $$ - ptext SLIT("Probable cause:") <+> - vcat [ptext SLIT("missing") <+> quotes (pprInst dict) <+> ptext SLIT("in") <+> str, - if all_tyvars then empty else - ptext SLIT("or missing instance declaration for") <+> quotes (pprInst dict)] + = addInstErrTcM (instLoc dict) + (tidy_env, + sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict), + nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens] + $$ + ptext SLIT("Probable cause:") <+> + vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict), + ptext SLIT("in") <+> str], + if isClassDict dict && all_tyvars then empty else + ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)] ) where all_tyvars = all isTyVarTy tys (_, tys) = getDictClassTys dict + (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens) -- Used for the ...Thetas variants; all top level addNoInstErr (c,ts) = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts)) + +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"), + nest 4 (pprInstsInFull stack)] + +reduceDepthMsg n stack = nest 4 (pprInstsInFull stack) \end{code}