X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=8c4de82dac7b5e0882b660d0db32c9ac57e21ab9;hb=e7f04a0da2a711266b58274a1a935d93bb034620;hp=3bd5792b020909111544876e6b67af9ff383727c;hpb=f8e67a2c986fe2b1d81c97874d4c9d60cb027642;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 3bd5792..8c4de82 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -118,7 +118,7 @@ and hence the default mechanism would resolve the "a". module TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts, tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, - bindInstsOfLocalFuns + bindInstsOfLocalFuns, partitionPredsOfLIE ) where #include "HsVersions.h" @@ -132,14 +132,16 @@ import TcHsSyn ( TcExpr, TcId, import TcMonad import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), tyVarsOfInst, tyVarsOfInsts, - isDict, isClassDict, isStdClassTyVarDict, - isMethodFor, notFunDep, + isDict, isClassDict, isMethod, notFunDep, + isStdClassTyVarDict, isMethodFor, instToId, instBindingRequired, instCanBeGeneralised, - newDictFromOld, + newDictFromOld, newFunDepFromDict, getDictClassTys, getIPs, + getDictPred_maybe, getMethodTheta_maybe, instLoc, pprInst, zonkInst, tidyInst, tidyInsts, Inst, LIE, pprInsts, pprInstsInFull, - mkLIE, emptyLIE, plusLIE, lieToList + mkLIE, emptyLIE, unitLIE, consLIE, plusLIE, + lieToList, listToLIE ) import TcEnv ( tcGetGlobalTyVars ) import TcType ( TcType, TcTyVarSet, typeToTcType ) @@ -163,6 +165,8 @@ import CmdLineOpts ( opt_GlasgowExts ) import Outputable import Util import List ( partition ) +import Maybe ( fromJust ) +import Maybes ( maybeToBool ) \end{code} @@ -228,17 +232,7 @@ tcSimplify str local_tvs wanted_lie -- 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 (lieToList wanted_lie) + wanteds = lieToList wanted_lie try_me inst -- Does not constrain a local tyvar @@ -252,8 +246,8 @@ tcSimplify str local_tvs wanted_lie -- 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 + | isClassDict inst = DontReduceUnlessConstant -- Dicts + | otherwise = ReduceMe AddToIrreds -- Lits and Methods \end{code} @tcSimplifyAndCheck@ is similar to the above, except that it checks @@ -288,14 +282,13 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie returnTc (mkLIE frees, binds) where givens = lieToList given_lie - -- see comment on wanteds in tcSimplify - wanteds = filter notFunDep (lieToList wanted_lie) + wanteds = lieToList wanted_lie given_dicts = filter isClassDict givens try_me inst -- Does not constrain a local tyvar | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) - && (isDict inst || null (getIPs inst)) + && (not (isMethod inst) || null (getIPs inst)) = Free -- When checking against a given signature we always reduce @@ -335,14 +328,55 @@ tcSimplifyToDicts wanted_lie ASSERT( null frees ) returnTc (mkLIE irreds, binds) where - -- see comment on wanteds in tcSimplify - 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} %************************************************************************ @@ -358,7 +392,10 @@ 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 @@ -469,6 +506,11 @@ reduceContext str try_me givens wanteds = -- Zonking first mapNF_Tc zonkInst givens `thenNF_Tc` \ givens -> mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds -> + -- JRL - process fundeps last. We eliminate fundeps by seeing + -- what available classes generate them, so we need to process the + -- classes first. (would it be useful to make LIEs ordered in the first place?) + let (wantedOther, wantedFds) = partition notFunDep wanteds + wanteds' = wantedOther ++ wantedFds in {- pprTrace "reduceContext" (vcat [ @@ -480,10 +522,10 @@ reduceContext str try_me givens wanteds ]) $ -} -- Build the Avail mapping from "givens" - foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails -> + foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails -> -- Do the real work - reduceList (0,[]) try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) -> + reduceList (0,[]) try_me wanteds' (avails, [], []) `thenNF_Tc` \ (avails, frees, irreds) -> -- Extract the bindings from avails let @@ -515,7 +557,7 @@ reduceContext str try_me givens wanteds text "----------------------" ]) $ -} - returnTc (binds, frees, irreds) + returnNF_Tc (binds, frees, irreds) \end{code} The main context-reduction function is @reduce@. Here's its game plan. @@ -605,7 +647,11 @@ reduce stack try_me wanted state@(avails, frees, irreds) ; - DontReduce -> -- It's irreducible (or at least should not be reduced) + + 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 @@ -726,6 +772,7 @@ addAvail avails wanted avail addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s) -- Add all the superclasses of the Inst to Avails + -- JRL - also add in the functional dependencies -- Invariant: the Inst is already in Avails. addSuperClasses avails dict @@ -733,10 +780,15 @@ addSuperClasses avails dict = returnNF_Tc avails | otherwise -- It is a dictionary - = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) + = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' -> + newFunDepFromDict dict `thenNF_Tc` \ fdInst_maybe -> + case fdInst_maybe of + Nothing -> returnNF_Tc avails' + Just fdInst -> + let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in + addAvail avails fdInst fdAvail where (clas, tys) = getDictClassTys dict - (tyvars, sc_theta, sc_sels, _) = classBigSig clas sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta @@ -1028,8 +1080,7 @@ tcSimplifyTop wanted_lie returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig) where - -- see comment on wanteds in tcSimplify - wanteds = filter notFunDep (lieToList wanted_lie) + wanteds = lieToList wanted_lie try_me inst = ReduceMe AddToIrreds d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 @@ -1169,8 +1220,7 @@ addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts addAmbigErr ambig_tv_fn dict = addInstErrTcM (instLoc dict) (tidy_env, - sep [text "Ambiguous type variable(s)" <+> - hsep (punctuate comma (map (quotes . ppr) ambig_tvs)), + sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs, nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))]) where ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)