Commit 8d7dd547 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent e4a1d2d0
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -142,7 +142,7 @@ module TcType (
isUnboxedTupleType, -- Ditto
isPrimitiveType,
tyVarsOfType, tyVarsOfTypes,
tyVarsOfType, tyVarsOfTypes, closeOverKinds,
tcTyVarsOfType, tcTyVarsOfTypes,
pprKind, pprParendKind, pprSigmaType,
......
......@@ -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}
......
......@@ -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}
%************************************************************************
......
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