X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=4c6c0d5bc5a6e7625352d5ad663f8792e8c1f662;hp=c0bb23bc47fbd7b78353bee3bb0de58d51d048af;hb=8611d7d952b4a5bb0046898b386ded8fb287fdfa;hpb=44ba24dc84d271ca9bd5ab5060cb63ed87f585e3 diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index c0bb23b..4c6c0d5 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -21,45 +21,44 @@ module TcSimplify ( #include "HsVersions.h" import {-# SOURCE #-} TcUnify( unifyType ) -import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, - ExprCoFn(..), (<.>), nlHsTyApp, emptyLHsBinds ) -import TcHsSyn ( mkHsApp ) +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, mkInstCoFn, - 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 @@ -773,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} @@ -1386,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 ] @@ -1411,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. @@ -1445,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 @@ -1456,27 +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 is just used for Linear - 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 @@ -1494,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 = nlHsTyApp id [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) @@ -1759,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 { @@ -1814,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 @@ -1863,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 @@ -1912,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 @@ -1924,14 +1806,14 @@ addSCs is_loop avails dict | is_given sc_dict = return avails | otherwise = addSCs is_loop avails' sc_dict where - sc_sel_rhs = L (instSpan dict) (HsCoerce co_fn (HsVar sc_sel)) - co_fn = mkInstCoFn tys [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] @@ -2070,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 @@ -2269,12 +2151,13 @@ 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 @@ -2325,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_`