From ad552fe28f05107378eec34e13d30b5318339567 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 7 Feb 2002 14:06:01 +0000 Subject: [PATCH] [project @ 2002-02-07 14:06:00 by simonpj] ------------------------------------------- Improve the "stragely-kinded tyvar" problem ------------------------------------------- When the type checker finds a type variable with no binding, which means it can be instantiated with an arbitrary type, it usually instantiates it to Void. Eg. length [] ===> length Void (Nil Void) But in really obscure programs, the type variable might have a kind other than *, so we need to invent a suitably-kinded type. This commit uses Void for kind * List for kind *->* Tuple for kind *->...*->* which deals with most cases. (Previously, it only dealt with kind *.) In the other cases, it just makes up a TyCon with a suitable kind. If this gets into an interface file, anyone reading that file won't understand it. This is fixable (by making the client of the interface file make up a TyCon too) but it is tiresome and never happens, so I am leaving it. Most of the added lines are comments. --- ghc/compiler/typecheck/TcMType.lhs | 78 ++++++++++++++++++++++++++---------- ghc/compiler/typecheck/TcType.lhs | 4 +- ghc/compiler/types/Type.lhs | 13 +++--- 3 files changed, 66 insertions(+), 29 deletions(-) diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index aa1a2ce..eb37c46 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -58,20 +58,21 @@ import TcType ( TcType, TcThetaType, TcTauType, TcPredType, liftedTypeKind, openTypeKind, defaultKind, superKind, superBoxity, liftedBoxity, typeKind, tyVarsOfType, tyVarsOfTypes, - eqKind, isTypeKind, + eqKind, isTypeKind, isAnyTypeKind, isFFIArgumentTy, isFFIImportResultTy ) +import qualified Type ( splitFunTys ) import Subst ( Subst, mkTopTyVarSubst, substTy ) import Class ( Class, classArity, className ) import TyCon ( TyCon, mkPrimTyCon, isSynTyCon, isUnboxedTupleTyCon, - tyConArity, tyConName ) + tyConArity, tyConName, tyConKind ) import PrimRep ( PrimRep(VoidRep) ) import Var ( TyVar, tyVarKind, tyVarName, isTyVar, mkTyVar, isMutTyVar ) -- others: import TcMonad -- TcType, amongst others -import TysWiredIn ( voidTy ) +import TysWiredIn ( voidTy, listTyCon, tupleTyCon ) import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) import ForeignCall ( Safety(..) ) import FunDeps ( grow ) @@ -80,6 +81,7 @@ import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName, mkLocalName, mkDerivedTyConOcc ) import VarSet +import BasicTypes ( Boxity(Boxed) ) import CmdLineOpts ( dopt, DynFlag(..) ) import Unique ( Uniquable(..) ) import SrcLoc ( noSrcLoc ) @@ -398,32 +400,64 @@ zonkKindEnv pairs zonkTcTypeToType :: TcType -> NF_TcM Type zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty where - -- Zonk a mutable but unbound type variable to - -- Void if it has kind Lifted - -- :Void otherwise + -- Zonk a mutable but unbound type variable to an arbitrary type -- We know it's unbound even though we don't carry an environment, -- because at the binding site for a type variable we bind the -- mutable tyvar to a fresh immutable one. So the mutable store -- plays the role of an environment. If we come across a mutable -- type variable that isn't so bound, it must be completely free. - zonk_unbound_tyvar tv - | kind `eqKind` liftedTypeKind || kind `eqKind` openTypeKind - = putTcTyVar tv voidTy -- Just to avoid creating a new tycon in - -- this vastly common case - | otherwise - = putTcTyVar tv (TyConApp (mk_void_tycon tv kind) []) - where - kind = tyVarKind tv - - mk_void_tycon tv kind -- Make a new TyCon with the same kind as the - -- type variable tv. Same name too, apart from - -- making it start with a colon (sigh) + zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv) + + +-- When the type checker finds a type variable with no binding, +-- which means it can be instantiated with an arbitrary type, it +-- usually instantiates it to Void. Eg. +-- +-- length [] +-- ===> +-- length Void (Nil Void) +-- +-- But in really obscure programs, the type variable might have +-- a kind other than *, so we need to invent a suitably-kinded type. +-- +-- This commit uses +-- Void for kind * +-- List for kind *->* +-- Tuple for kind *->...*->* +-- +-- which deals with most cases. (Previously, it only dealt with +-- kind *.) +-- +-- In the other cases, it just makes up a TyCon with a suitable +-- kind. If this gets into an interface file, anyone reading that +-- file won't understand it. This is fixable (by making the client +-- of the interface file make up a TyCon too) but it is tiresome and +-- never happens, so I am leaving it + +mkArbitraryType :: TcTyVar -> Type +-- Make up an arbitrary type whose kind is the same as the tyvar. +-- We'll use this to instantiate the (unbound) tyvar. +mkArbitraryType tv + | isAnyTypeKind kind = voidTy -- The vastly common case + | otherwise = TyConApp tycon [] + where + kind = tyVarKind tv + (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys + + tycon | kind `eqKind` tyConKind listTyCon -- *->* + = listTyCon -- No tuples this size + + | all isTypeKind args && isTypeKind res + = tupleTyCon Boxed (length args) -- *-> ... ->*->* + + | otherwise + = pprTrace "Urk! Inventing strangely-kinded void TyCon" (ppr tc_name) $ + mkPrimTyCon tc_name kind 0 [] VoidRep + -- Same name as the tyvar, apart from making it start with a colon (sigh) -- I dread to think what will happen if this gets out into an -- interface file. Catastrophe likely. Major sigh. - = pprTrace "Urk! Inventing strangely-kinded void TyCon" (ppr tc_name) $ - mkPrimTyCon tc_name kind 0 [] VoidRep - where - tc_name = mkLocalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc + + tc_name = mkLocalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc -- zonkTcTyVarToTyVar is applied to the *binding* occurrence -- of a type variable, at the *end* of type checking. It changes diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index ee7a060..205292b 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -82,7 +82,7 @@ module TcType ( Kind, -- Stuff to do with kinds is insensitive to pre/post Tc unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind, - isTypeKind, + isTypeKind, isAnyTypeKind, Type, SourceType(..), PredType, ThetaType, mkForAllTy, mkForAllTys, @@ -113,7 +113,7 @@ import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, Kind, Type, SourceType(..), PredType, ThetaType, unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, - mkForAllTy, mkForAllTys, defaultKind, isTypeKind, + mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind, mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 9a67311..e34c924 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -15,7 +15,7 @@ module Type ( typeCon, -- :: BX -> KX liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX - isTypeKind, + isTypeKind, isAnyTypeKind, funTyCon, usageKindCon, -- :: KX @@ -121,12 +121,15 @@ import UniqSet ( sizeUniqSet ) -- Should come via VarSet hasMoreBoxityInfo :: Kind -> Kind -> Bool -- (k1 `hasMoreBoxityInfo` k2) checks that k1 <: k2 hasMoreBoxityInfo k1 k2 - | k2 `eqKind` openTypeKind = ok k1 + | k2 `eqKind` openTypeKind = isAnyTypeKind k1 | otherwise = k1 `eqKind` k2 where - ok (TyConApp tc _) = tc == typeCon || tc == openKindCon - ok (NoteTy _ k) = ok k - ok other = False + +isAnyTypeKind :: Kind -> Bool +-- True of kind * and *# and ? +isAnyTypeKind (TyConApp tc _) = tc == typeCon || tc == openKindCon +isAnyTypeKind (NoteTy _ k) = isAnyTypeKind k +isAnyTypeKind other = False isTypeKind :: Kind -> Bool -- True of kind * and *# -- 1.7.10.4