Typechecker performance fixes and flatten skolem bugfixing

parent bff88b3a
\begin{code}
module TcCanonical(
mkCanonical, mkCanonicals, canWanteds, canGivens, canOccursCheck
mkCanonical, mkCanonicals, canWanteds, canGivens, canOccursCheck,
canEq
) where
#include "HsVersions.h"
......
This diff is collapsed.
......@@ -497,12 +497,12 @@ zonkTcTypeCarefully ty
| otherwise
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
SkolemTv {} -> return (TyVarTy tv)
SkolemTv {} -> return (TyVarTy tv)
FlatSkol ty -> zonkType (zonk_tv env_tvs) ty
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> return (TyVarTy tv)
Indirect ty -> zonkType (zonk_tv env_tvs) ty }
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> return (TyVarTy tv)
Indirect ty -> zonkType (zonk_tv env_tvs) ty }
zonkTcType :: TcType -> TcM TcType
-- Simply look through all Flexis
......@@ -513,12 +513,12 @@ zonkTcTyVar :: TcTyVar -> TcM TcType
zonkTcTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
SkolemTv {} -> return (TyVarTy tv)
SkolemTv {} -> return (TyVarTy tv)
FlatSkol ty -> zonkTcType ty
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> return (TyVarTy tv)
Indirect ty -> zonkTcType ty }
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> return (TyVarTy tv)
Indirect ty -> zonkTcType ty }
zonkTcTypeAndSubst :: TvSubst -> TcType -> TcM TcType
-- Zonk, and simultaneously apply a non-necessarily-idempotent substitution
......@@ -526,12 +526,12 @@ zonkTcTypeAndSubst subst ty = zonkType zonk_tv ty
where
zonk_tv tv
= case tcTyVarDetails tv of
SkolemTv {} -> return (TyVarTy tv)
FlatSkol ty -> zonkType zonk_tv ty
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> zonk_flexi tv
Indirect ty -> zonkType zonk_tv ty }
SkolemTv {} -> return (TyVarTy tv)
FlatSkol ty -> zonkType zonk_tv ty
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> zonk_flexi tv
Indirect ty -> zonkType zonk_tv ty }
zonk_flexi tv
= case lookupTyVar subst tv of
Just ty -> zonkType zonk_tv ty
......@@ -750,12 +750,12 @@ mkZonkTcTyVar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable var
mkZonkTcTyVar unbound_var_fn tyvar
= ASSERT( isTcTyVar tyvar )
case tcTyVarDetails tyvar of
SkolemTv {} -> return (TyVarTy tyvar)
FlatSkol ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> unbound_var_fn tyvar
Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty }
SkolemTv {} -> return (TyVarTy tyvar)
FlatSkol ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> unbound_var_fn tyvar
Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty }
-- Zonk the kind of a non-TC tyvar in case it is a coercion variable
-- (their kind contains types).
......
......@@ -35,6 +35,8 @@ module TcSMonad (
newFlattenSkolemTy, -- Flatten skolems
zonkFlattenedType,
instDFunTypes, -- Instantiation
instDFunConstraints,
......@@ -63,7 +65,6 @@ module TcSMonad (
import HscTypes
import BasicTypes
import Type
import Inst
import InstEnv
......@@ -83,6 +84,8 @@ import DynFlags
import Coercion
import Class
import TyCon
import TypeRep
import Name
import Var
import Outputable
......@@ -570,9 +573,30 @@ newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
newFlattenSkolemTyVar ty
= wrapTcS $ do { uniq <- TcM.newUnique
; let name = mkSysTvName uniq (fsLit "f")
; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty)
; return $
mkTcTyVar name (typeKind ty) (FlatSkol ty)
}
zonkFlattenedType :: TcType -> TcS TcType
zonkFlattenedType ty = wrapTcS (TcM.zonkTcType ty)
{--
tyVarsOfUnflattenedType :: TcType -> TcTyVarSet
-- A version of tyVarsOfType which looks through flatSkols
tyVarsOfUnflattenedType ty
= foldVarSet (unionVarSet . do_tv) emptyVarSet (tyVarsOfType ty)
where
do_tv :: TyVar -> TcTyVarSet
do_tv tv = ASSERT( isTcTyVar tv)
case tcTyVarDetails tv of
FlatSkol _ ty -> tyVarsOfUnflattenedType ty
_ -> unitVarSet tv
--}
-- Instantiations
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -274,17 +274,18 @@ TcBinds.tcInstSig, and its use_skols parameter.
data TcTyVarDetails
= SkolemTv SkolemInfo -- A skolem constant
| FlatSkol TcType -- The "skolem" obtained by flattening during
-- constraint simplification
| FlatSkol TcType
-- The "skolem" obtained by flattening during
-- constraint simplification
-- In comments we will use the notation alpha[flat = ty]
-- to represent a flattening skolem variable alpha
-- identified with type ty.
-- In comments we will use the notation alpha[flat = ty]
-- to represent a flattening skolem variable alpha
-- identified with type ty.
| MetaTv MetaInfo (IORef MetaDetails)
data MetaDetails
= Flexi -- Flexi type variables unify to become Indirects
= Flexi -- Flexi type variables unify to become Indirects
| Indirect TcType
data MetaInfo
......@@ -405,7 +406,7 @@ kind_var_occ = mkOccName tvName "k"
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
-- For debugging
pprTcTyVarDetails (SkolemTv _) = ptext (sLit "sk")
pprTcTyVarDetails (FlatSkol _) = ptext (sLit "fsk")
pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk")
pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig")
......@@ -431,7 +432,7 @@ pprSkolTvBinding tv
quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
where
ppr_details (SkolemTv info) = ppr_skol info
ppr_details (FlatSkol _) = ptext (sLit "is a flattening type variable")
ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable")
ppr_details (MetaTv TauTv _) = ptext (sLit "is a meta type variable")
ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for") <+> quotes (ppr n)
......
......@@ -889,9 +889,8 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType)
-- (checkTauTvUpdate tv ty)
-- We are about to update the TauTv tv with ty.
-- Check (a) that tv doesn't occur in ty (occurs check)
-- (b) that ty is a monotype
-- (c) that kind(ty) is a sub-kind of kind(tv)
-- (d) that ty does not contain any type families, see Note [SHARING]
-- (b) that kind(ty) is a sub-kind of kind(tv)
-- (c) that ty does not contain any type families, see Note [Type family sharing]
--
-- We have two possible outcomes:
-- (1) Return the type to update the type variable with,
......@@ -914,8 +913,10 @@ checkTauTvUpdate tv ty
then return (Just ty')
else return Nothing }
where ok :: TcType -> Bool
-- Check that tv is not among the free variables of
-- the type and that the type is type-family-free.
-- Check that (a) tv is not among the free variables of
-- the type and that (b) the type is type-family-free.
-- Reason: Note [Type family sharing]
ok ty1 | Just ty1' <- tcView ty1 = ok ty1'
ok (TyVarTy tv') = not (tv == tv')
ok (TyConApp tc tys) = all ok tys && not (isSynFamilyTyCon tc)
ok (PredTy sty) = ok_pred sty
......@@ -929,7 +930,7 @@ checkTauTvUpdate tv ty
\end{code}
Note [SHARING]
Note [Type family sharing]
~~~~~~~~~~~~~~
We must avoid eagerly unifying type variables to types that contain function symbols,
because this may lead to loss of sharing, and in turn, in very poor performance of the
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment