X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=d80e6097ea27d4fb31e045392c84ef68f7f2f1af;hb=e03c0dd3bf272e00ea0fc70559b861b37177efa4;hp=0de237dfffbb6c483f87706dd2b7be837e3cbc74;hpb=c29022c49449b7d8862dcc2259e16cafe9461945;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 0de237d..d80e609 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,50 +116,49 @@ and hence the default mechanism would resolve the "a". \begin{code} module TcSimplify ( - tcSimplify, tcSimplifyAndCheck, + tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts, tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, bindInstsOfLocalFuns ) 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, + isDict, isStdClassTyVarDict, isMethodFor, notFunDep, instToId, instBindingRequired, instCanBeGeneralised, newDictFromOld, - instLoc, getDictClassTys, - pprInst, zonkInst, - Inst(..), LIE, pprInsts, pprInstsInFull, mkLIE, - InstOrigin, pprOrigin + getDictClassTys, + instLoc, pprInst, zonkInst, tidyInst, tidyInsts, + Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE, + plusLIE ) -import TcEnv ( TcIdOcc(..) ) -import TcType ( TcType, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta ) -import Unify ( unifyTauTy ) -import Id ( mkIdSet ) +import TcEnv ( tcGetGlobalTyVars ) +import TcType ( TcType, TcTyVarSet, typeToTcType ) +import TcUnify ( unifyTauTy ) +import Id ( idType ) +import Bag ( bagToList ) +import Class ( Class, classBigSig, classInstEnv ) +import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) -import Bag ( Bag, bagToList, snocBag ) -import Class ( Class, ClassInstEnv, classBigSig, classInstEnv ) -import PrelInfo ( isNumericClass, isCcallishClass ) - -import Maybes ( maybeToBool ) import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar, - isTyVarTy, instantiateThetaTy + isTyVarTy, splitSigmaTy, tyVarsOfTypes ) +import InstEnv ( InstEnv ) +import Subst ( mkTopTyVarSubst, substTheta ) import PprType ( pprConstraint ) import TysWiredIn ( unitTy ) -import TyVar ( intersectTyVarSets, unionManyTyVarSets, - isEmptyTyVarSet, zipTyVarEnv, emptyTyVarEnv - ) +import VarSet import FiniteMap import BasicTypes ( TopLevelFlag(..) ) -import Unique ( Unique ) +import CmdLineOpts ( opt_GlasgowExts ) import Outputable import Util import List ( partition ) @@ -183,55 +182,19 @@ float them out if poss, after inlinings are sorted out. tcSimplify :: SDoc -> TopLevelFlag - -> TcTyVarSet s -- ``Local'' type variables - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - TcDictBinds s, -- Bindings - LIE s) -- Remaining wanteds; no dups - -tcSimplify str top_lvl local_tvs wanteds - = tcSimpl str top_lvl local_tvs Nothing wanteds -\end{code} - -@tcSimplifyAndCheck@ is similar to the above, except that it checks -that there is an empty wanted-set at the end. It may still return -some of constant insts, which have to be resolved finally at the end. + -> TcTyVarSet -- ``Local'' type variables + -- ASSERT: this tyvar set is already zonked + -> LIE -- Wanted + -> TcM s (LIE, -- Free + TcDictBinds, -- Bindings + LIE) -- Remaining wanteds; no dups -\begin{code} -tcSimplifyAndCheck - :: SDoc - -> TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint - -> LIE s -- Given - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - TcDictBinds s) -- Bindings - -tcSimplifyAndCheck str local_tvs givens wanteds - = tcSimpl str top_lvl local_tvs (Just givens) wanteds `thenTc` \ (free_insts, binds, new_wanteds) -> - ASSERT( isEmptyBag new_wanteds ) - returnTc (free_insts, binds) - where - top_lvl = error "tcSimplifyAndCheck" -- Never needed -\end{code} +tcSimplify str top_lvl local_tvs wanted_lie + | isEmptyVarSet local_tvs + = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE) -\begin{code} -tcSimpl :: SDoc - -> TopLevelFlag - -> TcTyVarSet s -- ``Local'' type variables - -- ASSERT: this tyvar set is already zonked - -> Maybe (LIE s) -- Given; these constrain only local tyvars - -- Nothing => just simplify - -- Just g => check that g entails wanteds - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - TcMonoBinds s, -- Bindings - LIE s) -- Remaining wanteds; no dups - -tcSimpl str top_lvl local_tvs maybe_given_lie wanted_lie - = -- ASSSERT: local_tvs are already zonked - reduceContext str try_me - givens - (bagToList wanted_lie) `thenTc` \ (binds, frees, irreds) -> + | otherwise + = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) -> -- Check for non-generalisable insts let @@ -240,41 +203,137 @@ tcSimpl str top_lvl local_tvs maybe_given_lie wanted_lie checkTc (null cant_generalise) (genCantGenErr cant_generalise) `thenTc_` - -- Finished - returnTc (mkLIE frees, binds, mkLIE irreds) - where - givens = case maybe_given_lie of - Just given_lie -> bagToList given_lie - Nothing -> [] + -- Check for ambiguous insts. + -- You might think these can't happen (I did) because an ambiguous + -- inst like (Eq a) will get tossed out with "frees", and eventually + -- dealt with by tcSimplifyTop. + -- 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 + -- 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 `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_` + - checking_against_signature = maybeToBool maybe_given_lie - is_top_level = case top_lvl of { TopLevel -> True; other -> False } + -- Finished + returnTc (mkLIE frees, binds, mkLIE irreds') + where + -- 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 (bagToList wanted_lie) try_me inst -- Does not constrain a local tyvar - | isEmptyTyVarSet (inst_tyvars `intersectTyVarSets` local_tvs) - = -- if not checking_against_signature && is_top_level then + | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) + = -- if is_top_level then -- FreeIfTautological -- Special case for inference on -- -- top-level defns -- else - Free + -- We're infering (not checking) the type, and + -- the inst constrains a local type variable + | isDict inst = DontReduce -- Dicts + | otherwise = ReduceMe AddToIrreds -- Lits and Methods +\end{code} + +@tcSimplifyAndCheck@ is similar to the above, except that it checks +that there is an empty wanted-set at the end. It may still return +some of constant insts, which have to be resolved finally at the end. + +\begin{code} +tcSimplifyAndCheck + :: SDoc + -> 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 + mapNF_Tc complain irreds `thenNF_Tc_` + + -- Done + returnTc (mkLIE frees, binds) + where + givens = bagToList given_lie + -- see comment on wanteds in tcSimplify + wanteds = filter notFunDep (bagToList wanted_lie) + given_dicts = filter isDict givens + + try_me inst + -- Does not constrain a local tyvar + | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) + = Free + -- When checking against a given signature we always reduce -- until we find a match against something given, or can't reduce - | checking_against_signature - = ReduceMe CarryOn - - -- So we're infering (not checking) the type, and - -- the inst constrains a local type variable | otherwise - = if isDict inst then - DontReduce -- Dicts - else - ReduceMe CarryOn -- Lits and Methods + = ReduceMe AddToIrreds - where - inst_tyvars = tyVarsOfInst inst + complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens -> + 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 + wanteds = filter notFunDep (bagToList 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} @@ -289,7 +348,7 @@ The main control over context reduction is here \begin{code} data WhatToDo - = ReduceMe -- Reduce this + = ReduceMe -- Try to reduce this NoInstanceAction -- What to do if there's no such instance | DontReduce -- Return as irreducible @@ -298,16 +357,21 @@ data WhatToDo | 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 - = CarryOn -- Produce an error message, but keep on with next inst - - | Stop -- Produce an error message and stop reduction + = Stop -- Fail; no error message + -- (Only used when tautology checking.) | AddToIrreds -- Just add the inst to the irreductible ones; don't -- produce an error message of any kind. - -- It might be quite legitimate - -- such as (Eq a)! + -- It might be quite legitimate such as (Eq a)! \end{code} @@ -315,26 +379,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 +407,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 +419,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. @@ -384,10 +448,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], [Inst s]) +reduceContext :: SDoc -> (Inst -> WhatToDo) + -> [Inst] -- Given + -> [Inst] -- Wanted + -> TcM s (TcDictBinds, + [Inst], -- Free + [Inst]) -- Irreducible reduceContext str try_me givens wanteds = -- Zonking first @@ -403,12 +469,11 @@ reduceContext str try_me givens wanteds text "----------------------" ]) $ -} - -- Build the Avail mapping from "givens" 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 @@ -428,13 +493,14 @@ 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 "----", - pprAvails avails, + text "avails" <+> pprAvails avails, + text "irreds" <+> ppr irreds, text "----------------------" ]) $ -} @@ -444,10 +510,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 @@ -459,94 +527,96 @@ 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 -> -- Fail - addNoInstanceErr wanted `thenNF_Tc_` - failTc - - CarryOn -> -- Carry on. - -- Add the bad guy to the avails to suppress similar - -- messages from other insts in wanteds - addNoInstanceErr wanted `thenNF_Tc_` - addGiven avails wanted `thenNF_Tc` \ avails' -> - reduce try_me wanteds (avails', frees, irreds) -- Carry on - - AddToIrreds -> -- Add the offending insts to the irreds - add_to_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 } ) + ; + DontReduce -> -- 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 - + 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 try_me_taut inst = ReduceMe Stop -- No error recovery @@ -554,7 +624,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). @@ -596,10 +666,41 @@ 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 @@ -609,7 +710,7 @@ addGiven avails given 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. @@ -618,19 +719,17 @@ addSuperClasses avails 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' = substTheta (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 @@ -675,16 +774,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 + -> ThetaType -- Wanted + -> TcM s ThetaType -- 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 @@ -709,8 +814,6 @@ tcSimplifyCheckThetas givens wanteds else mapNF_Tc addNoInstErr irreds `thenNF_Tc_` failTc - -addNoInstErr (c,ts) = addErrTc (noDictInstanceErr c ts) \end{code} @@ -719,36 +822,40 @@ type AvailsSimple = FiniteMap (Class, [TauType]) Bool -- True => irreducible -- False => given, or can be derived from a given or from an irreducible -reduceSimple :: (Class -> ClassInstEnv) +reduceSimple :: (Class -> InstEnv) -> ThetaType -- Given -> ThetaType -- Wanted -> NF_TcM s ThetaType -- 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,ThetaType) -- Stack + -> (Class -> InstEnv) -> AvailsSimple -> ThetaType -> 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 @@ -761,8 +868,8 @@ addNonIrred givens 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 = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl add givens ct = case lookupFM givens ct of Nothing -> -- Add it and its superclasses @@ -802,19 +909,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 CarryOn - | 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) + (bagToList init_lie) + try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds + | otherwise = Free \end{code} @@ -859,9 +980,9 @@ 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 wanteds - = reduceContext (text "tcSimplTop") try_me [] (bagToList wanteds) `thenTc` \ (binds1, frees, irreds) -> +tcSimplifyTop :: LIE -> TcM s TcDictBinds +tcSimplifyTop wanted_lie + = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) -> ASSERT( null frees ) let @@ -877,8 +998,8 @@ tcSimplifyTop wanteds -- 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 @@ -890,14 +1011,16 @@ tcSimplifyTop wanteds -- 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 - try_me inst = ReduceMe AddToIrreds + -- see comment on wanteds in tcSimplify + wanteds = filter notFunDep (bagToList wanted_lie) + try_me inst = ReduceMe AddToIrreds d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 - complain d | isEmptyTyVarSet (tyVarsOfInst d) = addNoInstanceErr d - | otherwise = addAmbigErr [d] + complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d + | otherwise = addAmbigErr tyVarsOfInst d get_tv d = case getDictClassTys d of (clas, [ty]) -> getTyVar "tcSimplifyTop" ty @@ -918,11 +1041,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 @@ -936,7 +1063,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 @@ -945,35 +1072,69 @@ disambigGroup dicts in -- See if any default works, and if so bind the type variable to it -- If not, add an AmbigErr - recoverTc (addAmbigErr dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $ + recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $ 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 isCcallishClass classes + | all isCreturnableClass classes = -- Default CCall stuff to (); we don't even both to check that () is an - -- instance of CCallable/CReturnable, because we know it is. + -- instance of CReturnable, because we know it is. unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_` returnTc EmptyMonoBinds | otherwise -- No defaults - = addAmbigErr dicts `thenNF_Tc_` + = complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds where - try_me inst = ReduceMe CarryOn + complain = addAmbigErrs tyVarsOfInst + try_me inst = ReduceMe AddToIrreds -- This reduce should not fail tyvar = get_tv (head dicts) -- Should be non-empty 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 ~~~~~~~~~~~~~~~~~~~ @@ -987,25 +1148,75 @@ genCantGenErr insts -- Can't generalise these Insts nest 4 (pprInstsInFull insts) ] -addAmbigErr dicts - = tcAddSrcLoc (instLoc (head dicts)) $ - addErrTc (sep [text "Cannot resolve the ambiguous context" <+> pprInsts dicts, - nest 4 (pprInstsInFull dicts)]) +addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts -addNoInstanceErr dict - = tcAddSrcLoc (instLoc dict) $ - tcAddErrCtxt (pprOrigin dict) $ - addErrTc (noDictInstanceErr clas tys) +addAmbigErr ambig_tv_fn dict + = addInstErrTcM (instLoc dict) + (tidy_env, + sep [text "Ambiguous type variable(s)" <+> + hsep (punctuate comma (map (quotes . ppr) ambig_tvs)), + nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))]) where - (clas, tys) = getDictClassTys dict + ambig_tvs = varSetElems (ambig_tv_fn tidy_dict) + (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict -noDictInstanceErr clas tys - = ptext SLIT("No instance for:") <+> quotes (pprConstraint clas tys) +warnDefault dicts default_ty + | not opt_WarnTypeDefaults + = returnNF_Tc () -reduceSigCtxt lie - = sep [ptext SLIT("When matching against a type signature with context"), - nest 4 (quotes (pprInsts (bagToList lie))) - ] -\end{code} + | 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 +-- Used for top-level irreducibles +addTopInstanceErr 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 + = 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 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}