From: keithw Date: Tue, 11 May 1999 16:33:11 +0000 (+0000) Subject: [project @ 1999-05-11 16:33:06 by keithw] X-Git-Tag: Approximately_9120_patches~6228 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5c18c653824cc629940a8b73afcd59c78c1e97bb;p=ghc-hetmet.git [project @ 1999-05-11 16:33:06 by keithw] (this is number 2 of 9 commits to be applied together) Type constructors now carry information on the variance (positive and/or negative) of each of their type arguments (tyConArgVrcs). This information is provided for primitive types and computed for others. If a tycon has been imported abstractly and this variance information is subsequently demanded, we make a pessimistic assumption and warn that -fno-prune-tydecls should be used. --- diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 6bb4f67..2400e72 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -48,7 +48,7 @@ module TysPrim( import Var ( TyVar, mkSysTyVar ) import Name ( mkWiredInTyConName ) import PrimRep ( PrimRep(..), isFollowableRep ) -import TyCon ( mkPrimTyCon, TyCon ) +import TyCon ( mkPrimTyCon, TyCon, ArgVrcs ) import Type ( Type, mkTyConApp, mkTyConTy, mkTyVarTys, unboxedTypeKind, boxedTypeKind, openTypeKind, mkArrowKinds @@ -80,6 +80,15 @@ openAlphaTyVar = mkSysTyVar (mkAlphaTyVarUnique 1) openTypeKind openAlphaTyVars :: [TyVar] openAlphaTyVars = [ mkSysTyVar u openTypeKind | u <- map mkAlphaTyVarUnique [2..] ] + +vrcPos,vrcZero :: (Bool,Bool) +vrcPos = (True,False) +vrcZero = (False,False) + +vrcsP,vrcsZ,vrcsZP :: ArgVrcs +vrcsP = [vrcPos] +vrcsZ = [vrcZero] +vrcsZP = [vrcZero,vrcPos] \end{code} %************************************************************************ @@ -90,39 +99,39 @@ openAlphaTyVars = [ mkSysTyVar u openTypeKind \begin{code} -- only used herein -pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> PrimRep -> TyCon -pcPrimTyCon key str arity rep +pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> ArgVrcs -> PrimRep -> TyCon +pcPrimTyCon key str arity arg_vrcs rep = the_tycon where name = mkWiredInTyConName key pREL_GHC str the_tycon - the_tycon = mkPrimTyCon name kind arity rep + the_tycon = mkPrimTyCon name kind arity arg_vrcs rep kind = mkArrowKinds (take arity (repeat boxedTypeKind)) result_kind result_kind | isFollowableRep rep = boxedTypeKind -- Represented by a GC-ish ptr | otherwise = unboxedTypeKind -- Represented by a non-ptr charPrimTy = mkTyConTy charPrimTyCon -charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 CharRep +charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 [] CharRep intPrimTy = mkTyConTy intPrimTyCon -intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 IntRep +intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 [] IntRep int64PrimTy = mkTyConTy int64PrimTyCon -int64PrimTyCon = pcPrimTyCon int64PrimTyConKey SLIT("Int64#") 0 Int64Rep +int64PrimTyCon = pcPrimTyCon int64PrimTyConKey SLIT("Int64#") 0 [] Int64Rep wordPrimTy = mkTyConTy wordPrimTyCon -wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 WordRep +wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 [] WordRep word64PrimTy = mkTyConTy word64PrimTyCon -word64PrimTyCon = pcPrimTyCon word64PrimTyConKey SLIT("Word64#") 0 Word64Rep +word64PrimTyCon = pcPrimTyCon word64PrimTyConKey SLIT("Word64#") 0 [] Word64Rep addrPrimTy = mkTyConTy addrPrimTyCon -addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 AddrRep +addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 [] AddrRep floatPrimTy = mkTyConTy floatPrimTyCon -floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 FloatRep +floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 [] FloatRep doublePrimTy = mkTyConTy doublePrimTyCon -doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 DoubleRep +doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 [] DoubleRep \end{code} @@ -143,7 +152,7 @@ keep different state threads separate. It is represented by nothing at all. \begin{code} mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] -statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1 VoidRep +statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1 vrcsZ VoidRep \end{code} @_RealWorld@ is deeply magical. It {\em is primitive}, but it @@ -153,7 +162,7 @@ system, to parameterise State#. \begin{code} realWorldTy = mkTyConTy realWorldTyCon -realWorldTyCon = pcPrimTyCon realWorldTyConKey SLIT("RealWorld") 0 PtrRep +realWorldTyCon = pcPrimTyCon realWorldTyConKey SLIT("RealWorld") 0 [] PtrRep realWorldStatePrimTy = mkStatePrimTy realWorldTy \end{code} @@ -168,13 +177,15 @@ defined in \tr{TysWiredIn.lhs}, not here. %************************************************************************ \begin{code} -arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1 ArrayRep +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1 vrcsP ArrayRep -byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0 ByteArrayRep +byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0 [] ByteArrayRep -mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") 2 ArrayRep +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") + 2 vrcsZP ArrayRep -mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1 ByteArrayRep +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") + 1 vrcsZ ByteArrayRep mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt] byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon @@ -189,7 +200,8 @@ mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s] %************************************************************************ \begin{code} -mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConKey SLIT("MutVar#") 2 PtrRep +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConKey SLIT("MutVar#") + 2 vrcsZP PtrRep mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] \end{code} @@ -201,7 +213,8 @@ mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -mVarPrimTyCon = pcPrimTyCon mVarPrimTyConKey SLIT("MVar#") 2 PtrRep +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConKey SLIT("MVar#") + 2 vrcsZP PtrRep mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] \end{code} @@ -213,7 +226,8 @@ mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1 StablePtrRep +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") + 1 vrcsP StablePtrRep mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] \end{code} @@ -225,7 +239,8 @@ mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] %************************************************************************ \begin{code} -stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConKey SLIT("StableName#") 1 StableNameRep +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConKey SLIT("StableName#") + 1 vrcsP StableNameRep mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty] \end{code} @@ -248,7 +263,7 @@ dead before it really was. \begin{code} foreignObjPrimTy = mkTyConTy foreignObjPrimTyCon -foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 ForeignObjRep +foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 [] ForeignObjRep \end{code} %************************************************************************ @@ -258,7 +273,7 @@ foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 F %************************************************************************ \begin{code} -weakPrimTyCon = pcPrimTyCon weakPrimTyConKey SLIT("Weak#") 1 WeakPtrRep +weakPrimTyCon = pcPrimTyCon weakPrimTyConKey SLIT("Weak#") 1 vrcsP WeakPtrRep mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v] \end{code} @@ -280,7 +295,7 @@ to the thread id internally. \begin{code} threadIdPrimTy = mkTyConTy threadIdPrimTyCon -threadIdPrimTyCon = pcPrimTyCon threadIdPrimTyConKey SLIT("ThreadId#") 0 ThreadIdRep +threadIdPrimTyCon = pcPrimTyCon threadIdPrimTyConKey SLIT("ThreadId#") 0 [] ThreadIdRep \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index c775e7a..ab79f16 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -86,7 +86,7 @@ import Module ( Module ) import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, dataName ) import DataCon ( DataCon, mkDataCon ) import Var ( TyVar, tyVarKind ) -import TyCon ( TyCon, mkAlgTyCon, mkSynTyCon, mkTupleTyCon ) +import TyCon ( TyCon, ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon ) import BasicTypes ( Arity, NewOrData(..), RecFlag(..), StrictnessMark(..) ) import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, @@ -107,18 +107,19 @@ alpha_beta_tyvars = [alphaTyVar, betaTyVar] pcRecDataTyCon, pcNonRecDataTyCon, pcNonRecNewTyCon :: Unique{-TyConKey-} -> Module -> FAST_STRING - -> [TyVar] -> [DataCon] -> TyCon + -> [TyVar] -> ArgVrcs -> [DataCon] -> TyCon pcRecDataTyCon = pcTyCon DataType Recursive pcNonRecDataTyCon = pcTyCon DataType NonRecursive pcNonRecNewTyCon = pcTyCon NewType NonRecursive -pcTyCon new_or_data is_rec key mod str tyvars cons +pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons = tycon where tycon = mkAlgTyCon name kind tyvars [] -- No context + argvrcs cons [] -- No derivings Nothing -- Not a dictionary @@ -128,10 +129,10 @@ pcTyCon new_or_data is_rec key mod str tyvars cons name = mkWiredInTyConName key mod str tycon kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind -pcSynTyCon key mod str kind arity tyvars expansion +pcSynTyCon key mod str kind arity tyvars expansion argvrcs -- this fun never used! = tycon where - tycon = mkSynTyCon name kind arity tyvars expansion + tycon = mkSynTyCon name kind arity tyvars expansion argvrcs name = mkWiredInTyConName key mod str tycon pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING @@ -262,7 +263,7 @@ voidTy = unitTy \begin{code} charTy = mkTyConTy charTyCon -charTyCon = pcNonRecDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [charDataCon] +charTyCon = pcNonRecDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [] [charDataCon] charDataCon = pcDataCon charDataConKey pREL_BASE SLIT("C#") [] [] [charPrimTy] charTyCon stringTy = mkListTy charTy -- convenience only @@ -271,7 +272,7 @@ stringTy = mkListTy charTy -- convenience only \begin{code} intTy = mkTyConTy intTyCon -intTyCon = pcNonRecDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [intDataCon] +intTyCon = pcNonRecDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [] [intDataCon] intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon isIntTy :: Type -> Bool @@ -293,14 +294,14 @@ min_int = toInteger minInt wordTy = mkTyConTy wordTyCon -wordTyCon = pcNonRecDataTyCon wordTyConKey pREL_ADDR SLIT("Word") [] [wordDataCon] +wordTyCon = pcNonRecDataTyCon wordTyConKey pREL_ADDR SLIT("Word") [] [] [wordDataCon] wordDataCon = pcDataCon wordDataConKey pREL_ADDR SLIT("W#") [] [] [wordPrimTy] wordTyCon \end{code} \begin{code} addrTy = mkTyConTy addrTyCon -addrTyCon = pcNonRecDataTyCon addrTyConKey pREL_ADDR SLIT("Addr") [] [addrDataCon] +addrTyCon = pcNonRecDataTyCon addrTyConKey pREL_ADDR SLIT("Addr") [] [] [addrDataCon] addrDataCon = pcDataCon addrDataConKey pREL_ADDR SLIT("A#") [] [] [addrPrimTy] addrTyCon isAddrTy :: Type -> Bool @@ -314,7 +315,7 @@ isAddrTy ty \begin{code} floatTy = mkTyConTy floatTyCon -floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [floatDataCon] +floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [] [floatDataCon] floatDataCon = pcDataCon floatDataConKey pREL_BASE SLIT("F#") [] [] [floatPrimTy] floatTyCon isFloatTy :: Type -> Bool @@ -334,14 +335,14 @@ isDoubleTy ty Just (tycon, [], _) -> getUnique tycon == doubleTyConKey _ -> False -doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [doubleDataCon] +doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [] [doubleDataCon] doubleDataCon = pcDataCon doubleDataConKey pREL_BASE SLIT("D#") [] [] [doublePrimTy] doubleTyCon \end{code} \begin{code} stablePtrTyCon = pcNonRecDataTyCon stablePtrTyConKey pREL_STABLE SLIT("StablePtr") - alpha_tyvar [stablePtrDataCon] + alpha_tyvar [(True,False)] [stablePtrDataCon] where stablePtrDataCon = pcDataCon stablePtrDataConKey pREL_STABLE SLIT("StablePtr") @@ -351,7 +352,7 @@ stablePtrTyCon \begin{code} foreignObjTyCon = pcNonRecDataTyCon foreignObjTyConKey pREL_IO_BASE SLIT("ForeignObj") - [] [foreignObjDataCon] + [] [] [foreignObjDataCon] where foreignObjDataCon = pcDataCon foreignObjDataConKey pREL_IO_BASE SLIT("ForeignObj") @@ -369,7 +370,8 @@ foreignObjTyCon integerTy :: Type integerTy = mkTyConTy integerTyCon -integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_BASE SLIT("Integer") [] [smallIntegerDataCon, largeIntegerDataCon] +integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_BASE SLIT("Integer") + [] [] [smallIntegerDataCon, largeIntegerDataCon] smallIntegerDataCon = pcDataCon smallIntegerDataConKey pREL_BASE SLIT("S#") [] [] [intPrimTy] integerTyCon @@ -501,7 +503,7 @@ primitive counterpart. boolTy = mkTyConTy boolTyCon boolTyCon = pcTyCon EnumType NonRecursive boolTyConKey - pREL_BASE SLIT("Bool") [] [falseDataCon, trueDataCon] + pREL_BASE SLIT("Bool") [] [] [falseDataCon, trueDataCon] falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon @@ -529,7 +531,7 @@ mkListTy ty = mkTyConApp listTyCon [ty] alphaListTy = mkSigmaTy alpha_tyvar [] (mkTyConApp listTyCon alpha_ty) listTyCon = pcRecDataTyCon listTyConKey pREL_BASE SLIT("[]") - alpha_tyvar [nilDataCon, consDataCon] + alpha_tyvar [(True,False)] [nilDataCon, consDataCon] nilDataCon = pcDataCon nilDataConKey pREL_BASE SLIT("[]") alpha_tyvar [] [] listTyCon consDataCon = pcDataCon consDataConKey pREL_BASE SLIT(":") diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index e4ad273..df3c25f 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -23,20 +23,28 @@ import TcMonad import Inst ( InstanceMapper ) import TcClassDcl ( kcClassDecl, tcClassDecl1 ) import TcEnv ( ValueEnv, TcTyThing(..), - tcExtendTypeEnv + tcExtendTypeEnv, getAllEnvTyCons ) import TcTyDecls ( tcTyDecl, kcTyDecl ) import TcMonoType ( kcHsTyVar ) import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind, zonkTcKindToKind ) -import Type ( mkArrowKind, boxedTypeKind ) +import Type ( mkArrowKind, boxedTypeKind, mkDictTy ) + -- next two imports for usage stuff only +import TyCon ( ArgVrcs, tyConKind, tyConArity, tyConDataCons, tyConTyVars, + tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon ) +import DataCon ( dataConRawArgTys, dataConSig ) + import Class ( Class, classBigSig ) -import Var ( tyVarKind ) +import Type ( Type(..), TyNote(..), tyVarsOfTypes ) +import Var ( TyVar, tyVarKind ) +import FiniteMap import Bag +import VarSet import Digraph ( stronglyConnComp, SCC(..) ) import Name ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName ) import Outputable -import Maybes ( mapMaybe ) +import Maybes ( mapMaybe, expectJust ) import UniqSet ( UniqSet, emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) @@ -71,6 +79,9 @@ tcGroups unf_env inst_mapper (group:groups) Dealing with a group ~~~~~~~~~~~~~~~~~~~~ +The knot-tying parameters: @rec_tyclss@ is an alist mapping @Name@s to +@TcTyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. + \begin{code} tcGroup :: ValueEnv -> InstanceMapper -> SCC RenamedTyClDecl -> TcM s TcEnv tcGroup unf_env inst_mapper scc @@ -80,7 +91,7 @@ tcGroup unf_env inst_mapper scc -- Tie the knot -- traceTc (ppr (map fst ty_env_stuff1)) `thenTc_` - fixTc ( \ ~(rec_tyclss, _) -> + fixTc ( \ ~(rec_tyclss, rec_vrcs, _) -> let rec_env = listToUFM rec_tyclss in @@ -88,11 +99,17 @@ tcGroup unf_env inst_mapper scc -- Do type checking mapNF_Tc (getTyBinding2 rec_env) ty_env_stuff1 `thenNF_Tc` \ ty_env_stuff2 -> tcExtendTypeEnv ty_env_stuff2 $ - mapTc (tcDecl is_rec_group unf_env inst_mapper) decls `thenTc` \ tyclss -> + mapTc (tcDecl is_rec_group unf_env inst_mapper rec_vrcs) decls + `thenTc` \ tyclss -> tcGetEnv `thenTc` \ env -> - returnTc (tyclss, env) - ) `thenTc` \ (_, env) -> + let + tycons = getAllEnvTyCons env + vrcs = calcTyConArgVrcs tycons + in + + returnTc (tyclss, vrcs, env) + ) `thenTc` \ (_, _, env) -> -- traceTc (text "done" <+> ppr (map fst ty_env_stuff1)) `thenTc_` returnTc env where @@ -116,18 +133,18 @@ kcDecl decl kcTyDecl decl tcDecl :: RecFlag -- True => recursive group - -> ValueEnv -> InstanceMapper + -> ValueEnv -> InstanceMapper -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s (Name, TcTyThing) -tcDecl is_rec_group unf_env inst_mapper decl +tcDecl is_rec_group unf_env inst_mapper vrcs_env decl = tcAddDeclCtxt decl $ -- traceTc (text "Starting" <+> ppr name) `thenTc_` if isClassDecl decl then - tcClassDecl1 unf_env inst_mapper decl `thenTc` \ clas -> + tcClassDecl1 unf_env inst_mapper vrcs_env decl `thenTc` \ clas -> -- traceTc (text "Finished" <+> ppr name) `thenTc_` returnTc (getName clas, AClass clas) else - tcTyDecl is_rec_group decl `thenTc` \ tycon -> + tcTyDecl is_rec_group vrcs_env decl `thenTc` \ tycon -> -- traceTc (text "Finished" <+> ppr name) `thenTc_` returnTc (getName tycon, ATyCon tycon) @@ -315,9 +332,12 @@ get_ty (MonoListTy ty) = set_name listTyCon_name `unionUniqSets` get_ty ty get_ty (MonoTupleTy tys boxed) = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys +get_ty (MonoUsgTy _ ty) + = get_ty ty get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty -get_ty other = panic "TcTyClsDecls:get_ty" +get_ty (MonoDictTy name _) + = set_name name ---------------------------------------------------- get_tys tys @@ -355,3 +375,145 @@ pp_cycle str decls where name = tyClDeclName decl \end{code} + + +Computing the tyConArgVrcs info +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +@tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each +tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed +separately. Note that this is information about occurrences of type +variables, not usages of term variables. + +The function @calcTyConArgVrcs@ must be passed a list of *algebraic or +syntycons only* such that all tycons referred to (by mutual recursion) +appear in the list. The fixpointing will be done on this set of +tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to +be (knot-tyingly?) stuck back into the appropriate fields. + +\begin{code} +calcTyConArgVrcs :: [TyCon] + -> FiniteMap Name ArgVrcs + +calcTyConArgVrcs tycons + = let oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons + initial tc = if isAlgTyCon tc && null (tyConDataCons tc) then + -- make pessimistic assumption (and warn) + take (tyConArity tc) abstractVrcs + else + replicate (tyConArity tc) (False,False) + oi'' = tcaoFix oi + go (tc,vrcs) = (getName tc,vrcs) + in listToFM (map go (fmToList oi'')) + + where + + tcaoFix :: FiniteMap TyCon ArgVrcs -- initial ArgVrcs per tycon + -> FiniteMap TyCon ArgVrcs -- fixpointed ArgVrcs per tycon + + tcaoFix oi = let (changed,oi') = foldFM (\ tc pms + (changed,oi') + -> let pms' = tcaoIter oi' tc -- seq not simult + in (changed || (pms /= pms'), + addToFM oi' tc pms')) + (False,oi) -- seq not simult for faster fixpting + oi + in if changed + then tcaoFix oi' + else oi' + + tcaoIter :: FiniteMap TyCon ArgVrcs -- reference ArgVrcs (initial) + -> TyCon -- tycon to update + -> ArgVrcs -- new ArgVrcs for tycon + + tcaoIter oi tc | isAlgTyCon tc + = let cs = tyConDataCons tc + vs = tyConTyVars tc + argtys = concatMap dataConRawArgTys cs + exdicttys = concatMap ((\ (_,_,_,exth,_,_) -> map (uncurry mkDictTy) exth) + . dataConSig) cs + myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $ + tyConArgVrcs_maybe tc) + tc + -- we use the already-computed result for tycons not in this SCC + in map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) (exdicttys ++ argtys)) + vs + + tcaoIter oi tc | isSynTyCon tc + = let (tyvs,ty) = getSynTyConDefn tc + myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Syn)" $ + tyConArgVrcs_maybe tc) + tc + -- we use the already-computed result for tycons not in this SCC + in map (\v -> vrcInTy myfao v ty) tyvs + + +abstractVrcs :: ArgVrcs +-- we pull this out as a CAF so the warning only appears *once* +abstractVrcs = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n" + ++ "\tUse -fno-prune-tydecls to fix.") $ + repeat (True,True) +\end{code} + +And a general variance-check function. We pass a function for +determining the @ArgVrc@s of a tycon; when fixpointing this refers to +the current value; otherwise this should be looked up from the tycon's +own tyConArgVrcs. + +\begin{code} +vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion) + -> TyVar -- tyvar to check Vrcs of + -> Type -- type to check for occ in + -> (Bool,Bool) -- (occurs positively, occurs negatively) + +vrcInTy fao v (NoteTy (UsgNote _) ty) = vrcInTy fao v ty + +vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty + -- SynTyCon doesn't neccessarily have vrcInfo at this point, + -- so don't try and use it + +vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv + then vrcInTy fao v ty + else (False,False) + -- note that ftv cannot be calculated as occPos||occNeg, + -- since if a tyvar occurs only as unused tyconarg, + -- occPos==occNeg==False, but ftv=True + +vrcInTy fao v (TyVarTy v') = if v==v' + then (True,False) + else (False,False) + +vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False) + then (True,True) + else vrcInTy fao v ty1 + -- ty1 is probably unknown (or it would have been beta-reduced); + -- hence if v occurs in ty2 at all then it could occur with + -- either variance. Otherwise it occurs as it does in ty1. + +vrcInTy fao v (FunTy ty1 ty2) = let (p1,m1) = vrcInTy fao v ty1 + (p2,m2) = vrcInTy fao v ty2 + in (m1||p2,p1||m2) + +vrcInTy fao v (ForAllTy v' ty) = if v==v' + then (False,False) + else vrcInTy fao v ty + +vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys + pms2 = fao tc + in orVrcs (zipWith timesVrc pms1 pms2) + +orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) +orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2) + +orVrcs :: [(Bool,Bool)] -> (Bool,Bool) +orVrcs = foldl orVrc (False,False) + +anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool) +anyVrc p as = foldl (\pm a -> pm `orVrc` p a) (False,False) as + +timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) +timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2, + p1 && m2 || m1 && p2) +\end{code} + + diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index d33163c..1632327 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -38,9 +38,9 @@ import Id ( getIdUnfolding ) import CoreUnfold ( getUnfoldingTemplate ) import FieldLabel import Var ( Id, TyVar ) -import Name ( isLocallyDefined, OccName, NamedThing(..) ) +import Name ( Name, isLocallyDefined, OccName, NamedThing(..) ) import Outputable -import TyCon ( TyCon, mkSynTyCon, mkAlgTyCon, isAlgTyCon, +import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isAlgTyCon, isSynTyCon, tyConDataCons, isNewTyCon ) import Type ( getTyVar, tyVarsOfTypes, @@ -52,6 +52,7 @@ import Type ( getTyVar, tyVarsOfTypes, import Var ( tyVarKind ) import VarSet ( intersectVarSet, isEmptyVarSet ) import Util ( equivClasses ) +import FiniteMap ( FiniteMap, lookupWithDefaultFM ) \end{code} %************************************************************************ @@ -104,20 +105,22 @@ kcConDecl (ConDecl _ ex_tvs ex_ctxt details loc) %************************************************************************ \begin{code} -tcTyDecl :: RecFlag -> RenamedTyClDecl -> TcM s TyCon +tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s TyCon -tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc) +tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc) = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, Just arity, _) -> tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ -> tcHsTopType rhs `thenTc` \ rhs_ty -> let -- Construct the tycon - tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty + argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name) + tycon_name + tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs in returnTc tycon -tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc) +tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc) = -- Lookup the pieces tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, _, ATyCon rec_tycon) -> tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ -> @@ -134,7 +137,10 @@ tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls der DataType | all isNullaryDataCon data_cons -> EnumType | otherwise -> DataType - tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt + argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name) + tycon_name + + tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs data_cons derived_classes Nothing -- Not a dictionary diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index c3c95b8..49cf2bc 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -5,7 +5,7 @@ \begin{code} module TyCon( - TyCon, KindCon, SuperKindCon, + TyCon, KindCon, SuperKindCon, ArgVrcs, isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, @@ -24,6 +24,7 @@ module TyCon( tyConKind, tyConUnique, tyConTyVars, + tyConArgVrcs_maybe, tyConDataCons, tyConFamilySize, tyConDerivings, @@ -79,8 +80,9 @@ data TyCon tyConKind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], - dataTyConTheta :: [(Class,[Type])], + tyConTyVars :: [TyVar], + dataTyConTheta :: [(Class,[Type])], + dataTyConArgVrcs :: ArgVrcs, dataCons :: [DataCon], -- Its data constructors, with fully polymorphic types @@ -106,6 +108,7 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, + primTyConArgVrcs :: ArgVrcs, primTyConRep :: PrimRep } @@ -126,10 +129,11 @@ data TyCon tyConKind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], -- Bound tyvars - synTyConDefn :: Type -- Right-hand side, mentioning these type vars. + tyConTyVars :: [TyVar], -- Bound tyvars + synTyConDefn :: Type, -- Right-hand side, mentioning these type vars. -- Acts as a template for the expansion when -- the tycon is applied to some types. + synTyConArgVrcs :: ArgVrcs } | KindCon { -- Type constructor at the kind level @@ -143,6 +147,10 @@ data TyCon tyConUnique :: Unique, tyConName :: Name } + +type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] + -- *NB*: this is tyvar variance info, *not* + -- termvar usage info. \end{code} %************************************************************************ @@ -182,7 +190,7 @@ mkFunTyCon name kind tyConArity = 2 } -mkAlgTyCon name kind tyvars theta cons derivs maybe_clas flavour rec +mkAlgTyCon name kind tyvars theta argvrcs cons derivs maybe_clas flavour rec = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -190,6 +198,7 @@ mkAlgTyCon name kind tyvars theta cons derivs maybe_clas flavour rec tyConArity = length tyvars, tyConTyVars = tyvars, dataTyConTheta = theta, + dataTyConArgVrcs = argvrcs, dataCons = cons, dataTyConDerivings = derivs, dataTyConClass_maybe = maybe_clas, @@ -208,23 +217,25 @@ mkTupleTyCon name kind arity tyvars con boxed dataCon = con } -mkPrimTyCon name kind arity rep +mkPrimTyCon name kind arity arg_vrcs rep = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, + primTyConArgVrcs = arg_vrcs, primTyConRep = rep } -mkSynTyCon name kind arity tyvars rhs +mkSynTyCon name kind arity tyvars rhs argvrcs = SynTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, tyConTyVars = tyvars, - synTyConDefn = rhs + synTyConDefn = rhs, + synTyConArgVrcs = argvrcs } setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name} @@ -315,6 +326,21 @@ tyConTheta (AlgTyCon {dataTyConTheta = theta}) = theta -- should ask about anything else \end{code} +@tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for +each tyvar, if available. See @calcAlgTyConArgVrcs@ for how this is +actually computed (in another file). + +\begin{code} +tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs + +tyConArgVrcs_maybe (FunTyCon {} ) = Just [(False,True),(True,False)] +tyConArgVrcs_maybe (AlgTyCon {dataTyConArgVrcs = oi}) = Just oi +tyConArgVrcs_maybe (PrimTyCon {primTyConArgVrcs = oi}) = Just oi +tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity }) = Just (replicate arity (True,False)) +tyConArgVrcs_maybe (SynTyCon {synTyConArgVrcs = oi }) = Just oi +tyConArgVrcs_maybe _ = Nothing +\end{code} + \begin{code} getSynTyConDefn :: TyCon -> ([TyVar], Type) getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,ty) @@ -326,7 +352,9 @@ maybeTyConSingleCon (AlgTyCon {dataCons = [c]}) = Just c maybeTyConSingleCon (AlgTyCon {}) = Nothing maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con maybeTyConSingleCon (PrimTyCon {}) = Nothing -maybeTyConSingleCon other = panic (showSDoc (ppr other)) +maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty +maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ + ppr tc \end{code} \begin{code}