X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=ffd88b8712c7c7247f190d2c6b43f660c31949da;hb=49c98d143c382a1341e1046f5ca00819a25691ba;hp=3c8160cbcbc459083738f8b4141981be398bb9d6;hpb=2ed6929441ca033f2c5e1cf1a836579fff30b073;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 3c8160c..ffd88b8 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -21,44 +21,44 @@ module TcSimplify ( #include "HsVersions.h" import {-# SOURCE #-} TcUnify( unifyType ) -import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds ) -import TcHsSyn ( mkHsApp, mkHsTyApp, mkHsDictApp ) +import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, mkWpTyApps, + HsWrapper(..), (<.>), emptyLHsBinds ) import TcRnMonad import Inst ( lookupInst, LookupInstResult(..), - tyVarsOfInst, fdPredsOfInsts, newDicts, - isDict, isClassDict, isLinearInst, linearInstType, + tyVarsOfInst, fdPredsOfInsts, + isDict, isClassDict, isMethodFor, isMethod, - instToId, tyVarsOfInsts, cloneDict, + instToId, tyVarsOfInsts, ipNamesOfInsts, ipNamesOfInst, dictPred, - fdPredsOfInst, - newDictsAtLoc, tcInstClassOp, + fdPredsOfInst, + newDictBndrs, newDictBndrsO, getDictClassTys, isTyVarDict, instLoc, zonkInst, tidyInsts, tidyMoreInsts, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs, isInheritableInst, pprDictsTheta ) -import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders, +import TcEnv ( tcGetGlobalTyVars, 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, + mkClassPred, isOverloadedTy, isSkolemTyVar, mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys, tyVarsOfPred, tcEqType, pprPred, mkPredTy, tcIsTyVarTy ) import TcIface ( checkWiredInTyCon ) -import Id ( idType, mkUserLocal ) +import Id ( idType ) import Var ( TyVar ) import TyCon ( TyCon ) -import Name ( Name, getOccName, getSrcLoc ) +import Name ( Name ) 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, +import PrelNames ( integerTyConName, showClassKey, eqClassKey, ordClassKey ) import Type ( zipTopTvSubst, substTheta, substTy ) -import TysWiredIn ( pairTyCon, doubleTy, doubleTyCon ) +import TysWiredIn ( doubleTy, doubleTyCon ) import ErrUtils ( Message ) import BasicTypes ( TopLevelFlag, isNotTopLevel ) import VarSet @@ -86,6 +86,24 @@ import DynFlags ( DynFlags(ctxtStkDepth), 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 +275,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 +772,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} @@ -1048,8 +1066,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 @@ -1058,25 +1074,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 @@ -1090,7 +1111,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 @@ -1101,14 +1122,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} @@ -1364,23 +1385,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 ] @@ -1389,11 +1398,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. @@ -1423,8 +1429,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 @@ -1434,26 +1440,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 @@ -1471,58 +1458,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) @@ -1736,11 +1671,7 @@ reduceList (n,stack) try_me wanteds state 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 +1722,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 +1745,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 +1794,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 +1806,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] @@ -2046,7 +1952,7 @@ tc_simplify_top doc use_extended_defaulting 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 | use_extended_defaulting = any isInteractiveClass clss @@ -2245,17 +2151,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 @@ -2301,7 +2208,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_` @@ -2509,7 +2416,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