X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcCanonical.lhs;h=435cfc49deb5d6c4994d91e9e2a2cb94d2f4013c;hp=59cc736083e5883ac4a0da65fd178856c59fa04a;hb=9591547fbbdf12728884e125f8ba08b0e6e69f82;hpb=2d5205118357cac8a2dd43b33bcd93a3c00f5558 diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 59cc736..435cfc4 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -92,6 +92,7 @@ expansions contain any type function applications would speed things up a bit; right now we waste a lot of energy traversing the same types multiple times. + \begin{code} -- Flatten a bunch of types all at once. flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts) @@ -139,7 +140,7 @@ flatten fl (TyConApp tc tys) -- Otherwise, it's a type function application, and we have to -- flatten it away as well, and generate a new given equality constraint -- between the application and a newly generated flattening skolem variable. - | otherwise + | otherwise = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated do { (xis, cos, ccs) <- flattenMany fl tys ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis @@ -148,33 +149,40 @@ flatten fl (TyConApp tc tys) -- in which case the remaining arguments should -- be dealt with by AppTys fam_ty = mkTyConApp tc xi_args - fam_co = fam_ty -- identity - - ; (ret_co, rhs_var, ct) <- - if isGiven fl then - do { rhs_var <- newFlattenSkolemTy fam_ty - ; cv <- newGivenCoVar fam_ty rhs_var fam_co - ; let ct = CFunEqCan { cc_id = cv - , cc_flavor = fl -- Given - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_var } - ; return $ (mkCoVarCoercion cv, rhs_var, ct) } - else -- Derived or Wanted: make a new *unification* flatten variable - do { rhs_var <- newFlexiTcSTy (typeKind fam_ty) - ; cv <- newCoVar fam_ty rhs_var - ; let ct = CFunEqCan { cc_id = cv - , cc_flavor = mkWantedFlavor fl - -- Always Wanted, not Derived - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_var } - ; return $ (mkCoVarCoercion cv, rhs_var, ct) } - + fam_co = fam_ty -- identity + ; (ret_co, rhs_var, ct) <- + do { is_cached <- lookupFlatCacheMap tc xi_args fl + ; case is_cached of + Just (rhs_var,ret_co,_fl) -> return (ret_co, rhs_var, emptyCCan) + Nothing + | isGivenOrSolved fl -> + do { rhs_var <- newFlattenSkolemTy fam_ty + ; cv <- newGivenCoVar fam_ty rhs_var fam_co + ; let ct = CFunEqCan { cc_id = cv + , cc_flavor = fl -- Given + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_var } + ; let ret_co = mkCoVarCoercion cv + ; updateFlatCacheMap tc xi_args rhs_var fl ret_co + ; return $ (ret_co, rhs_var, singleCCan ct) } + | otherwise -> + -- Derived or Wanted: make a new *unification* flatten variable + do { rhs_var <- newFlexiTcSTy (typeKind fam_ty) + ; cv <- newCoVar fam_ty rhs_var + ; let ct = CFunEqCan { cc_id = cv + , cc_flavor = mkWantedFlavor fl + -- Always Wanted, not Derived + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_var } + ; let ret_co = mkCoVarCoercion cv + ; updateFlatCacheMap tc xi_args rhs_var fl ret_co + ; return $ (ret_co, rhs_var, singleCCan ct) } } ; return ( foldl AppTy rhs_var xi_rest , foldl AppTy (mkSymCoercion ret_co - `mkTransCoercion` mkTyConCoercion tc cos_args) cos_rest - , ccs `extendCCans` ct) } + `mkTransCoercion` mkTyConCoercion tc cos_args) cos_rest + , ccs `andCCan` ct) } flatten ctxt (PredTy pred) @@ -222,7 +230,7 @@ canWanteds :: [WantedEvVar] -> TcS WorkList canWanteds = fmap unionWorkLists . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev) canGivens :: GivenLoc -> [EvVar] -> TcS WorkList -canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc)) givens +canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc GivenOrig)) givens ; return (unionWorkLists ccs) } mkCanonicals :: CtFlavor -> [EvVar] -> TcS WorkList @@ -238,6 +246,7 @@ mkCanonicalFEVs = foldrBagM canon_one emptyWorkList canon_one fev wl = do { wl' <- mkCanonicalFEV fev ; return (unionWorkList wl' wl) } + mkCanonical :: CtFlavor -> EvVar -> TcS WorkList mkCanonical fl ev = case evVarPred ev of ClassP clas tys -> canClassToWorkList fl ev clas tys @@ -250,13 +259,13 @@ canClassToWorkList fl v cn tys = do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys ; let no_flattening_happened = isEmptyCCan ccs dict_co = mkTyConCoercion (classTyCon cn) cos - ; v_new <- if no_flattening_happened then return v - else if isGiven fl then return v + ; v_new <- if no_flattening_happened then return v + else if isGivenOrSolved fl then return v -- The cos are all identities if fl=Given, -- hence nothing to do else do { v' <- newDictVar cn xis -- D xis ; when (isWanted fl) $ setDictBind v (EvCast v' dict_co) - ; when (isGiven fl) $ setDictBind v' (EvCast v (mkSymCoercion dict_co)) + ; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCoercion dict_co)) -- NB: No more setting evidence for derived now ; return v' } @@ -320,7 +329,7 @@ For Deriveds: Here's an example that demonstrates why we chose to NOT add superclasses during simplification: [Comes from ticket #4497] - + class Num (RealOf t) => Normed t type family RealOf x @@ -346,14 +355,18 @@ newSCWorkFromFlavored ev orig_flavor cls xis = return emptyWorkList -- Deriveds don't yield more superclasses because we will -- add them transitively in the case of wanteds. - | isGiven orig_flavor - = do { let sc_theta = immSuperClasses cls xis - flavor = orig_flavor - ; sc_vars <- mapM newEvVar sc_theta - ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]] - ; mkCanonicals flavor sc_vars } - - | isEmptyVarSet (tyVarsOfTypes xis) + | Just gk <- isGiven_maybe orig_flavor + = case gk of + GivenOrig -> do { let sc_theta = immSuperClasses cls xis + flavor = orig_flavor + ; sc_vars <- mapM newEvVar sc_theta + ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]] + ; mkCanonicals flavor sc_vars } + GivenSolved -> return emptyWorkList + -- Seems very dangerous to add the superclasses for dictionaries that may be + -- partially solved because we may end up with evidence loops. + + | isEmptyVarSet (tyVarsOfTypes xis) = return emptyWorkList -- Wanteds with no variables yield no deriveds. -- See Note [Improvement from Ground Wanteds] @@ -428,7 +441,7 @@ canEq fl cv s1 s2 (mkCoVarCoercion v2) (mkCoVarCoercion v3) ; setCoBind cv res_co ; return (v1,v2,v3) } - else if isGiven fl then -- Given + else if isGivenOrSolved fl then -- Given let co_orig = mkCoVarCoercion cv coa = mkCsel1Coercion co_orig cob = mkCsel2Coercion co_orig @@ -458,7 +471,7 @@ canEq fl cv (FunTy s1 t1) (FunTy s2 t2) mkFunCoercion (mkCoVarCoercion argv) (mkCoVarCoercion resv) ; return (argv,resv) } - else if isGiven fl then + else if isGivenOrSolved fl then let [arg,res] = decomposeCo 2 (mkCoVarCoercion cv) in do { argv <- newGivenCoVar s1 s2 arg ; resv <- newGivenCoVar t1 t2 res @@ -510,7 +523,7 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2) mkTyConCoercion tc1 (map mkCoVarCoercion argsv) ; return argsv } - else if isGiven fl then + else if isGivenOrSolved fl then let cos = decomposeCo (length tys1) (mkCoVarCoercion cv) in zipWith3M newGivenCoVar tys1 tys2 cos @@ -532,7 +545,7 @@ canEq fl cv ty1 ty2 mkAppCoercion (mkCoVarCoercion cv1) (mkCoVarCoercion cv2) ; return (cv1,cv2) } - else if isGiven fl then + else if isGivenOrSolved fl then let co1 = mkLeftCoercion $ mkCoVarCoercion cv co2 = mkRightCoercion $ mkCoVarCoercion cv in do { cv1 <- newGivenCoVar s1 s2 co1 @@ -751,7 +764,7 @@ canEqLeaf _untch fl cv cls1 cls2 then do { cv' <- newCoVar s2 s1 ; setCoBind cv $ mkSymCoercion (mkCoVarCoercion cv') ; return cv' } - else if isGiven fl then + else if isGivenOrSolved fl then newGivenCoVar s2 s1 (mkSymCoercion (mkCoVarCoercion cv)) else -- Derived newDerivedId (EqPred s2 s1) @@ -784,8 +797,8 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2 -- cv : F tys1 -- co2 :: xi2 ~ s2 ; let ccs = ccs1 `andCCan` ccs2 no_flattening_happened = isEmptyCCan ccs - ; cv_new <- if no_flattening_happened then return cv - else if isGiven fl then return cv + ; cv_new <- if no_flattening_happened then return cv + else if isGivenOrSolved fl then return cv else if isWanted fl then do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2 -- cv' : F xis ~ xi2 @@ -830,8 +843,8 @@ canEqLeafTyVarLeft fl cv tv s2 -- cv : tv ~ s2 Nothing -> canEqFailure fl cv ; Just xi2' -> do { let no_flattening_happened = isEmptyCCan ccs2 - ; cv_new <- if no_flattening_happened then return cv - else if isGiven fl then return cv + ; cv_new <- if no_flattening_happened then return cv + else if isGivenOrSolved fl then return cv else if isWanted fl then do { cv' <- newCoVar (mkTyVarTy tv) xi2' -- cv' : tv ~ xi2 ; setCoBind cv (mkCoVarCoercion cv' `mkTransCoercion` co) @@ -1057,7 +1070,7 @@ instFunDepEqn fl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs ; mapM (do_one subst) eqs } where fl' = case fl of - Given _ -> panic "mkFunDepEqns" + Given {} -> panic "mkFunDepEqns" Wanted loc -> Wanted (push_ctx loc) Derived loc -> Derived (push_ctx loc)