Repository : ssh://[email protected]/ghc On branch : master Link : http://ghc.haskell.org/trac/ghc/changeset/8d7dd5477e7882f1ad3c1429671d4adfffa63202/ghc
>--------------------------------------------------------------- commit 8d7dd5477e7882f1ad3c1429671d4adfffa63202 Author: Simon Peyton Jones <[email protected]> Date: Mon Sep 2 09:49:40 2013 +0100 Make Specialise close over kind variables (fixes Trac #8196) This is a lingering bug from the introduction of polymorphic kinds. In the specialiser we were specialising over a type, but failing to specialise over the kinds it mentions. The fix is simple: add a call to closeOverKinds. Most of the patch is to add closeOverKinds, and to use it in a few other places where we are doing essentially the same thing. >--------------------------------------------------------------- 8d7dd5477e7882f1ad3c1429671d4adfffa63202 compiler/specialise/Specialise.lhs | 4 ++-- compiler/typecheck/TcBinds.lhs | 5 ++--- compiler/typecheck/TcMType.lhs | 6 ++---- compiler/typecheck/TcType.lhs | 2 +- compiler/types/Type.lhs | 10 +--------- compiler/types/TypeRep.lhs | 18 ++++++++++++++++-- 6 files changed, 24 insertions(+), 21 deletions(-) diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index bf73bec..a175e5e 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -10,7 +10,7 @@ module Specialise ( specProgram ) where import Id import TcType hiding( substTy, extendTvSubstList ) -import Type( TyVar, isDictTy, mkPiTypes, classifyPredType, PredTree(..), isIPClass ) +import Type hiding( substTy, extendTvSubstList ) import Coercion( Coercion ) import CoreMonad import qualified CoreSubst @@ -1614,7 +1614,7 @@ mkCallUDs env f args _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts , ppr (map (interestingDict env) dicts)] (tyvars, theta, _) = tcSplitSigmaTy (idType f) - constrained_tyvars = tyVarsOfTypes theta + constrained_tyvars = closeOverKinds (tyVarsOfTypes theta) n_tyvars = length tyvars n_dicts = length theta diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index b8bef9e..2a33955 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -559,9 +559,8 @@ mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id) -- In the inference case (no signature) this stuff figures out -- the right type variables and theta to quantify over -- See Note [Impedence matching] - my_tvs1 = growThetaTyVars theta (tyVarsOfType mono_ty) - my_tvs2 = foldVarSet (\tv tvs -> tyVarsOfType (tyVarKind tv) `unionVarSet` tvs) - my_tvs1 my_tvs1 -- Add kind variables! Trac #7916 + my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType mono_ty)) + -- Include kind variables! Trac #7916 my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order my_theta = filter (quantifyPred my_tvs2) theta inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 481cb89..6049d5b 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -511,11 +511,9 @@ quantifyTyVars :: TcTyVarSet -> TcTyVarSet -> TcM [TcTyVar] quantifyTyVars gbl_tvs tkvs = do { tkvs <- zonkTyVarsAndFV tkvs ; gbl_tvs <- zonkTyVarsAndFV gbl_tvs - ; let (kvs1, tvs) = partitionVarSet isKindVar (tkvs `minusVarSet` gbl_tvs) - kvs2 = varSetElems (foldVarSet add_kvs kvs1 tvs - `minusVarSet` gbl_tvs ) - add_kvs tv kvs = tyVarsOfType (tyVarKind tv) `unionVarSet` kvs + ; let (kvs, tvs) = partitionVarSet isKindVar (closeOverKinds tkvs `minusVarSet` gbl_tvs) -- NB kinds of tvs are zonked by zonkTyVarsAndFV + kvs2 = varSetElems kvs qtvs = varSetElems tvs -- In the non-PolyKinds case, default the kind variables diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 8a8de41..af67808 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -142,7 +142,7 @@ module TcType ( isUnboxedTupleType, -- Ditto isPrimitiveType, - tyVarsOfType, tyVarsOfTypes, + tyVarsOfType, tyVarsOfTypes, closeOverKinds, tcTyVarsOfType, tcTyVarsOfTypes, pprKind, pprParendKind, pprSigmaType, diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 8596dde..5753aba 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -85,7 +85,7 @@ module Type ( constraintKindTyCon, anyKindTyCon, -- * Type free variables - tyVarsOfType, tyVarsOfTypes, + tyVarsOfType, tyVarsOfTypes, closeOverKinds, expandTypeSynonyms, typeSize, varSetElemsKvsFirst, @@ -171,7 +171,6 @@ import Util import Outputable import FastString -import Data.List ( partition ) import Maybes ( orElse ) import Data.Maybe ( isJust ) import Control.Monad ( guard ) @@ -995,13 +994,6 @@ typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 typeSize (ForAllTy _ t) = 1 + typeSize t typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) - -varSetElemsKvsFirst :: VarSet -> [TyVar] --- {k1,a,k2,b} --> [k1,k2,a,b] -varSetElemsKvsFirst set - = kvs ++ tvs - where - (kvs, tvs) = partition isKindVar (varSetElems set) \end{code} diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index cb5b8f0..2b12736 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -45,7 +45,7 @@ module TypeRep ( pprPrefixApp, pprArrowChain, ppr_type, -- Free variables - tyVarsOfType, tyVarsOfTypes, + tyVarsOfType, tyVarsOfTypes, closeOverKinds, varSetElemsKvsFirst, -- * Tidying type related things up for printing tidyType, tidyTypes, @@ -85,7 +85,7 @@ import StaticFlags( opt_PprStyle_Debug ) import Util -- libraries -import Data.List( mapAccumL ) +import Data.List( mapAccumL, partition ) import qualified Data.Data as Data hiding ( TyCon ) \end{code} @@ -327,6 +327,20 @@ tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys + +closeOverKinds :: TyVarSet -> TyVarSet +-- Add the kind variables free in the kinds +-- of the tyvars in the given set +closeOverKinds tvs + = foldVarSet (\tv ktvs -> tyVarsOfType (tyVarKind tv) `unionVarSet` ktvs) + tvs tvs + +varSetElemsKvsFirst :: VarSet -> [TyVar] +-- {k1,a,k2,b} --> [k1,k2,a,b] +varSetElemsKvsFirst set + = kvs ++ tvs + where + (kvs, tvs) = partition isKindVar (varSetElems set) \end{code} %************************************************************************ _______________________________________________ ghc-commits mailing list [email protected] http://www.haskell.org/mailman/listinfo/ghc-commits
