From 9d787ef5a8072b6c1f576f2de1b66edfa59813ed Mon Sep 17 00:00:00 2001 From: keithw Date: Thu, 15 Jul 1999 14:08:50 +0000 Subject: [PATCH] [project @ 1999-07-15 14:08:03 by keithw] This commit makes a start at implementing polymorphic usage annotations. * The module Type has now been split into TypeRep, containing the representation Type(..) and other information for `friends' only, and Type, providing the public interface to Type. Due to a bug in the interface-file slurping prior to ghc-4.04, {-# SOURCE #-} dependencies must unfortunately still refer to TypeRep even though they are not friends. * Unfoldings in interface files now print as __U instead of __u. UpdateInfo now prints as __UA instead of __U. * A new sort of variables, UVar, in their own namespace, uvName, has been introduced for usage variables. * Usage binders __fuall uv have been introduced. Usage annotations are now __u - ty (used once), __u ! ty (used possibly many times), __u uv ty (used uv times), where uv is a UVar. __o and __m have gone. All this still lives only in a TyNote, *for now* (but not for much longer). * Variance calculation for TyCons has moved from typecheck/TcTyClsDecls to types/Variance. * Usage annotation and inference are now done together in a single pass. Provision has been made for inferring polymorphic usage annotations (with __fuall) but this has not yet been implemented. Watch this space! --- ghc/compiler/basicTypes/DataCon.hi-boot | 2 +- ghc/compiler/basicTypes/DataCon.hi-boot-5 | 2 +- ghc/compiler/basicTypes/FieldLabel.lhs | 2 +- ghc/compiler/basicTypes/IdInfo.lhs | 4 +- ghc/compiler/basicTypes/MkId.lhs | 2 +- ghc/compiler/basicTypes/OccName.lhs | 12 +- ghc/compiler/basicTypes/Var.lhs | 14 +- ghc/compiler/basicTypes/VarEnv.lhs | 2 +- ghc/compiler/basicTypes/VarSet.lhs | 5 +- ghc/compiler/coreSyn/CoreLint.lhs | 4 +- ghc/compiler/coreSyn/CoreUtils.lhs | 7 +- ghc/compiler/coreSyn/Subst.hi-boot | 4 +- ghc/compiler/coreSyn/Subst.hi-boot-5 | 4 +- ghc/compiler/coreSyn/Subst.lhs | 7 +- ghc/compiler/cprAnalysis/CprAnalyse.lhs | 6 +- ghc/compiler/deSugar/DsForeign.lhs | 4 +- ghc/compiler/deSugar/DsUtils.lhs | 2 +- ghc/compiler/hsSyn/HsTypes.lhs | 70 +++- ghc/compiler/main/CmdLineOpts.lhs | 6 +- ghc/compiler/main/MkIface.lhs | 2 +- ghc/compiler/parser/Lex.lhs | 11 +- ghc/compiler/parser/RdrHsSyn.lhs | 1 + ghc/compiler/rename/ParseIface.y | 33 +- ghc/compiler/rename/RnEnv.lhs | 4 + ghc/compiler/rename/RnHsSyn.lhs | 1 + ghc/compiler/rename/RnSource.lhs | 20 +- ghc/compiler/stgSyn/CoreToStg.lhs | 14 +- ghc/compiler/stranal/WwLib.lhs | 2 +- ghc/compiler/typecheck/TcEnv.lhs | 89 ++-- ghc/compiler/typecheck/TcIfaceSig.lhs | 7 +- ghc/compiler/typecheck/TcMonoType.lhs | 30 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 148 +------ ghc/compiler/typecheck/TcType.lhs | 9 +- ghc/compiler/typecheck/TcUnify.lhs | 6 +- ghc/compiler/types/Class.lhs | 2 +- ghc/compiler/types/PprType.hi-boot | 2 +- ghc/compiler/types/PprType.hi-boot-5 | 2 +- ghc/compiler/types/PprType.lhs | 25 +- ghc/compiler/types/TyCon.lhs | 5 +- ghc/compiler/types/Type.hi-boot | 9 - ghc/compiler/types/Type.hi-boot-5 | 7 - ghc/compiler/types/Type.lhs | 392 ++++-------------- ghc/compiler/types/TypeRep.hi-boot | 7 + ghc/compiler/types/TypeRep.hi-boot-5 | 6 + ghc/compiler/types/TypeRep.lhs | 306 ++++++++++++++ ghc/compiler/types/Unify.lhs | 5 +- ghc/compiler/types/Variance.lhs | 190 +++++++++ ghc/compiler/usageSP/UsageSPInf.lhs | 634 +++++++++++++++++------------ ghc/compiler/usageSP/UsageSPLint.lhs | 3 +- ghc/compiler/usageSP/UsageSPUtils.lhs | 13 +- 50 files changed, 1285 insertions(+), 859 deletions(-) delete mode 100644 ghc/compiler/types/Type.hi-boot delete mode 100644 ghc/compiler/types/Type.hi-boot-5 create mode 100644 ghc/compiler/types/TypeRep.hi-boot create mode 100644 ghc/compiler/types/TypeRep.hi-boot-5 create mode 100644 ghc/compiler/types/TypeRep.lhs create mode 100644 ghc/compiler/types/Variance.lhs diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot b/ghc/compiler/basicTypes/DataCon.hi-boot index 511160d..e1a6dae 100644 --- a/ghc/compiler/basicTypes/DataCon.hi-boot +++ b/ghc/compiler/basicTypes/DataCon.hi-boot @@ -3,4 +3,4 @@ _exports_ DataCon DataCon dataConType ; _declarations_ 1 data DataCon ; -1 dataConType _:_ DataCon -> Type.Type ;; +1 dataConType _:_ DataCon -> TypeRep.Type ;; diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot-5 b/ghc/compiler/basicTypes/DataCon.hi-boot-5 index e641a92..31963e3 100644 --- a/ghc/compiler/basicTypes/DataCon.hi-boot-5 +++ b/ghc/compiler/basicTypes/DataCon.hi-boot-5 @@ -1,4 +1,4 @@ __interface DataCon 1 0 where __export DataCon DataCon dataConType ; 1 data DataCon ; -1 dataConType :: DataCon -> Type.Type ; +1 dataConType :: DataCon -> TypeRep.Type ; diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index 3a9ec6d..a0a85dd 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -8,7 +8,7 @@ module FieldLabel where #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 diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 52a4ad5..9209295 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -346,6 +346,7 @@ seqInlinePrag other = () 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") @@ -500,7 +501,8 @@ Text instance so that the update annotations can be read in. \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} %************************************************************************ diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 2fffbfc..20cdf6c 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -353,7 +353,7 @@ mkNewTySelId field_label selector_ty = sel_id [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} diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 0735434..d2c28f1 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -8,7 +8,7 @@ module OccName ( -- The NameSpace type; abstact NameSpace, tcName, clsName, tcClsName, dataName, varName, tvName, - nameSpaceString, + uvName, nameSpaceString, -- The OccName type OccName, -- Abstract, instance of Outputable @@ -19,7 +19,7 @@ module OccName ( mkDictOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, - isTvOcc, isDataOcc, isDataSymOcc, isSymOcc, + isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, setOccNameSpace, @@ -84,6 +84,7 @@ pprEncodedFS fs 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 ) @@ -96,6 +97,7 @@ tcClsName = TcClsName -- Not sure which! dataName = DataName tvName = TvName +uvName = UvName varName = VarName @@ -103,6 +105,7 @@ nameSpaceString :: NameSpace -> String nameSpaceString DataName = "Data constructor" nameSpaceString VarName = "Variable" nameSpaceString TvName = "Type variable" +nameSpaceString UvName = "Usage variable" nameSpaceString TcClsName = "Type constructor or class" \end{code} @@ -211,11 +214,14 @@ occNameFlavour (OccName sp _) = nameSpaceString sp \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) diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index d80eab6..3a070e7 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -21,7 +21,7 @@ module Var ( -- UVars UVar, isUVar, - mkUVar, + mkUVar, mkNamedUVar, -- Ids Id, DictId, @@ -32,7 +32,7 @@ module Var ( #include "HsVersions.h" -import {-# SOURCE #-} Type( Type, Kind ) +import {-# SOURCE #-} TypeRep( Type, Kind ) import {-# SOURCE #-} IdInfo( IdInfo, seqIdInfo ) import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey ) @@ -232,6 +232,16 @@ mkUVar :: Unique -> UVar 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} diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index 0b3d921..0088812 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -28,7 +28,7 @@ module VarEnv ( #include "HsVersions.h" import {-# SOURCE #-} CoreSyn( CoreExpr ) -import {-# SOURCE #-} Type( Type ) +import {-# SOURCE #-} TypeRep( Type ) import OccName ( TidyOccEnv, emptyTidyOccEnv ) import Var ( Var, Id, IdOrTyVar ) diff --git a/ghc/compiler/basicTypes/VarSet.lhs b/ghc/compiler/basicTypes/VarSet.lhs index 18579d3..cf4f5df 100644 --- a/ghc/compiler/basicTypes/VarSet.lhs +++ b/ghc/compiler/basicTypes/VarSet.lhs @@ -5,7 +5,7 @@ \begin{code} module VarSet ( - VarSet, IdSet, TyVarSet, IdOrTyVarSet, + VarSet, IdSet, TyVarSet, IdOrTyVarSet, UVarSet, emptyVarSet, unitVarSet, mkVarSet, extendVarSet, elemVarSet, varSetElems, subVarSet, @@ -21,7 +21,7 @@ module VarSet ( #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 ) @@ -39,6 +39,7 @@ type VarSet = UniqSet Var type IdSet = UniqSet Id type TyVarSet = UniqSet TyVar type IdOrTyVarSet = UniqSet IdOrTyVar +type UVarSet = UniqSet UVar emptyVarSet :: VarSet intersectVarSet :: VarSet -> VarSet -> VarSet diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index fb9f014..f778d0d 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -32,7 +32,7 @@ import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message, 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, @@ -238,7 +238,7 @@ lintCoreExpr (Note (Coerce to_ty from_ty) expr) = 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) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 9b9b03c..fb0b0eb 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -62,10 +62,11 @@ coreExprType :: CoreExpr -> Type 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 @@ -439,7 +440,7 @@ eqExpr e1 e2 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} diff --git a/ghc/compiler/coreSyn/Subst.hi-boot b/ghc/compiler/coreSyn/Subst.hi-boot index fcc7b82..fe12bad 100644 --- a/ghc/compiler/coreSyn/Subst.hi-boot +++ b/ghc/compiler/coreSyn/Subst.hi-boot @@ -2,6 +2,6 @@ _interface_ Subst 1 _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 ;; diff --git a/ghc/compiler/coreSyn/Subst.hi-boot-5 b/ghc/compiler/coreSyn/Subst.hi-boot-5 index 147065a..e959642 100644 --- a/ghc/compiler/coreSyn/Subst.hi-boot-5 +++ b/ghc/compiler/coreSyn/Subst.hi-boot-5 @@ -1,6 +1,6 @@ __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 ; diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 7bc2c10..6974223 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -36,7 +36,9 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr, emptyCoreRules, isEmptyCoreRules, seqRules ) import CoreFVs ( exprFreeVars ) -import Type ( Type(..), ThetaType, TyNote(..), +import TypeRep ( Type(..), TyNote(..), + ) -- friend +import Type ( ThetaType, tyVarsOfType, tyVarsOfTypes, mkAppTy ) import VarSet @@ -218,7 +220,8 @@ subst_ty subst ty 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 diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index 7cf43ca..6ad58cd 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -15,7 +15,7 @@ import Var ( Var, Id, TyVar, idType, varName, varType ) 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 ) @@ -365,8 +365,9 @@ splitTypeToFunArgAndRes ty = (tyvars, argtys, resty) (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 @@ -378,6 +379,7 @@ splitFunTysIgnoringNewTypes ty = split ty 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 diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 1abd67f..f944581 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -30,7 +30,7 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, 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 @@ -423,7 +423,7 @@ dsFExportDynamic i ty mod_name ext_name cconv = 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 -> diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 455b41b..7cb082f 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -225,7 +225,7 @@ mkCoAlgCaseMatchResult var match_alts (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 diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index f57cbe8..dc00198 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -3,16 +3,12 @@ % \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 @@ -58,12 +54,24 @@ data HsType name | 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 @@ -156,9 +164,26 @@ ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty) 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} @@ -213,7 +238,7 @@ cmpHsType cmp (MonoDictTy c1 tys1) (MonoDictTy c2 tys2) = 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 @@ -226,9 +251,10 @@ cmpHsType cmp ty1 ty2 -- tags must be different 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 @@ -237,13 +263,19 @@ 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 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 5d06739..106d313 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -295,8 +295,8 @@ src_filename = case argv of \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") @@ -305,7 +305,7 @@ opt_D_dump_deriv = opt_D_dump_most || lookUp SLIT("-ddump-deriv") 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") diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 53a70be..e823e47 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -337,7 +337,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs 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 diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 39b2358..5528052 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -147,8 +147,8 @@ data Token | ITlit_lit | ITstring_lit | ITtypeapp - | ITonce - | ITmany + | ITusage + | ITfuall | ITarity | ITspecialise | ITnocaf @@ -182,6 +182,7 @@ data Token | ITdot | ITbiglam -- GHC-extension symbols + | IThash | ITocurly -- special symbols | ITccurly @@ -304,13 +305,13 @@ ghcExtensionKeywordsFM = listToUFM $ ("__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)), diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 25aa168..40250ee 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -157,6 +157,7 @@ extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys 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) diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 6df655d..3621264 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -5,7 +5,7 @@ module ParseIface ( parseIface, IfaceStuff(..) ) where 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(..), @@ -25,7 +25,7 @@ import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) 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 ) @@ -100,8 +100,8 @@ import Ratio ( (%) ) '__scc' { ITscc } '__sccC' { ITsccAllCafs } - '__o' { ITonce } - '__m' { ITmany } + '__u' { ITusage } + '__fuall' { ITfuall } '__A' { ITarity } '__P' { ITspecialise } @@ -401,11 +401,15 @@ field : var_names1 '::' type { ($1, Unbanged $3) } -------------------------------------------------------------------------- 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 } @@ -427,8 +431,12 @@ types2 : type ',' type { [$1,$3] } 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 } @@ -545,6 +553,17 @@ qcls_name :: { RdrName } | 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 -} } diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index f4cdea1..61dd76a 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -289,6 +289,10 @@ bindLocalsFVRn doc rdr_names enclosed_scope 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 diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index f183777..d4bcb2f 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -81,6 +81,7 @@ extractHsTyNames ty `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) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 753ab7b..702ac98 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -22,7 +22,7 @@ import HsCore 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, @@ -630,9 +630,23 @@ rnHsType doc (MonoDictTy clas tys) 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} diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 970f04f..5e8bfa7 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -39,7 +39,7 @@ import TysPrim ( intPrimTy ) 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 @@ -143,9 +143,15 @@ mkDemTy :: Demand -> Type -> RhsDemand 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)) diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index b8cf54c..c545ad5 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -501,7 +501,7 @@ mk_cpr_case (ty, cpr_info@(CPRInfo ci_args)) 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, diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 4fb993e..586c5a5 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -7,6 +7,8 @@ module TcEnv( initEnv, getEnvTyCons, getEnvClasses, getAllEnvTyCons, + tcExtendUVarEnv, tcLookupUVar, + tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars, tcLookupTy, @@ -33,7 +35,7 @@ import HsTypes ( HsTyVar, getTyVarName ) 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, @@ -136,6 +138,7 @@ Data type declarations \begin{code} data TcEnv = TcEnv + UsageEnv TypeEnv ValueEnv (TcTyVarSet, -- The in-scope TyVars @@ -145,6 +148,7 @@ data TcEnv = TcEnv type NameEnv val = UniqFM val -- Keyed by Names +type UsageEnv = NameEnv UVar type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing) type ValueEnv = NameEnv Id @@ -156,17 +160,41 @@ data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable 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 ~~~~~~~~~~~~ @@ -175,7 +203,7 @@ Extending the type environment. \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 @@ -191,7 +219,7 @@ tcExtendTyVarEnv tyvars scope -- 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 @@ -201,20 +229,20 @@ tcExtendTyVarEnv tyvars scope 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 -> @@ -231,7 +259,7 @@ the environment. \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 @@ -242,7 +270,7 @@ tcGetGlobalTyVars 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} @@ -254,11 +282,11 @@ tcExtendTypeEnv :: [(Name, (TcKind, Maybe Arity, TcTyThing))] -> TcM s r -> TcM 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} @@ -267,7 +295,7 @@ Looking up in the environments. \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 -> @@ -295,14 +323,14 @@ tcLookupTyCon name 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) @@ -320,22 +348,22 @@ tcLookupTyConByKey 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} @@ -344,7 +372,7 @@ tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found 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) @@ -353,28 +381,28 @@ tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id) 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 @@ -438,6 +466,9 @@ badCon con_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} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 556980d..4aba2a1 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -39,7 +39,7 @@ import Id ( Id, mkId, mkVanillaId, ) 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(..) ) @@ -213,7 +213,7 @@ tcCoreExpr (UfTuple name args) 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) @@ -255,7 +255,8 @@ tcCoreExpr (UfNote note expr) = 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') diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 1857850..6569592 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -13,12 +13,14 @@ module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsT #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, @@ -28,8 +30,9 @@ 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, @@ -37,7 +40,7 @@ import Type ( Type, ThetaType, ) 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 ) @@ -161,8 +164,23 @@ tc_type_kind (MonoDictTy class_name tys) 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 -> diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index e56e5ff..d3b82d6 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -30,13 +30,8 @@ import TcMonoType ( kcHsTyVar ) 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 @@ -50,7 +45,8 @@ import UniqSet ( UniqSet, emptyUniqSet, 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} @@ -334,6 +330,8 @@ get_ty (MonoTupleTy tys boxed) = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys get_ty (MonoUsgTy _ ty) = get_ty ty +get_ty (MonoUsgForAllTy _ ty) + = get_ty ty get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty get_ty (MonoDictTy name _) @@ -377,143 +375,5 @@ pp_cycle str decls \end{code} -Computing the tyConArgVrcs info -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -@tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each -tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed -separately. Note that this is information about occurrences of type -variables, not usages of term variables. - -The function @calcTyConArgVrcs@ must be passed a list of *algebraic or -syntycons only* such that all tycons referred to (by mutual recursion) -appear in the list. The fixpointing will be done on this set of -tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to -be (knot-tyingly?) stuck back into the appropriate fields. - -\begin{code} -calcTyConArgVrcs :: [TyCon] - -> FiniteMap Name ArgVrcs - -calcTyConArgVrcs tycons - = let oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons - initial tc = if isAlgTyCon tc && null (tyConDataCons tc) then - -- make pessimistic assumption (and warn) - take (tyConArity tc) abstractVrcs - else - replicate (tyConArity tc) (False,False) - oi'' = tcaoFix oi - go (tc,vrcs) = (getName tc,vrcs) - in listToFM (map go (fmToList oi'')) - - where - - tcaoFix :: FiniteMap TyCon ArgVrcs -- initial ArgVrcs per tycon - -> FiniteMap TyCon ArgVrcs -- fixpointed ArgVrcs per tycon - - tcaoFix oi = let (changed,oi') = foldFM (\ tc pms - (changed,oi') - -> let pms' = tcaoIter oi' tc -- seq not simult - in (changed || (pms /= pms'), - addToFM oi' tc pms')) - (False,oi) -- seq not simult for faster fixpting - oi - in if changed - then tcaoFix oi' - else oi' - - tcaoIter :: FiniteMap TyCon ArgVrcs -- reference ArgVrcs (initial) - -> TyCon -- tycon to update - -> ArgVrcs -- new ArgVrcs for tycon - - tcaoIter oi tc | isAlgTyCon tc - = let cs = tyConDataCons tc - vs = tyConTyVars tc - argtys = concatMap dataConRawArgTys cs - exdicttys = concatMap ((\ (_,_,_,exth,_,_) -> map (uncurry mkDictTy) exth) - . dataConSig) cs - myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $ - tyConArgVrcs_maybe tc) - tc - -- we use the already-computed result for tycons not in this SCC - in map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) (exdicttys ++ argtys)) - vs - - tcaoIter oi tc | isSynTyCon tc - = let (tyvs,ty) = getSynTyConDefn tc - myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Syn)" $ - tyConArgVrcs_maybe tc) - tc - -- we use the already-computed result for tycons not in this SCC - in map (\v -> vrcInTy myfao v ty) tyvs - - -abstractVrcs :: ArgVrcs --- we pull this out as a CAF so the warning only appears *once* -abstractVrcs = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n" - ++ "\tUse -fno-prune-tydecls to fix.") $ - repeat (True,True) -\end{code} - -And a general variance-check function. We pass a function for -determining the @ArgVrc@s of a tycon; when fixpointing this refers to -the current value; otherwise this should be looked up from the tycon's -own tyConArgVrcs. - -\begin{code} -vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion) - -> TyVar -- tyvar to check Vrcs of - -> Type -- type to check for occ in - -> (Bool,Bool) -- (occurs positively, occurs negatively) - -vrcInTy fao v (NoteTy (UsgNote _) ty) = vrcInTy fao v ty - -vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty - -- SynTyCon doesn't neccessarily have vrcInfo at this point, - -- so don't try and use it - -vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv - then vrcInTy fao v ty - else (False,False) - -- note that ftv cannot be calculated as occPos||occNeg, - -- since if a tyvar occurs only as unused tyconarg, - -- occPos==occNeg==False, but ftv=True - -vrcInTy fao v (TyVarTy v') = if v==v' - then (True,False) - else (False,False) - -vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False) - then (True,True) - else vrcInTy fao v ty1 - -- ty1 is probably unknown (or it would have been beta-reduced); - -- hence if v occurs in ty2 at all then it could occur with - -- either variance. Otherwise it occurs as it does in ty1. - -vrcInTy fao v (FunTy ty1 ty2) = let (p1,m1) = vrcInTy fao v ty1 - (p2,m2) = vrcInTy fao v ty2 - in (m1||p2,p1||m2) - -vrcInTy fao v (ForAllTy v' ty) = if v==v' - then (False,False) - else vrcInTy fao v ty - -vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys - pms2 = fao tc - in orVrcs (zipWith timesVrc pms1 pms2) - -orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) -orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2) - -orVrcs :: [(Bool,Bool)] -> (Bool,Bool) -orVrcs = foldl orVrc (False,False) - -anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool) -anyVrc p as = foldl (\pm a -> pm `orVrc` p a) (False,False) as - -timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) -timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2, - p1 && m2 || m1 && p2) -\end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 72d4eb7..95a5bdd 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -52,11 +52,13 @@ module TcType ( -- 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 ) @@ -436,6 +438,9 @@ zonkType unbound_var_fn ty 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') diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index c136846..0f037f6 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -16,10 +16,12 @@ module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, -- 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 ) diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 82f6fa5..be82f23 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -16,7 +16,7 @@ module Class ( #include "HsVersions.h" import {-# SOURCE #-} TyCon ( TyCon ) -import {-# SOURCE #-} Type ( Type ) +import {-# SOURCE #-} TypeRep ( Type ) import {-# SOURCE #-} InstEnv ( InstEnv ) import Var ( Id, TyVar ) diff --git a/ghc/compiler/types/PprType.hi-boot b/ghc/compiler/types/PprType.hi-boot index 6db121f..0d8436e 100644 --- a/ghc/compiler/types/PprType.hi-boot +++ b/ghc/compiler/types/PprType.hi-boot @@ -2,5 +2,5 @@ _interface_ PprType 1 _exports_ PprType pprType; _declarations_ -1 pprType _:_ Type.Type -> Outputable.SDoc ;; +1 pprType _:_ TypeRep.Type -> Outputable.SDoc ;; diff --git a/ghc/compiler/types/PprType.hi-boot-5 b/ghc/compiler/types/PprType.hi-boot-5 index 9619770..b08f9b8 100644 --- a/ghc/compiler/types/PprType.hi-boot-5 +++ b/ghc/compiler/types/PprType.hi-boot-5 @@ -1,4 +1,4 @@ __interface PprType 1 0 where __export PprType pprType ; -1 pprType :: Type.Type -> Outputable.SDoc ; +1 pprType :: TypeRep.Type -> Outputable.SDoc ; diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 6b1b905..116f12e 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -18,11 +18,14 @@ module PprType( -- 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 @@ -205,9 +208,18 @@ ppr_ty env ctxt_prec (NoteTy (SynNote ty) expansion) 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))) @@ -224,11 +236,12 @@ pprTyEnv = initPprEnv b b (Just ppr) b (Just (\site -> pprTyVarBndr)) b \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@} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 28eaddf..d79f003 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -41,7 +41,10 @@ module TyCon( #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 ) diff --git a/ghc/compiler/types/Type.hi-boot b/ghc/compiler/types/Type.hi-boot deleted file mode 100644 index cc55830..0000000 --- a/ghc/compiler/types/Type.hi-boot +++ /dev/null @@ -1,9 +0,0 @@ -_interface_ Type 1 -_exports_ -Type Type Kind SuperKind ; -_declarations_ -1 data Type ; -1 type Kind = Type ; -1 type SuperKind = Type ; - - diff --git a/ghc/compiler/types/Type.hi-boot-5 b/ghc/compiler/types/Type.hi-boot-5 deleted file mode 100644 index 43c7bf3..0000000 --- a/ghc/compiler/types/Type.hi-boot-5 +++ /dev/null @@ -1,7 +0,0 @@ -__interface Type 1 0 where -__export Type Type Kind SuperKind ; -1 data Type ; -1 type Kind = Type ; -1 type SuperKind = Type ; - - diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 5b4aa54..fde23a9 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -1,11 +1,12 @@ % % (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 @@ -21,13 +22,15 @@ module Type ( 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, @@ -35,7 +38,8 @@ module Type ( 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, @@ -66,231 +70,53 @@ module Type ( #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 @@ -306,21 +132,6 @@ 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} %* * %************************************************************************ @@ -626,10 +437,11 @@ NB: Invariant: if present, usage note is at the very top of the type. 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 @@ -646,16 +458,18 @@ isUsgTy :: Type -> Bool #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, @@ -663,7 +477,8 @@ isNotUsgTy other = True 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 @@ -684,8 +499,38 @@ unUsgTy 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} --------------------------------------------------------------------- @@ -747,11 +592,12 @@ Applying a for-all to its arguments \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 @@ -760,30 +606,25 @@ 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} @@ -873,6 +714,7 @@ tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys 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 @@ -883,9 +725,10 @@ tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys -- 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 @@ -956,6 +799,7 @@ tidyType env@(tidy_env, subst) ty 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} @@ -1026,64 +870,6 @@ typePrimRep ty = case splitTyConApp_maybe ty of 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} - %************************************************************************ %* * diff --git a/ghc/compiler/types/TypeRep.hi-boot b/ghc/compiler/types/TypeRep.hi-boot new file mode 100644 index 0000000..68e5167 --- /dev/null +++ b/ghc/compiler/types/TypeRep.hi-boot @@ -0,0 +1,7 @@ +_interface_ TypeRep 1 +_exports_ TypeRep Type Kind SuperKind ; +_declarations_ +1 data Type ; +1 type Kind = Type ; +1 type SuperKind = Type ;; + diff --git a/ghc/compiler/types/TypeRep.hi-boot-5 b/ghc/compiler/types/TypeRep.hi-boot-5 new file mode 100644 index 0000000..f12a1df --- /dev/null +++ b/ghc/compiler/types/TypeRep.hi-boot-5 @@ -0,0 +1,6 @@ +__interface TypeRep 1 0 where +__export TypeRep Type Kind SuperKind ; +1 data Type ; +1 type Kind = Type ; +1 type SuperKind = Type ; + diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs new file mode 100644 index 0000000..d4902ad --- /dev/null +++ b/ghc/compiler/types/TypeRep.lhs @@ -0,0 +1,306 @@ +% +% (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} + diff --git a/ghc/compiler/types/Unify.lhs b/ghc/compiler/types/Unify.lhs index 97a5481..bd9cde1 100644 --- a/ghc/compiler/types/Unify.lhs +++ b/ghc/compiler/types/Unify.lhs @@ -11,8 +11,9 @@ module Unify ( unifyTysX, unifyTyListsX, 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 ) diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs new file mode 100644 index 0000000..e3b34eb --- /dev/null +++ b/ghc/compiler/types/Variance.lhs @@ -0,0 +1,190 @@ +% +% (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} diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index 88b7162..160dbc6 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -6,7 +6,7 @@ This code is (based on) PhD work of Keith Wansbrough , 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 @@ -18,20 +18,27 @@ import UsageSPLint 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 ) @@ -46,13 +53,17 @@ For full details, see _Once Upon a Polymorphic Type_, University of 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. @@ -64,8 +75,9 @@ not allowed to alter. 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 @@ -79,21 +91,20 @@ doUsageSPInf :: UniqSupply 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 @@ -111,259 +122,352 @@ doUsageSPInf us binds = do 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 @@ -372,15 +476,16 @@ 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 @@ -511,11 +616,12 @@ A @VarMultiset@ is what it says: a set of variables with counts 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 diff --git a/ghc/compiler/usageSP/UsageSPLint.lhs b/ghc/compiler/usageSP/UsageSPLint.lhs index 5e74b74..ae2436e 100644 --- a/ghc/compiler/usageSP/UsageSPLint.lhs +++ b/ghc/compiler/usageSP/UsageSPLint.lhs @@ -19,7 +19,8 @@ module UsageSPLint ( doLintUSPAnnotsBinds, 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 ) diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index 6f7c636..e41609a 100644 --- a/ghc/compiler/usageSP/UsageSPUtils.lhs +++ b/ghc/compiler/usageSP/UsageSPUtils.lhs @@ -6,7 +6,7 @@ This code is (based on) PhD work of Keith Wansbrough , 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, @@ -14,7 +14,7 @@ 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, @@ -29,7 +29,8 @@ import Const ( Con(..), Literal(..) ) 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 @@ -326,11 +327,11 @@ genAnnotVar mungeType v | isTyVar v = return v | 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} @@ -459,6 +460,7 @@ unTermUsg _ = panic "unTermUsg" 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) @@ -474,6 +476,7 @@ fixAnnotTy :: Type -> Type #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) -- 1.7.10.4