Commit 5c18c653 authored by keithw's avatar keithw
Browse files

[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.
parent 39b581ba
......@@ -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}
%************************************************************************
......
......@@ -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(":")
......
......@@ -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}
......@@ -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
......
......@@ -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])],