[commit: ghc] master: Make Specialise close over kind variables (fixes Trac #8196) (8d7dd54)
git at git.haskell.org
git at git.haskell.org
Mon Sep 2 12:12:56 CEST 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/8d7dd5477e7882f1ad3c1429671d4adfffa63202/ghc
>---------------------------------------------------------------
commit 8d7dd5477e7882f1ad3c1429671d4adfffa63202
Author: Simon Peyton Jones <simonpj at microsoft.com>
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}
%************************************************************************
More information about the ghc-commits
mailing list