DataCon DataCon dataConType ;
_declarations_
1 data DataCon ;
-1 dataConType _:_ DataCon -> Type.Type ;;
+1 dataConType _:_ DataCon -> TypeRep.Type ;;
__interface DataCon 1 0 where
__export DataCon DataCon dataConType ;
1 data DataCon ;
-1 dataConType :: DataCon -> Type.Type ;
+1 dataConType :: DataCon -> TypeRep.Type ;
#include "HsVersions.h"
-import {-# SOURCE #-} Type( Type ) -- FieldLabel is compiled very early
+import {-# SOURCE #-} TypeRep( Type ) -- FieldLabel is compiled very early
import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique )
import Outputable
= ()
instance Outputable InlinePragInfo where
+ -- only used for debugging; never parsed. KSW 1999-07
ppr NoInlinePragInfo = empty
ppr IMustBeINLINEd = ptext SLIT("__UU")
ppr IMustNotBeINLINEd = ptext SLIT("__Unot")
\begin{code}
ppUpdateInfo NoUpdateInfo = empty
ppUpdateInfo (SomeUpdateInfo []) = empty
-ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("__U ")) (hcat (map int spec))
+ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("__UA ")) (hcat (map int spec))
+ -- was "__U "; changed to avoid conflict with unfoldings. KSW 1999-07.
\end{code}
%************************************************************************
[data_id] = mkTemplateLocals [data_ty]
sel_rhs = mkLams tyvars $ Lam data_id $
- Note (Coerce rhs_ty data_ty) (Var data_id)
+ Note (Coerce (unUsgTy rhs_ty) (unUsgTy data_ty)) (Var data_id)
\end{code}
module OccName (
-- The NameSpace type; abstact
NameSpace, tcName, clsName, tcClsName, dataName, varName, tvName,
- nameSpaceString,
+ uvName, nameSpaceString,
-- The OccName type
OccName, -- Abstract, instance of Outputable
mkDictOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
- isTvOcc, isDataOcc, isDataSymOcc, isSymOcc,
+ isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc,
occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
setOccNameSpace,
data NameSpace = VarName -- Variables
| DataName -- Data constructors
| TvName -- Type variables
+ | UvName -- Usage variables
| TcClsName -- Type constructors and classes; Haskell has them
-- in the same name space for now.
deriving( Eq, Ord )
dataName = DataName
tvName = TvName
+uvName = UvName
varName = VarName
nameSpaceString DataName = "Data constructor"
nameSpaceString VarName = "Variable"
nameSpaceString TvName = "Type variable"
+nameSpaceString UvName = "Usage variable"
nameSpaceString TcClsName = "Type constructor or class"
\end{code}
\end{code}
\begin{code}
-isTvOcc, isDataSymOcc, isSymOcc :: OccName -> Bool
+isTvOcc, isDataSymOcc, isSymOcc, isUvOcc :: OccName -> Bool
isTvOcc (OccName TvName _) = True
isTvOcc other = False
+isUvOcc (OccName UvName _) = True
+isUvOcc other = False
+
-- Data constructor operator (starts with ':', or '[]')
-- Pretty inefficient!
isDataSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
-- UVars
UVar,
isUVar,
- mkUVar,
+ mkUVar, mkNamedUVar,
-- Ids
Id, DictId,
#include "HsVersions.h"
-import {-# SOURCE #-} Type( Type, Kind )
+import {-# SOURCE #-} TypeRep( Type, Kind )
import {-# SOURCE #-} IdInfo( IdInfo, seqIdInfo )
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
mkUVar unique = Var { varName = mkSysLocalName unique SLIT("u"),
realUnique = getKey unique,
varDetails = UVar }
+
+mkNamedUVar :: Name -> UVar
+mkNamedUVar name = Var { varName = name
+ , realUnique = getKey (nameUnique name)
+ , varDetails = UVar
+#ifdef DEBUG
+ , varType = pprPanic "looking at Type of a uvar" (ppr name)
+ , varInfo = pprPanic "looking at IdInfo of a uvar" (ppr name)
+#endif
+ }
\end{code}
\begin{code}
#include "HsVersions.h"
import {-# SOURCE #-} CoreSyn( CoreExpr )
-import {-# SOURCE #-} Type( Type )
+import {-# SOURCE #-} TypeRep( Type )
import OccName ( TidyOccEnv, emptyTidyOccEnv )
import Var ( Var, Id, IdOrTyVar )
\begin{code}
module VarSet (
- VarSet, IdSet, TyVarSet, IdOrTyVarSet,
+ VarSet, IdSet, TyVarSet, IdOrTyVarSet, UVarSet,
emptyVarSet, unitVarSet, mkVarSet,
extendVarSet,
elemVarSet, varSetElems, subVarSet,
#include "HsVersions.h"
import CmdLineOpts ( opt_PprStyle_Debug )
-import Var ( Var, Id, TyVar, IdOrTyVar, setVarUnique )
+import Var ( Var, Id, TyVar, UVar, IdOrTyVar, setVarUnique )
import Unique ( Unique, Uniquable(..), incrUnique, deriveUnique )
import UniqSet
import UniqFM ( delFromUFM_Directly )
type IdSet = UniqSet Id
type TyVarSet = UniqSet TyVar
type IdOrTyVarSet = UniqSet IdOrTyVar
+type UVarSet = UniqSet UVar
emptyVarSet :: VarSet
intersectVarSet :: VarSet -> VarSet -> VarSet
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
import Type ( Type, Kind, tyVarsOfType,
- splitFunTy_maybe, mkPiType, mkTyVarTy,
+ splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
splitForAllTy_maybe, splitTyConApp_maybe,
isUnLiftedType, typeKind,
splitAlgTyConApp_maybe,
= lintCoreExpr expr `thenL` \ expr_ty ->
lintTy to_ty `seqL`
lintTy from_ty `seqL`
- checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
+ checkTys from_ty (unUsgTy expr_ty) (mkCoerceErr from_ty expr_ty) `seqL`
returnL to_ty
lintCoreExpr (Note other_note expr)
coreExprType (Var var) = idType var
coreExprType (Let _ body) = coreExprType body
coreExprType (Case _ _ alts) = coreAltsType alts
-coreExprType (Note (Coerce ty _) e) = ty
+coreExprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
coreExprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (coreExprType e))
coreExprType (Note other_note e) = coreExprType e
-coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args
+coreExprType e@(Con con args) = ASSERT2( all (\ a -> case a of { Type ty -> isNotUsgTy ty; _ -> True }) args, ppr e)
+ applyTypeToArgs e (conType con) args
coreExprType (Lam binder expr)
| isId binder = (case (lbvarInfo . idInfo) binder of
eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
- eq_note env (Coerce f1 t1) (Coerce f2 t2) = f1==f2 && t1==t2
+ eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
eq_note env InlineCall InlineCall = True
eq_note env other1 other2 = False
\end{code}
_exports_ Subst Subst mkTyVarSubst substTy ;
_declarations_
1 data Subst;
-1 mkTyVarSubst _:_ [Var.TyVar] -> [Type.Type] -> Subst ;;
-1 substTy _:_ Subst -> Type.Type -> Type.Type ;;
+1 mkTyVarSubst _:_ [Var.TyVar] -> [TypeRep.Type] -> Subst ;;
+1 substTy _:_ Subst -> TypeRep.Type -> TypeRep.Type ;;
__interface Subst 1 0 where
__export Subst Subst mkTyVarSubst substTy ;
1 data Subst;
-1 mkTyVarSubst :: [Var.TyVar] -> [Type.Type] -> Subst ;
-1 substTy :: Subst -> Type.Type -> Type.Type ;
+1 mkTyVarSubst :: [Var.TyVar] -> [TypeRep.Type] -> Subst ;
+1 substTy :: Subst -> TypeRep.Type -> TypeRep.Type ;
emptyCoreRules, isEmptyCoreRules, seqRules
)
import CoreFVs ( exprFreeVars )
-import Type ( Type(..), ThetaType, TyNote(..),
+import TypeRep ( Type(..), TyNote(..),
+ ) -- friend
+import Type ( ThetaType,
tyVarsOfType, tyVarsOfTypes, mkAppTy
)
import VarSet
go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
- go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
+ go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
+ go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
Nothing -> ty
import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding )
import IdInfo ( CprInfo(..) )
import VarEnv
-import Type ( Type(..), splitFunTys, splitForAllTys, splitNewType_maybe )
+import Type ( Type, splitFunTys, splitForAllTys, splitNewType_maybe )
import TyCon ( isProductTyCon, isNewTyCon, isUnLiftedTyCon )
import DataCon ( dataConTyCon, splitProductType_maybe )
import Const ( Con(DataCon), isWHNFCon )
(argtys, resty) = splitFunTysIgnoringNewTypes funty
-- (argtys, resty) = splitFunTys funty
--- Taken from splitFunTys in Type.lhs. Modified to keep searching through newtypes
+-- splitFunTys, modified to keep searching through newtypes.
-- Should move to Type.lhs if it is doing something sensible.
+
splitFunTysIgnoringNewTypes :: Type -> ([Type], Type)
splitFunTysIgnoringNewTypes ty = split ty
where
where
(args, res) = splitFunTys ty
+
-- Is this the constructor for a product type (i.e. algebraic, single constructor)
-- NB: isProductTyCon replies 'False' for unboxed tuples
isConProdType :: Con -> Bool
NamedThing(..), Provenance(..), ExportFlag(..)
)
import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME, realWorldPrimId )
-import Type ( splitAlgTyConApp_maybe,
+import Type ( splitAlgTyConApp_maybe, unUsgTy,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
mkTyVarTy, mkFunTy, splitAppTy
let ccall_io_adj =
mkLams [stbl_value] $
bindNonRec x_ccall_adj ccall_adj $
- Note (Coerce (mkTyConApp ioTyCon [res_ty]) ccall_adj_ty)
+ Note (Coerce (mkTyConApp ioTyCon [res_ty]) (unUsgTy ccall_adj_ty))
(Var x_ccall_adj)
in
newSysLocalDs (coreExprType ccall_io_adj) `thenDs` \ x_ccall_io_adj ->
(con_id, arg_ids, match_result) = head match_alts
arg_id = head arg_ids
coercion_bind = NonRec arg_id
- (Note (Coerce (idType arg_id) scrut_ty) (Var var))
+ (Note (Coerce (unUsgTy (idType arg_id)) (unUsgTy scrut_ty)) (Var var))
newtype_sanity = null (tail match_alts) && null (tail arg_ids)
-- Stuff for data types
%
\section[HsTypes]{Abstract syntax: user-defined types}
-If compiled without \tr{#define COMPILING_GHC}, you get
-(part of) a Haskell-abstract-syntax library. With it,
-you get part of GHC.
-
\begin{code}
module HsTypes (
- HsType(..), HsTyVar(..),
+ HsType(..), MonoUsageAnn(..), HsTyVar(..),
Context, ClassAssertion
- , mkHsForAllTy
+ , mkHsForAllTy, mkHsUsForAllTy
, getTyVarName, replaceTyVarName
, pprParendHsType
, pprForAll, pprContext, pprClassAssertion
| MonoDictTy name -- Class
[HsType name]
- | MonoUsgTy UsageAnn
+ | MonoUsgTy (MonoUsageAnn name)
+ (HsType name)
+
+ | MonoUsgForAllTy name
(HsType name)
+data MonoUsageAnn name
+ = MonoUsOnce
+ | MonoUsMany
+ | MonoUsVar name
+
+
mkHsForAllTy [] [] ty = ty
mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty
+mkHsUsForAllTy uvs ty = foldr (\ uv ty -> MonoUsgForAllTy uv ty)
+ ty uvs
+
data HsTyVar name
= UserTyVar name
| IfaceTyVar name Kind
ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
= ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
+ppr_mono_ty ctxt_prec ty@(MonoUsgForAllTy _ _)
+ = maybeParen (ctxt_prec >= pREC_FUN) $
+ sep [ ptext SLIT("__fuall") <+> brackets pp_uvars <+> ptext SLIT("=>"),
+ ppr_mono_ty pREC_TOP sigma
+ ]
+ where
+ (uvars,sigma) = split [] ty
+ pp_uvars = interppSP uvars
+
+ split uvs (MonoUsgForAllTy uv ty') = split (uv:uvs) ty'
+ split uvs ty' = (reverse uvs,ty')
+
ppr_mono_ty ctxt_prec (MonoUsgTy u ty)
= maybeParen (ctxt_prec >= pREC_CON) $
- ppr u <+> ppr_mono_ty pREC_CON ty
+ ptext SLIT("__u") <+> pp_ua <+> ppr_mono_ty pREC_CON ty
+ where
+ pp_ua = case u of
+ MonoUsOnce -> ptext SLIT("-")
+ MonoUsMany -> ptext SLIT("!")
+ MonoUsVar uv -> ppr uv
\end{code}
= cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
cmpHsType cmp (MonoUsgTy u1 ty1) (MonoUsgTy u2 ty2)
- = cmpUsg u1 u2 `thenCmp` cmpHsType cmp ty1 ty2
+ = cmpUsg cmp u1 u2 `thenCmp` cmpHsType cmp ty1 ty2
cmpHsType cmp ty1 ty2 -- tags must be different
= let tag1 = tag ty1
tag (MonoListTy ty1) = ILIT(3)
tag (MonoTyApp tc1 tys1) = ILIT(4)
tag (MonoFunTy a1 b1) = ILIT(5)
- tag (MonoDictTy c1 tys1) = ILIT(7)
- tag (MonoUsgTy c1 tys1) = ILIT(6)
- tag (HsForAllTy _ _ _) = ILIT(8)
+ tag (MonoDictTy c1 tys1) = ILIT(6)
+ tag (MonoUsgTy c1 ty1) = ILIT(7)
+ tag (MonoUsgForAllTy uv1 ty1) = ILIT(8)
+ tag (HsForAllTy _ _ _) = ILIT(9)
-------------------
cmpContext cmp a b
cmp_ctxt (c1, tys1) (c2, tys2)
= cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
--- Should be in Type, perhaps
-cmpUsg UsOnce UsOnce = EQ
-cmpUsg UsOnce UsMany = LT
-cmpUsg UsMany UsOnce = GT
-cmpUsg UsMany UsMany = EQ
-cmpUsg u1 u2 = pprPanic "cmpUsg:" $
- ppr u1 <+> ppr u2
+cmpUsg cmp MonoUsOnce MonoUsOnce = EQ
+cmpUsg cmp MonoUsMany MonoUsMany = EQ
+cmpUsg cmp (MonoUsVar u1) (MonoUsVar u2) = cmp u1 u2
+
+cmpUsg cmp ua1 ua2 -- tags must be different
+ = let tag1 = tag ua1
+ tag2 = tag ua2
+ in
+ if tag1 _LT_ tag2 then LT else GT
+ where
+ tag MonoUsOnce = (ILIT(1) :: FAST_INT)
+ tag MonoUsMany = ILIT(2)
+ tag (MonoUsVar _) = ILIT(3)
-- Should be in Maybes, I guess
cmpMaybe cmp Nothing Nothing = EQ
\begin{code}
-- debugging opts
-opt_D_dump_all = lookUp SLIT("-ddump-all")
-opt_D_dump_most = opt_D_dump_all || lookUp SLIT("-ddump-most")
+opt_D_dump_all {- do not -} = lookUp SLIT("-ddump-all")
+opt_D_dump_most {- export -} = opt_D_dump_all || lookUp SLIT("-ddump-most")
opt_D_dump_absC = opt_D_dump_all || lookUp SLIT("-ddump-absC")
opt_D_dump_asm = opt_D_dump_all || lookUp SLIT("-ddump-asm")
opt_D_dump_ds = opt_D_dump_most || lookUp SLIT("-ddump-ds")
opt_D_dump_flatC = opt_D_dump_all || lookUp SLIT("-ddump-flatC")
opt_D_dump_foreign = opt_D_dump_most || lookUp SLIT("-ddump-foreign-stubs")
-opt_D_dump_inlinings = opt_D_dump_most || lookUp SLIT("-ddump-inlinings")
+opt_D_dump_inlinings = opt_D_dump_all || lookUp SLIT("-ddump-inlinings")
opt_D_dump_occur_anal = opt_D_dump_most || lookUp SLIT("-ddump-occur-anal")
opt_D_dump_parsed = opt_D_dump_most || lookUp SLIT("-ddump-parsed")
opt_D_dump_realC = opt_D_dump_all || lookUp SLIT("-ddump-realC")
IAmALoopBreaker -> True
other -> False
- unfold_pretty | show_unfold = ptext SLIT("__u") <+> pprIfaceUnfolding rhs
+ unfold_pretty | show_unfold = ptext SLIT("__U") <+> pprIfaceUnfolding rhs
| otherwise = empty
show_unfold = not has_worker && -- Not unnecessary
| ITlit_lit
| ITstring_lit
| ITtypeapp
- | ITonce
- | ITmany
+ | ITusage
+ | ITfuall
| ITarity
| ITspecialise
| ITnocaf
| ITdot
| ITbiglam -- GHC-extension symbols
+ | IThash
| ITocurly -- special symbols
| ITccurly
("__litlit", ITlit_lit),
("__string", ITstring_lit),
("__a", ITtypeapp),
- ("__o", ITonce),
- ("__m", ITmany),
+ ("__u", ITusage),
+ ("__fuall", ITfuall),
("__A", ITarity),
("__P", ITspecialise),
("__C", ITnocaf),
("__R", ITrules),
- ("__u", ITunfold NoInlinePragInfo),
+ ("__U", ITunfold NoInlinePragInfo),
("__ccall", ITccall (False, False, False)),
("__ccall_GC", ITccall (False, False, True)),
extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
+extract_ty (MonoUsgForAllTy uv ty) acc = extract_ty ty acc
extract_ty (MonoTyVar tv) acc = tv : acc
extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
extract_ty (HsForAllTy (Just tvs) ctxt ty)
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
-import HsTypes ( mkHsForAllTy )
+import HsTypes ( mkHsForAllTy, mkHsUsForAllTy )
import HsCore
import Const ( Literal(..), mkMachInt_safe )
import BasicTypes ( Fixity(..), FixityDirection(..),
import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual )
import Name ( OccName, Provenance )
import OccName ( mkSysOccFS,
- tcName, varName, dataName, clsName, tvName,
+ tcName, varName, dataName, clsName, tvName, uvName,
EncodedFS
)
import Module ( ModuleName, mkSysModuleFS )
'__scc' { ITscc }
'__sccC' { ITsccAllCafs }
- '__o' { ITonce }
- '__m' { ITmany }
+ '__u' { ITusage }
+ '__fuall' { ITfuall }
'__A' { ITarity }
'__P' { ITspecialise }
--------------------------------------------------------------------------
type :: { RdrNameHsType }
-type : '__forall' forall context '=>' type
+type : '__fuall' fuall '=>' type { mkHsUsForAllTy $2 $4 }
+ | '__forall' forall context '=>' type
{ mkHsForAllTy $2 $3 $5 }
| btype '->' type { MonoFunTy $1 $3 }
| btype { $1 }
+fuall :: { [RdrName] }
+fuall : '[' uv_bndrs ']' { $2 }
+
forall :: { [HsTyVar RdrName] }
forall : '[' tv_bndrs ']' { $2 }
btype :: { RdrNameHsType }
btype : atype { $1 }
| btype atype { MonoTyApp $1 $2 }
- | '__o' atype { MonoUsgTy UsOnce $2 }
- | '__m' atype { MonoUsgTy UsMany $2 }
+ | '__u' usage atype { MonoUsgTy $2 $3 }
+
+usage :: { MonoUsageAnn RdrName }
+usage : '-' { MonoUsOnce }
+ | '!' { MonoUsMany }
+ | uv_name { MonoUsVar $1 }
atype :: { RdrNameHsType }
atype : qtc_name { MonoTyVar $1 }
| qdata_fs { mkSysQual clsName $1 }
---------------------------------------------------
+uv_name :: { RdrName }
+ : VARID { mkSysUnqual uvName $1 }
+
+uv_bndr :: { RdrName }
+ : uv_name { $1 }
+
+uv_bndrs :: { [RdrName] }
+ : { [] }
+ | uv_bndr uv_bndrs { $1 : $2 }
+
+---------------------------------------------------
tv_name :: { RdrName }
: VARID { mkSysUnqual tvName $1 }
| VARSYM { mkSysUnqual tvName $1 {- Allow t2 as a tyvar -} }
returnRn (thing, delListFromNameSet fvs names)
-------------------------------------
+bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
+bindUVarRn = bindLocalRn
+
+-------------------------------------
extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
-- This tiresome function is used only in rnDecl on InstDecl
extendTyVarEnvFVRn tyvars enclosed_scope
`unionNameSets` extractHsTyNames_s tys
get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2
get (MonoDictTy cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys
+ get (MonoUsgForAllTy uv ty) = get ty
get (MonoUsgTy u ty) = get ty
get (MonoTyVar tv) = unitNameSet tv
get (HsForAllTy (Just tvs)
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
lookupImplicitOccRn,
- bindLocalsRn, bindLocalRn, bindLocalsFVRn,
+ bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
bindCoreLocalFVRn, bindCoreLocalsFVRn,
checkDupOrQualNames, checkDupNames,
rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
+rnHsType doc (MonoUsgForAllTy uv_rdr ty)
+ = bindUVarRn doc uv_rdr $ \ uv_name ->
+ rnHsType doc ty `thenRn` \ (ty', fvs) ->
+ returnRn (MonoUsgForAllTy uv_name ty',
+ fvs )
+
rnHsType doc (MonoUsgTy usg ty)
- = rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (MonoUsgTy usg ty', fvs)
+ = newUsg usg `thenRn` \ (usg', usg_fvs) ->
+ rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
+ returnRn (MonoUsgTy usg' ty',
+ usg_fvs `plusFV` ty_fvs)
+ where
+ newUsg usg = case usg of
+ MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs)
+ MonoUsMany -> returnRn (MonoUsMany, emptyFVs)
+ MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
+ returnRn (MonoUsVar uv_name, emptyFVs)
rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
\end{code}
import UniqSupply -- all of it, really
import Util ( lengthExceeds )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
-import CmdLineOpts ( opt_D_verbose_stg2stg )
+import CmdLineOpts ( opt_D_verbose_stg2stg, opt_UsageSPOn )
import UniqSet ( emptyUniqSet )
import Maybes
import Outputable
mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
isOnceTy :: Type -> Bool
-isOnceTy ty = case tyUsg ty of
- UsOnce -> True
- UsMany -> False
+isOnceTy ty
+ =
+#ifdef USMANY
+ opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
+#endif
+ case tyUsg ty of
+ UsOnce -> True
+ UsMany -> False
+ UsVar uv -> pprPanic "CoreToStg: unexpected uvar annot:" (ppr uv)
bdrDem :: Id -> RhsDemand
bdrDem id = mkDem (getIdDemandInfo id) (isOnceTy (idType id))
getUniqueUs `thenUs` \id_uniq ->
let id_id = mk_ww_local id_uniq ty
(args, tup, exp) = unzip3 sub_builds
- con_app = mkConApp data_con (map Var args)
+ -- not used: con_app = mkConApp data_con (map Var args)
new_tup = concat tup
new_exp_case = \var -> Case (Var id_id) (mkWildId ty)
[(DataCon data_con, args,
initEnv, getEnvTyCons, getEnvClasses, getAllEnvTyCons,
+ tcExtendUVarEnv, tcLookupUVar,
+
tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
tcLookupTy,
import Id ( mkUserLocal, isDataConId_maybe )
import MkId ( mkSpecPragmaId )
import Var ( TyVar, Id, setVarName,
- idType, lazySetIdInfo, idInfo, tyVarKind
+ idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
)
import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
tcInstTyVars, zonkTcTyVars,
\begin{code}
data TcEnv = TcEnv
+ UsageEnv
TypeEnv
ValueEnv
(TcTyVarSet, -- The in-scope TyVars
type NameEnv val = UniqFM val -- Keyed by Names
+type UsageEnv = NameEnv UVar
type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing)
type ValueEnv = NameEnv Id
initEnv :: TcRef TcTyVarSet -> TcEnv
-initEnv mut = TcEnv emptyUFM emptyUFM (emptyVarSet, mut)
+initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM (emptyVarSet, mut)
-getEnvTyCons (TcEnv te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
-getEnvClasses (TcEnv te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
-getAllEnvTyCons (TcEnv te _ _) = catMaybes (map gettc (eltsUFM te))
+getEnvTyCons (TcEnv _ te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
+getEnvClasses (TcEnv _ te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
+getAllEnvTyCons (TcEnv _ te _ _) = catMaybes (map gettc (eltsUFM te))
where
gettc (_,_, ATyCon tc) = Just tc
gettc (_,_, AClass cl) = Just (classTyCon cl)
gettc _ = Nothing
\end{code}
+The UsageEnv
+~~~~~~~~~~~~
+
+Extending the usage environment.
+
+\begin{code}
+tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
+tcExtendUVarEnv uv_name uv scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
+ tcSetEnv (TcEnv (addToUFM ue uv_name uv) te ve gtvs) scope
+\end{code}
+
+Looking up in the environments.
+
+\begin{code}
+tcLookupUVar :: Name -> NF_TcM s UVar
+tcLookupUVar uv_name
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
+ case lookupUFM ue uv_name of
+ Just uv -> returnNF_Tc uv
+ Nothing -> failWithTc (uvNameOutOfScope uv_name)
+\end{code}
+
+
The TypeEnv
~~~~~~~~~~~~
\begin{code}
tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
tcExtendTyVarEnv tyvars scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) ->
let
extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), Nothing, ATyVar tv))
| tv <- tyvars
-- class and instance decls, when we mustn't generalise the class tyvars
-- when typechecking the methods.
tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
- tcSetEnv (TcEnv te' ve (in_scope_tvs', gtvs')) scope
+ tcSetEnv (TcEnv ue te' ve (in_scope_tvs', gtvs')) scope
-- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
-- the signature tyvars contain the original names
tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
let
te' = addListToUFM te stuff
in
- tcSetEnv (TcEnv te' ve gtvs) thing_inside
+ tcSetEnv (TcEnv ue te' ve gtvs) thing_inside
where
stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), Nothing, ATyVar inst_tv))
| (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
]
tcExtendGlobalTyVars extra_global_tvs scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope,gtvs)) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope,gtvs)) ->
tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
- tcSetEnv (TcEnv te ve (in_scope,gtvs')) scope
+ tcSetEnv (TcEnv ue te ve (in_scope,gtvs')) scope
tc_extend_gtvs gtvs extra_global_tvs
= tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
\begin{code}
tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
tcGetGlobalTyVars
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (_,gtvs)) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (_,gtvs)) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
let
tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
tcGetInScopeTyVars
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) ->
returnNF_Tc (varSetElems in_scope_tvs)
\end{code}
tcExtendTypeEnv bindings scope
= ASSERT( null [tv | (_, (_,_,ATyVar tv)) <- bindings] )
-- Not for tyvars; use tcExtendTyVarEnv
- tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
let
te' = addListToUFM te bindings
in
- tcSetEnv (TcEnv te' ve gtvs) scope
+ tcSetEnv (TcEnv ue te' ve gtvs) scope
\end{code}
\begin{code}
tcLookupTy :: Name -> NF_TcM s (TcKind, Maybe Arity, TcTyThing)
tcLookupTy name
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
case lookupUFM te name of {
Just thing -> returnNF_Tc thing ;
Nothing ->
tcLookupClassByKey :: Unique -> NF_TcM s Class
tcLookupClassByKey key
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
case lookupUFM_Directly te key of
Just (_, _, AClass cl) -> returnNF_Tc cl
other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
tcLookupTyConByKey key
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
case lookupUFM_Directly te key of
Just (_, _, ATyCon tc) -> returnNF_Tc tc
other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
\begin{code}
tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
tcExtendGlobalValEnv ids scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
let
ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
in
- tcSetEnv (TcEnv te ve' gtvs) scope
+ tcSetEnv (TcEnv ue te ve' gtvs) scope
tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
tcExtendLocalValEnv names_w_ids scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs,gtvs)) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs,gtvs)) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
let
ve' = addListToUFM ve names_w_ids
extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
in
tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
- tcSetEnv (TcEnv te ve' (in_scope_tvs,gtvs')) scope
+ tcSetEnv (TcEnv ue te ve' (in_scope_tvs,gtvs')) scope
\end{code}
tcLookupValue name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc id
- Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
returnNF_Tc (lookupWithDefaultUFM ve def name)
where
def = pprPanic "tcLookupValue:" (ppr name)
tcLookupValueMaybe name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc (Just id)
- Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
returnNF_Tc (lookupUFM ve name)
tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
tcLookupValueByKey key
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
returnNF_Tc (explicitLookupValueByKey ve key)
tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
tcLookupValueByKeyMaybe key
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
returnNF_Tc (lookupUFM_Directly ve key)
tcGetValueEnv :: NF_TcM s ValueEnv
tcGetValueEnv
- = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
returnNF_Tc ve
tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
tcSetValueEnv ve scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv te _ gtvs) ->
- tcSetEnv (TcEnv te ve gtvs) scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ gtvs) ->
+ tcSetEnv (TcEnv ue te ve gtvs) scope
-- Non-monadic version, environment given explicitly
explicitLookupValueByKey :: ValueEnv -> Unique -> Id
badPrimOp op
= quotes (ppr op) <+> ptext SLIT("is not a primop")
+uvNameOutOfScope name
+ = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")
+
tyNameOutOfScope name
= quotes (ppr name) <+> ptext SLIT("is not in scope")
\end{code}
)
import IdInfo
import DataCon ( dataConSig, dataConArgTys )
-import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp )
+import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, unUsgTy )
import Var ( IdOrTyVar, mkTyVar, tyVarKind )
import VarEnv
import Name ( Name, NamedThing(..) )
mapTc tcCoreExpr args `thenTc` \ args' ->
let
-- Put the missing type arguments back in
- con_args = map (Type . coreExprType) args' ++ args'
+ con_args = map (Type . unUsgTy . coreExprType) args' ++ args'
in
returnTc (Con con con_args)
= tcCoreExpr expr `thenTc` \ expr' ->
case note of
UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' ->
- returnTc (Note (Coerce to_ty' (coreExprType expr')) expr')
+ returnTc (Note (Coerce (unUsgTy to_ty')
+ (unUsgTy (coreExprType expr'))) expr')
UfInlineCall -> returnTc (Note InlineCall expr')
UfInlineMe -> returnTc (Note InlineMe expr')
UfSCC cc -> returnTc (Note (SCC cc) expr')
#include "HsVersions.h"
-import HsSyn ( HsType(..), HsTyVar(..), Sig(..), pprClassAssertion, pprParendHsType )
+import HsSyn ( HsType(..), HsTyVar(..), MonoUsageAnn(..),
+ Sig(..), pprClassAssertion, pprParendHsType )
import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig )
import TcHsSyn ( TcId )
import TcMonad
import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars,
+ tcExtendUVarEnv, tcLookupUVar,
tcGetGlobalTyVars, TcTyThing(..)
)
import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
)
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
import TcUnify ( unifyKind, unifyKinds, unifyTypeKind )
-import Type ( Type, ThetaType,
- mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy, zipFunTys,
+import Type ( Type, ThetaType, UsageAnn(..),
+ mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,
+ mkUsForAllTy, zipFunTys,
mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy,
boxedTypeKind, unboxedTypeKind, tyVarsOfType,
mkArrowKinds, getTyVar_maybe, getTyVar,
)
import Subst ( mkTopTyVarSubst, substTy )
import Id ( mkVanillaId, idName, idType, idFreeTyVars )
-import Var ( TyVar, mkTyVar )
+import Var ( TyVar, mkTyVar, mkNamedUVar )
import VarEnv
import VarSet
import Bag ( bagToList )
returnTc (boxedTypeKind, mkDictTy clas arg_tys)
tc_type_kind (MonoUsgTy usg ty)
- = tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
- returnTc (kind, mkUsgTy usg tc_ty)
+ = newUsg usg `thenTc` \ usg' ->
+ tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
+ returnTc (kind, mkUsgTy usg' tc_ty)
+ where
+ newUsg usg = case usg of
+ MonoUsOnce -> returnTc UsOnce
+ MonoUsMany -> returnTc UsMany
+ MonoUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv ->
+ returnTc (UsVar uv)
+
+tc_type_kind (MonoUsgForAllTy uv_name ty)
+ = let
+ uv = mkNamedUVar uv_name
+ in
+ tcExtendUVarEnv uv_name uv $
+ tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
+ returnTc (kind, mkUsForAllTy uv tc_ty)
tc_type_kind (HsForAllTy (Just tv_names) context ty)
= tcExtendTyVarScope tv_names $ \ tyvars ->
import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind, zonkTcKindToKind )
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 Type ( Type(..), TyNote(..), tyVarsOfTypes )
import Var ( TyVar, tyVarKind )
import FiniteMap
import Bag
unionManyUniqSets, uniqSetToList )
import ErrUtils ( Message )
import SrcLoc ( SrcLoc )
-import TyCon ( TyCon )
+import TyCon ( TyCon, ArgVrcs )
+import Variance ( calcTyConArgVrcs )
import Unique ( Unique, Uniquable(..) )
import UniqFM ( listToUFM, lookupUFM )
\end{code}
= set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys
get_ty (MonoUsgTy _ ty)
= get_ty ty
+get_ty (MonoUsgForAllTy _ ty)
+ = get_ty ty
get_ty (HsForAllTy _ ctxt mty)
= get_ctxt ctxt `unionUniqSets` get_ty mty
get_ty (MonoDictTy name _)
\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}
-- friends:
import PprType ( pprType )
-import Type ( Type(..), Kind, ThetaType, TyNote(..),
+import TypeRep ( Type(..), Kind, TyNote(..),
+ typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
+ ) -- friend
+import Type ( ThetaType,
mkAppTy, mkTyConApp,
splitDictTy_maybe, splitForAllTys, isNotUsgTy,
isTyVarTy, mkTyVarTy, mkTyVarTys,
- typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
)
import Subst ( Subst, mkTopTyVarSubst, substTy )
import TyCon ( tyConKind, mkPrimTyCon )
go (NoteTy (UsgNote usg) ty2) = go ty2 `thenNF_Tc` \ ty2' ->
returnNF_Tc (NoteTy (UsgNote usg) ty2')
+ go (NoteTy (UsgForAll uv) ty2)= go ty2 `thenNF_Tc` \ ty2' ->
+ returnNF_Tc (NoteTy (UsgForAll uv) ty2')
+
go (FunTy arg res) = go arg `thenNF_Tc` \ arg' ->
go res `thenNF_Tc` \ res' ->
returnNF_Tc (FunTy arg' res')
-- friends:
import TcMonad
-import Type ( Type(..), tyVarsOfType, funTyCon,
+import TypeRep ( Type(..), funTyCon,
+ Kind, boxedTypeKind, typeCon, anyBoxCon, anyBoxKind,
+ ) -- friend
+import Type ( tyVarsOfType,
mkFunTy, splitFunTy_maybe, splitTyConApp_maybe,
isNotUsgTy,
- Kind, boxedTypeKind, typeCon, anyBoxCon, anyBoxKind,
splitAppTy_maybe,
tidyOpenType, tidyOpenTypes, tidyTyVar
)
#include "HsVersions.h"
import {-# SOURCE #-} TyCon ( TyCon )
-import {-# SOURCE #-} Type ( Type )
+import {-# SOURCE #-} TypeRep ( Type )
import {-# SOURCE #-} InstEnv ( InstEnv )
import Var ( Id, TyVar )
_exports_
PprType pprType;
_declarations_
-1 pprType _:_ Type.Type -> Outputable.SDoc ;;
+1 pprType _:_ TypeRep.Type -> Outputable.SDoc ;;
__interface PprType 1 0 where
__export PprType pprType ;
-1 pprType :: Type.Type -> Outputable.SDoc ;
+1 pprType :: TypeRep.Type -> Outputable.SDoc ;
-- friends:
-- (PprType can see all the representations it's trying to print)
-import Type ( Type(..), TyNote(..), Kind, ThetaType, UsageAnn(..),
+import TypeRep ( Type(..), TyNote(..), Kind, UsageAnn(..),
+ boxedTypeKind,
+ ) -- friend
+import Type ( ThetaType,
splitDictTy_maybe,
splitForAllTys, splitSigmaTy, splitRhoTy,
isDictTy, splitTyConApp_maybe, splitFunTy_maybe,
- boxedTypeKind
+ splitUsForAllTys
)
import Var ( TyVar, tyVarKind,
tyVarName, setTyVarName
ppr_ty env ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty
+ppr_ty env ctxt_prec ty@(NoteTy (UsgForAll _) _)
+ = maybeParen ctxt_prec fUN_PREC $
+ sep [ ptext SLIT("__fuall") <+> brackets pp_uvars <+> ptext SLIT("=>"),
+ ppr_ty env tOP_PREC sigma
+ ]
+ where
+ (uvars,sigma) = splitUsForAllTys ty
+ pp_uvars = hsep (map ppr uvars)
+
ppr_ty env ctxt_prec (NoteTy (UsgNote u) ty)
= maybeParen ctxt_prec tYCON_PREC $
- ppr u <+> ppr_ty env tYCON_PREC ty
+ ptext SLIT("__u") <+> ppr u <+> ppr_ty env tYCON_PREC ty
ppr_theta env [] = empty
ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
\begin{code}
instance Outputable UsageAnn where
- ppr UsOnce = ptext SLIT("__o")
- ppr UsMany = ptext SLIT("__m")
- ppr (UsVar uv) = ptext SLIT("__uv") <> ppr uv
+ ppr UsOnce = ptext SLIT("-")
+ ppr UsMany = ptext SLIT("!")
+ ppr (UsVar uv) = ppr uv
\end{code}
+
%************************************************************************
%* *
\subsection[TyVar]{@TyVar@}
#include "HsVersions.h"
-import {-# SOURCE #-} Type ( Type, Kind, SuperKind )
+import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind )
+ -- Should just be Type(Type), but this fails due to bug present up to
+ -- and including 4.02 involving slurping of hi-boot files. Bug is now fixed.
+
import {-# SOURCE #-} DataCon ( DataCon )
import Class ( Class )
+++ /dev/null
-_interface_ Type 1
-_exports_
-Type Type Kind SuperKind ;
-_declarations_
-1 data Type ;
-1 type Kind = Type ;
-1 type SuperKind = Type ;
-
-
+++ /dev/null
-__interface Type 1 0 where
-__export Type Type Kind SuperKind ;
-1 data Type ;
-1 type Kind = Type ;
-1 type SuperKind = Type ;
-
-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
-\section[Type]{Type}
+\section[Type]{Type - public interface}
\begin{code}
module Type (
- Type(..), TyNote(..), UsageAnn(..), -- Representation visible to friends
+ -- re-exports from TypeRep:
+ Type,
Kind, TyVarSubst,
superKind, superBoxity, -- :: SuperKind
funTyCon,
+ -- exports from this module:
+ hasMoreBoxityInfo,
+
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN,
- funResultTy, funArgTy,
- zipFunTys,
+ funResultTy, funArgTy, zipFunTys,
mkTyConApp, mkTyConTy, splitTyConApp_maybe,
splitAlgTyConApp_maybe, splitAlgTyConApp,
mkSynTy, isSynTy, deNoteType, repType, splitNewType_maybe,
- mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
+ UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
+ mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
isForAllTy, applyTy, applyTys, mkPiType,
#include "HsVersions.h"
+-- We import the representation and primitive functions from TypeRep.
+-- Many things are reexported, but not the representation!
+
+import TypeRep
+
+-- Other imports:
+
import {-# SOURCE #-} DataCon( DataCon, dataConType )
import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
-- friends:
-import Var ( Id, TyVar, IdOrTyVar, UVar,
- tyVarKind, tyVarName, isId, idType, setTyVarName, setVarOcc
+import Var ( TyVar, IdOrTyVar, UVar,
+ tyVarKind, tyVarName, setTyVarName, isId, idType,
)
import VarEnv
import VarSet
-import Name ( NamedThing(..), Provenance(..), ExportFlag(..),
- mkWiredInTyConName, mkGlobalName, mkLocalName, mkKindOccFS, tcName,
- tidyOccName, TidyOccEnv
+import Name ( NamedThing(..), mkLocalName, tidyOccName,
)
import NameSet
import Class ( classTyCon, Class )
-import TyCon ( TyCon, KindCon,
- mkFunTyCon, mkKindCon, mkSuperKindCon,
- matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon,
+import TyCon ( TyCon,
+ isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isDataTyCon, isNewTyCon,
isAlgTyCon, isSynTyCon, tyConArity,
- tyConKind, tyConDataCons, getSynTyConDefn,
+ tyConKind, tyConDataCons, getSynTyConDefn,
tyConPrimRep, tyConClass_maybe
)
-- others
-import BasicTypes ( Unused )
-import SrcLoc ( mkBuiltinSrcLoc, noSrcLoc )
-import PrelMods ( pREL_GHC )
+import SrcLoc ( noSrcLoc )
import Maybes ( maybeToBool )
import PrimRep ( PrimRep(..), isFollowableRep )
-import Unique -- quite a few *Keys
-import Util ( thenCmp, mapAccumL, seqList, ($!) )
+import Unique ( Uniquable(..) )
+import Util ( mapAccumL, seqList )
import Outputable
import UniqSet ( sizeUniqSet ) -- Should come via VarSet
\end{code}
-%************************************************************************
-%* *
-\subsection{Type Classifications}
-%* *
-%************************************************************************
-
-A type is
-
- *unboxed* iff its representation is other than a pointer
- Unboxed types cannot instantiate a type variable.
- Unboxed types are always unlifted.
-
- *lifted* A type is lifted iff it has bottom as an element.
- Closures always have lifted types: i.e. any
- let-bound identifier in Core must have a lifted
- type. Operationally, a lifted object is one that
- can be entered.
- (NOTE: previously "pointed").
-
- *algebraic* A type with one or more constructors, whether declared
- with "data" or "newtype".
- An algebraic type is one that can be deconstructed
- with a case expression.
- *NOT* the same as lifted types, because we also
- include unboxed tuples in this classification.
-
- *data* A type declared with "data". Also boxed tuples.
-
- *primitive* iff it is a built-in type that can't be expressed
- in Haskell.
-
-Currently, all primitive types are unlifted, but that's not necessarily
-the case. (E.g. Int could be primitive.)
-
-Some primitive types are unboxed, such as Int#, whereas some are boxed
-but unlifted (such as ByteArray#). The only primitive types that we
-classify as algebraic are the unboxed tuples.
-
-examples of type classifications:
-
-Type primitive boxed lifted algebraic
------------------------------------------------------------------------------
-Int#, Yes No No No
-ByteArray# Yes Yes No No
-(# a, b #) Yes No No Yes
-( a, b ) No Yes Yes Yes
-[a] No Yes Yes Yes
-
-%************************************************************************
-%* *
-\subsection{The data type}
-%* *
-%************************************************************************
-
-
-\begin{code}
-type SuperKind = Type
-type Kind = Type
-
-type TyVarSubst = TyVarEnv Type
-
-data Type
- = TyVarTy TyVar
-
- | AppTy
- Type -- Function is *not* a TyConApp
- Type
-
- | TyConApp -- Application of a TyCon
- TyCon -- *Invariant* saturated appliations of FunTyCon and
- -- synonyms have their own constructors, below.
- [Type] -- Might not be saturated.
-
- | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
- Type
- Type
-
- | NoteTy -- Saturated application of a type synonym
- TyNote
- Type -- The expanded version
-
- | ForAllTy
- TyVar
- Type -- TypeKind
-
-data TyNote
- = SynNote Type -- The unexpanded version of the type synonym; always a TyConApp
- | FTVNote TyVarSet -- The free type variables of the noted expression
- | UsgNote UsageAnn -- The usage annotation at this node
-
-data UsageAnn
- = UsOnce -- Used at most once
- | UsMany -- Used possibly many times (no info; this annotation can be omitted)
- | UsVar UVar -- Annotation is variable (should only happen inside analysis)
-\end{code}
-
%************************************************************************
%* *
-\subsection{Kinds}
+\subsection{Stuff to do with kinds.}
%* *
%************************************************************************
-Kinds
-~~~~~
-k::K = Type bx
- | k -> k
- | kv
-
-kv :: KX is a kind variable
-
-Type :: BX -> KX
-
-bx::BX = Boxed
- | Unboxed
- | AnyBox -- Used *only* for special built-in things
- -- like error :: forall (a::*?). String -> a
- -- Here, the 'a' can be instantiated to a boxed or
- -- unboxed type.
- | bv
-
-bxv :: BX is a boxity variable
-
-sk = KX -- A kind
- | BX -- A boxity
- | sk -> sk -- In ptic (BX -> KX)
-
-\begin{code}
-mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str)
- (LocalDef mkBuiltinSrcLoc NotExported)
- -- mk_kind_name is a bit of a hack
- -- The LocalDef means that we print the name without
- -- a qualifier, which is what we want for these kinds.
- -- It's used for both Kinds and Boxities
-\end{code}
-
-Define KX, BX.
-
-\begin{code}
-superKind :: SuperKind -- KX, the type of all kinds
-superKindName = mk_kind_name kindConKey SLIT("KX")
-superKind = TyConApp (mkSuperKindCon superKindName) []
-
-superBoxity :: SuperKind -- BX, the type of all boxities
-superBoxityName = mk_kind_name boxityConKey SLIT("BX")
-superBoxity = TyConApp (mkSuperKindCon superBoxityName) []
-\end{code}
-
-Define Boxed, Unboxed, AnyBox
-
-\begin{code}
-boxedKind, unboxedKind, anyBoxKind :: Kind -- Of superkind superBoxity
-
-boxedConName = mk_kind_name boxedConKey SLIT("*")
-boxedKind = TyConApp (mkKindCon boxedConName superBoxity) []
-
-unboxedConName = mk_kind_name unboxedConKey SLIT("#")
-unboxedKind = TyConApp (mkKindCon unboxedConName superBoxity) []
-
-anyBoxConName = mk_kind_name anyBoxConKey SLIT("?")
-anyBoxCon = mkKindCon anyBoxConName superBoxity -- A kind of wild card
-anyBoxKind = TyConApp anyBoxCon []
-\end{code}
-
-Define Type
-
-\begin{code}
-typeCon :: KindCon
-typeConName = mk_kind_name typeConKey SLIT("Type")
-typeCon = mkKindCon typeConName (superBoxity `FunTy` superKind)
-\end{code}
-
-Define (Type Boxed), (Type Unboxed), (Type AnyBox)
-
-\begin{code}
-boxedTypeKind, unboxedTypeKind, openTypeKind :: Kind
-boxedTypeKind = TyConApp typeCon [boxedKind]
-unboxedTypeKind = TyConApp typeCon [unboxedKind]
-openTypeKind = TyConApp typeCon [anyBoxKind]
-
-mkArrowKind :: Kind -> Kind -> Kind
-mkArrowKind k1 k2 = k1 `FunTy` k2
-
-mkArrowKinds :: [Kind] -> Kind -> Kind
-mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
-\end{code}
-
\begin{code}
hasMoreBoxityInfo :: Kind -> Kind -> Bool
hasMoreBoxityInfo k1 k2
%************************************************************************
%* *
-\subsection{Wired-in type constructors
-%* *
-%************************************************************************
-
-We define a few wired-in type constructors here to avoid module knots
-
-\begin{code}
-funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("(->)") funTyCon
-funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind)
-\end{code}
-
-
-
-%************************************************************************
-%* *
\subsection{Constructor-specific functions}
%* *
%************************************************************************
This should be carefully preserved.
In some parts of the compiler, comments use the _Once Upon a
-Polymorphic Type_ (POPL'99) usage of "sigma = usage-annotated type;
-tau = un-usage-annotated type"; unfortunately this conflicts with the
-rho/tau/theta/sigma usage in the rest of the compiler.
-(KSW 1999-04)
+Polymorphic Type_ (POPL'99) usage of "rho = generalised
+usage-annotated type; sigma = usage-annotated type; tau =
+usage-annotated type except on top"; unfortunately this conflicts with
+the rho/tau/theta/sigma usage in the rest of the compiler. (KSW
+1999-07)
\begin{code}
mkUsgTy :: UsageAnn -> Type -> Type
#ifndef USMANY
isUsgTy _ = True
#else
-isUsgTy (NoteTy (UsgNote _) _) = True
-isUsgTy other = False
+isUsgTy (NoteTy (UsgForAll _) ty) = isUsgTy ty
+isUsgTy (NoteTy (UsgNote _) _ ) = True
+isUsgTy other = False
#endif
-- The isNotUsgTy function may return a false True if UsManys are omitted;
-- in other words, A SSERT( isNotUsgTy ty ) may be useful but
-- A SSERT( not (isNotUsg ty) ) is asking for trouble. KSW 1999-04.
isNotUsgTy :: Type -> Bool
-isNotUsgTy (NoteTy (UsgNote _) _) = False
-isNotUsgTy other = True
+isNotUsgTy (NoteTy (UsgForAll _) _) = False
+isNotUsgTy (NoteTy (UsgNote _) _) = False
+isNotUsgTy other = True
-- splitUsgTy_maybe is not exported, since it is meaningless if
-- UsManys are omitted. It is used in several places in this module,
splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type)
splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 )
Just (usg,ty2)
-splitUsgTy_maybe ty = Nothing
+splitUsgTy_maybe ty@(NoteTy (UsgForAll _) _) = pprPanic "splitUsgTy_maybe:" $ pprType ty
+splitUsgTy_maybe ty = Nothing
splitUsgTy :: Type -> (UsageAnn,Type)
splitUsgTy ty = case splitUsgTy_maybe ty of
Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty )
ty1
Nothing -> ty
-\end{code}
+mkUsForAllTy :: UVar -> Type -> Type
+mkUsForAllTy uv ty = NoteTy (UsgForAll uv) ty
+
+mkUsForAllTys :: [UVar] -> Type -> Type
+mkUsForAllTys uvs ty = foldr (NoteTy . UsgForAll) ty uvs
+
+splitUsForAllTys :: Type -> ([UVar],Type)
+splitUsForAllTys ty = split ty []
+ where split (NoteTy (UsgForAll u) ty) uvs = split ty (u:uvs)
+ split other_ty uvs = (reverse uvs, other_ty)
+
+substUsTy :: VarEnv UsageAnn -> Type -> Type
+-- assumes range is fresh uvars, so no conflicts
+substUsTy ve (NoteTy note@(UsgNote (UsVar u))
+ ty ) = NoteTy (case lookupVarEnv ve u of
+ Just ua -> UsgNote ua
+ Nothing -> note)
+ (substUsTy ve ty)
+substUsTy ve (NoteTy note@(UsgNote _) ty ) = NoteTy note (substUsTy ve ty)
+substUsTy ve (NoteTy note@(UsgForAll _) ty ) = NoteTy note (substUsTy ve ty)
+substUsTy ve (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1))
+ (substUsTy ve ty2)
+substUsTy ve (NoteTy note@(FTVNote _) ty ) = NoteTy note (substUsTy ve ty)
+substUsTy ve ty@(TyVarTy _ ) = ty
+substUsTy ve (AppTy ty1 ty2) = AppTy (substUsTy ve ty1)
+ (substUsTy ve ty2)
+substUsTy ve (FunTy ty1 ty2) = FunTy (substUsTy ve ty1)
+ (substUsTy ve ty2)
+substUsTy ve (TyConApp tyc tys) = TyConApp tyc (map (substUsTy ve) tys)
+substUsTy ve (ForAllTy yv ty ) = ForAllTy yv (substUsTy ve ty)
+\end{code}
---------------------------------------------------------------------
\begin{code}
applyTy :: Type -> Type -> Type
-applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
-applyTy (NoteTy _ fun) arg = applyTy fun arg
-applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
- substTy (mkTyVarSubst [tv] [arg]) ty
-applyTy other arg = panic "applyTy"
+applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
+applyTy (NoteTy note@(UsgForAll _) fun) arg = NoteTy note (applyTy fun arg)
+applyTy (NoteTy _ fun) arg = applyTy fun arg
+applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
+ substTy (mkTyVarSubst [tv] [arg]) ty
+applyTy other arg = panic "applyTy"
applyTys :: Type -> [Type] -> Type
applyTys fun_ty arg_tys
(tvs, ty) = split fun_ty arg_tys
split fun_ty [] = ([], fun_ty)
+ split (NoteTy note@(UsgNote _) fun_ty)
+ args = case split fun_ty args of
+ (tvs, ty) -> (tvs, NoteTy note ty)
+ split (NoteTy note@(UsgForAll _) fun_ty)
+ args = case split fun_ty args of
+ (tvs, ty) -> (tvs, NoteTy note ty)
split (NoteTy _ fun_ty) args = split fun_ty args
split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$
text "in application of" <+> pprType fun_ty)
case split fun_ty args of
(tvs, ty) -> (tv:tvs, ty)
split other_ty args = panic "applyTys"
-
-{- OLD version with bogus usage stuff
-
- ************* CHECK WITH KEITH **************
-
- go env ty [] = substTy (mkVarEnv env) ty
- go env (NoteTy note@(UsgNote _) fun)
- args = NoteTy note (go env fun args)
- go env (NoteTy _ fun) args = go env fun args
- go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
- go env other args = panic "applyTys"
--}
\end{code}
Note that we allow applications to be of usage-annotated- types, as an
extension: we handle them by lifting the annotation outside. The
argument, however, must still be unannotated.
+
%************************************************************************
%* *
\subsection{Stuff to do with the source-language types}
tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
+tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty
tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
-- Add a Note with the free tyvars to the top of the type
-- (but under a usage if there is one)
addFreeTyVars :: Type -> Type
-addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
-addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
-addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
+addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
+addFreeTyVars (NoteTy note@(UsgForAll _) ty) = NoteTy note (addFreeTyVars ty)
+addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
+addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
-- Find the free names of a type, including the type constructors and classes it mentions
namesOfType :: Type -> NameSet
go_note (SynNote ty) = SynNote $! (go ty)
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
go_note note@(UsgNote _) = note -- Usage annotation is already tidy
+ go_note note@(UsgForAll _) = note -- Uvar binder is already tidy
tidyTypes env tys = map (tidyType env) tys
\end{code}
other -> PtrRep
\end{code}
-%************************************************************************
-%* *
-\subsection{Equality on types}
-%* *
-%************************************************************************
-
-For the moment at least, type comparisons don't work if
-there are embedded for-alls.
-
-\begin{code}
-instance Eq Type where
- ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
-
-instance Ord Type where
- compare ty1 ty2 = cmpTy ty1 ty2
-
-cmpTy :: Type -> Type -> Ordering
-cmpTy ty1 ty2
- = cmp emptyVarEnv ty1 ty2
- where
- -- The "env" maps type variables in ty1 to type variables in ty2
- -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
- -- we in effect substitute tv2 for tv1 in t1 before continuing
- lookup env tv1 = case lookupVarEnv env tv1 of
- Just tv2 -> tv2
- Nothing -> tv1
-
- -- Get rid of NoteTy
- cmp env (NoteTy _ ty1) ty2 = cmp env ty1 ty2
- cmp env ty1 (NoteTy _ ty2) = cmp env ty1 ty2
-
- -- Deal with equal constructors
- cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
- cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
- cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
- cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
- cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (extendVarEnv env tv1 tv2) t1 t2
-
- -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
- cmp env (AppTy _ _) (TyVarTy _) = GT
-
- cmp env (FunTy _ _) (TyVarTy _) = GT
- cmp env (FunTy _ _) (AppTy _ _) = GT
-
- cmp env (TyConApp _ _) (TyVarTy _) = GT
- cmp env (TyConApp _ _) (AppTy _ _) = GT
- cmp env (TyConApp _ _) (FunTy _ _) = GT
-
- cmp env (ForAllTy _ _) other = GT
-
- cmp env _ _ = LT
-
- cmps env [] [] = EQ
- cmps env (t:ts) [] = GT
- cmps env [] (t:ts) = LT
- cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
-\end{code}
-
%************************************************************************
%* *
--- /dev/null
+_interface_ TypeRep 1
+_exports_ TypeRep Type Kind SuperKind ;
+_declarations_
+1 data Type ;
+1 type Kind = Type ;
+1 type SuperKind = Type ;;
+
--- /dev/null
+__interface TypeRep 1 0 where
+__export TypeRep Type Kind SuperKind ;
+1 data Type ;
+1 type Kind = Type ;
+1 type SuperKind = Type ;
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+\section[TypeRep]{Type - friends' interface}
+
+\begin{code}
+module TypeRep (
+ Type(..), TyNote(..), UsageAnn(..), -- Representation visible to friends
+ Kind, TyVarSubst,
+
+ superKind, superBoxity, -- :: SuperKind
+
+ boxedKind, -- :: Kind :: BX
+ anyBoxKind, -- :: Kind :: BX
+ typeCon, -- :: KindCon :: BX -> KX
+ anyBoxCon, -- :: KindCon :: BX
+
+ boxedTypeKind, unboxedTypeKind, openTypeKind, -- Kind :: superKind
+
+ mkArrowKind, mkArrowKinds,
+
+ funTyCon
+ ) where
+
+#include "HsVersions.h"
+
+-- friends:
+import Var ( TyVar, UVar )
+import VarEnv
+import VarSet
+
+import Name ( Provenance(..), ExportFlag(..),
+ mkWiredInTyConName, mkGlobalName, mkKindOccFS, tcName,
+ )
+import TyCon ( TyCon, KindCon,
+ mkFunTyCon, mkKindCon, mkSuperKindCon,
+ )
+
+-- others
+import SrcLoc ( mkBuiltinSrcLoc )
+import PrelMods ( pREL_GHC )
+import Unique -- quite a few *Keys
+import Util ( thenCmp )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Type Classifications}
+%* *
+%************************************************************************
+
+A type is
+
+ *unboxed* iff its representation is other than a pointer
+ Unboxed types cannot instantiate a type variable.
+ Unboxed types are always unlifted.
+
+ *lifted* A type is lifted iff it has bottom as an element.
+ Closures always have lifted types: i.e. any
+ let-bound identifier in Core must have a lifted
+ type. Operationally, a lifted object is one that
+ can be entered.
+ (NOTE: previously "pointed").
+
+ *algebraic* A type with one or more constructors, whether declared
+ with "data" or "newtype".
+ An algebraic type is one that can be deconstructed
+ with a case expression.
+ *NOT* the same as lifted types, because we also
+ include unboxed tuples in this classification.
+
+ *data* A type declared with "data". Also boxed tuples.
+
+ *primitive* iff it is a built-in type that can't be expressed
+ in Haskell.
+
+Currently, all primitive types are unlifted, but that's not necessarily
+the case. (E.g. Int could be primitive.)
+
+Some primitive types are unboxed, such as Int#, whereas some are boxed
+but unlifted (such as ByteArray#). The only primitive types that we
+classify as algebraic are the unboxed tuples.
+
+examples of type classifications:
+
+Type primitive boxed lifted algebraic
+-----------------------------------------------------------------------------
+Int#, Yes No No No
+ByteArray# Yes Yes No No
+(# a, b #) Yes No No Yes
+( a, b ) No Yes Yes Yes
+[a] No Yes Yes Yes
+
+%************************************************************************
+%* *
+\subsection{The data type}
+%* *
+%************************************************************************
+
+
+\begin{code}
+type SuperKind = Type
+type Kind = Type
+
+type TyVarSubst = TyVarEnv Type
+
+data Type
+ = TyVarTy TyVar
+
+ | AppTy
+ Type -- Function is *not* a TyConApp
+ Type
+
+ | TyConApp -- Application of a TyCon
+ TyCon -- *Invariant* saturated appliations of FunTyCon and
+ -- synonyms have their own constructors, below.
+ [Type] -- Might not be saturated.
+
+ | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
+ Type
+ Type
+
+ | NoteTy -- Saturated application of a type synonym
+ TyNote
+ Type -- The expanded version
+
+ | ForAllTy
+ TyVar
+ Type -- TypeKind
+
+data TyNote
+ = SynNote Type -- The unexpanded version of the type synonym; always a TyConApp
+ | FTVNote TyVarSet -- The free type variables of the noted expression
+ | UsgNote UsageAnn -- The usage annotation at this node
+ | UsgForAll UVar -- Annotation variable binder
+
+data UsageAnn
+ = UsOnce -- Used at most once
+ | UsMany -- Used possibly many times (no info; this annotation can be omitted)
+ | UsVar UVar -- Annotation is variable (unbound OK only inside analysis)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Kinds}
+%* *
+%************************************************************************
+
+Kinds
+~~~~~
+k::K = Type bx
+ | k -> k
+ | kv
+
+kv :: KX is a kind variable
+
+Type :: BX -> KX
+
+bx::BX = Boxed
+ | Unboxed
+ | AnyBox -- Used *only* for special built-in things
+ -- like error :: forall (a::*?). String -> a
+ -- Here, the 'a' can be instantiated to a boxed or
+ -- unboxed type.
+ | bv
+
+bxv :: BX is a boxity variable
+
+sk = KX -- A kind
+ | BX -- A boxity
+ | sk -> sk -- In ptic (BX -> KX)
+
+\begin{code}
+mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str)
+ (LocalDef mkBuiltinSrcLoc NotExported)
+ -- mk_kind_name is a bit of a hack
+ -- The LocalDef means that we print the name without
+ -- a qualifier, which is what we want for these kinds.
+ -- It's used for both Kinds and Boxities
+\end{code}
+
+Define KX, BX.
+
+\begin{code}
+superKind :: SuperKind -- KX, the type of all kinds
+superKindName = mk_kind_name kindConKey SLIT("KX")
+superKind = TyConApp (mkSuperKindCon superKindName) []
+
+superBoxity :: SuperKind -- BX, the type of all boxities
+superBoxityName = mk_kind_name boxityConKey SLIT("BX")
+superBoxity = TyConApp (mkSuperKindCon superBoxityName) []
+\end{code}
+
+Define Boxed, Unboxed, AnyBox
+
+\begin{code}
+boxedKind, unboxedKind, anyBoxKind :: Kind -- Of superkind superBoxity
+
+boxedConName = mk_kind_name boxedConKey SLIT("*")
+boxedKind = TyConApp (mkKindCon boxedConName superBoxity) []
+
+unboxedConName = mk_kind_name unboxedConKey SLIT("#")
+unboxedKind = TyConApp (mkKindCon unboxedConName superBoxity) []
+
+anyBoxConName = mk_kind_name anyBoxConKey SLIT("?")
+anyBoxCon = mkKindCon anyBoxConName superBoxity -- A kind of wild card
+anyBoxKind = TyConApp anyBoxCon []
+\end{code}
+
+Define Type
+
+\begin{code}
+typeCon :: KindCon
+typeConName = mk_kind_name typeConKey SLIT("Type")
+typeCon = mkKindCon typeConName (superBoxity `FunTy` superKind)
+\end{code}
+
+Define (Type Boxed), (Type Unboxed), (Type AnyBox)
+
+\begin{code}
+boxedTypeKind, unboxedTypeKind, openTypeKind :: Kind
+boxedTypeKind = TyConApp typeCon [boxedKind]
+unboxedTypeKind = TyConApp typeCon [unboxedKind]
+openTypeKind = TyConApp typeCon [anyBoxKind]
+
+mkArrowKind :: Kind -> Kind -> Kind
+mkArrowKind k1 k2 = k1 `FunTy` k2
+
+mkArrowKinds :: [Kind] -> Kind -> Kind
+mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Wired-in type constructors
+%* *
+%************************************************************************
+
+We define a few wired-in type constructors here to avoid module knots
+
+\begin{code}
+funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("(->)") funTyCon
+funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Equality on types}
+%* *
+%************************************************************************
+
+For the moment at least, type comparisons don't work if
+there are embedded for-alls.
+
+\begin{code}
+instance Eq Type where
+ ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
+
+instance Ord Type where
+ compare ty1 ty2 = cmpTy ty1 ty2
+
+cmpTy :: Type -> Type -> Ordering
+cmpTy ty1 ty2
+ = cmp emptyVarEnv ty1 ty2
+ where
+ -- The "env" maps type variables in ty1 to type variables in ty2
+ -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
+ -- we in effect substitute tv2 for tv1 in t1 before continuing
+ lookup env tv1 = case lookupVarEnv env tv1 of
+ Just tv2 -> tv2
+ Nothing -> tv1
+
+ -- Get rid of NoteTy
+ cmp env (NoteTy _ ty1) ty2 = cmp env ty1 ty2
+ cmp env ty1 (NoteTy _ ty2) = cmp env ty1 ty2
+
+ -- Deal with equal constructors
+ cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
+ cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
+ cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
+ cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
+ cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (extendVarEnv env tv1 tv2) t1 t2
+
+ -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
+ cmp env (AppTy _ _) (TyVarTy _) = GT
+
+ cmp env (FunTy _ _) (TyVarTy _) = GT
+ cmp env (FunTy _ _) (AppTy _ _) = GT
+
+ cmp env (TyConApp _ _) (TyVarTy _) = GT
+ cmp env (TyConApp _ _) (AppTy _ _) = GT
+ cmp env (TyConApp _ _) (FunTy _ _) = GT
+
+ cmp env (ForAllTy _ _) other = GT
+
+ cmp env _ _ = LT
+
+ cmps env [] [] = EQ
+ cmps env (t:ts) [] = GT
+ cmps env [] (t:ts) = LT
+ cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
+\end{code}
+
match, matchTy, matchTys
) where
-import Type ( Type(..), funTyCon, typeKind, tyVarsOfType,
- splitAppTy_maybe
+import TypeRep ( Type(..), funTyCon
+ ) -- friend
+import Type ( typeKind, tyVarsOfType, splitAppTy_maybe
)
import Var ( TyVar, tyVarKind )
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
+%
+\section[Variance]{Variance in @Type@ and @TyCon@}
+
+\begin{code}
+module Variance(
+ calcTyConArgVrcs,
+ tyVarVrc
+ ) where
+
+#include "HsVersions.h"
+
+import TypeRep ( Type(..), TyNote(..) ) -- friend
+import Type ( mkDictTy )
+import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataCons, tyConTyVars,
+ tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
+import DataCon ( dataConRawArgTys, dataConSig )
+
+import FiniteMap
+import Var ( TyVar )
+import VarSet
+import Name ( Name, getName )
+import Maybes ( expectJust )
+import Outputable
+\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}
+
+
+Variance of tyvars in a type
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+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 (UsgForAll _) 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)
+\end{code}
+
+
+External entry point: assumes tyconargvrcs already computed.
+
+\begin{code}
+tyVarVrc :: TyVar -- tyvar to check Vrc of
+ -> Type -- type to check for occ in
+ -> (Bool,Bool) -- (occurs positively, occurs negatively)
+
+tyVarVrc = vrcInTy (expectJust "tyVarVrcs" . tyConArgVrcs_maybe)
+\end{code}
+
+
+Variance algebra
+~~~~~~~~~~~~~~~~
+
+\begin{code}
+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}
This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
September 1998 .. May 1999.
-Keith Wansbrough 1998-09-04..1999-06-25
+Keith Wansbrough 1998-09-04..1999-07-06
\begin{code}
module UsageSPInf ( doUsageSPInf ) where
import UConSet
import CoreSyn
-import Type ( Type(..), TyNote(..), UsageAnn(..),
+import TypeRep ( Type(..), TyNote(..) ) -- friend
+import Type ( UsageAnn(..),
applyTy, applyTys,
splitFunTy_maybe, splitFunTys, splitTyConApp_maybe,
mkUsgTy, splitUsgTy, isUsgTy, isNotUsgTy, unUsgTy, tyUsg,
+ splitUsForAllTys, substUsTy,
mkFunTy, mkForAllTy )
-import TyCon ( tyConArgVrcs_maybe )
+import TyCon ( tyConArgVrcs_maybe, isFunTyCon )
import DataCon ( dataConType )
import Const ( Con(..), Literal(..), literalType )
-import Var ( IdOrTyVar, UVar, varType, mkUVar, modifyIdInfo )
+import Var ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo )
import IdInfo ( setLBVarInfo, LBVarInfo(..) )
+import Id ( idMustBeINLINEd, isExportedId )
+import Name ( isLocallyDefined )
import VarEnv
+import VarSet
import UniqSupply ( UniqSupply, UniqSM,
initUs, splitUniqSupply )
import Outputable
+import Maybes ( expectJust )
+import List ( unzip4 )
import CmdLineOpts ( opt_D_dump_usagesp, opt_DoUSPLinting )
import ErrUtils ( doIfSet, dumpIfSet )
import PprCore ( pprCoreBindings )
Glasgow Department of Computing Science Technical Report TR-1998-19,
December 1998, or the summary in POPL'99.
+[** NEW VERSION NOW IMPLEMENTED; different from the papers
+ above. Hopefully to appear in PLDI'00, and Keith Wansbrough's
+ University of Cambridge PhD thesis, c. Sep 2000 **]
+
+
Inference is performed as follows:
- 1. Remove all manipulable[*] annotations and add fresh @UVar@
- annotations.
+ 1. Remove all manipulable[*] annotations.
- 2. Walk over the resulting term applying the type rules and
- collecting the constraints.
+ 2. Walk over the resulting term adding fresh UVar annotations,
+ applying the type rules and collecting the constraints.
3. Find the solution to the constraints and apply the substitution
to the annotations, leaving a @UVar@-free term.
As in the paper, a ``tau-type'' is a type that does *not* have an
annotation on top (although it may have some inside), and a
``sigma-type'' is one that does (i.e., is a tau-type with an
-annotation added). This conflicts with the totally unrelated usage of
-these terms in the remainder of GHC. Caveat lector! KSW 1999-04.
+annotation added). Also, a ``rho-type'' is one that may have initial
+``\/u.''s. This conflicts with the totally unrelated usage of these
+terms in the remainder of GHC. Caveat lector! KSW 1999-07.
The inference is done over a set of @CoreBind@s, and inside the IO
doUsageSPInf us binds = do
let binds1 = doUnAnnotBinds binds
- (us1,us2) = splitUniqSupply us
- (binds2,_) = doAnnotBinds us1 binds1
+ dumpIfSet opt_D_dump_usagesp "UsageSPInf unannot'd" $
+ pprCoreBindings binds1
- dumpIfSet opt_D_dump_usagesp "UsageSPInf reannot'd" $
- pprCoreBindings binds2
+ let ((binds2,ucs,_),_)
+ = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
- doIfSet opt_DoUSPLinting $
- doLintUSPAnnotsBinds binds2 -- lint check 0
+ dumpIfSet opt_D_dump_usagesp "UsageSPInf annot'd" $
+ pprCoreBindings binds2
- let ((ucs,_),_) = initUs us2 (uniqSMMToUs (usgInfBinds binds2))
- ms = solveUCS ucs
- s = case ms of
- Just s -> s
- Nothing -> panic "doUsageSPInf: insol. conset!"
- binds3 = appUSubstBinds s binds2
+ let ms = solveUCS ucs
+ s = case ms of
+ Just s -> s
+ Nothing -> panic "doUsageSPInf: insol. conset!"
+ binds3 = appUSubstBinds s binds2
doIfSet opt_DoUSPLinting $
do doLintUSPAnnotsBinds binds3 -- lint check 1
Inferring an expression
~~~~~~~~~~~~~~~~~~~~~~~
-When we infer types for an expression, we expect it to be already
-annotated - normally with usage variables everywhere (or possibly
-constants). No context is required since variables already know their
-types.
+Inference takes an annotated (rho-typed) environment and an expression
+unannotated except for variables not appearing in the environment. It
+returns an annotated expression, a type, a constraint set, and a
+multiset of free variables. It is in the unique supply monad, which
+supplies fresh uvars for annotation.
+
+We conflate usage metavariables and usage variables; the latter are
+distinguished by falling within the scope of a usage binder.
\begin{code}
-usgInfBinds :: [CoreBind]
- -> UniqSMM (UConSet,
- VarMultiset)
-
-usgInfBinds [] = return (emptyUConSet,
- emptyMS)
-
-usgInfBinds (b:bs) = do { (ucs2,fv2) <- usgInfBinds bs -- careful of scoping here
- ; (ucs1,fv1) <- usgInfBind b fv2
- ; return (ucs1 `unionUCS` ucs2,
- fv1)
- }
-
-usgInfBind :: CoreBind -- CoreBind to infer for
- -> VarMultiset -- fvs of `body' (later CoreBinds)
- -> UniqSMM (UConSet, -- constraints generated by this CoreBind
- VarMultiset) -- fvs of this CoreBind and later ones
-
-usgInfBind (NonRec v1 e1) fv0 = do { (ty1u,ucs1,fv1) <- usgInfCE e1
- ; let ty2u = varType v1
- ucs2 = usgSubTy ty1u ty2u
- ucs3 = occChkUConSet v1 fv0
- ; return (unionUCSs [ucs1,ucs2,ucs3],
- fv1 `plusMS` (fv0 `delFromMS` v1))
- }
-
-usgInfBind (Rec ves) fv0 = do { tuf1s <- mapM (usgInfCE . snd) ves
- ; let (ty1us,ucs1s,fv1s) = unzip3 tuf1s
- vs = map fst ves
- ucs2s = zipWith usgSubTy ty1us (map varType vs)
- fv3 = foldl plusMS fv0 fv1s
- ucs3 = occChksUConSet vs fv3
- ; return (unionUCSs (ucs1s ++ ucs2s ++ [ucs3]),
- foldl delFromMS fv3 vs)
- }
-
-usgInfCE :: CoreExpr
- -> UniqSMM (Type,UConSet,VarMultiset)
- -- ^- in the unique supply monad for new uvars
- -- ^- type of the @CoreExpr@ (always a sigma type)
- -- ^- set of constraints arising
- -- ^- variable appearances for occur()
-
-usgInfCE e0@(Var v) | isTyVar v = panic "usgInfCE: unexpected TyVar"
- | otherwise = return (ASSERT( isUsgTy (varType v) )
- varType v,
- emptyUConSet,
- unitMS v)
-
-usgInfCE e0@(Con (Literal lit) args) = ASSERT( null args )
- do { u1 <- newVarUSMM (Left e0)
- ; return (mkUsgTy u1 (literalType lit),
- emptyUConSet,
- emptyMS)
- }
-
-usgInfCE (Con DEFAULT _) = panic "usgInfCE: DEFAULT"
-
-usgInfCE e0@(Con con args) = -- constant or primop. guaranteed saturated.
- do { let (ety1s,e1s) = span isTypeArg args
- ty1s = map (\ (Type ty) -> ty) ety1s -- univ. + exist.
- ; (ty3us,ty3u) <- case con of
- DataCon c -> do { u4 <- newVarUSMM (Left e0)
- ; return $ dataConTys c u4 ty1s
- -- ty1s is exdicts + args
- }
- PrimOp p -> return $ primOpUsgTys p ty1s
- otherwise -> panic "usgInfCE: unrecognised Con"
- ; tuf4s <- mapM usgInfCE e1s
- ; let (ty4us,ucs4s,fv4s) = unzip3 tuf4s
- ucs5s = zipWith usgSubTy
- ty4us ty3us
- ; return (ty3u,
- -- note ty3 is T ty1s, so it already
- -- has annotations inside where they
- -- should be (for datacons); for
- -- primops we assume types are
- -- appropriately annotated already.
- unionUCSs (ucs4s ++ ucs5s),
- foldl plusMS emptyMS fv4s)
- }
- where dataConTys c u tys = -- compute argtys of a datacon
- let rawCTy = dataConType c
- cTy = ASSERT( isUnAnnotated rawCTy )
- -- algebraic data types are defined entirely
- -- unannotated; we place Many annotations inside
- -- them to get the required tau-types (p20(fn) TR)
- annotManyN rawCTy
- -- we really don't want annots on top of the
- -- funargs, but we can't easily avoid
- -- this so we use unUsgTy later
- (ty3us,ty3) = ASSERT( all isNotUsgTy tys )
- splitFunTys (applyTys cTy tys)
- -- safe 'cos a DataCon always returns a
- -- value of type (TyCon tys), not an
- -- arrow type
- ty3u = if null ty3us then mkUsgTy u ty3 else ty3
- -- if no args, ty3 is tau; else already sigma
- reUsg = mkUsgTy u . unUsgTy
- in (map reUsg ty3us,
- reUsg ty3u)
-
-usgInfCE (App e1 (Type ty2)) = do { (ty1u,ucs,fv) <- usgInfCE e1
- ; let (u,ty1) = splitUsgTy ty1u
- ; ASSERT( isNotUsgTy ty2 )
- return (mkUsgTy u (applyTy ty1 ty2),
- ucs,
- fv)
- }
-
-usgInfCE (App e1 e2) = do { (ty1u,ucs1,fv1) <- usgInfCE e1
- ; (ty2u,ucs2,fv2) <- usgInfCE e2
- ; let (u1,ty1) = splitUsgTy ty1u
- (ty3u,ty4u) = case splitFunTy_maybe ty1 of
- Just tys -> tys
- Nothing -> panic "usgInfCE: app of non-funty"
- ucs5 = usgSubTy ty2u ty3u
- ; return (ASSERT( isUsgTy ty4u )
- ty4u,
- unionUCSs [ucs1,ucs2,ucs5],
- fv1 `plusMS` fv2)
- }
-
-usgInfCE (Lam v e) | isTyVar v = do { (ty1u,ucs,fv) <- usgInfCE e -- safe to ignore free v here
- ; let (u,ty1) = splitUsgTy ty1u
- ; return (mkUsgTy u (mkForAllTy v ty1),
- ucs,
- fv)
- }
- | otherwise = panic "usgInfCE: missing lambda usage annot"
+usgInfBinds :: VarEnv Var -- incoming environment (usu. empty)
+ -> [CoreBind] -- CoreBinds in dependency order
+ -> UniqSMM ([CoreBind], -- annotated CoreBinds
+ UConSet, -- constraint set
+ VarMultiset) -- usage of environment vars
+
+usgInfBinds ve []
+ = return ([],
+ emptyUConSet,
+ emptyMS)
+
+usgInfBinds ve (b0:b0s)
+-- (this clause is almost the same as the Let clause)
+ = do (v1s,ve1,b1,h1,fb1,fa1) <- usgInfBind ve b0
+ (b2s,h2,f2) <- usgInfBinds ve1 b0s
+ let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
+ return (b1:b2s,
+ unionUCSs [h1,h2,h3],
+ fa1 `plusMS` (f2 `delsFromMS` v1s))
+
+
+usgInfBind :: VarEnv Var
+ -> CoreBind -- CoreBind to infer for
+ -> UniqSMM ([Var], -- variables bound
+ VarEnv Var, -- extended VarEnv
+ CoreBind, -- annotated CoreBind
+ UConSet, -- constraints generated by this CoreBind
+ VarMultiset, -- this bd's use of vars bound in this bd
+ -- (could be anything for other vars)
+ VarMultiset) -- this bd's use of other vars
+
+usgInfBind ve (NonRec v1 e1)
+ = do (v1',y1u) <- annotVar v1
+ (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v1 v1') e1
+ let h3 = usgSubTy y2u y1u
+ h4 = h2 `unionUCS` h3
+ (y4r,h4') = usgClos ve y2u h4
+ v1'' = setVarType v1 y4r
+ h5 = if isExportedId v1 then pessimise y4r else emptyUConSet
+ return ([v1''],
+ extendVarEnv ve v1 v1'',
+ NonRec v1'' e2,
+ h4' `unionUCS` h5,
+ emptyMS,
+ f2)
+
+usgInfBind ve (Rec ves)
+ = do let (v1s,e1s) = unzip ves
+ vy1s' <- mapM annotVar v1s
+ let (v1s',y1us) = unzip vy1s'
+ ve' = ve `plusVarEnv` (zipVarEnv v1s v1s')
+ eyhf2s <- mapM (usgInfCE ve') e1s
+ let (e2s,y2us,h2s,f2s) = unzip4 eyhf2s
+ h3s = zipWith usgSubTy y2us y1us
+ h4s = zipWith unionUCS h2s h3s
+ yh4s = zipWith (usgClos ve) y2us h4s
+ (y4rs,h4s') = unzip yh4s
+ v1s'' = zipWith setVarType v1s y4rs
+ f5 = foldl plusMS emptyMS f2s
+ h6s = zipWith (\ v y -> if isExportedId v then pessimise y else emptyUConSet)
+ v1s y4rs
+ return (v1s'',
+ ve `plusVarEnv` (zipVarEnv v1s v1s''),
+ Rec (zip v1s'' e2s),
+ unionUCSs (h4s' ++ h6s),
+ f5,
+ f5 `delsFromMS` v1s') -- we take pains that v1'==v1'' etc
+
+
+usgInfCE :: VarEnv Var -- unannotated -> annotated vars
+ -> CoreExpr -- expression to annotate / infer
+ -> UniqSMM (CoreExpr, -- annotated expression (e)
+ Type, -- (sigma) type of expression (y)(u=sigma)(r=rho)
+ UConSet, -- set of constraints arising (h)
+ VarMultiset) -- variable occurrences (f)
+
+usgInfCE ve e0@(Var v) | isTyVar v
+ = panic "usgInfCE: unexpected TyVar"
+ | otherwise
+ = do v' <- instVar (lookupVar ve v)
+ ASSERT( isUsgTy (varType v' {-'cpp-}) )
+ return (Var v',
+ varType v',
+ emptyUConSet,
+ unitMS v')
+
+usgInfCE ve e0@(Con (Literal lit) args)
+ = ASSERT( null args )
+ do u1 <- newVarUSMM (Left e0)
+ return (e0,
+ mkUsgTy u1 (literalType lit),
+ emptyUConSet,
+ emptyMS)
+
+usgInfCE ve (Con DEFAULT _)
+ = panic "usgInfCE: DEFAULT"
+
+usgInfCE ve e0@(Con con args)
+ = -- constant or primop. guaranteed saturated.
+ do let (ey1s,e1s) = span isTypeArg args
+ y1s <- mapM (\ (Type ty) -> annotTyN (Left e0) ty) ey1s -- univ. + exist.
+ (y2us,y2u) <- case con of
+ DataCon c -> do u2 <- newVarUSMM (Left e0)
+ return $ dataConTys c u2 y1s
+ -- y1s is exdicts + args
+ PrimOp p -> return $ primOpUsgTys p y1s
+ otherwise -> panic "usgInfCE: unrecognised Con"
+ eyhf3s <- mapM (usgInfCE ve) e1s
+ let (e3s,y3us,h3s,f3s) = unzip4 eyhf3s
+ h4s = zipWith usgSubTy y3us y2us
+ ASSERT( isUsgTy y2u )
+ return (Con con (map Type y1s ++ e3s),
+ y2u,
+ unionUCSs (h3s ++ h4s),
+ foldl plusMS emptyMS f3s)
+
+ where dataConTys c u y1s
+ -- compute argtys of a datacon
+ = let cTy = annotMany (dataConType c) -- extra (sigma) annots later replaced
+ (y2us,y2u) = splitFunTys (applyTys cTy y1s)
+ -- safe 'cos a DataCon always returns a value of type (TyCon tys),
+ -- not an arrow type.
+ reUsg = mkUsgTy u . unUsgTy
+ in (map reUsg y2us, reUsg y2u)
+
+usgInfCE ve e0@(App ea (Type yb))
+ = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
+ let (u1,ya1) = splitUsgTy ya1u
+ yb1 <- annotTyN (Left e0) yb
+ return (App ea1 (Type yb1),
+ mkUsgTy u1 (applyTy ya1 yb1),
+ ha1,
+ fa1)
+
+usgInfCE ve (App ea eb)
+ = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
+ let ( u1,ya1) = splitUsgTy ya1u
+ (y2u,y3u) = expectJust "usgInfCE:App" $ splitFunTy_maybe ya1
+ (eb1,yb1u,hb1,fb1) <- usgInfCE ve eb
+ let h4 = usgSubTy yb1u y2u
+ ASSERT( isUsgTy y3u )
+ return (App ea1 eb1,
+ y3u,
+ unionUCSs [ha1,hb1,h4],
+ fa1 `plusMS` fb1)
+
+usgInfCE ve e0@(Lam v0 e) | isTyVar v0
+ = do (e1,y1u,h1,f1) <- usgInfCE ve e
+ let (u1,y1) = splitUsgTy y1u
+ return (Lam v0 e1,
+ mkUsgTy u1 (mkForAllTy v0 y1),
+ h1,
+ f1)
+
+ -- [OLD COMMENT:]
-- if used for checking also, may need to extend this case to
-- look in lbvarInfo instead.
-
-usgInfCE (Note (TermUsg u) (Lam v e))
- = ASSERT( not (isTyVar v) )
- do { (ty1u,ucs1,fv) <- usgInfCE e
- ; let ty2u = varType v
- ucs2 = occChkUConSet v fv
- fv' = fv `delFromMS` v
- ucs3s = foldMS (\v _ ucss -> (leqUConSet u ((tyUsg . varType) v)
- : ucss)) -- in reverse order!
- []
- fv'
- ; return (mkUsgTy u (mkFunTy ty2u ty1u),
- unionUCSs ([ucs1,ucs2] ++ ucs3s),
- fv')
- }
-
-usgInfCE (Let bind e0) = do { (ty0u,ucs0,fv0) <- usgInfCE e0
- ; (ucs1,fv1) <- usgInfBind bind fv0
- ; return (ASSERT( isUsgTy ty0u )
- ty0u,
- ucs0 `unionUCS` ucs1,
- fv1)
- }
-
-usgInfCE (Case e0 v0 [(DEFAULT,[],e1)])
- = -- pure strict let, no selection (could be at polymorphic or function type)
- do { (ty0u,ucs0,fv0) <- usgInfCE e0
- ; (ty1u,ucs1,fv1) <- usgInfCE e1
- ; let (u0,ty0) = splitUsgTy ty0u
- ucs2 = usgEqTy ty0u (varType v0) -- messy! but OK
- ; ty4u <- freshannotTy ty1u
- ; let ucs5 = usgSubTy ty1u ty4u
- ucs7 = occChkUConSet v0 (fv1 `plusMS` (unitMS v0))
- ; return (ASSERT( isUsgTy ty4u )
- ty4u,
- unionUCSs [ucs0,ucs1,ucs2,ucs5,ucs7],
- fv0 `plusMS` (fv1 `delFromMS` v0))
- }
-
-usgInfCE expr@(Case e0 v0 alts)
- = -- general case (tycon of scrutinee must be known)
- do { let (cs,vss,es) = unzip3 alts
- ; (ty0u,ucs0,fv0) <- usgInfCE e0
- ; tuf2s <- mapM usgInfCE es
- ; let (u0,ty0) = splitUsgTy ty0u
- ucs1 = usgEqTy ty0u (varType v0) -- messy! but OK
- (tc,ty0ks) = case splitTyConApp_maybe ty0 of
- Just tcks -> tcks
- Nothing -> pprPanic "usgInfCE: weird:" $
- vcat [text "scrutinee:" <+> ppr e0,
- text "type:" <+> ppr ty0u]
- ; let (ty2us,ucs2s,fv2s) = unzip3 tuf2s
- ucs3ss = ASSERT2( all isNotUsgTy ty0ks, text "expression" <+> ppr e0 $$ text "has type" <+> ppr ty0u )
- zipWith (\ c vs -> zipWith (\ty v ->
- usgSubTy (mkUsgTy u0 ty)
- (varType v))
- (caseAltArgs ty0ks c)
- vs)
- cs
- vss
- ; ty4u <- freshannotTy (head ty2us) -- assume at least one alt
- ; let ucs5s = zipWith usgSubTy ty2us (repeat ty4u)
- ucs6s = zipWith occChksUConSet vss fv2s
- fv7 = ASSERT( not (null fv2s) && (length fv2s == length vss) )
- foldl1 maxMS (zipWith (foldl delFromMS) fv2s vss)
- ucs7 = occChkUConSet v0 (fv7 `plusMS` (unitMS v0))
- ; return (ASSERT( isUsgTy ty4u )
- ty4u,
- unionUCSs ([ucs0,ucs1] ++ ucs2s
- ++ (concat ucs3ss)
- ++ ucs5s
- ++ ucs6s
- ++ [ucs7]),
- fv0 `plusMS` (fv7 `delFromMS` v0))
- }
- where caseAltArgs :: [Type] -> Con -> [Type]
- -- compute list of tau-types required by a case-alt
- caseAltArgs tys (DataCon dc) = let rawCTy = dataConType dc
- cTy = ASSERT2( isUnAnnotated rawCTy, (text "caseAltArgs: rawCTy annotated!:" <+> ppr rawCTy <+> text "in" <+> ppr expr) )
- annotManyN rawCTy
- in ASSERT( all isNotUsgTy tys )
- map unUsgTy (fst (splitFunTys (applyTys cTy tys)))
- caseAltArgs tys (Literal _) = []
- caseAltArgs tys DEFAULT = []
- caseAltArgs tys (PrimOp _) = panic "caseAltArgs: unexpected PrimOp"
-
-usgInfCE (Note (SCC _) e) = usgInfCE e
-
-usgInfCE (Note (Coerce ty1 ty0) e)
- = do { (ty2u,ucs2,fv2) <- usgInfCE e
- ; let (u2,ty2) = splitUsgTy ty2u
- ucs3 = usgEqTy ty0 ty2 -- messy but OK
- ty0' = (annotManyN . unannotTy) ty0 -- really nasty type
- ucs4 = usgEqTy ty0 ty0'
- ucs5 = emptyUConSet
+ | otherwise
+ = do u1 <- newVarUSMM (Left e0)
+ (v1,y1u) <- annotVar v0
+ (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v0 v1) e
+ let h3 = occChkUConSet v1 f2
+ f2' = f2 `delFromMS` v1
+ h4s = foldMS (\ v _ hs -> (leqUConSet u1 ((tyUsg . varType . lookupVar ve) v)
+ : hs)) -- in reverse order!
+ []
+ f2'
+ return (Note (TermUsg u1) (Lam v1 e2), -- add annot for lbVarInfo computation
+ mkUsgTy u1 (mkFunTy y1u y2u),
+ unionUCSs (h2:h3:h4s),
+ f2')
+
+usgInfCE ve (Let b0s e0)
+ = do (v1s,ve1,b1s,h1,fb1,fa1) <- usgInfBind ve b0s
+ (e2,y2u,h2,f2) <- usgInfCE ve1 e0
+ let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
+ ASSERT( isUsgTy y2u )
+ return (Let b1s e2,
+ y2u,
+ unionUCSs [h1,h2,h3],
+ fa1 `plusMS` (f2 `delsFromMS` v1s))
+
+usgInfCE ve (Case e0 v0 [(DEFAULT,[],e1)])
+-- pure strict let, no selection (could be at polymorphic or function type)
+ = do (v1,y1u) <- annotVar v0
+ (e2,y2u,h2,f2) <- usgInfCE ve e0
+ (e3,y3u,h3,f3) <- usgInfCE (extendVarEnv ve v0 v1) e1
+ let h4 = usgEqTy y2u y1u -- **! why not subty?
+ h5 = occChkUConSet v1 f3
+ ASSERT( isUsgTy y3u )
+ return (Case e2 v1 [(DEFAULT,[],e3)],
+ y3u,
+ unionUCSs [h2,h3,h4,h5],
+ f2 `plusMS` (f3 `delFromMS` v1))
+
+usgInfCE ve e0@(Case e1 v1 alts)
+-- general case (tycon of scrutinee must be known)
+-- (assumes well-typed already; so doesn't check constructor)
+ = do (v2,y1u) <- annotVar v1
+ (e2,y2u,h2,f2) <- usgInfCE ve e1
+ let h3 = usgEqTy y2u y1u -- **! why not subty?
+ (u2,y2) = splitUsgTy y2u
+ (tc,y2s) = expectJust "usgInfCE:Case" $ splitTyConApp_maybe y2
+ (cs,v1ss,es) = unzip3 alts
+ v2ss = map (map (\ v -> setVarType v (mkUsgTy u2 (annotManyN (varType v)))))
+ v1ss
+ ve3 = extendVarEnv ve v1 v2
+ eyhf4s <- mapM (\ (v1s,v2s,e) -> usgInfCE (ve3 `plusVarEnv` (zipVarEnv v1s v2s)) e)
+ (zip3 v1ss v2ss es)
+ let (e4s,y4us,h4s,f4s) = unzip4 eyhf4s
+ y5u <- annotTy (Left e0) (unannotTy (head y4us))
+ let h5s = zipWith usgSubTy y4us (repeat y5u)
+ h6s = zipWith occChksUConSet v2ss f4s
+ f4 = foldl1 maxMS (zipWith delsFromMS f4s v2ss)
+ h7 = occChkUConSet v2 (f4 `plusMS` (unitMS v2))
+ ASSERT( isUsgTy y5u )
+ return (Case e2 v2 (zip3 cs v2ss e4s),
+ y5u,
+ unionUCSs (h2:h3:h7:(h4s ++ h5s ++ h6s)),
+ f2 `plusMS` (f4 `delFromMS` v2))
+
+usgInfCE ve e0@(Note note ea)
+ = do (e1,y1u,h1,f1) <- usgInfCE ve ea
+ case note of
+ Coerce yb ya -> do let (u1,y1) = splitUsgTy y1u
+ ya3 = annotManyN ya -- really nasty type
+ h3 = usgEqTy y1 ya3 -- messy but OK
+ yb3 <- annotTyN (Left e0) yb
-- What this says is that a Coerce does the most general possible
-- annotation to what's inside it (nasty, nasty), because no information
-- can pass through a Coerce. It of course simply ignores the info
-- that filters down through into ty1, because it can do nothing with it.
-- It does still pass through the topmost usage annotation, though.
- ; return (mkUsgTy u2 ty1,
- unionUCSs [ucs2,ucs3,ucs4,ucs5],
- fv2)
- }
+ return (Note (Coerce yb3 ya3) e1,
+ mkUsgTy u1 yb3,
+ unionUCSs [h1,h3],
+ f1)
+
+ SCC _ -> return (Note note e1, y1u, h1, f1)
+
+ InlineCall -> return (Note note e1, y1u, h1, f1)
-usgInfCE (Note InlineCall e) = usgInfCE e
+ InlineMe -> return (Note note e1, y1u, h1, f1)
-usgInfCE (Note InlineMe e) = usgInfCE e
+ TermUsg _ -> pprPanic "usgInfCE:Note TermUsg" $ ppr e0
+
+usgInfCE ve e0@(Type _)
+ = pprPanic "usgInfCE:Type" $ ppr e0
+\end{code}
-usgInfCE (Note (TermUsg u) e) = pprTrace "usgInfCE: ignoring extra TermUsg:" (ppr u) $
- usgInfCE e
-usgInfCE (Type ty) = panic "usgInfCE: unexpected Type"
+\begin{code}
+lookupVar :: VarEnv Var -> Var -> Var
+-- if variable in VarEnv then return annotated version,
+-- otherwise it's imported and already annotated so leave alone.
+--lookupVar ve v = error "lookupVar unimplemented"
+lookupVar ve v = case lookupVarEnv ve v of
+ Just v' -> v'
+ Nothing -> ASSERT( not (isLocallyDefined v) || (idMustBeINLINEd v) )
+ ASSERT( isUsgTy (varType v) )
+ v
+
+instVar :: Var -> UniqSMM Var
+-- instantiate variable with rho-type, giving it a fresh sigma-type
+instVar v = do let (uvs,ty) = splitUsForAllTys (varType v)
+ case uvs of
+ [] -> return v
+ _ -> do uvs' <- mapM (\_ -> newVarUSMM (Left (Var v))) uvs
+ let ty' = substUsTy (zipVarEnv uvs uvs') ty
+ return (setVarType v ty')
+
+annotVar :: Var -> UniqSMM (Var,Type)
+-- freshly annotates a variable and returns it along with its new type
+annotVar v = do y1u <- annotTy (Left (Var v)) (varType v)
+ return (setVarType v y1u, y1u)
\end{code}
+
+The closure operation, which does the generalisation at let bindings.
+
+\begin{code}
+usgClos :: VarEnv Var -- environment to close with respect to
+ -> Type -- type to close (sigma)
+ -> UConSet -- constraint set to reduce
+ -> (Type, -- closed type (rho)
+ UConSet) -- residual constraint set
+
+usgClos _ve ty ucs = (ty,ucs) -- dummy definition; no generalisation at all
+
+ -- hmm! what if it sets some uvars to 1 or omega?
+ -- (should it do substitution here, or return a substitution,
+ -- or should it leave all that work to the end and just use
+ -- an "=" constraint here for now?)
+\end{code}
+
+The pessimise operation, which generates constraints to pessimise an
+id (applied to exported ids, to ensure that they have fully general
+types, since we don't know how they will be used in other modules).
+
+\begin{code}
+pessimise :: Type -> UConSet
+
+pessimise ty
+ = pess True emptyVarEnv ty
+
+ where
+ pess :: Bool -> UVarSet -> Type -> UConSet
+ pess co ve (NoteTy (UsgForAll uv) ty)
+ = pess co (ve `extendVarSet` uv) ty
+ pess co ve ty0@(NoteTy (UsgNote u) ty)
+ = pessN co ve ty `unionUCS`
+ (case (co,u) of
+ (False,_ ) -> emptyUConSet
+ (True ,UsMany ) -> emptyUConSet
+ (True ,UsOnce ) -> pprPanic "pessimise: can't force:" (ppr ty0)
+ (True ,UsVar uv) -> if uv `elemVarSet` ve
+ then emptyUConSet -- if bound by \/u, no need to pessimise
+ else eqManyUConSet u)
+ pess _ _ ty0
+ = pprPanic "pessimise: missing annot:" (ppr ty0)
+
+ pessN :: Bool -> UVarSet -> Type -> UConSet
+ pessN co ve (NoteTy (UsgForAll uv) ty) = pessN co (ve `extendVarSet` uv) ty
+ pessN co ve ty0@(NoteTy (UsgNote _) _ ) = pprPanic "pessimise: unexpected annot:" (ppr ty0)
+ pessN co ve (NoteTy (SynNote sty) ty) = pessN co ve sty `unionUCS` pessN co ve ty
+ pessN co ve (NoteTy (FTVNote _) ty) = pessN co ve ty
+ pessN co ve (TyVarTy _) = emptyUConSet
+ pessN co ve (AppTy _ _) = emptyUConSet
+ pessN co ve (TyConApp tc tys) = ASSERT( not((isFunTyCon tc)&&(length tys > 1)) )
+ emptyUConSet
+ pessN co ve (FunTy ty1 ty2) = pess (not co) ve ty1 `unionUCS` pess co ve ty2
+ pessN co ve (ForAllTy _ ty) = pessN co ve ty
+\end{code}
+
+
+
======================================================================
Helper functions
If a variable appears more than once in an fv set, force its usage to be Many.
\begin{code}
-occChkUConSet :: IdOrTyVar
+occChkUConSet :: Var
-> VarMultiset
-> UConSet
occChkUConSet v fv = if occInMS v fv > 1
- then eqManyUConSet ((tyUsg . varType) v)
+ then ASSERT2( isUsgTy (varType v), ppr v )
+ eqManyUConSet ((tyUsg . varType) v)
else emptyUConSet
-occChksUConSet :: [IdOrTyVar]
+occChksUConSet :: [Var]
-> VarMultiset
-> UConSet
attached to them. We build one out of a @VarEnv@.
\begin{code}
-type VarMultiset = VarEnv (IdOrTyVar,Int) -- I guess 536 870 911 occurrences is enough
+type VarMultiset = VarEnv (Var,Int) -- I guess 536 870 911 occurrences is enough
emptyMS = emptyVarEnv
unitMS v = unitVarEnv v (v,1)
delFromMS = delVarEnv
+delsFromMS = delVarEnvList
plusMS :: VarMultiset -> VarMultiset -> VarMultiset
plusMS = plusVarEnv_C (\ (v,n) (_,m) -> (v,n+m))
maxMS :: VarMultiset -> VarMultiset -> VarMultiset
import UsageSPUtils
import CoreSyn
-import Type ( Type(..), TyNote(..), UsageAnn(..), isUsgTy, tyUsg )
+import TypeRep ( Type(..), TyNote(..) ) -- friend
+import Type ( UsageAnn(..), isUsgTy, tyUsg )
import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
import Var ( IdOrTyVar, varType, idInfo )
import IdInfo ( LBVarInfo(..), lbvarInfo )
This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
September 1998 .. May 1999.
-Keith Wansbrough 1998-09-04..1999-06-25
+Keith Wansbrough 1998-09-04..1999-07-07
\begin{code}
module UsageSPUtils ( AnnotM(AnnotM), initAnnotM,
MungeFlags(isSigma,isLocal,isExp,hasUsg,mfLoc),
doAnnotBinds, doUnAnnotBinds,
- annotMany, annotManyN, unannotTy, freshannotTy,
+ annotTy, annotTyN, annotMany, annotManyN, unannotTy, freshannotTy,
newVarUs, newVarUSMM,
UniqSMM, usToUniqSMM, uniqSMMToUs,
import Var ( IdOrTyVar, varName, varType, setVarType, mkUVar )
import Id ( idMustBeINLINEd, isExportedId )
import Name ( isLocallyDefined )
-import Type ( Type(..), TyNote(..), UsageAnn(..), isUsgTy, splitFunTys )
+import TypeRep ( Type(..), TyNote(..) ) -- friend
+import Type ( UsageAnn(..), isUsgTy, splitFunTys )
import Subst ( substTy, mkTyVarSubst )
import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
import VarEnv
| otherwise = do { vty' <- mungeType (sigVarTyMF v) (varType v)
; return (setVarType v vty')
}
-{- #ifdef DEBUG
+{- ifdef DEBUG
; return $
pprTrace "genAnnotVar" (ppr (tyUsg vty') <+> ppr v) $
(setVarType v vty')
- #endif
+ endif
-}
\end{code}
unannotTy :: Type -> Type
-- strip all annotations
+unannotTy (NoteTy (UsgForAll uv) ty) = unannotTy ty
unannotTy (NoteTy (UsgNote _ ) ty) = unannotTy ty
unannotTy (NoteTy (SynNote sty) ty) = NoteTy (SynNote (unannotTy sty)) (unannotTy ty)
unannotTy (NoteTy note@(FTVNote _ ) ty) = NoteTy note (unannotTy ty)
#ifndef USMANY
fixAnnotTy = id
#else
+fixAnnotTy (NoteTy note@(UsgForAll uv) ty) = NoteTy note (fixAnnotTy ty)
fixAnnotTy (NoteTy note@(UsgNote _ ) ty) = NoteTy note (fixAnnotTyN ty)
fixAnnotTy ty0 = NoteTy (UsgNote UsMany) (fixAnnotTyN ty0)
projects / ghc-hetmet.git / commitdiff