From bca9dd54c2b39638cb4638aaccf6015a104a1df5 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 7 Nov 2000 15:21:43 +0000 Subject: [PATCH] [project @ 2000-11-07 15:21:38 by simonmar] This commit completes the merge of compiler part of the HEAD with the before-ghci-branch to before-ghci-branch-merged. --- ghc/compiler/HsVersions.h | 9 + ghc/compiler/basicTypes/Id.lhs | 52 ++-- ghc/compiler/basicTypes/IdInfo.lhs | 108 +++++++- ghc/compiler/basicTypes/MkId.lhs | 33 ++- ghc/compiler/basicTypes/OccName.lhs | 14 +- ghc/compiler/basicTypes/Var.hi-boot | 1 - ghc/compiler/basicTypes/Var.hi-boot-5 | 1 - ghc/compiler/basicTypes/Var.lhs | 43 ---- ghc/compiler/basicTypes/VarSet.lhs | 5 +- ghc/compiler/codeGen/CgCase.lhs | 4 +- ghc/compiler/coreSyn/CoreSyn.lhs | 5 +- ghc/compiler/coreSyn/CoreUtils.lhs | 15 +- ghc/compiler/coreSyn/PprCore.lhs | 13 +- ghc/compiler/coreSyn/Subst.lhs | 32 ++- ghc/compiler/deSugar/Check.lhs | 6 +- ghc/compiler/deSugar/DsExpr.lhs | 12 +- ghc/compiler/deSugar/DsForeign.lhs | 16 +- ghc/compiler/deSugar/DsListComp.lhs | 81 +++++- ghc/compiler/deSugar/DsUtils.lhs | 14 +- ghc/compiler/ghci/StgInterp.lhs | 58 ++--- ghc/compiler/hsSyn/HsCore.lhs | 78 ++++-- ghc/compiler/hsSyn/HsDecls.lhs | 29 ++- ghc/compiler/hsSyn/HsExpr.lhs | 8 +- ghc/compiler/hsSyn/HsSyn.lhs | 3 +- ghc/compiler/hsSyn/HsTypes.lhs | 152 ++++++------ ghc/compiler/main/CmdLineOpts.lhs | 2 + ghc/compiler/main/CodeOutput.lhs | 3 +- ghc/compiler/parser/Parser.y | 16 +- ghc/compiler/parser/RdrHsSyn.lhs | 2 - ghc/compiler/prelude/PrelNames.lhs | 66 ++++- ghc/compiler/prelude/PrimOp.lhs | 12 +- ghc/compiler/prelude/TysPrim.lhs | 66 ++--- ghc/compiler/prelude/primops.txt | 18 +- ghc/compiler/rename/ParseIface.y | 85 ++++--- ghc/compiler/rename/RnEnv.lhs | 10 +- ghc/compiler/rename/RnExpr.lhs | 53 ++-- ghc/compiler/rename/RnHsSyn.lhs | 2 - ghc/compiler/rename/RnIfaces.lhs | 2 +- ghc/compiler/rename/RnSource.lhs | 23 +- ghc/compiler/simplCore/FloatIn.lhs | 5 - ghc/compiler/simplCore/SimplUtils.lhs | 29 ++- ghc/compiler/simplCore/Simplify.lhs | 2 +- ghc/compiler/specialise/Rules.lhs | 2 +- ghc/compiler/stgSyn/CoreToStg.lhs | 38 ++- ghc/compiler/typecheck/TcClassDcl.lhs | 42 ++-- ghc/compiler/typecheck/TcExpr.lhs | 14 +- ghc/compiler/typecheck/TcHsSyn.lhs | 9 + ghc/compiler/typecheck/TcIfaceSig.lhs | 8 +- ghc/compiler/typecheck/TcInstDcls.lhs | 10 +- ghc/compiler/typecheck/TcMatches.lhs | 84 +++++-- ghc/compiler/typecheck/TcModule.lhs | 8 - ghc/compiler/typecheck/TcMonoType.lhs | 383 +++++++++++++++++------------ ghc/compiler/typecheck/TcTyClsDecls.lhs | 46 ++-- ghc/compiler/typecheck/TcTyDecls.lhs | 60 ++--- ghc/compiler/typecheck/TcType.lhs | 21 +- ghc/compiler/typecheck/TcUnify.lhs | 13 +- ghc/compiler/types/Generics.lhs | 137 ++++++++--- ghc/compiler/types/PprType.lhs | 71 +++--- ghc/compiler/types/TyCon.lhs | 2 - ghc/compiler/types/Type.lhs | 408 +++++++++++++++++-------------- ghc/compiler/types/TypeRep.lhs | 63 +++-- ghc/compiler/types/Unify.lhs | 79 ++++-- ghc/compiler/types/Variance.lhs | 36 +-- ghc/compiler/usageSP/UConSet.lhs | 16 +- ghc/compiler/usageSP/UsageSPInf.lhs | 19 +- ghc/compiler/usageSP/UsageSPLint.lhs | 16 +- ghc/compiler/usageSP/UsageSPUtils.lhs | 18 +- 67 files changed, 1677 insertions(+), 1114 deletions(-) diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index 3da1db1..abcaa99 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -28,6 +28,15 @@ name = global (value) :: IORef (ty); \ #define WARN(e,msg) #endif +-- temporary usage assertion control KSW 2000-10 +#ifdef DO_USAGES +#define UASSERT(e) ASSERT(e) +#define UASSERT2(e,msg) ASSERT2(e,msg) +#else +#define UASSERT(e) +#define UASSERT2(e,msg) +#endif + #if __STDC__ #define CAT2(a,b)a##b #else diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 28bc5da..7faafba 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -47,6 +47,7 @@ module Id ( setIdArityInfo, setIdDemandInfo, setIdStrictness, + setIdTyGenInfo, setIdWorkerInfo, setIdSpecialisation, setIdCafInfo, @@ -57,6 +58,7 @@ module Id ( idFlavour, idDemandInfo, idStrictness, + idTyGenInfo, idWorkerInfo, idUnfolding, idSpecialisation, @@ -82,14 +84,15 @@ import Var ( Id, DictId, ) import VarSet import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, - seqType, splitTyConApp_maybe ) + usOnce, seqType, splitTyConApp_maybe ) import IdInfo import Demand ( Demand ) import Name ( Name, OccName, mkSysLocalName, mkLocalName, - isUserExportedName, getOccName, isIPOcc + isUserExportedName, nameIsLocallyDefined, + getOccName, isIPOcc ) import OccName ( UserFS ) import PrimRep ( PrimRep ) @@ -98,11 +101,13 @@ import FieldLabel ( FieldLabel ) import SrcLoc ( SrcLoc ) import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques, getNumBuiltinUniques ) +import Outputable infixl 1 `setIdUnfolding`, `setIdArityInfo`, `setIdDemandInfo`, `setIdStrictness`, + `setIdTyGenInfo`, `setIdWorkerInfo`, `setIdSpecialisation`, `setInlinePragma`, @@ -272,7 +277,15 @@ in some other interface unfolding. \begin{code} omitIfaceSigForId :: Id -> Bool omitIfaceSigForId id - | otherwise + = ASSERT2( not (omit && nameIsLocallyDefined (idName id) + && idTyGenInfo id /= TyGenNever), + ppr id ) + -- mustn't omit type signature for a name whose type might change! + omit + where + omit = omitIfaceSigForId' id + +omitIfaceSigForId' id = case idFlavour id of RecordSelId _ -> True -- Includes dictionary selectors PrimOpId _ -> True @@ -332,6 +345,14 @@ isBottomingId :: Id -> Bool isBottomingId id = isBottomingStrictness (idStrictness id) --------------------------------- + -- TYPE GENERALISATION +idTyGenInfo :: Id -> TyGenInfo +idTyGenInfo id = tyGenInfo (idInfo id) + +setIdTyGenInfo :: Id -> TyGenInfo -> Id +setIdTyGenInfo id tygen_info = modifyIdInfo (`setTyGenInfo` tygen_info) id + + --------------------------------- -- WORKER ID idWorkerInfo :: Id -> WorkerInfo idWorkerInfo id = workerInfo (idInfo id) @@ -413,11 +434,14 @@ idLBVarInfo :: Id -> LBVarInfo idLBVarInfo id = lbvarInfo (idInfo id) isOneShotLambda :: Id -> Bool -isOneShotLambda id = case idLBVarInfo id of - IsOneShotLambda -> True - NoLBVarInfo -> case splitTyConApp_maybe (idType id) of - Just (tycon,_) -> tycon == statePrimTyCon - other -> False +isOneShotLambda id = analysis || hack + where analysis = case idLBVarInfo id of + LBVarInfo u | u == usOnce -> True + other -> False + hack = case splitTyConApp_maybe (idType id) of + Just (tycon,_) | tycon == statePrimTyCon -> True + other -> False + -- The last clause is a gross hack. It claims that -- every function over realWorldStatePrimTy is a one-shot -- function. This is pretty true in practice, and makes a big @@ -437,7 +461,7 @@ isOneShotLambda id = case idLBVarInfo id of -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. setOneShotLambda :: Id -> Id -setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id +setOneShotLambda id = modifyIdInfo (`setLBVarInfo` LBVarInfo usOnce) id clearOneShotLambda :: Id -> Id clearOneShotLambda id @@ -457,13 +481,3 @@ zapLamIdInfo :: Id -> Id zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id \end{code} - - - - - - - - - - diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 3fe281a..1fdf18e 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -29,9 +29,13 @@ module IdInfo ( StrictnessInfo(..), mkStrictnessInfo, noStrictnessInfo, ppStrictnessInfo,isBottomingStrictness, - strictnessInfo, setStrictnessInfo, + -- Usage generalisation + TyGenInfo(..), + tyGenInfo, setTyGenInfo, + noTyGenInfo, isNoTyGenInfo, ppTyGenInfo, tyGenInfoString, + -- Worker WorkerInfo(..), workerExists, wrapperArity, workerId, workerInfo, setWorkerInfo, ppWorkerInfo, @@ -69,6 +73,7 @@ module IdInfo ( import CoreSyn +import Type ( Type, usOnce ) import PrimOp ( PrimOp ) import Var ( Id ) import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker, @@ -78,10 +83,13 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea ) import DataCon ( DataCon ) import FieldLabel ( FieldLabel ) +import Type ( usOnce, usMany ) import Demand -- Lots of stuff import Outputable +import Util ( seqList ) infixl 1 `setDemandInfo`, + `setTyGenInfo`, `setStrictnessInfo`, `setSpecInfo`, `setArityInfo`, @@ -89,6 +97,7 @@ infixl 1 `setDemandInfo`, `setUnfoldingInfo`, `setCprInfo`, `setWorkerInfo`, + `setLBVarInfo`, `setCafInfo`, `setOccInfo` -- infixl so you can say (id `set` a `set` b) @@ -118,6 +127,7 @@ data IdInfo arityInfo :: ArityInfo, -- Its arity demandInfo :: Demand, -- Whether or not it is definitely demanded specInfo :: CoreRules, -- Specialisations of this function which exist + tyGenInfo :: TyGenInfo, -- Restrictions on usage-generalisation of this Id strictnessInfo :: StrictnessInfo, -- Strictness properties workerInfo :: WorkerInfo, -- Pointer to Worker Function unfoldingInfo :: Unfolding, -- Its unfolding @@ -137,6 +147,7 @@ megaSeqIdInfo info seqArity (arityInfo info) `seq` seqDemand (demandInfo info) `seq` seqRules (specInfo info) `seq` + seqTyGenInfo (tyGenInfo info) `seq` seqStrictnessInfo (strictnessInfo info) `seq` seqWorker (workerInfo info) `seq` @@ -155,6 +166,7 @@ Setters \begin{code} setWorkerInfo info wk = wk `seq` info { workerInfo = wk } setSpecInfo info sp = PSEQ sp (info { specInfo = sp }) +setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg } setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } setOccInfo info oc = oc `seq` info { occInfo = oc } setStrictnessInfo info st = st `seq` info { strictnessInfo = st } @@ -203,6 +215,7 @@ mkIdInfo flv = IdInfo { arityInfo = UnknownArity, demandInfo = wwLazy, specInfo = emptyCoreRules, + tyGenInfo = noTyGenInfo, workerInfo = NoWorker, strictnessInfo = NoStrictnessInfo, unfoldingInfo = noUnfolding, @@ -349,6 +362,83 @@ instance Show InlinePragInfo where %************************************************************************ +%* * +\subsection[TyGen-IdInfo]{Type generalisation info about an @Id@} +%* * +%************************************************************************ + +Certain passes (notably usage inference) may change the type of an +identifier, modifying all in-scope uses of that identifier +appropriately to maintain type safety. + +However, some identifiers must not have their types changed in this +way, because their types are conjured up in the front end of the +compiler rather than being read from the interface file. Default +methods, dictionary functions, record selectors, and others are in +this category. (see comment at TcClassDcl.tcClassSig). + +To indicate this property, such identifiers are marked TyGenNever. + +Furthermore, if the usage inference generates a usage-specialised +variant of a function, we must NOT re-infer a fully-generalised type +at the next inference. This finer property is indicated by a +TyGenUInfo on the identifier. + +\begin{code} +data TyGenInfo + = NoTyGenInfo -- no restriction on type generalisation + + | TyGenUInfo [Maybe Type] -- restrict generalisation of this Id to + -- preserve specified usage annotations + + | TyGenNever -- never generalise the type of this Id + + deriving ( Eq ) +\end{code} + +For TyGenUInfo, the list has one entry for each usage annotation on +the type of the Id, in left-to-right pre-order (annotations come +before the type they annotate). Nothing means no restriction; Just +usOnce or Just usMany forces that annotation to that value. Other +usage annotations are illegal. + +\begin{code} +seqTyGenInfo :: TyGenInfo -> () +seqTyGenInfo NoTyGenInfo = () +seqTyGenInfo (TyGenUInfo us) = seqList us () +seqTyGenInfo TyGenNever = () + +noTyGenInfo :: TyGenInfo +noTyGenInfo = NoTyGenInfo + +isNoTyGenInfo :: TyGenInfo -> Bool +isNoTyGenInfo NoTyGenInfo = True +isNoTyGenInfo _ = False + +-- NB: There's probably no need to write this information out to the interface file. +-- Why? Simply because imported identifiers never get their types re-inferred. +-- But it's definitely nice to see in dumps, it for debugging purposes. + +ppTyGenInfo :: TyGenInfo -> SDoc +ppTyGenInfo NoTyGenInfo = empty +ppTyGenInfo (TyGenUInfo us) = ptext SLIT("__G") <+> text (tyGenInfoString us) +ppTyGenInfo TyGenNever = ptext SLIT("__G N") + +tyGenInfoString us = map go us + where go Nothing = 'x' -- for legibility, choose + go (Just u) | u == usOnce = '1' -- chars with identity + | u == usMany = 'M' -- Z-encoding. + go other = pprPanic "IdInfo.tyGenInfoString: unexpected annotation" (ppr other) + +instance Outputable TyGenInfo where + ppr = ppTyGenInfo + +instance Show TyGenInfo where + showsPrec p c = showsPrecSDoc p (ppr c) +\end{code} + + +%************************************************************************ %* * \subsection[worker-IdInfo]{Worker info about an @Id@} %* * @@ -495,8 +585,10 @@ work. data LBVarInfo = NoLBVarInfo - | IsOneShotLambda -- The lambda that binds this Id is applied - -- at most once + | LBVarInfo Type -- The lambda that binds this Id has this usage + -- annotation (i.e., if ==usOnce, then the + -- lambda is applied at most once). + -- The annotation's kind must be `$' -- HACK ALERT! placing this info here is a short-term hack, -- but it minimises changes to the rest of the compiler. -- Hack agreed by SLPJ/KSW 1999-04. @@ -510,9 +602,13 @@ noLBVarInfo = NoLBVarInfo -- not safe to print or parse LBVarInfo because it is not really a -- property of the definition, but a property of the context. pprLBVarInfo NoLBVarInfo = empty -pprLBVarInfo IsOneShotLambda = getPprStyle $ \ sty -> - if ifaceStyle sty then empty - else ptext SLIT("OneShot") +pprLBVarInfo (LBVarInfo u) | u == usOnce + = getPprStyle $ \ sty -> + if ifaceStyle sty + then empty + else ptext SLIT("OneShot") + | otherwise + = empty instance Outputable LBVarInfo where ppr = pprLBVarInfo diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 022877c..1f29b86 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -43,8 +43,7 @@ import Rules ( addRule ) import Type ( Type, ThetaType, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, - splitFunTys, splitForAllTys, unUsgTy, - mkUsgTy, UsageAnn(..) + splitFunTys, splitForAllTys ) import Module ( Module ) import CoreUtils ( exprType, mkInlineMe ) @@ -79,9 +78,9 @@ import Id ( idType, mkId, ) import IdInfo ( IdInfo, vanillaIdInfo, mkIdInfo, exactArity, setUnfoldingInfo, setCafInfo, setCprInfo, - setArityInfo, setSpecInfo, + setArityInfo, setSpecInfo, setTyGenInfo, mkStrictnessInfo, setStrictnessInfo, - IdFlavour(..), CafInfo(..), CprInfo(..) + IdFlavour(..), CafInfo(..), CprInfo(..), TyGenInfo(..) ) import FieldLabel ( mkFieldLabel, fieldLabelName, firstFieldLabelTag, allFieldLabelTags, fieldLabelType @@ -143,7 +142,11 @@ mkSpecPragmaId occ uniq ty loc -- Maybe a SysLocal? But then we'd lose the location mkDefaultMethodId dm_name rec_c ty - = mkVanillaId dm_name ty + = mkId dm_name ty info + where + info = vanillaIdInfo `setTyGenInfo` TyGenNever + -- type is wired-in (see comment at TcClassDcl.tcClassSig), so + -- do not generalise it mkWorkerId uniq unwrkr ty = mkVanillaId (mkDerivedName mkWorkerOcc (getName unwrkr) uniq) ty @@ -243,6 +246,9 @@ mkDataConWrapId data_con -- The wrapper Id ends up in STG code as an argument, -- sometimes before its definition, so we want to -- signal that it has no CAFs + `setTyGenInfo` TyGenNever + -- No point generalising its type, since it gets eagerly inlined + -- away anyway wrap_ty = mkForAllTys all_tyvars $ mkFunTys all_arg_tys @@ -413,6 +419,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id `setArityInfo` exactArity (1 + length dict_tys) `setUnfoldingInfo` unfolding `setCafInfo` NoCafRefs + `setTyGenInfo` TyGenNever -- ToDo: consider adding further IdInfo unfolding = mkTopUnfolding sel_rhs @@ -428,7 +435,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id mkLams dict_ids $ Lam data_id $ sel_body - sel_body | isNewTyCon tycon = Note (Coerce (unUsgTy field_tau) (unUsgTy data_ty)) (Var data_id) + sel_body | isNewTyCon tycon = Note (Coerce field_tau data_ty) (Var data_id) | otherwise = Case (Var data_id) data_id (the_alts ++ default_alt) mk_maybe_alt data_con @@ -446,8 +453,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label field_lbls = dataConFieldLabels data_con - error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), err_string] - -- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04. + error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type field_tau, err_string] err_string | all safeChar full_msg = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg))) @@ -524,6 +530,7 @@ mkDictSelId name clas `setArityInfo` exactArity 1 `setUnfoldingInfo` unfolding `setCafInfo` NoCafRefs + `setTyGenInfo` TyGenNever -- We no longer use 'must-inline' on record selectors. They'll -- inline like crazy if they scrutinise a constructor @@ -622,9 +629,12 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> Id mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta - = mkVanillaId dfun_name dfun_ty + = mkId dfun_name dfun_ty info where dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) + info = vanillaIdInfo `setTyGenInfo` TyGenNever + -- type is wired-in (see comment at TcClassDcl.tcClassSig), so + -- do not generalise it {- 1 dec 99: disable the Mark Jones optimisation for the sake of compatibility with Hugs. @@ -810,9 +820,8 @@ openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy = mkTyVarTy openBetaTyVar errorTy :: Type -errorTy = mkUsgTy UsMany $ - mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkUsgTy UsOnce (mkListTy charTy)] - (mkUsgTy UsMany openAlphaTy)) +errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] + openAlphaTy) -- Notice the openAlphaTyVar. It says that "error" can be applied -- to unboxed as well as boxed types. This is OK because it never -- returns, so the return type is irrelevant. diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index ea370e2..a794b75 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, ipName, - tvName, uvName, nameSpaceString, + tvName, nameSpaceString, -- The OccName type OccName, -- Abstract, instance of Outputable @@ -20,7 +20,7 @@ module OccName ( mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, mkGenOcc1, mkGenOcc2, - isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc, + isSysOcc, isTvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc, occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, setOccNameSpace, @@ -86,7 +86,6 @@ data NameSpace = VarName -- Variables | IPName -- Implicit Parameters | 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 ) @@ -99,7 +98,6 @@ tcClsName = TcClsName -- Not sure which! dataName = DataName tvName = TvName -uvName = UvName varName = VarName ipName = IPName @@ -109,7 +107,6 @@ nameSpaceString DataName = "Data constructor" nameSpaceString VarName = "Variable" nameSpaceString IPName = "Implicit Param" nameSpaceString TvName = "Type variable" -nameSpaceString UvName = "Usage variable" nameSpaceString TcClsName = "Type constructor or class" \end{code} @@ -177,7 +174,7 @@ mkCCallOcc :: EncodedString -> OccName -- But then alreadyEncoded complains about the braces! mkCCallOcc str = OccName varName (_PK_ str) --- Kind constructors get a speical function. Uniquely, they are not encoded, +-- Kind constructors get a special function. Uniquely, they are not encoded, -- so that they have names like '*'. This means that *even in interface files* -- we'll get kinds like (* -> (* -> *)). We can't use mkSysOcc because it -- has an ASSERT that doesn't hold. @@ -225,14 +222,11 @@ occNameFlavour (OccName sp _) = nameSpaceString sp \end{code} \begin{code} -isTvOcc, isDataSymOcc, isSymOcc, isUvOcc :: OccName -> Bool +isTvOcc, isDataSymOcc, isSymOcc :: OccName -> Bool isTvOcc (OccName TvName _) = True isTvOcc other = False -isUvOcc (OccName UvName _) = True -isUvOcc other = False - isValOcc (OccName VarName _) = True isValOcc (OccName DataName _) = True isValOcc other = False diff --git a/ghc/compiler/basicTypes/Var.hi-boot b/ghc/compiler/basicTypes/Var.hi-boot index cc6684b..f7cf7c0 100644 --- a/ghc/compiler/basicTypes/Var.hi-boot +++ b/ghc/compiler/basicTypes/Var.hi-boot @@ -6,6 +6,5 @@ _declarations_ -- Used by Name 1 type Id = Var ; 1 type TyVar = Var ; -1 type UVar = Var ; 1 data Var ; 1 setIdName _:_ Id -> Name.Name -> Id ;; diff --git a/ghc/compiler/basicTypes/Var.hi-boot-5 b/ghc/compiler/basicTypes/Var.hi-boot-5 index 65ba3fa..ee50bf2 100644 --- a/ghc/compiler/basicTypes/Var.hi-boot-5 +++ b/ghc/compiler/basicTypes/Var.hi-boot-5 @@ -3,7 +3,6 @@ __export Var Var TyVar Id setIdName ; -- Used by Name 1 type Id = Var; 1 type TyVar = Var; -1 type UVar = Var; 1 data Var ; 1 setIdName :: Id -> Name.Name -> Id ; diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 89bef36..2d9f068 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -17,11 +17,6 @@ module Var ( newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar, isMutTyVar, makeTyVarImmutable, - -- UVars - UVar, - isUVar, - mkUVar, mkNamedUVar, - -- Ids Id, DictId, idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo, @@ -76,7 +71,6 @@ data VarDetails | MutTyVar (IORef (Maybe Type)) -- Used during unification; Bool -- True <=> this is a type signature variable, which -- should not be unified with a non-tyvar type - | UVar -- Usage variable -- For a long time I tried to keep mutable Vars statically type-distinct -- from immutable Vars, but I've finally given up. It's just too painful. @@ -214,43 +208,6 @@ isSigTyVar other = False %************************************************************************ %* * -\subsection{Usage variables} -%* * -%************************************************************************ - -\begin{code} -type UVar = Var -\end{code} - -\begin{code} -mkUVar :: Unique -> UVar -mkUVar unique = Var { varName = name - , realUnique = getKey unique - , varDetails = UVar - , varType = pprPanic "mkUVar (varType)" (ppr name) - , varInfo = pprPanic "mkUVar (varInfo)" (ppr name) - } - where name = mkSysLocalName unique SLIT("u") - -mkNamedUVar :: Name -> UVar -mkNamedUVar name = Var { varName = name - , realUnique = getKey (nameUnique name) - , varDetails = UVar - , varType = pprPanic "mkNamedUVar (varType)" (ppr name) - , varInfo = pprPanic "mkNamedUVar (varInfo)" (ppr name) - } -\end{code} - -\begin{code} -isUVar :: Var -> Bool -isUVar (Var {varDetails = details}) = case details of - UVar -> True - other -> False -\end{code} - - -%************************************************************************ -%* * \subsection{Id Construction} %* * %************************************************************************ diff --git a/ghc/compiler/basicTypes/VarSet.lhs b/ghc/compiler/basicTypes/VarSet.lhs index 03ec1ea..e90ed25 100644 --- a/ghc/compiler/basicTypes/VarSet.lhs +++ b/ghc/compiler/basicTypes/VarSet.lhs @@ -5,7 +5,7 @@ \begin{code} module VarSet ( - VarSet, IdSet, TyVarSet, UVarSet, + VarSet, IdSet, TyVarSet, emptyVarSet, unitVarSet, mkVarSet, extendVarSet, extendVarSet_C, elemVarSet, varSetElems, subVarSet, @@ -18,7 +18,7 @@ module VarSet ( #include "HsVersions.h" -import Var ( Var, Id, TyVar, UVar ) +import Var ( Var, Id, TyVar ) import Unique ( Unique ) import UniqSet import UniqFM ( delFromUFM_Directly, addToUFM_C ) @@ -34,7 +34,6 @@ import UniqFM ( delFromUFM_Directly, addToUFM_C ) type VarSet = UniqSet Var type IdSet = UniqSet Id type TyVarSet = UniqSet TyVar -type UVarSet = UniqSet UVar emptyVarSet :: VarSet intersectVarSet :: VarSet -> VarSet -> VarSet diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 2bca305..ecd4a1c 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.47 2000/11/07 13:12:22 simonpj Exp $ +% $Id: CgCase.lhs,v 1.48 2000/11/07 15:21:39 simonmar Exp $ % %******************************************************** %* * @@ -874,7 +874,7 @@ restoreCurrentCostCentre (Just slot) freeStackSlots [slot] `thenC` returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep]) -- we use the RESTORE_CCCS macro, rather than just - -- assigning into CurCostCentre, in case RESTORE_CCC + -- assigning into CurCostCentre, in case RESTORE_CCCS -- has some sanity-checking in it. \end{code} diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 2c06210..3cce2d5 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -49,7 +49,7 @@ module CoreSyn ( import CostCentre ( CostCentre, noCostCentre ) import Var ( Var, Id, TyVar, isTyVar, isId ) -import Type ( Type, UsageAnn, mkTyVarTy, seqType ) +import Type ( Type, mkTyVarTy, seqType ) import Literal ( Literal, mkMachInt ) import DataCon ( DataCon, dataConId ) import VarSet @@ -103,9 +103,6 @@ data Note | InlineMe -- Instructs simplifer to treat the enclosed expression -- as very small, and inline it at its call sites - - | TermUsg -- A term-level usage annotation - UsageAnn -- (should not be a variable except during UsageSP inference) \end{code} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 012075c..b5e7133 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -55,9 +55,9 @@ import IdInfo ( LBVarInfo(..), megaSeqIdInfo ) import Demand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, - splitFunTy_maybe, - isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..), - applyTys, isUnLiftedType, seqType + splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes, + applyTys, isUnLiftedType, seqType, + mkUTy ) import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) @@ -81,7 +81,6 @@ exprType (Lit lit) = literalType lit exprType (Let _ body) = exprType body exprType (Case _ _ alts) = coreAltsType alts exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e -exprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (exprType e)) exprType (Note other_note e) = exprType e exprType (Lam binder expr) = mkPiType binder (exprType expr) exprType e@(App _ _) @@ -102,8 +101,8 @@ case of a term variable. \begin{code} mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work... mkPiType v ty | isId v = (case idLBVarInfo v of - IsOneShotLambda -> mkUsgTy UsOnce - otherwise -> id) $ + LBVarInfo u -> mkUTy u + otherwise -> id) $ mkFunTy (idType v) ty | isTyVar v = mkForAllTy v ty \end{code} @@ -115,9 +114,6 @@ applyTypeToArgs e op_ty [] = op_ty applyTypeToArgs e op_ty (Type ty : args) = -- Accumulate type arguments so we can instantiate all at once - ASSERT2( all isNotUsgTy tys, - ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> - ppr (Type ty : args) <+> text "i.e." <+> ppr tys ) applyTypeToArgs e (applyTys op_ty tys) rest_args where (tys, rest_args) = go [ty] args @@ -699,7 +695,6 @@ noteSize (SCC cc) = cc `seq` 1 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1 noteSize InlineCall = 1 noteSize InlineMe = 1 -noteSize (TermUsg usg) = usg `seq` 1 varSize :: Var -> Int varSize b | isTyVar b = 1 diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index bed901b..e195c53 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -27,7 +27,9 @@ import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo, specInfo, cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, - workerInfo, ppWorkerInfo + cprInfo, ppCprInfo, lbvarInfo, + workerInfo, ppWorkerInfo, + tyGenInfo, ppTyGenInfo ) import DataCon ( dataConTyCon ) import TyCon ( tupleTyConBoxity, isTupleTyCon ) @@ -269,13 +271,6 @@ ppr_expr add_par pe (Note InlineCall expr) ppr_expr add_par pe (Note InlineMe expr) = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr -ppr_expr add_par pe (Note (TermUsg u) expr) - = getPprStyle $ \ sty -> - if ifaceStyle sty then - ppr_expr add_par pe expr - else - add_par (ppr u <+> ppr_noparend_expr pe expr) - ppr_case_pat pe con@(DataAlt dc) args | isTupleTyCon tc = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow @@ -339,6 +334,7 @@ ppIdInfo b info = hsep [ ppFlavourInfo (flavourInfo info), ppArityInfo a, + ppTyGenInfo g, ppWorkerInfo (workerInfo info), ppStrictnessInfo s, ppCafInfo c, @@ -350,6 +346,7 @@ ppIdInfo b info ] where a = arityInfo info + g = tyGenInfo info s = strictnessInfo info c = cafInfo info m = cprInfo info diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 1e7fc22..1866956 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -42,18 +42,18 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, isEmptyCoreRules, seqRules ) import CoreFVs ( exprFreeVars, mustHaveLocalBinding ) -import TypeRep ( Type(..), TyNote(..), - ) -- friend +import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( ThetaType, PredType(..), ClassContext, - tyVarsOfType, tyVarsOfTypes, mkAppTy + tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy ) import VarSet import VarEnv import Var ( setVarUnique, isId ) -import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo ) +import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo, maybeModifyIdInfo ) import IdInfo ( IdInfo, isFragileOcc, specInfo, setSpecInfo, - WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo + WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo, + lbvarInfo, LBVarInfo(..), setLBVarInfo ) import Unique ( Uniquable(..), deriveUnique ) import UniqSet ( elemUniqSet_Directly ) @@ -245,10 +245,12 @@ zapSubstEnv :: Subst -> Subst zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv extendSubst :: Subst -> Var -> SubstResult -> Subst -extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r) +extendSubst (Subst in_scope env) v r = UASSERT( case r of { DoneTy ty -> not (isUTy ty) ; _ -> True } ) + Subst in_scope (extendSubstEnv env v r) extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst -extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r) +extendSubstList (Subst in_scope env) v r = UASSERT( all (\ r1 -> case r1 of { DoneTy ty -> not (isUTy ty) ; _ -> True }) r ) + Subst in_scope (extendSubstEnvList env v r) lookupSubst :: Subst -> Var -> Maybe SubstResult lookupSubst (Subst _ env) v = lookupSubstEnv env v @@ -377,7 +379,8 @@ mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv) zip_ty_env [] [] env = env -zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty)) +zip_ty_env (tv:tvs) (ty:tys) env = UASSERT( not (isUTy ty) ) + zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty)) \end{code} substTy works with general Substs, so that it can be called from substExpr too. @@ -411,8 +414,6 @@ 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 (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 (FunTy arg res) = (FunTy $! (go arg)) $! (go res) go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) @@ -422,6 +423,8 @@ subst_ty subst ty go (ForAllTy tv ty) = case substTyVar subst tv of (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) + + go (UsageTy u ty) = mkUTy (go u) $! (go ty) \end{code} Here is where we invent a new binder if necessary. @@ -565,9 +568,14 @@ substId subst@(Subst in_scope env) old_id -- id2 has its IdInfo zapped id2 = zapFragileIdInfo id1 - -- new_id is cloned if necessary - new_id = uniqAway in_scope id2 + -- id3 has its LBVarInfo zapped + id3 = maybeModifyIdInfo (\ info -> go info (lbvarInfo info)) id2 + where go info (LBVarInfo u@(TyVarTy _)) = Just $ setLBVarInfo info $ + LBVarInfo (subst_ty subst u) + go info _ = Nothing + -- new_id is cloned if necessary + new_id = uniqAway in_scope id3 -- Extend the substitution if the unique has changed, -- or there's some useful occurrence information -- See the notes with substTyVar for the delSubstEnv diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index c692b2d..4fcc01a 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -414,12 +414,16 @@ get_unused_cons :: [TypecheckedPat] -> [DataCon] get_unused_cons used_cons = unused_cons where (ConPat _ ty _ _ _) = head used_cons - Just (ty_con,_) = splitTyConApp_maybe ty + Just (ty_con,_) = sTyConApp_maybe used_cons ty all_cons = tyConDataCons ty_con used_cons_as_id = map (\ (ConPat d _ _ _ _) -> d) used_cons unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) +sTyConApp_maybe used_cons ty = + case splitTyConApp_maybe ty of + Just x -> Just x + Nothing -> pprTrace "splitTyConApp_maybe" (ppr (used_cons, ty)) $ Nothing all_vars :: [TypecheckedPat] -> Bool all_vars [] = True diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index da86ba8..ff55523 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -38,7 +38,6 @@ import DataCon ( isExistentialDataCon ) import Literal ( Literal(..) ) import Type ( splitFunTys, splitAlgTyConApp, splitAlgTyConApp_maybe, splitTyConApp_maybe, - isNotUsgTy, unUsgTy, splitAppTy, isUnLiftedType, Type ) import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon, isIntegerTy ) @@ -285,14 +284,12 @@ dsExpr (ExplicitListOut ty xs) go [] = returnDs (mkNilExpr ty) go (x:xs) = dsExpr x `thenDs` \ core_x -> go xs `thenDs` \ core_xs -> - ASSERT( isNotUsgTy ty ) returnDs (mkConsExpr ty core_x core_xs) dsExpr (ExplicitTuple expr_list boxity) = mapDs dsExpr expr_list `thenDs` \ core_exprs -> returnDs (mkConApp (tupleCon boxity (length expr_list)) - (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs)) - -- the above unUsgTy is *required* -- KSW 1999-04-07 + (map (Type . exprType) core_exprs ++ core_exprs)) dsExpr (ArithSeqOut expr (From from)) = dsExpr expr `thenDs` \ expr2 -> @@ -498,8 +495,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty go (GuardStmt expr locn : stmts) = do_expr expr locn `thenDs` \ expr2 -> go stmts `thenDs` \ rest -> - let msg = ASSERT( isNotUsgTy b_ty ) - "Pattern match failure in do expression, " ++ showSDoc (ppr locn) + let msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in mkStringLit msg `thenDs` \ core_msg -> returnDs (mkIfThenElse expr2 @@ -532,9 +528,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a) fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) (HsLit (HsString (_PK_ msg))) - msg = ASSERT2( isNotUsgTy a_ty, ppr a_ty ) - ASSERT2( isNotUsgTy b_ty, ppr b_ty ) - "Pattern match failure in do expression, " ++ showSDoc (ppr locn) + msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) main_match = mkSimpleMatch [pat] (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty locn) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index a5dbf53..c56b1d4 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -29,7 +29,7 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, mkForeignExportOcc, isLocalName, NamedThing(..), ) -import Type ( unUsgTy, repType, +import Type ( repType, splitTyConApp_maybe, splitFunTys, splitForAllTys, Type, mkFunTys, mkForAllTys, mkTyConApp, mkFunTy, splitAppTy, applyTy, funResultTy @@ -37,8 +37,8 @@ import Type ( unUsgTy, repType, import PrimOp ( CCall(..), CCallTarget(..), dynamicTarget ) import TysWiredIn ( unitTy, addrTy, stablePtrTyCon ) import TysPrim ( addrPrimTy ) -import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, - bindIOName, returnIOName, makeStablePtrName +import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName, + bindIOName, returnIOName ) import Outputable @@ -305,7 +305,7 @@ foreign export dynamic f :: (Addr -> Int -> IO Int) -> IO Addr f :: (Addr -> Int -> IO Int) -> IO Addr f cback = - bindIO (makeStablePtr cback) + bindIO (newStablePtr cback) (\StablePtr sp# -> IO (\s1# -> case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of (# s2#, a# #) -> (# s2#, A# a# #))) @@ -332,9 +332,9 @@ dsFExportDynamic i ty mod_name ext_name cconv = dsFExport i export_ty mod_name fe_ext_name cconv True `thenDs` \ (feb, fe, h_code, c_code) -> newSysLocalDs arg_ty `thenDs` \ cback -> - dsLookupGlobalValue makeStablePtrName `thenDs` \ makeStablePtrId -> + dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId -> let - mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ] + mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] in dsLookupGlobalValue bindIOName `thenDs` \ bindIOId -> newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value -> @@ -365,7 +365,7 @@ dsFExportDynamic i ty mod_name ext_name cconv = dsCCall adjustor adj_args False False io_res_ty `thenDs` \ ccall_adj -> let ccall_adj_ty = exprType ccall_adj ccall_io_adj = mkLams [stbl_value] $ - Note (Coerce io_res_ty (unUsgTy ccall_adj_ty)) + Note (Coerce io_res_ty ccall_adj_ty) ccall_adj in let io_app = mkLams tvs $ @@ -484,7 +484,7 @@ unpackHObj :: Type -> SDoc unpackHObj t = text "rts_get" <> text (showFFIType t) showStgType :: Type -> SDoc -showStgType t = text "Stg" <> text (showFFIType t) +showStgType t = text "Hs" <> text (showFFIType t) showFFIType :: Type -> String showFFIType t = getOccString (getName tc) diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index c39cddd..2d532e3 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -10,7 +10,8 @@ module DsListComp ( dsListComp ) where import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) -import HsSyn ( Stmt(..) ) +import BasicTypes ( Boxity(..) ) +import HsSyn ( OutPat(..), HsExpr(..), Stmt(..) ) import TcHsSyn ( TypecheckedStmt ) import DsHsSyn ( outPatType ) import CoreSyn @@ -24,9 +25,10 @@ import Id ( idType ) import Var ( Id ) import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type ) import TysPrim ( alphaTyVar ) -import TysWiredIn ( nilDataCon, consDataCon ) +import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, tupleCon, mkListTy, mkTupleTy ) import Match ( matchSimply ) import PrelNames ( foldrName, buildName ) +import List ( zip4 ) \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -102,10 +104,80 @@ TQ << [ e | p <- L1, qs ] ++ L2 >> = is the TE translation scheme. Note that we carry around the @L@ list already desugared. @dsListComp@ does the top TE rule mentioned above. +To the above, we add an additional rule to deal with parallel list +comprehensions. The translation goes roughly as follows: + [ e | p1 <- e11, let v1 = e12, p2 <- e13 + | q1 <- e21, let v2 = e22, q2 <- e23] + => + [ e | ((p1,v1,p2), (q1,v2,q2)) <- + zip [(p1,v1,p2) | p1 <- e11, let v1 = e12, p2 <- e13] + [(q1,v2,q2) | q1 <- e21, let v2 = e22, q2 <- e23]] +In the translation below, the ParStmtOut branch translates each parallel branch +into a sub-comprehension, and desugars each independently. The resulting lists +are fed to a zip function, we create a binding for all the variables bound in all +the comprehensions, and then we hand things off the the desugarer for bindings. +The zip function is generated here a) because it's small, and b) because then we +don't have to deal with arbitrary limits on the number of zip functions in the +prelude, nor which library the zip function came from. +The introduced tuples are Boxed, but only because I couldn't get it to work +with the Unboxed variety. \begin{code} + deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr +deListComp (ParStmtOut bndrstmtss : quals) list + = mapDs doListComp qualss `thenDs` \ exps -> + mapDs genAS bndrss `thenDs` \ ass -> + mapDs genA bndrss `thenDs` \ as -> + mapDs genAS' bndrss `thenDs` \ as's -> + let retTy = myTupleTy Boxed (length bndrss) qualTys + zipTy = foldr mkFunTy (mkListTy retTy) (map mkListTy qualTys) + in + newSysLocalDs zipTy `thenDs` \ zipFn -> + let target = mkConsExpr retTy (mkTupleExpr as) (foldl App (Var zipFn) (map Var as's)) + zipExp = mkLet zipFn (zip4 (map fst bndrstmtss) ass as as's) exps target + in + deBindComp pat zipExp quals list + where (bndrss, stmtss) = unzip bndrstmtss + pats = map (\ps -> mkTuplePat (map VarPat ps)) bndrss + mkTuplePat [p] = p + mkTuplePat ps = TuplePat ps Boxed + pat = TuplePat pats Boxed + + qualss = map mkQuals bndrstmtss + mkQuals (bndrs, stmts) = (bndrs, stmts ++ [ReturnStmt (myTupleExpr bndrs)]) + + qualTys = map mkBndrsTy bndrss + mkBndrsTy bndrs = myTupleTy Boxed (length bndrs) (map idType bndrs) + + doListComp (bndrs, stmts) + = dsListComp stmts (mkBndrsTy bndrs) + genA bndrs = newSysLocalDs (mkBndrsTy bndrs) + genAS bndrs = newSysLocalDs (mkListTy (mkBndrsTy bndrs)) + genAS' bndrs = newSysLocalDs (mkListTy (mkBndrsTy bndrs)) + + mkLet zipFn vars exps target + = Let (Rec [(zipFn, + foldr Lam (mkBody target vars) (map getAs vars))]) + (foldl App (Var zipFn) exps) + getAs (_, as, _, _) = as + mkBody target vars + = foldr mkCase (foldr mkTuplCase target vars) vars + mkCase (ps, as, a, as') rest + = Case (Var as) as [(DataAlt nilDataCon, [], mkConApp nilDataCon []), + (DataAlt consDataCon, [a, as'], rest)] + mkTuplCase ([p], as, a, as') rest + = App (Lam p rest) (Var a) + mkTuplCase (ps, as, a, as') rest + = Case (Var a) a [(DataAlt (tupleCon Boxed (length ps)), ps, rest)] + + myTupleTy boxity arity [ty] = ty + myTupleTy boxity arity tys = mkTupleTy boxity arity tys + myTupleExpr [] = HsVar unitDataConId + myTupleExpr [id] = HsVar id + myTupleExpr ids = ExplicitTuple [ HsVar i | i <- ids ] Boxed + deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above = dsExpr expr `thenDs` \ core_expr -> returnDs (mkConsExpr (exprType core_expr) core_expr list) @@ -122,7 +194,10 @@ deListComp (LetStmt binds : quals) list deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above = dsExpr list1 `thenDs` \ core_list1 -> - let + deBindComp pat core_list1 quals core_list2 + +deBindComp pat core_list1 quals core_list2 + = let u3_ty@u1_ty = exprType core_list1 -- two names, same thing -- u1_ty is a [alpha] type, and u2_ty = alpha diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index f27b78c..7344cd7 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -47,7 +47,7 @@ import TyCon ( isNewTyCon, tyConDataCons ) import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks, dataConId, splitProductType_maybe ) -import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy, +import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, Type ) import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy ) @@ -278,8 +278,8 @@ mkCoAlgCaseMatchResult var match_alts -- Stuff for newtype (_, arg_ids, match_result) = head match_alts arg_id = head arg_ids - coercion_bind = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id)) - (unUsgTy scrut_ty)) + coercion_bind = NonRec arg_id (Note (Coerce (idType arg_id) + scrut_ty) (Var var)) newtype_sanity = null (tail match_alts) && null (tail arg_ids) @@ -362,8 +362,7 @@ mkErrorAppDs err_id ty msg full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) in mkStringLit full_msg `thenDs` \ core_msg -> - returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg]) - -- unUsgTy *required* -- KSW 1999-04-07 + returnDs (mkApps (Var err_id) [Type ty, core_msg]) \end{code} @@ -522,8 +521,7 @@ mkSelectorBinds pat val_expr @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it -has only one element, it is the identity function. Notice we must -throw out any usage annotation on the outside of an Id. +has only one element, it is the identity function. \begin{code} mkTupleExpr :: [Id] -> CoreExpr @@ -531,7 +529,7 @@ mkTupleExpr :: [Id] -> CoreExpr mkTupleExpr [] = Var unitDataConId mkTupleExpr [id] = Var id mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids)) - (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ]) + (map (Type . idType) ids ++ [ Var i | i <- ids ]) \end{code} diff --git a/ghc/compiler/ghci/StgInterp.lhs b/ghc/compiler/ghci/StgInterp.lhs index e3e58c0..43146b5 100644 --- a/ghc/compiler/ghci/StgInterp.lhs +++ b/ghc/compiler/ghci/StgInterp.lhs @@ -29,21 +29,6 @@ module StgInterp ( #include "HsVersions.h" -#if __GLASGOW_HASKELL__ <= 408 - -import Panic ( panic ) -import RdrName ( RdrName ) -import PrelAddr ( Addr ) -import FiniteMap ( FiniteMap ) -import InterpSyn ( HValue ) - -type ItblEnv = FiniteMap RdrName Addr -type ClosureEnv = FiniteMap RdrName HValue -linkIModules = panic "StgInterp.linkIModules: this hsc was not built with an interpreter" -stgToInterpSyn = panic "StgInterp.linkIModules: this hsc was not built with an interpreter" - -#else - import Linker import Id ( Id, idPrimRep ) import Outputable @@ -65,10 +50,7 @@ import PrelGHC --( unsafeCoerce#, dataToTag#, -- indexPtrOffClosure#, indexWordOffClosure# ) import PrelAddr ( Addr(..) ) import PrelFloat ( Float(..), Double(..) ) -import Word import Bits -import Storable -import CTypes import FastString import GlaExts ( Int(..) ) import Module ( moduleNameFS ) @@ -83,12 +65,14 @@ import FiniteMap import Panic ( panic ) import OccName ( occNameString ) +import Foreign +import CTypes -- --------------------------------------------------------------------------- -- Environments needed by the linker -- --------------------------------------------------------------------------- -type ItblEnv = FiniteMap RdrName Addr +type ItblEnv = FiniteMap RdrName (Ptr StgInfoTable) type ClosureEnv = FiniteMap RdrName HValue -- --------------------------------------------------------------------------- @@ -309,10 +293,10 @@ lit2expr lit -- Addr#. So, copy the string into C land and introduce a -- memory leak at the same time. let n = I# l in - case unsafePerformIO (do a <- malloc (n+1); + case unsafePerformIO (do a <- mallocBytes (n+1); strncpy a ba (fromIntegral n); - writeCharOffAddr a n '\0' - return a) + pokeByteOff a n '\0' + case a of { Ptr a -> return a }) of A# a -> LitI (addr2Int# a) _ -> error "StgInterp.lit2expr: unhandled string constant type" @@ -520,7 +504,7 @@ linkIExpr ie ce expr = case expr of lookupCon ie con = case lookupFM ie con of - Just addr -> addr + Just (Ptr addr) -> addr Nothing -> -- try looking up in the object files. case {-HACK!!!-} @@ -1053,6 +1037,12 @@ indexIntOffClosure con (I# offset) --- Manufacturing of info tables for DataCons defined in this module --- ------------------------------------------------------------------------ +#if __GLASGOW_HASKELL__ <= 408 +type ItblPtr = Addr +#else +type ItblPtr = Ptr StgInfoTable +#endif + -- Make info tables for the data decls in this module mkITbls :: [TyCon] -> IO ItblEnv mkITbls [] = return emptyFM @@ -1090,7 +1080,7 @@ make_constr_itbls cons mk_dirret_itbl (dcon, conNo) = mk_itbl dcon conNo mci_constr_entry - mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,Addr) + mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,ItblPtr) mk_itbl dcon conNo entry_addr = let (tot_wds, ptr_wds, _) = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon) @@ -1120,12 +1110,12 @@ make_constr_itbls cons entry_addr_w :: Word32 entry_addr_w = fromIntegral (addrToInt entry_addr) in - do addr <- mallocElem itbl + do addr <- malloc putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl)) putStrLn ("# ptrs of itbl is " ++ show ptrs) putStrLn ("# nptrs of itbl is " ++ show nptrs) poke addr itbl - return (toRdrName dcon, intToAddr (addrToInt addr + 8)) + return (toRdrName dcon, addr `plusPtr` 8) byte :: Int -> Word32 -> Word32 @@ -1186,7 +1176,7 @@ instance Storable StgInfoTable where fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7] poke a0 itbl - = do a1 <- store (ptrs itbl) a0 + = do a1 <- store (ptrs itbl) (castPtr a0) a2 <- store (nptrs itbl) a1 a3 <- store (tipe itbl) a2 a4 <- store (srtlen itbl) a3 @@ -1201,7 +1191,7 @@ instance Storable StgInfoTable where return () peek a0 - = do (a1,ptrs) <- load a0 + = do (a1,ptrs) <- load (castPtr a0) (a2,nptrs) <- load a1 (a3,tipe) <- load a2 (a4,srtlen) <- load a3 @@ -1225,18 +1215,16 @@ fieldSz sel x = sizeOf (sel x) fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int fieldAl sel x = alignment (sel x) -store :: Storable a => a -> Addr -> IO Addr +store :: Storable a => a -> Ptr a -> IO (Ptr b) store x addr = do poke addr x - return (addr `plusAddr` fromIntegral (sizeOf x)) + return (castPtr (addr `plusPtr` sizeOf x)) -load :: Storable a => Addr -> IO (Addr, a) +load :: Storable a => Ptr a -> IO (Ptr b, a) load addr = do x <- peek addr - return (addr `plusAddr` fromIntegral (sizeOf x), x) + return (castPtr (addr `plusPtr` sizeOf x), x) -----------------------------------------------------------------------------q -foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO () - -#endif /* #if __GLASGOW_HASKELL__ <= 408 */ +foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO () \end{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index c2bd453..67d5c24 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -16,7 +16,7 @@ module HsCore ( UfBinding(..), UfConAlt(..), HsIdInfo(..), pprHsIdInfo, - eq_ufExpr, eq_ufBinders, pprUfExpr, + eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo, toUfExpr, toUfBndr, ufBinderName ) where @@ -25,9 +25,9 @@ module HsCore ( -- friends: import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, - HsTupCon(..), hsTupParens, + HsTupCon(..), EqHsEnv, hsTupParens, emptyEqHsEnv, extendEqHsEnv, eqListBy, - eq_hsType, eq_hsVar, eq_hsVars + eq_hsType, eq_hsVars ) -- others: @@ -36,7 +36,9 @@ import Var ( varType, isId ) import IdInfo ( ArityInfo, InlinePragInfo, pprInlinePragInfo, ppArityInfo, ppStrictnessInfo ) -import Name ( Name, getName ) +import Name ( Name, NamedThing(..), getName, toRdrName ) +import RdrName ( RdrName, rdrNameOcc ) +import OccName ( isTvOcc ) import CoreSyn import CostCentre ( pprCostCentreCore ) import PrimOp ( PrimOp(CCallOp) ) @@ -46,6 +48,7 @@ import PrimOp ( CCall, pprCCallOp ) import DataCon ( dataConTyCon ) import TyCon ( isTupleTyCon, tupleTyConBoxity ) import Type ( Kind ) +import FiniteMap ( lookupFM ) import CostCentre import Outputable \end{code} @@ -179,13 +182,21 @@ toUfVar v = case isPrimOpId_maybe v of %************************************************************************ \begin{code} -instance Outputable name => Outputable (UfExpr name) where +instance (NamedThing name, Outputable name) => Outputable (UfExpr name) where ppr e = pprUfExpr noParens e + +-- Small-hack alert: this instance allows us to do a getOccName on RdrNames. +-- Important because we want to pretty-print UfExprs, and we have to +-- print an '@' before tyvar-binders in a case alternative. +instance NamedThing RdrName where + getOccName n = rdrNameOcc n + getName n = pprPanic "instance NamedThing RdrName" (ppr n) + noParens :: SDoc -> SDoc noParens pp = pp -pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc +pprUfExpr :: (NamedThing name, Outputable name) => (SDoc -> SDoc) -> UfExpr name -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) @@ -206,10 +217,14 @@ pprUfExpr add_par (UfCase scrut bndr alts) braces (hsep (map pp_alt alts))]) where pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs - pp_alt (c, bs, rhs) = ppr c <+> interppSP bs <+> ppr_rhs rhs + pp_alt (c, bs, rhs) = ppr c <+> hsep (map pp_bndr bs) <+> ppr_rhs rhs ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi + -- This use of getOccName is the sole reason for the NamedThing in pprUfExpr's type + pp_bndr v | isTvOcc (getOccName v) = char '@' <+> ppr v + | otherwise = ppr v + pprUfExpr add_par (UfLet (UfNonRec b rhs) body) = add_par (hsep [ptext SLIT("let"), braces (ppr b <+> equals <+> pprUfExpr noParens rhs), @@ -223,6 +238,7 @@ pprUfExpr add_par (UfLet (UfRec pairs) body) pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body) + collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name) collectUfBndrs expr = go [] expr @@ -254,8 +270,26 @@ instance Outputable name => Outputable (UfBinder name) where %* * %************************************************************************ + ---------------------------------------- + HACK ALERT + ---------------------------------------- + +Whe comparing UfExprs, we compare names by converting to RdrNames and comparing +those. Reason: this is used when comparing ufoldings in interface files, and the +uniques can differ. Converting to RdrNames makes it more like comparing the file +contents directly. But this is bad: version numbers can change when only alpha-conversion +has happened. + + The hack shows up in eq_ufVar + There are corresponding getOccName calls in MkIface.diffDecls + + ---------------------------------------- + END OF HACK ALERT + ---------------------------------------- + + \begin{code} -instance Ord name => Eq (UfExpr name) where +instance (NamedThing name, Ord name) => Eq (UfExpr name) where (==) a b = eq_ufExpr emptyEqHsEnv a b ----------------- @@ -271,7 +305,17 @@ eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinde eq_ufBinders env _ _ _ = False ----------------- -eq_ufExpr env (UfVar v1) (UfVar v2) = eq_hsVar env v1 v2 +eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool +-- Compare *Rdr* names. A real hack to avoid gratuitous +-- differences when comparing interface files +eq_ufVar env n1 n2 = case lookupFM env n1 of + Just n1 -> toRdrName n1 == toRdrName n2 + Nothing -> toRdrName n1 == toRdrName n2 + + +----------------- +eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool +eq_ufExpr env (UfVar v1) (UfVar v2) = eq_ufVar env v1 v2 eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2 eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2 eq_ufExpr env (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2 @@ -324,8 +368,9 @@ eq_ufConAlt env _ _ = False %************************************************************************ \begin{code} +pprHsIdInfo :: (NamedThing n, Outputable n) => [HsIdInfo n] -> SDoc pprHsIdInfo [] = empty -pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr info) <+> ptext SLIT("##-}") +pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}") data HsIdInfo name = HsArity ArityInfo @@ -338,12 +383,11 @@ data HsIdInfo name -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. -instance Outputable name => Outputable (HsIdInfo name) where - ppr (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (ppr unf) - ppr (HsArity arity) = ppArityInfo arity - ppr (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str - ppr HsNoCafRefs = ptext SLIT("__C") - ppr HsCprInfo = ptext SLIT("__M") - ppr (HsWorker w) = ptext SLIT("__P") <+> ppr w +ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (pprUfExpr noParens unf) +ppr_hs_info (HsArity arity) = ppArityInfo arity +ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str +ppr_hs_info HsNoCafRefs = ptext SLIT("__C") +ppr_hs_info HsCprInfo = ptext SLIT("__M") +ppr_hs_info (HsWorker w) = ptext SLIT("__P") <+> ppr w \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 2592136..db29d44 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -17,7 +17,7 @@ module HsDecls ( hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls, mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName, - getClassDeclSysNames + getClassDeclSysNames, conDetailsTys ) where #include "HsVersions.h" @@ -35,6 +35,7 @@ import BasicTypes ( NewOrData(..) ) import CallConv ( CallConv, pprCallConv ) -- others: +import Name ( NamedThing ) import FunDeps ( pprFundeps ) import Class ( FunDep, DefMeth(..) ) import CStrings ( CLabelString, pprCLabelString ) @@ -76,7 +77,7 @@ data HsDecl name pat \begin{code} #ifdef DEBUG -hsDeclName :: (Outputable name, Outputable pat) +hsDeclName :: (NamedThing name, Outputable name, Outputable pat) => HsDecl name pat -> name #endif hsDeclName (TyClD decl) = tyClDeclName decl @@ -95,7 +96,7 @@ instDeclName (InstDecl _ _ _ (Just name) _) = name \end{code} \begin{code} -instance (Outputable name, Outputable pat) +instance (NamedThing name, Outputable name, Outputable pat) => Outputable (HsDecl name pat) where ppr (TyClD dcl) = ppr dcl @@ -108,14 +109,6 @@ instance (Outputable name, Outputable pat) ppr (DeprecD dd) = ppr dd \end{code} -\begin{code} -instance Ord name => Eq (HsDecl name pat) where - -- Used only when comparing interfaces, - -- at which time only signature and type/class decls - (TyClD d1) == (TyClD d2) = d1 == d2 - _ == _ = False -\end{code} - %************************************************************************ %* * @@ -259,7 +252,7 @@ getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds) \end{code} \begin{code} -instance Ord name => Eq (TyClDecl name pat) where +instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where -- Used only when building interface files (==) (IfaceSig n1 t1 i1 _) (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2 @@ -321,7 +314,7 @@ countTyClDecls decls \end{code} \begin{code} -instance (Outputable name, Outputable pat) +instance (NamedThing name, Outputable name, Outputable pat) => Outputable (TyClDecl name pat) where ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info] @@ -425,6 +418,12 @@ conDeclsNames cons \end{code} \begin{code} +conDetailsTys :: ConDetails name -> [HsType name] +conDetailsTys (VanillaCon btys) = map getBangType btys +conDetailsTys (InfixCon bty1 bty2) = [getBangType bty1, getBangType bty2] +conDetailsTys (RecCon fields) = [getBangType bty | (_, bty) <- fields] + + eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _) (ConDecl n2 _ tvs2 cxt2 cds2 _) = n1 == n2 && @@ -655,14 +654,14 @@ data RuleBndr name = RuleBndr name | RuleBndrSig name (HsType name) -instance Ord name => Eq (RuleDecl name pat) where +instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where -- Works for IfaceRules only; used when comparing interface file versions (IfaceRule n1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 bs2 f2 es2 rhs2 _) = n1==n2 && f1 == f2 && eq_ufBinders emptyEqHsEnv bs1 bs2 (\env -> eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2)) -instance (Outputable name, Outputable pat) +instance (NamedThing name, Outputable name, Outputable pat) => Outputable (RuleDecl name pat) where ppr (HsRule name tvs ns lhs rhs loc) = sep [text "{-# RULES" <+> doubleQuotes (ptext name), diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 8cbc038..4359218 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -451,7 +451,9 @@ pprDo ListComp stmts \begin{code} data Stmt id pat - = BindStmt pat + = ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals + | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming + | BindStmt pat (HsExpr id pat) SrcLoc @@ -475,6 +477,10 @@ instance (Outputable id, Outputable pat) => Outputable (Stmt id pat) where ppr stmt = pprStmt stmt +pprStmt (ParStmt stmtss) + = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) +pprStmt (ParStmtOut stmtss) + = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr] pprStmt (LetStmt binds) diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 4a3c1f6..f2ad080 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -42,6 +42,7 @@ import HsTypes import BasicTypes ( Fixity, Version, NewOrData ) -- others: +import Name ( NamedThing ) import Outputable import SrcLoc ( SrcLoc ) import Bag @@ -67,7 +68,7 @@ data HsModule name pat \end{code} \begin{code} -instance (Outputable name, Outputable pat) +instance (NamedThing name, Outputable name, Outputable pat) => Outputable (HsModule name pat) where ppr (HsModule name iface_version exports imports diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index bd51781..aeb4f28 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -5,11 +5,12 @@ \begin{code} module HsTypes ( - HsType(..), HsUsageAnn(..), HsTyVarBndr(..), + HsType(..), HsTyVarBndr(..), , HsContext, HsPred(..) , HsTupCon(..), hsTupParens, mkHsTupCon, + , hsUsOnce, hsUsMany - , mkHsForAllTy, mkHsUsForAllTy, mkHsDictTy, mkHsIParamTy + , mkHsForAllTy, mkHsDictTy, mkHsIParamTy , hsTyVarName, hsTyVarNames, replaceTyVarName -- Printing @@ -27,17 +28,20 @@ module HsTypes ( import Class ( FunDep ) import Type ( Type, Kind, PredType(..), ClassContext, - splitSigmaTy, unUsgTy, boxedTypeKind + splitSigmaTy, boxedTypeKind ) import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation -import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity ) -import RdrName ( RdrName ) -import Name ( Name, getName ) -import OccName ( NameSpace ) +import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, getSynTyConDefn ) +import RdrName ( RdrName, mkUnqual ) +import Name ( Name, getName, setLocalNameSort ) +import OccName ( NameSpace, tvName ) import Var ( TyVar, tyVarKind ) +import Subst ( mkTyVarSubst, substTy ) import PprType ( {- instance Outputable Kind -}, pprParendKind ) import BasicTypes ( Boxity(..), tupleParens ) -import PrelNames ( mkTupConRdrName, listTyConKey, hasKey ) +import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey, + usOnceTyConName, usManyTyConName + ) import FiniteMap import Outputable @@ -73,18 +77,21 @@ data HsType name | HsNumTy Integer -- these next two are only used in interfaces | HsPredTy (HsPred name) + + | HsUsageTy (HsType name) -- Usage annotation + (HsType name) -- Annotated type - | HsUsgTy (HsUsageAnn name) - (HsType name) - | HsUsgForAllTy name - (HsType name) +----------------------- +hsUsOnce, hsUsMany :: HsType RdrName +hsUsOnce = HsTyVar (mkUnqual tvName SLIT(".")) -- deep magic +hsUsMany = HsTyVar (mkUnqual tvName SLIT("!")) -- deep magic -data HsUsageAnn name - = HsUsOnce - | HsUsMany - | HsUsVar name - +hsUsOnce_Name, hsUsMany_Name :: HsType Name +-- Fudge the TyConName so that it prints unqualified +-- I hate it! I hate it! +hsUsOnce_Name = HsTyVar (setLocalNameSort usOnceTyConName False) +hsUsMany_Name = HsTyVar (setLocalNameSort usManyTyConName False) ----------------------- data HsTupCon name = HsTupCon name Boxity @@ -116,9 +123,6 @@ mkHsForAllTy mtvs1 [] (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus (Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2) mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty -mkHsUsForAllTy uvs ty = foldr (\ uv ty -> HsUsgForAllTy uv ty) - ty uvs - mkHsDictTy cls tys = HsPredTy (HsPClass cls tys) mkHsIParamTy v ty = HsPredTy (HsPIParam v ty) @@ -173,6 +177,8 @@ pprHsForAll tvs cxt = getPprStyle $ \ sty -> if userStyle sty then ptext SLIT("forall") <+> interppSP tvs <> dot <+> + -- **! ToDo: want to hide uvars from user, but not enough info + -- in a HsTyVarBndr name (see PprType). KSW 2000-10. (if null cxt then empty else @@ -191,9 +197,9 @@ ppr_context cxt = parens (interpp'SP cxt) \end{code} \begin{code} -pREC_TOP = (0 :: Int) -pREC_FUN = (1 :: Int) -pREC_CON = (2 :: Int) +pREC_TOP = (0 :: Int) -- type in ParseIface.y +pREC_FUN = (1 :: Int) -- btype in ParseIface.y +pREC_CON = (2 :: Int) -- atype in ParseIface.y maybeParen :: Bool -> SDoc -> SDoc maybeParen True p = parens p @@ -235,26 +241,12 @@ ppr_mono_ty ctxt_prec (HsPredTy pred) = maybeParen (ctxt_prec >= pREC_FUN) $ braces (ppr pred) -ppr_mono_ty ctxt_prec ty@(HsUsgForAllTy _ _) - = - 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 (HsUsgForAllTy uv ty') = split (uv:uvs) ty' - split uvs ty' = (reverse uvs,ty') +ppr_mono_ty ctxt_prec (HsUsageTy u ty) + = maybeParen (ctxt_prec >= pREC_CON) + (sep [ptext SLIT("__u") <+> ppr_mono_ty pREC_CON u, + ppr_mono_ty pREC_CON ty]) + -- pREC_FUN would be logical for u, but it yields a reduce/reduce conflict with AppTy -ppr_mono_ty ctxt_prec (HsUsgTy u ty) - = maybeParen (ctxt_prec >= pREC_CON) $ - ptext SLIT("__u") <+> pp_ua <+> ppr_mono_ty pREC_CON ty - where - pp_ua = case u of - HsUsOnce -> ptext SLIT("-") - HsUsMany -> ptext SLIT("!") - HsUsVar uv -> ppr uv -- Generics ppr_mono_ty ctxt_prec (HsNumTy n) = integer n ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = ppr ty1 <+> ppr op <+> ppr ty2 @@ -278,36 +270,60 @@ toHsTyVar tv = IfaceTyVar (getName tv) (tyVarKind tv) toHsTyVars tvs = map toHsTyVar tvs toHsType :: Type -> HsType Name -toHsType ty = toHsType' (unUsgTy ty) - -- For now we just discard the usage - -toHsType' :: Type -> HsType Name --- Called after the usage is stripped off -- This function knows the representation of types -toHsType' (TyVarTy tv) = HsTyVar (getName tv) -toHsType' (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res) -toHsType' (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg) - -toHsType' (NoteTy (SynNote ty) _) = toHsType ty -- Use synonyms if possible!! -toHsType' (NoteTy _ ty) = toHsType ty - -toHsType' (PredTy p) = HsPredTy (toHsPred p) - -toHsType' ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind * - | not saturated = generic_case - | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc)) tys' - | tc `hasKey` listTyConKey = HsListTy (head tys') - | otherwise = generic_case +toHsType (TyVarTy tv) = HsTyVar (getName tv) +toHsType (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res) +toHsType (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg) + +toHsType (NoteTy (SynNote syn_ty) real_ty) + | syn_matches = toHsType syn_ty -- Use synonyms if possible!! + | otherwise = +#ifdef DEBUG + pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $ +#endif + toHsType real_ty -- but drop it if not. + where + syn_matches = ty_from_syn == real_ty + + TyConApp syn_tycon tyargs = syn_ty + (tyvars,ty) = getSynTyConDefn syn_tycon + ty_from_syn = substTy (mkTyVarSubst tyvars tyargs) ty + + -- We only use the type synonym in the file if this doesn't cause + -- us to lose important information. This matters for usage + -- annotations. It's an issue if some of the args to the synonym + -- have arrows in them, or if the synonym's RHS has an arrow; for + -- example, with nofib/real/ebnf2ps/ in Parsers.using. + + -- **! It would be nice if when this test fails we could still + -- write the synonym in as a Note, so we don't lose the info for + -- error messages, but it's too much work for right now. + -- KSW 2000-07. + +toHsType (NoteTy _ ty) = toHsType ty + +toHsType (PredTy p) = HsPredTy (toHsPred p) + +toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind * + | not saturated = generic_case + | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc)) tys' + | tc `hasKey` listTyConKey = HsListTy (head tys') + | tc `hasKey` usOnceTyConKey = hsUsOnce_Name -- must print !, . unqualified + | tc `hasKey` usManyTyConKey = hsUsMany_Name -- must print !, . unqualified + | otherwise = generic_case where generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys' tys' = map toHsType tys saturated = length tys == tyConArity tc -toHsType' ty@(ForAllTy _ _) = case splitSigmaTy ty of +toHsType ty@(ForAllTy _ _) = case splitSigmaTy ty of (tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs)) (map toHsPred preds) (toHsType tau) +toHsType (UsageTy u ty) = HsUsageTy (toHsType u) (toHsType ty) + -- **! consider dropping usMany annotations ToDo KSW 2000-10 + toHsPred (Class cls tys) = HsPClass (getName cls) (map toHsType tys) toHsPred (IParam n ty) = HsPIParam (getName n) (toHsType ty) @@ -410,12 +426,12 @@ eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2) eq_hsType env (HsPredTy p1) (HsPredTy p2) = eq_hsPred env p1 p2 +eq_hsType env (HsUsageTy u1 ty1) (HsUsageTy u2 ty2) + = eq_hsType env u1 u2 && eq_hsType env ty1 ty2 + eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2) = eq_hsVar env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2 -eq_hsType env (HsUsgTy u1 ty1) (HsUsgTy u2 ty2) - = eqUsg u1 u2 && eq_hsType env ty1 ty2 - eq_hsType env ty1 ty2 = False @@ -430,12 +446,6 @@ eq_hsPred env (HsPIParam n1 ty1) (HsPIParam n2 ty2) eq_hsPred env _ _ = False ------------------- -eqUsg HsUsOnce HsUsOnce = True -eqUsg HsUsMany HsUsMany = True -eqUsg (HsUsVar u1) (HsUsVar u2) = u1 == u2 -eqUsg _ _ = False - -------------------- eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool eqListBy eq [] [] = True eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 69b8565..a1012cd 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -21,6 +21,7 @@ module CmdLineOpts ( isStaticHscFlag, opt_PprStyle_NoPrags, + opt_PprStyle_RawTypes, opt_PprUserLength, opt_PprStyle_Debug, @@ -373,6 +374,7 @@ unpacked_opts = -- debugging opts opt_PprStyle_NoPrags = lookUp SLIT("-dppr-noprags") opt_PprStyle_Debug = lookUp SLIT("-dppr-debug") +opt_PprStyle_RawTypes = lookUp SLIT("-dppr-rawtypes") opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name -- profiling opts diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 63a090e..a8a1a0a 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -31,6 +31,7 @@ import ErrUtils ( dumpIfSet_dyn ) import Outputable import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName ) import TmpFiles ( newTempName ) +import UniqSupply ( mkSplitUniqSupply ) import IO ( IOMode(..), hClose, openFile, Handle ) \end{code} @@ -182,7 +183,7 @@ outputForeignStubs_help is_header doc_str | is_header = "h_stub" | otherwise = "c_stub" include_prefix - | is_header = "#include \"Rts.h\"\n" + | is_header = "#include \"HsFFI.h\"\n" | otherwise = "#include \"RtsAPI.h\"\n" \end{code} diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index fce6c58..779c235 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.46 2000/10/31 17:30:17 simonpj Exp $ +$Id: Parser.y,v 1.47 2000/11/07 15:21:40 simonmar Exp $ Haskell grammar. @@ -762,8 +762,14 @@ list :: { RdrNameHsExpr } | exp ',' exp '..' { ArithSeqIn (FromThen $1 $3) } | exp '..' exp { ArithSeqIn (FromTo $1 $3) } | exp ',' exp '..' exp { ArithSeqIn (FromThenTo $1 $3 $5) } - | exp srcloc '|' quals { HsDo ListComp (reverse - (ReturnStmt $1 : $4)) $2 } + | exp srcloc pquals {% let { body [qs] = qs; + body qss = [ParStmt (map reverse qss)] } + in + returnP ( HsDo ListComp + (reverse (ReturnStmt $1 : body $3)) + $2 + ) + } lexps :: { [RdrNameHsExpr] } : lexps ',' exp { $3 : $1 } @@ -772,6 +778,10 @@ lexps :: { [RdrNameHsExpr] } ----------------------------------------------------------------------------- -- List Comprehensions +pquals :: { [[RdrNameStmt]] } + : pquals '|' quals { $3 : $1 } + | '|' quals { [$2] } + quals :: { [RdrNameStmt] } : quals ',' qual { $3 : $1 } | qual { [$1] } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 54e9408..8870c14 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -160,8 +160,6 @@ extract_ty (HsListTy ty) acc = extract_ty ty acc extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsPredTy p) acc = extract_pred p acc -extract_ty (HsUsgTy usg ty) acc = extract_ty ty acc -extract_ty (HsUsgForAllTy uv ty) acc = extract_ty ty acc extract_ty (HsTyVar tv) acc = tv : acc extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc) -- Generics diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 4b10236..391a77d 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -37,8 +37,8 @@ module PrelNames ( #include "HsVersions.h" import Module ( ModuleName, mkPrelModule, mkModuleName ) -import OccName ( NameSpace, UserFS, varName, dataName, tcName, clsName ) -import RdrName ( RdrName, mkOrig ) +import OccName ( NameSpace, UserFS, varName, dataName, tcName, clsName, mkKindOccFS ) +import RdrName ( RdrName, mkOrig, mkRdrOrig ) import UniqFM import Unique ( Unique, Uniquable(..), hasKey, mkPreludeMiscIdUnique, mkPreludeDataConUnique, @@ -123,7 +123,7 @@ knownKeyNames fromRationalName, deRefStablePtrName, - makeStablePtrName, + newStablePtrName, bindIOName, returnIOName, @@ -253,9 +253,41 @@ and it's convenient to write them all down in one place. mainName = varQual mAIN_Name SLIT("main") mainKey -- Stuff from PrelGHC -funTyConName = tcQual pREL_GHC_Name SLIT("(->)") funTyConKey -cCallableClassName = clsQual pREL_GHC_Name SLIT("CCallable") cCallableClassKey -cReturnableClassName = clsQual pREL_GHC_Name SLIT("CReturnable") cReturnableClassKey +usOnceTyConName = kindQual SLIT(".") usOnceTyConKey +usManyTyConName = kindQual SLIT("!") usManyTyConKey +superKindName = kindQual SLIT("KX") kindConKey +superBoxityName = kindQual SLIT("BX") boxityConKey +boxedConName = kindQual SLIT("*") boxedConKey +unboxedConName = kindQual SLIT("#") unboxedConKey +openKindConName = kindQual SLIT("?") anyBoxConKey +usageKindConName = kindQual SLIT("$") usageConKey +typeConName = kindQual SLIT("Type") typeConKey + +funTyConName = tcQual pREL_GHC_Name SLIT("(->)") funTyConKey +charPrimTyConName = tcQual pREL_GHC_Name SLIT("Char#") charPrimTyConKey +intPrimTyConName = tcQual pREL_GHC_Name SLIT("Int#") intPrimTyConKey +int64PrimTyConName = tcQual pREL_GHC_Name SLIT("Int64#") int64PrimTyConKey +wordPrimTyConName = tcQual pREL_GHC_Name SLIT("Word#") wordPrimTyConKey +word64PrimTyConName = tcQual pREL_GHC_Name SLIT("Word64#") word64PrimTyConKey +addrPrimTyConName = tcQual pREL_GHC_Name SLIT("Addr#") addrPrimTyConKey +floatPrimTyConName = tcQual pREL_GHC_Name SLIT("Float#") floatPrimTyConKey +doublePrimTyConName = tcQual pREL_GHC_Name SLIT("Double#") doublePrimTyConKey +statePrimTyConName = tcQual pREL_GHC_Name SLIT("State#") statePrimTyConKey +realWorldTyConName = tcQual pREL_GHC_Name SLIT("RealWorld") realWorldTyConKey +arrayPrimTyConName = tcQual pREL_GHC_Name SLIT("Array#") arrayPrimTyConKey +byteArrayPrimTyConName = tcQual pREL_GHC_Name SLIT("ByteArray#") byteArrayPrimTyConKey +mutableArrayPrimTyConName = tcQual pREL_GHC_Name SLIT("MutableArray#") mutableArrayPrimTyConKey +mutableByteArrayPrimTyConName = tcQual pREL_GHC_Name SLIT("MutableByteArray#") mutableByteArrayPrimTyConKey +mutVarPrimTyConName = tcQual pREL_GHC_Name SLIT("MutVar#") mutVarPrimTyConKey +mVarPrimTyConName = tcQual pREL_GHC_Name SLIT("MVar#") mVarPrimTyConKey +stablePtrPrimTyConName = tcQual pREL_GHC_Name SLIT("StablePtr#") stablePtrPrimTyConKey +stableNamePrimTyConName = tcQual pREL_GHC_Name SLIT("StableName#") stableNamePrimTyConKey +foreignObjPrimTyConName = tcQual pREL_GHC_Name SLIT("ForeignObj#") foreignObjPrimTyConKey +bcoPrimTyConName = tcQual pREL_GHC_Name SLIT("BCO#") bcoPrimTyConKey +weakPrimTyConName = tcQual pREL_GHC_Name SLIT("Weak#") weakPrimTyConKey +threadIdPrimTyConName = tcQual pREL_GHC_Name SLIT("ThreadId#") threadIdPrimTyConKey +cCallableClassName = clsQual pREL_GHC_Name SLIT("CCallable") cCallableClassKey +cReturnableClassName = clsQual pREL_GHC_Name SLIT("CReturnable") cReturnableClassKey -- PrelBase data types and constructors charTyConName = tcQual pREL_BASE_Name SLIT("Char") charTyConKey @@ -395,11 +427,10 @@ mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") m -- Forign objects and weak pointers foreignObjTyConName = tcQual pREL_IO_BASE_Name SLIT("ForeignObj") foreignObjTyConKey foreignObjDataConName = dataQual pREL_IO_BASE_Name SLIT("ForeignObj") foreignObjDataConKey -bcoPrimTyConName = tcQual pREL_BASE_Name SLIT("BCO#") bcoPrimTyConKey stablePtrTyConName = tcQual pREL_STABLE_Name SLIT("StablePtr") stablePtrTyConKey stablePtrDataConName = dataQual pREL_STABLE_Name SLIT("StablePtr") stablePtrDataConKey deRefStablePtrName = varQual pREL_STABLE_Name SLIT("deRefStablePtr") deRefStablePtrIdKey -makeStablePtrName = varQual pREL_STABLE_Name SLIT("makeStablePtr") makeStablePtrIdKey +newStablePtrName = varQual pREL_STABLE_Name SLIT("newStablePtr") newStablePtrIdKey errorName = varQual pREL_ERR_Name SLIT("error") errorIdKey assertName = varQual pREL_GHC_Name SLIT("assert") assertIdKey @@ -514,7 +545,7 @@ unpackCString_RDR = nameRdrName unpackCStringName unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name deRefStablePtr_RDR = nameRdrName deRefStablePtrName -makeStablePtr_RDR = nameRdrName makeStablePtrName +newStablePtr_RDR = nameRdrName newStablePtrName bindIO_RDR = nameRdrName bindIOName returnIO_RDR = nameRdrName returnIOName main_RDR = nameRdrName mainName @@ -537,6 +568,10 @@ dataQual mod str uq = mkKnownKeyGlobal (dataQual_RDR mod str) uq tcQual mod str uq = mkKnownKeyGlobal (tcQual_RDR mod str) uq clsQual mod str uq = mkKnownKeyGlobal (clsQual_RDR mod str) uq +kindQual str uq = mkKnownKeyGlobal (mkRdrOrig pREL_GHC_Name (mkKindOccFS tcName str)) uq + -- Kinds are not z-encoded in interface file, hence mkKindOccFS + -- And they all come from PrelGHC + varQual_RDR mod str = mkOrig varName mod str tcQual_RDR mod str = mkOrig tcName mod str clsQual_RDR mod str = mkOrig clsName mod str @@ -636,10 +671,15 @@ typeConKey = mkPreludeTyConUnique 69 threadIdPrimTyConKey = mkPreludeTyConUnique 70 bcoPrimTyConKey = mkPreludeTyConUnique 71 +-- Usage type constructors +usageConKey = mkPreludeTyConUnique 72 +usOnceTyConKey = mkPreludeTyConUnique 73 +usManyTyConKey = mkPreludeTyConUnique 74 + -- Generic Type Constructors -crossTyConKey = mkPreludeTyConUnique 72 -plusTyConKey = mkPreludeTyConUnique 73 -genUnitTyConKey = mkPreludeTyConUnique 74 +crossTyConKey = mkPreludeTyConUnique 75 +plusTyConKey = mkPreludeTyConUnique 76 +genUnitTyConKey = mkPreludeTyConUnique 77 \end{code} %************************************************************************ @@ -717,7 +757,7 @@ zipIdKey = mkPreludeMiscIdUnique 35 bindIOIdKey = mkPreludeMiscIdUnique 36 returnIOIdKey = mkPreludeMiscIdUnique 37 deRefStablePtrIdKey = mkPreludeMiscIdUnique 38 -makeStablePtrIdKey = mkPreludeMiscIdUnique 39 +newStablePtrIdKey = mkPreludeMiscIdUnique 39 getTagIdKey = mkPreludeMiscIdUnique 40 plusIntegerIdKey = mkPreludeMiscIdUnique 41 timesIntegerIdKey = mkPreludeMiscIdUnique 42 diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index e334fa1..70386d4 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -39,7 +39,7 @@ import TyCon ( TyCon, tyConArity ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, mkTyVarTys, mkTyConApp, typePrimRep, splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe, - UsageAnn(..), mkUsgTy + mkUTy, usOnce, usMany ) import Unique ( Unique, mkPrimOpIdUnique ) import BasicTypes ( Arity, Boxity(..) ) @@ -489,11 +489,11 @@ primOpUsg p@(CCallOp _) = mangle p [] mkM -- Helper bits & pieces for usage info. -mkZ = mkUsgTy UsOnce -- pointed argument used zero -mkO = mkUsgTy UsOnce -- pointed argument used once -mkM = mkUsgTy UsMany -- pointed argument used multiply -mkP = mkUsgTy UsOnce -- unpointed argument -mkR = mkUsgTy UsMany -- unpointed result +mkZ = mkUTy usOnce -- pointed argument used zero +mkO = mkUTy usOnce -- pointed argument used once +mkM = mkUTy usMany -- pointed argument used multiply +mkP = mkUTy usOnce -- unpointed argument +mkR = mkUTy usMany -- unpointed result nomangle op = case primOpSig op of diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 6eaa3c6..05feb3b 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -49,15 +49,13 @@ module TysPrim( #include "HsVersions.h" import Var ( TyVar, mkSysTyVar ) -import OccName ( tcName ) +import Name ( Name ) import PrimRep ( PrimRep(..), isFollowableRep ) -import TyCon ( mkPrimTyCon, TyCon, ArgVrcs ) +import TyCon ( TyCon, ArgVrcs, mkPrimTyCon ) import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy, unboxedTypeKind, boxedTypeKind, openTypeKind, mkArrowKinds ) -import Unique ( Unique, mkAlphaTyVarUnique ) -import Name ( mkKnownKeyGlobal ) -import RdrName ( mkOrig ) +import Unique ( mkAlphaTyVarUnique ) import PrelNames import Outputable \end{code} @@ -147,39 +145,38 @@ vrcsZP = [vrcZero,vrcPos] \begin{code} -- only used herein -pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> ArgVrcs -> PrimRep -> TyCon -pcPrimTyCon key str arity arg_vrcs rep +pcPrimTyCon :: Name -> Int -> ArgVrcs -> PrimRep -> TyCon +pcPrimTyCon name arity arg_vrcs rep = the_tycon where - name = mkKnownKeyGlobal (mkOrig tcName pREL_GHC_Name str) key the_tycon = mkPrimTyCon name kind arity arg_vrcs rep kind = mkArrowKinds (take arity (repeat boxedTypeKind)) result_kind result_kind | isFollowableRep rep = boxedTypeKind -- Represented by a GC-ish ptr | otherwise = unboxedTypeKind -- Represented by a non-ptr charPrimTy = mkTyConTy charPrimTyCon -charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 [] CharRep +charPrimTyCon = pcPrimTyCon charPrimTyConName 0 [] CharRep intPrimTy = mkTyConTy intPrimTyCon -intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 [] IntRep +intPrimTyCon = pcPrimTyCon intPrimTyConName 0 [] IntRep int64PrimTy = mkTyConTy int64PrimTyCon -int64PrimTyCon = pcPrimTyCon int64PrimTyConKey SLIT("Int64#") 0 [] Int64Rep +int64PrimTyCon = pcPrimTyCon int64PrimTyConName 0 [] Int64Rep wordPrimTy = mkTyConTy wordPrimTyCon -wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 [] WordRep +wordPrimTyCon = pcPrimTyCon wordPrimTyConName 0 [] WordRep word64PrimTy = mkTyConTy word64PrimTyCon -word64PrimTyCon = pcPrimTyCon word64PrimTyConKey SLIT("Word64#") 0 [] Word64Rep +word64PrimTyCon = pcPrimTyCon word64PrimTyConName 0 [] Word64Rep addrPrimTy = mkTyConTy addrPrimTyCon -addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 [] AddrRep +addrPrimTyCon = pcPrimTyCon addrPrimTyConName 0 [] AddrRep floatPrimTy = mkTyConTy floatPrimTyCon -floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 [] FloatRep +floatPrimTyCon = pcPrimTyCon floatPrimTyConName 0 [] FloatRep doublePrimTy = mkTyConTy doublePrimTyCon -doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 [] DoubleRep +doublePrimTyCon = pcPrimTyCon doublePrimTyConName 0 [] DoubleRep \end{code} @@ -200,7 +197,7 @@ keep different state threads separate. It is represented by nothing at all. \begin{code} mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] -statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1 vrcsZ VoidRep +statePrimTyCon = pcPrimTyCon statePrimTyConName 1 vrcsZ VoidRep \end{code} @_RealWorld@ is deeply magical. It {\em is primitive}, but it @@ -210,7 +207,7 @@ system, to parameterise State#. \begin{code} realWorldTy = mkTyConTy realWorldTyCon -realWorldTyCon = pcPrimTyCon realWorldTyConKey SLIT("RealWorld") 0 [] PrimPtrRep +realWorldTyCon = pcPrimTyCon realWorldTyConName 0 [] PrimPtrRep realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld \end{code} @@ -225,15 +222,10 @@ defined in \tr{TysWiredIn.lhs}, not here. %************************************************************************ \begin{code} -arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1 vrcsP ArrayRep - -byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0 [] ByteArrayRep - -mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") - 2 vrcsZP ArrayRep - -mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") - 1 vrcsZ ByteArrayRep +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName 1 vrcsP ArrayRep +byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConName 0 [] ByteArrayRep +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName 2 vrcsZP ArrayRep +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName 1 vrcsZ ByteArrayRep mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt] byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon @@ -248,8 +240,7 @@ mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s] %************************************************************************ \begin{code} -mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConKey SLIT("MutVar#") - 2 vrcsZP PrimPtrRep +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 vrcsZP PrimPtrRep mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] \end{code} @@ -261,8 +252,7 @@ mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -mVarPrimTyCon = pcPrimTyCon mVarPrimTyConKey SLIT("MVar#") - 2 vrcsZP PrimPtrRep +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 vrcsZP PrimPtrRep mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] \end{code} @@ -274,8 +264,7 @@ mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") - 1 vrcsP StablePtrRep +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 vrcsP StablePtrRep mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] \end{code} @@ -287,8 +276,7 @@ mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] %************************************************************************ \begin{code} -stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConKey SLIT("StableName#") - 1 vrcsP StableNameRep +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 vrcsP StableNameRep mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty] \end{code} @@ -311,7 +299,7 @@ dead before it really was. \begin{code} foreignObjPrimTy = mkTyConTy foreignObjPrimTyCon -foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 [] ForeignObjRep +foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConName 0 [] ForeignObjRep \end{code} %************************************************************************ @@ -322,7 +310,7 @@ foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 [ \begin{code} bcoPrimTy = mkTyConTy bcoPrimTyCon -bcoPrimTyCon = pcPrimTyCon bcoPrimTyConKey SLIT("BCO#") 0 [] BCORep +bcoPrimTyCon = pcPrimTyCon bcoPrimTyConName 0 [] BCORep \end{code} %************************************************************************ @@ -332,7 +320,7 @@ bcoPrimTyCon = pcPrimTyCon bcoPrimTyConKey SLIT("BCO#") 0 [] BCORep %************************************************************************ \begin{code} -weakPrimTyCon = pcPrimTyCon weakPrimTyConKey SLIT("Weak#") 1 vrcsP WeakPtrRep +weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 vrcsP WeakPtrRep mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v] \end{code} @@ -354,7 +342,7 @@ to the thread id internally. \begin{code} threadIdPrimTy = mkTyConTy threadIdPrimTyCon -threadIdPrimTyCon = pcPrimTyCon threadIdPrimTyConKey SLIT("ThreadId#") 0 [] ThreadIdRep +threadIdPrimTyCon = pcPrimTyCon threadIdPrimTyConName 0 [] ThreadIdRep \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/primops.txt b/ghc/compiler/prelude/primops.txt index 5eff2f5..fb3a522 100644 --- a/ghc/compiler/prelude/primops.txt +++ b/ghc/compiler/prelude/primops.txt @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt,v 1.5 2000/09/26 16:45:34 simonpj Exp $ +-- $Id: primops.txt,v 1.6 2000/11/07 15:21:40 simonmar Exp $ -- -- Primitive Operations -- @@ -422,6 +422,22 @@ primop IntegerToInt64Op "integerToInt64#" GenPrimOp primop IntegerToWord64Op "integerToWord64#" GenPrimOp Int# -> ByteArr# -> Word64# +primop IntegerAndOp "andInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerOrOp "orInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerXorOp "xorInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerComplementOp "complementInteger#" GenPrimOp + Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + ------------------------------------------------------------------------ --- Word# --- ------------------------------------------------------------------------ diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index c141938..1bf43a2 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -34,7 +34,7 @@ module ParseIface ( parseIface, IfaceStuff(..) ) where import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms -import HsTypes ( mkHsForAllTy, mkHsUsForAllTy, mkHsTupCon ) +import HsTypes ( mkHsForAllTy, mkHsTupCon ) import HsCore import Demand ( mkStrictnessInfo ) import Literal ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 ) @@ -43,7 +43,7 @@ import BasicTypes ( Fixity(..), FixityDirection(..), ) import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) ) import CallConv ( cCallConv ) -import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind ) +import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind, usageTypeKind ) import IdInfo ( exactArity, InlinePragInfo(..) ) import PrimOp ( CCall(..), CCallTarget(..) ) import Lex @@ -56,14 +56,13 @@ import HscTypes ( WhetherHasOrphans, IsBootInterface, GenAvailInfo(..), import RdrName ( RdrName, mkRdrUnqual, mkIfaceOrig ) import Name ( OccName ) import OccName ( mkSysOccFS, - tcName, varName, ipName, dataName, clsName, tvName, uvName, + tcName, varName, ipName, dataName, clsName, tvName, EncodedFS ) import Module ( ModuleName, PackageName, mkSysModuleNameFS, mkModule ) import SrcLoc ( SrcLoc ) import CmdLineOpts ( opt_InPackage, opt_IgnoreIfacePragmas ) import Outputable -import List ( insert ) import Class ( DefMeth (..) ) import GlaExts @@ -136,7 +135,6 @@ import FastString ( tailFS ) '__sccC' { ITsccAllCafs } '__u' { ITusage } - '__fuall' { ITfuall } '__A' { ITarity } '__P' { ITspecialise } @@ -155,13 +153,10 @@ import FastString ( tailFS ) '<-' { ITlarrow } '->' { ITrarrow } '@' { ITat } - '~' { ITtilde } '=>' { ITdarrow } '-' { ITminus } '!' { ITbang } - '/\\' { ITbiglam } -- GHC-extension symbols - '{' { ITocurly } -- special symbols '}' { ITccurly } '{|' { ITocurlybar } -- special symbols @@ -174,6 +169,7 @@ import FastString ( tailFS ) '#)' { ITcubxparen } ';' { ITsemi } ',' { ITcomma } + '.' { ITdot } VARID { ITvarid $$ } -- identifiers CONID { ITconid $$ } @@ -494,30 +490,27 @@ batypes : { [] } | batype batypes { $1 : $2 } batype :: { RdrNameBangType } -batype : atype { Unbanged $1 } - | '!' atype { Banged $2 } - | '!' '!' atype { Unpacked $3 } +batype : tatype { Unbanged $1 } + | '!' tatype { Banged $2 } + | '!' '!' tatype { Unpacked $3 } fields1 :: { [([RdrName], RdrNameBangType)] } fields1 : field { [$1] } | field ',' fields1 { $1 : $3 } field :: { ([RdrName], RdrNameBangType) } -field : qvar_names1 '::' type { ($1, Unbanged $3) } - | qvar_names1 '::' '!' type { ($1, Banged $4) } - | qvar_names1 '::' '!' '!' type { ($1, Unpacked $5) } +field : qvar_names1 '::' ttype { ($1, Unbanged $3) } + | qvar_names1 '::' '!' ttype { ($1, Banged $4) } + | qvar_names1 '::' '!' '!' ttype { ($1, Unpacked $5) } + -------------------------------------------------------------------------- type :: { RdrNameHsType } -type : '__fuall' fuall '=>' type { mkHsUsForAllTy $2 $4 } - | '__forall' tv_bndrs +type : '__forall' tv_bndrs opt_context '=>' type { mkHsForAllTy (Just $2) $3 $5 } | btype '->' type { HsFunTy $1 $3 } | btype { $1 } -fuall :: { [RdrName] } -fuall : '[' uv_bndrs ']' { $2 } - opt_context :: { RdrNameContext } opt_context : { [] } | context { $1 } @@ -546,16 +539,13 @@ types2 : type ',' type { [$1,$3] } btype :: { RdrNameHsType } btype : atype { $1 } | btype atype { HsAppTy $1 $2 } - | '__u' usage atype { HsUsgTy $2 $3 } - -usage :: { HsUsageAnn RdrName } -usage : '-' { HsUsOnce } - | '!' { HsUsMany } - | uv_name { HsUsVar $1 } + | '__u' atype atype { HsUsageTy $2 $3 } atype :: { RdrNameHsType } atype : qtc_name { HsTyVar $1 } | tv_name { HsTyVar $1 } + | '.' { hsUsOnce } + | '!' { hsUsMany } | '(' ')' { HsTupleTy (mkHsTupCon tcName Boxed []) [] } | '(' types2 ')' { HsTupleTy (mkHsTupCon tcName Boxed $2) $2 } | '(#' types0 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 } @@ -567,7 +557,34 @@ atype : qtc_name { HsTyVar $1 } atypes :: { [RdrNameHsType] {- Zero or more -} } atypes : { [] } | atype atypes { $1 : $2 } +-------------------------------------------------------------------------- + +-- versions of type/btype/atype that cant begin with '!' (or '.') +-- for use where the kind is definitely known NOT to be '$' + +ttype :: { RdrNameHsType } +ttype : '__forall' tv_bndrs + opt_context '=>' type { mkHsForAllTy (Just $2) $3 $5 } + | tbtype '->' type { HsFunTy $1 $3 } + | tbtype { $1 } + +tbtype :: { RdrNameHsType } +tbtype : tatype { $1 } + | tbtype atype { HsAppTy $1 $2 } + | '__u' atype atype { HsUsageTy $2 $3 } + +tatype :: { RdrNameHsType } +tatype : qtc_name { HsTyVar $1 } + | tv_name { HsTyVar $1 } + | '(' ')' { HsTupleTy (mkHsTupCon tcName Boxed []) [] } + | '(' types2 ')' { HsTupleTy (mkHsTupCon tcName Boxed $2) $2 } + | '(#' types0 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 } + | '[' type ']' { HsListTy $2 } + | '{' qcls_name atypes '}' { mkHsDictTy $2 $3 } + | '{' ipvar_name '::' type '}' { mkHsIParamTy $2 $4 } + | '(' type ')' { $2 } --------------------------------------------------------------------- + package :: { PackageName } : STRING { $1 } | {- empty -} { opt_InPackage } -- Useful for .hi-boot files, @@ -671,27 +688,15 @@ qcls_name :: { RdrName } | qdata_fs { mkIfaceOrig clsName $1 } --------------------------------------------------- -uv_name :: { RdrName } - : VARID { mkRdrUnqual (mkSysOccFS uvName $1) } - -uv_bndr :: { RdrName } - : uv_name { $1 } - -uv_bndrs :: { [RdrName] } - : { [] } - | uv_bndr uv_bndrs { $1 : $2 } - ---------------------------------------------------- tv_name :: { RdrName } : VARID { mkRdrUnqual (mkSysOccFS tvName $1) } - | VARSYM { mkRdrUnqual (mkSysOccFS tvName $1) {- Allow t2 as a tyvar -} } tv_bndr :: { HsTyVarBndr RdrName } : tv_name '::' akind { IfaceTyVar $1 $3 } | tv_name { IfaceTyVar $1 boxedTypeKind } tv_bndrs :: { [HsTyVarBndr RdrName] } -tv_bndrs : tv_bndrs1 { $1 } + : tv_bndrs1 { $1 } | '[' tv_bndrs1 ']' { $2 } -- Backward compatibility tv_bndrs1 :: { [HsTyVarBndr RdrName] } @@ -724,7 +729,9 @@ akind :: { Kind } boxedTypeKind else if $1 == SLIT("?") then openTypeKind - else panic "ParseInterface: akind" + else if $1 == SLIT("\36") then + usageTypeKind -- dollar + else panic "ParseInterface: akind" } | '(' kind ')' { $2 } diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index b991dc8..782ae26 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -381,6 +381,12 @@ bindLocalNames names enclosed_scope where pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names] +bindLocalNamesFV names enclosed_scope + = bindLocalNames names $ + enclosed_scope `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs names) + + ------------------------------------- bindLocalRn doc rdr_name enclosed_scope = getSrcLocRn `thenRn` \ loc -> @@ -402,10 +408,6 @@ bindLocalsFVRn doc rdr_names enclosed_scope returnRn (thing, delListFromNameSet fvs names) ------------------------------------- -bindUVarRn :: RdrName -> (Name -> RnMS a) -> RnMS a -bindUVarRn = bindCoreLocalRn - -------------------------------------- extendTyVarEnvFVRn :: [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/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 382f429..a881534 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -45,6 +45,7 @@ import NameSet import UniqFM ( isNullUFM ) import FiniteMap ( elemFM ) import UniqSet ( emptyUniqSet ) +import List ( intersectBy ) import ListSetOps ( unionLists, removeDups ) import Maybes ( maybeToBool ) import Outputable @@ -228,7 +229,7 @@ rnGRHS (GRHS guarded locn) returnRn () ) `thenRn_` - rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) -> + rnStmts rnExpr guarded `thenRn` \ ((_, guarded'), fvs) -> returnRn (GRHS guarded' locn, fvs) where -- Standard Haskell 1.4 guards are just a single boolean @@ -375,13 +376,13 @@ rnExpr (HsWith expr binds) rnExpr e@(HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs -> - rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) -> + rnStmts rnExpr stmts `thenRn` \ ((_, stmts'), fvs) -> -- check the statement list ends in an expression case last stmts' of { ExprStmt _ _ -> returnRn () ; ReturnStmt _ -> returnRn () ; -- for list comprehensions _ -> addErrRn (doStmtListErr e) - } `thenRn_` + } `thenRn_` returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs) where implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR] @@ -542,29 +543,46 @@ Quals. type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) rnStmts :: RnExprTy - -> [RdrNameStmt] - -> RnMS ([RenamedStmt], FreeVars) + -> [RdrNameStmt] + -> RnMS (([Name], [RenamedStmt]), FreeVars) rnStmts rn_expr [] - = returnRn ([], emptyFVs) + = returnRn (([], []), emptyFVs) rnStmts rn_expr (stmt:stmts) - = rnStmt rn_expr stmt $ \ stmt' -> - rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) -> - returnRn (stmt' : stmts', fvs) + = getLocalNameEnv `thenRn` \ name_env -> + rnStmt rn_expr stmt $ \ stmt' -> + rnStmts rn_expr stmts `thenRn` \ ((binders, stmts'), fvs) -> + returnRn ((binders, stmt' : stmts'), fvs) rnStmt :: RnExprTy -> RdrNameStmt - -> (RenamedStmt -> RnMS (a, FreeVars)) - -> RnMS (a, FreeVars) + -> (RenamedStmt -> RnMS (([Name], a), FreeVars)) + -> RnMS (([Name], a), FreeVars) -- Because of mutual recursion we have to pass in rnExpr. +rnStmt rn_expr (ParStmt stmtss) thing_inside + = mapFvRn (rnStmts rn_expr) stmtss `thenRn` \ (bndrstmtss, fv_stmtss) -> + let (binderss, stmtss') = unzip bndrstmtss + checkBndrs all_bndrs bndrs + = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_` + returnRn (bndrs ++ all_bndrs) + eqOcc n1 n2 = nameOccName n1 == nameOccName n2 + err = text "duplicate binding in parallel list comprehension" + in + foldlRn checkBndrs [] binderss `thenRn` \ binders -> + bindLocalNamesFV binders $ + thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) -> + returnRn ((rest_bndrs ++ binders, result), fv_stmtss `plusFV` fv_rest) + rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside = pushSrcLocRn src_loc $ - rn_expr expr `thenRn` \ (expr', fv_expr) -> - bindLocalsFVRn doc binders $ \ new_binders -> - rnPat pat `thenRn` \ (pat', fv_pat) -> - thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat) + rn_expr expr `thenRn` \ (expr', fv_expr) -> + bindLocalsFVRn doc binders $ \ new_binders -> + rnPat pat `thenRn` \ (pat', fv_pat) -> + thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) -> + -- ZZ is shadowing handled correctly? + returnRn ((rest_binders ++ new_binders, result), + fv_expr `plusFV` fvs `plusFV` fv_pat) where binders = collectPatBinders pat doc = text "a pattern in do binding" @@ -587,8 +605,9 @@ rnStmt rn_expr (ReturnStmt expr) thing_inside returnRn (result, fv_expr `plusFV` fvs) rnStmt rn_expr (LetStmt binds) thing_inside - = rnBinds binds $ \ binds' -> + = rnBinds binds $ \ binds' -> thing_inside (LetStmt binds') + \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index dc4bd87..d883716 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -81,8 +81,6 @@ extractHsTyNames ty `unionNameSets` extractHsTyNames_s tys get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsPredTy p) = extractHsPredTyNames p - get (HsUsgForAllTy uv ty) = get ty - get (HsUsgTy u ty) = get ty get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets` unitNameSet tycon get (HsNumTy n) = emptyNameSet diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index d4a6f32..43e3cd9 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -244,8 +244,8 @@ slurpSourceRefs source_binders source_fvs go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet = traceRn (text "go_outer" <+> ppr refs) `thenRn_` - getImportedInstDecls all_gates `thenRn` \ inst_decls -> foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) -> + getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls -> rnIfaceInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> go_outer decls2 fvs2 (all_gates `plusFV` gates2) (nameSetToList (gates2 `minusNameSet` all_gates)) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index efeef3d..42f8ce7 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -24,7 +24,7 @@ import HsCore import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs ) import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, lookupIfaceName, lookupOrigNames, lookupSysBinder, newLocalsRn, - bindLocalsFVRn, bindUVarRn, + bindLocalsFVRn, bindTyVarsRn, bindTyVars2Rn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, @@ -36,7 +36,7 @@ import Class ( FunDep, DefMeth (..) ) import Name ( Name, OccName, nameOccName, NamedThing(..) ) import NameSet import PrelInfo ( derivableClassKeys, cCallishClassKeys ) -import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR, +import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR, bindIO_RDR, returnIO_RDR ) import List ( partition, nub ) @@ -131,7 +131,7 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) lookupOccRn name `thenRn` \ name' -> let extra_fvs FoExport - | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR, + | isDyn = lookupOrigNames [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR] | otherwise = lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs -> @@ -613,23 +613,6 @@ rnHsType doc (HsPredTy pred) = rnPred doc pred `thenRn` \ pred' -> returnRn (HsPredTy pred') -rnHsType doc (HsUsgForAllTy uv_rdr ty) - = bindUVarRn uv_rdr $ \ uv_name -> - rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsUsgForAllTy uv_name ty') - -rnHsType doc (HsUsgTy usg ty) - = newUsg usg `thenRn` \ usg' -> - rnHsType doc ty `thenRn` \ ty' -> - -- A for-all can occur inside a usage annotation - returnRn (HsUsgTy usg' ty') - where - newUsg usg = case usg of - HsUsOnce -> returnRn HsUsOnce - HsUsMany -> returnRn HsUsMany - HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name -> - returnRn (HsUsVar uv_name) - rnHsTypes doc tys = mapRn (rnHsType doc) tys \end{code} diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 72ca33c..796cddf 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -215,11 +215,6 @@ fiExpr to_drop (_, AnnNote InlineMe expr) fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr) = -- Just float in past coercion Note note (fiExpr to_drop expr) - -fiExpr to_drop (_, AnnNote note@(TermUsg _) expr) - = -- Float in past term usage annotation - -- (for now; not sure if this is correct: KSW 1999-05) - Note note (fiExpr to_drop expr) \end{code} For @Lets@, the possible ``drop points'' for the \tr{to_drop} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 05c989c..5c7d33d 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -635,24 +635,29 @@ tryRhsTyLam rhs thing_inside -- Only does something if there's a let -- where x* has an INLINE prag on it. Now, once x* is inlined, -- the occurrences of x' will be just the occurrences originally -- pinned on x. - -- poly_info = vanillaIdInfo `setOccInfo` idOccInfo var in returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here)) - mk_silly_bind var rhs = NonRec var rhs + mk_silly_bind var rhs = NonRec var (Note InlineMe rhs) -- Suppose we start with: -- - -- x = let g = /\a -> \x -> f x x - -- in - -- /\ b -> let g* = g b in E + -- x = /\ a -> let g = G in E -- - -- Then: * the binding for g gets floated out - -- * but then it MIGHT get inlined into the rhs of g* - -- * then the binding for g* is floated out of the /\b - -- * so we're back to square one - -- We rely on the simplifier not to inline g into the RHS of g*, - -- because it's a "lone" occurrence, and there is no benefit in - -- inlining. But it's a slightly delicate property; hence this comment + -- Then we'll float to get + -- + -- x = let poly_g = /\ a -> G + -- in /\ a -> let g = poly_g a in E + -- + -- But now the occurrence analyser will see just one occurrence + -- of poly_g, not inside a lambda, so the simplifier will + -- PreInlineUnconditionally poly_g back into g! Badk to square 1! + -- (I used to think that the "don't inline lone occurrences" stuff + -- would stop this happening, but since it's the *only* occurrence, + -- PreInlineUnconditionally kicks in first!) + -- + -- Solution: put an INLINE note on g's RHS, so that poly_g seems + -- to appear many times. (NB: mkInlineMe eliminates + -- such notes on trivial RHSs, so do it manually.) \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index c972821..e654e0d 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -930,7 +930,7 @@ even if they occur exactly once. Reason: (a) some might appear as a function argument, so we simply replace static allocation with dynamic allocation: l = <...> - x = f x + x = f l becomes x = f <...> diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 760cd79..9fa7381 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -360,7 +360,7 @@ bind vs1 vs2 matcher tpl_vars kont subst ---------------------------------------- match_ty ty1 ty2 tpl_vars kont subst - = case Unify.match ty1 ty2 tpl_vars Just (substEnv subst) of + = case Unify.match False {- for now: KSW 2000-10 -} ty1 ty2 tpl_vars Just (substEnv subst) of Nothing -> match_fail Just senv' -> kont (setSubstEnv subst senv') diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index bcb1d9d..4e1ab82 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -31,8 +31,9 @@ import Name ( setNameUnique ) import VarEnv import PrimOp ( PrimOp(..), setCCallUnique ) import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, - UsageAnn(..), tyUsg, applyTy, repType, seqType, - splitRepFunTys, mkFunTys + applyTy, repType, seqType, + splitRepFunTys, mkFunTys, + uaUTy, usOnce, usMany, isTyVarTy ) import UniqSupply -- all of it, really import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) @@ -144,10 +145,12 @@ 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) + once + where + u = uaUTy ty + once | u == usOnce = True + | u == usMany = False + | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany bdrDem :: Id -> RhsDemand bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id)) @@ -297,7 +300,7 @@ exprToRhs dem toplev (StgConApp con args) -- isDllConApp checks for LitLit args too = StgRhsCon noCCS con args -exprToRhs dem _ expr +exprToRhs dem toplev expr = upd `seq` StgRhsClosure noCCS -- No cost centre (ToDo?) stgArgOcc -- safe @@ -307,8 +310,22 @@ exprToRhs dem _ expr [] expr where - upd = if isOnceDem dem then SingleEntry else Updatable - -- HA! Paydirt for "dem" + upd = if isOnceDem dem + then (if isNotTopLevel toplev + then SingleEntry -- HA! Paydirt for "dem" + else +#ifdef DEBUG + trace "WARNING: SE CAFs unsupported, forcing UPD instead" $ +#endif + Updatable) + else Updatable + -- For now we forbid SingleEntry CAFs; they tickle the + -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, + -- and I don't understand why. There's only one SE_CAF (well, + -- only one that tickled a great gaping bug in an earlier attempt + -- at ClosureInfo.getEntryConvention) in the whole of nofib, + -- specifically Main.lvl6 in spectral/cryptarithm2. + -- So no great loss. KSW 2000-07. \end{code} @@ -424,7 +441,7 @@ coreExprToStgFloat env expr@(Lam _ _) (binders, body) = collectBinders expr id_binders = filter isId binders in - if null id_binders then -- It was all type/usage binders; tossed + if null id_binders then -- It was all type binders; tossed coreExprToStgFloat env body else -- At least some value binders @@ -495,7 +512,6 @@ coreExprToStgFloat env expr@(App _ _) collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e in (the_fun,ads,ty,ss) collect_args (Note InlineCall e) = collect_args e - collect_args (Note (TermUsg _) e) = collect_args e collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun in (the_fun,ads,applyTy fun_ty tyarg,ss) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 67b17c4..5d30b11 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -31,14 +31,14 @@ import TcEnv ( TcId, TcEnv, RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo, tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName ) import TcBinds ( tcBindWithSigs, tcSpecSigs ) -import TcMonoType ( tcHsSigType, tcClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig ) +import TcMonoType ( tcHsRecType, tcRecClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig ) import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars ) import TcMonad import Generics ( mkGenericRhs, validGenericMethodType ) import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) -import Class ( classTyVars, classBigSig, classSelIds, classTyCon, classTvsFds, - Class, ClassOpItem, DefMeth (..), FunDep ) +import Class ( classTyVars, classBigSig, classSelIds, classTyCon, + Class, ClassOpItem, DefMeth (..) ) import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) import DataCon ( mkDataCon, notMarkedStrict ) import Id ( Id, idType, idName ) @@ -100,8 +100,9 @@ Death to "ExpandingDicts". %************************************************************************ \begin{code} -tcClassDecl1 :: RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails) -tcClassDecl1 rec_env + +tcClassDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails) +tcClassDecl1 is_rec rec_env (ClassDecl context class_name tyvar_names fundeps class_sigs def_methods sys_names src_loc) @@ -113,7 +114,7 @@ tcClassDecl1 rec_env -- LOOK THINGS UP IN THE ENVIRONMENT tcLookupClass class_name `thenTc` \ clas -> let - (tyvars, fds) = classTvsFds clas + tyvars = classTyVars clas op_sigs = filter isClassOpSig class_sigs op_names = [n | ClassOpSig n _ _ _ <- op_sigs] (_, datacon_name, datacon_wkr_name, sc_sel_names) = getClassDeclSysNames sys_names @@ -125,11 +126,10 @@ tcClassDecl1 rec_env checkGenericClassIsUnary clas dm_info `thenTc_` -- CHECK THE CONTEXT - tcSuperClasses clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) -> + tcSuperClasses is_rec clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) -> -- CHECK THE CLASS SIGNATURES, - mapTc (tcClassSig rec_env clas tyvars fds dm_info) - op_sigs `thenTc` \ sig_stuff -> + mapTc (tcClassSig is_rec rec_env clas tyvars dm_info) op_sigs `thenTc` \ sig_stuff -> -- MAKE THE CLASS DETAILS let @@ -201,13 +201,13 @@ checkGenericClassIsUnary clas dm_info \begin{code} -tcSuperClasses :: Class +tcSuperClasses :: RecFlag -> Class -> RenamedContext -- class context -> [Name] -- Names for superclass selectors -> TcM (ClassContext, -- the superclass context [Id]) -- superclass selector Ids -tcSuperClasses clas context sc_sel_names +tcSuperClasses is_rec clas context sc_sel_names = -- Check the context. -- The renamer has already checked that the context mentions -- only the type variable of the class decl. @@ -221,7 +221,7 @@ tcSuperClasses clas context sc_sel_names ) `thenTc_` -- Context is already kind-checked - tcClassContext context `thenTc` \ sc_theta -> + tcRecClassContext is_rec context `thenTc` \ sc_theta -> let sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names] in @@ -236,10 +236,9 @@ tcSuperClasses clas context sc_sel_names is_tyvar other = False -tcClassSig :: RecTcEnv +tcClassSig :: RecFlag -> RecTcEnv -- Knot tying only! -> Class -- ...ditto... -> [TyVar] -- The class type variable, used for error check only - -> [FunDep TyVar] -> NameEnv (DefMeth Name) -- Info about default methods -> RenamedClassOpSig -> TcM (Type, -- Type of the method @@ -250,19 +249,26 @@ tcClassSig :: RecTcEnv -- so we distinguish them in checkDefaultBinds, and pass this knowledge in the -- Class.DefMeth data structure. -tcClassSig unf_env clas clas_tyvars fds dm_info +tcClassSig is_rec unf_env clas clas_tyvars dm_info (ClassOpSig op_name maybe_dm op_ty src_loc) = tcAddSrcLoc src_loc $ -- Check the type signature. NB that the envt *already has* -- bindings for the type variables; see comments in TcTyAndClassDcls. - tcHsSigType op_ty `thenTc` \ local_ty -> + tcHsRecType is_rec op_ty `thenTc` \ local_ty -> + + -- Check for ambiguous class op types let theta = [mkClassPred clas (mkTyVarTys clas_tyvars)] in - -- Check for ambiguous class op types - checkAmbiguity True clas_tyvars theta local_ty `thenTc` \ global_ty -> + checkAmbiguity is_rec True clas_tyvars theta local_ty `thenTc` \ global_ty -> + -- The default method's type should really come from the + -- iface file, since it could be usage-generalised, but this + -- requires altering the mess of knots in TcModule and I'm + -- too scared to do that. Instead, I have disabled generalisation + -- of types of default methods (and dict funs) by annotating them + -- TyGenNever (in MkId). Ugh! KSW 1999-09. let -- Build the selector id and default method id diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 64430f8..48f97dc 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -47,7 +47,7 @@ import DataCon ( dataConFieldLabels, dataConSig, ) import Name ( Name, getName ) import Type ( mkFunTy, mkAppTy, mkTyVarTys, ipName_maybe, - splitFunTy_maybe, splitFunTys, isNotUsgTy, + splitFunTy_maybe, splitFunTys, mkTyConApp, splitSigmaTy, splitRhoTy, isTauTy, tyVarsOfType, tyVarsOfTypes, @@ -475,8 +475,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty -- Figure out the tycon and data cons from the first field name let (Just (AnId sel_id) : _) = maybe_sel_ids - (_, _, tau) = ASSERT( isNotUsgTy (idType sel_id) ) - splitSigmaTy (idType sel_id) -- Selectors can be overloaded + (_, _, tau) = splitSigmaTy (idType sel_id) -- Selectors can be overloaded -- when the data type has a context Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector (tycon, _, data_cons) = splitAlgTyConApp data_ty @@ -792,12 +791,6 @@ tcArg the_fun (arg, expected_arg_ty, arg_no) %* * %************************************************************************ -Between the renamer and the first invocation of the UsageSP inference, -identifiers read from interface files will have usage information in -their types, whereas other identifiers will not. The unannotTy here -in @tcId@ prevents this information from pointlessly propagating -further prior to the first usage inference. - \begin{code} tcId :: Name -> NF_TcM (TcExpr, LIE, TcType) @@ -808,7 +801,6 @@ tcId name ATcId tc_id -> instantiate_it (OccurrenceOf tc_id) tc_id (idType tc_id) AGlobal (AnId id) -> tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) -> instantiate_it2 (OccurrenceOf id) id tyvars theta tau - where -- The instantiate_it loop runs round instantiating the Id. -- It has to be a loop because we are now prepared to entertain @@ -858,7 +850,7 @@ tcDoStmts do_or_lc stmts src_loc res_ty ListComp -> unifyListTy res_ty `thenTc_` returnTc () _ -> returnTc ()) `thenTc_` - tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) -> + tcStmts do_or_lc (mkAppTy m) elt_ty src_loc stmts `thenTc` \ ((stmts', _), stmts_lie) -> -- Build the then and zero methods in case we need them -- It's important that "then" and "return" appear just once in the final LIE, diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 9dc5fca..a9a89e4 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -510,6 +510,15 @@ zonkStmts :: [TcStmt] zonkStmts [] = returnNF_Tc [] +zonkStmts (ParStmtOut bndrstmtss : stmts) + = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss -> + let new_binders = concat new_bndrss in + mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss -> + tcExtendGlobalValEnv new_binders $ + zonkStmts stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts) + where (bndrss, stmtss) = unzip bndrstmtss + zonkStmts [ReturnStmt expr] = zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc [ReturnStmt new_expr] diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index ed543f6..727a3c2 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -33,7 +33,7 @@ import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe ) import MkId ( mkCCallOpId ) import IdInfo import DataCon ( dataConSig, dataConArgTys ) -import Type ( mkTyVarTys, splitAlgTyConApp_maybe, unUsgTy ) +import Type ( mkTyVarTys, splitAlgTyConApp_maybe ) import Var ( mkTyVar, tyVarKind ) import Name ( Name, isLocallyDefined ) import Demand ( wwLazy ) @@ -212,7 +212,7 @@ tcCoreExpr (UfTuple (HsTupCon name _) args) mapTc tcCoreExpr args `thenTc` \ args' -> let -- Put the missing type arguments back in - con_args = map (Type . unUsgTy . exprType) args' ++ args' + con_args = map (Type . exprType) args' ++ args' in returnTc (mkApps (Var con_id) con_args) @@ -254,8 +254,8 @@ tcCoreExpr (UfNote note expr) = tcCoreExpr expr `thenTc` \ expr' -> case note of UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' -> - returnTc (Note (Coerce (unUsgTy to_ty') - (unUsgTy (exprType expr'))) expr') + returnTc (Note (Coerce to_ty' + (exprType 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/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 54967ac..ca18b67 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -57,7 +57,7 @@ import TyCon ( TyCon, isSynTyCon ) import Type ( splitDFunTy, isTyVarTy, splitTyConApp_maybe, splitDictTy, splitAlgTyConApp_maybe, splitForAllTys, - unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy, + tyVarsOfTypes, mkClassPred, mkTyVarTy, getClassTys_maybe ) import Subst ( mkTopTyVarSubst, substClasses ) @@ -369,9 +369,11 @@ getGenericBinds (AndMonoBinds m1 m2) = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2) getGenericBinds (FunMonoBind id infixop matches loc) - = mapAssoc wrap (foldr add emptyAssoc matches) + = mapAssoc wrap (foldl add emptyAssoc matches) + -- Using foldl not foldr is vital, else + -- we reverse the order of the bindings! where - add match env = case maybeGenericMatch match of + add env match = case maybeGenericMatch match of Nothing -> env Just (ty, match') -> extendAssoc_C (++) env (ty, [match']) @@ -613,7 +615,7 @@ tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, -- emit an error message. This in turn means that we don't -- mention the constructor, which doesn't exist for CCallable, CReturnable -- Hardly beautiful, but only three extra lines. - HsApp (TyApp (HsVar eRROR_ID) [(unUsgTy . idType) this_dict_id]) + HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id]) (HsLit (HsString msg)) | otherwise -- The common case diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 51723ec..8ac55c5 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -21,17 +21,19 @@ import TcHsSyn ( TcMatch, TcGRHSs, TcStmt ) import TcMonad import TcMonoType ( kcHsSigType, tcTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt ) import Inst ( LIE, plusLIE, emptyLIE, plusLIEs ) -import TcEnv ( tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars ) +import TcEnv ( TcId, tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars ) import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig ) import TcType ( TcType, newTyVarTy ) import TcBinds ( tcBindsAndThen ) import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) -import TcUnify ( unifyFunTy, unifyTauTy ) +import TcUnify ( unifyFunTy, unifyTauTy, unifyListTy ) import Name ( Name ) import TysWiredIn ( boolTy ) import BasicTypes ( RecFlag(..) ) -import Type ( tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind, openTypeKind ) +import Type ( tyVarsOfType, isTauTy, mkArrowKind, mkAppTy, mkFunTy, + boxedTypeKind, openTypeKind ) +import SrcLoc ( SrcLoc ) import VarSet import Var ( Id ) import Bag @@ -223,12 +225,13 @@ tcGRHSs (GRHSs grhss binds _) expected_ty ctxt = tcBindsAndThen glue_on binds (tc_grhss grhss) where tc_grhss grhss - = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) -> + = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) -> returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies) tc_grhs (GRHS guarded locn) = tcAddSrcLoc locn $ - tcStmts ctxt (\ty -> ty) guarded expected_ty `thenTc` \ (guarded', lie) -> + tcStmts ctxt (\ty -> ty) expected_ty locn guarded + `thenTc` \ ((guarded', _), lie) -> returnTc (GRHS guarded' locn, lie) \end{code} @@ -265,26 +268,46 @@ tcMatchPats (pat:pats) expected_ty \begin{code} +tcParStep src_loc stmts + = newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenTc` \ m -> + newTyVarTy boxedTypeKind `thenTc` \ elt_ty -> + unifyListTy (mkAppTy m elt_ty) `thenTc_` + + tcStmts ListComp (mkAppTy m) elt_ty src_loc stmts `thenTc` \ ((stmts', val_env), stmts_lie) -> + returnTc (stmts', val_env, stmts_lie) + tcStmts :: StmtCtxt - -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs - -> [RenamedStmt] + -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs -> TcType -- elt_ty, where type of the comprehension is (m elt_ty) - -> TcM ([TcStmt], LIE) + -> SrcLoc + -> [RenamedStmt] + -> TcM (([TcStmt], [(Name, TcId)]), LIE) + +tcStmts do_or_lc m elt_ty loc (ParStmtOut bndrstmtss : stmts) + = let (bndrss, stmtss) = unzip bndrstmtss in + mapAndUnzip3Tc (tcParStep loc) stmtss `thenTc` \ (stmtss', val_envs, lies) -> + let outstmts = zip (map (map snd) val_envs) stmtss' + lie = plusLIEs lies + new_val_env = concat val_envs + in + tcExtendLocalValEnv new_val_env ( + tcStmts do_or_lc m elt_ty loc stmts) `thenTc` \ ((stmts', rest_val_env), stmts_lie) -> + returnTc ((ParStmtOut outstmts : stmts', rest_val_env ++ new_val_env), lie `plusLIE` stmts_lie) -tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty +tcStmts do_or_lc m elt_ty loc (stmt@(ReturnStmt exp) : stmts) = ASSERT( null stmts ) tcSetErrCtxt (stmtCtxt do_or_lc stmt) $ tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) -> - returnTc ([ReturnStmt exp'], exp_lie) + returnTc (([ReturnStmt exp'], []), exp_lie) -- ExprStmt at the end -tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty +tcStmts do_or_lc m elt_ty loc [stmt@(ExprStmt exp src_loc)] = tcSetErrCtxt (stmtCtxt do_or_lc stmt) $ tcExpr exp (m elt_ty) `thenTc` \ (exp', exp_lie) -> - returnTc ([ExprStmt exp' src_loc], exp_lie) + returnTc (([ExprStmt exp' src_loc], []), exp_lie) -- ExprStmt not at the end -tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty +tcStmts do_or_lc m elt_ty loc (stmt@(ExprStmt exp src_loc) : stmts) = ASSERT( isDoStmt do_or_lc ) tcAddSrcLoc src_loc ( tcSetErrCtxt (stmtCtxt do_or_lc stmt) $ @@ -292,21 +315,22 @@ tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty newTyVarTy openTypeKind `thenNF_Tc` \ any_ty -> tcExpr exp (m any_ty) ) `thenTc` \ (exp', exp_lie) -> - tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) -> - returnTc (ExprStmt exp' src_loc : stmts', + tcStmts do_or_lc m elt_ty loc stmts `thenTc` \ ((stmts', rest_val_env), stmts_lie) -> + returnTc ((ExprStmt exp' src_loc : stmts', rest_val_env), exp_lie `plusLIE` stmts_lie) -tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty +tcStmts do_or_lc m elt_ty loc (stmt@(GuardStmt exp src_loc) : stmts) = ASSERT( not (isDoStmt do_or_lc) ) tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( tcAddSrcLoc src_loc $ tcExpr exp boolTy ) `thenTc` \ (exp', exp_lie) -> - tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) -> - returnTc (GuardStmt exp' src_loc : stmts', + tcStmts do_or_lc m elt_ty loc stmts `thenTc` \ ((stmts', rest_val_env), stmts_lie) -> + -- ZZ is this right? + returnTc ((GuardStmt exp' src_loc : stmts', rest_val_env), exp_lie `plusLIE` stmts_lie) -tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty +tcStmts do_or_lc m elt_ty loc (stmt@(BindStmt pat exp src_loc) : stmts) = tcAddSrcLoc src_loc ( tcSetErrCtxt (stmtCtxt do_or_lc stmt) $ newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty -> @@ -325,8 +349,8 @@ tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty -- Do the rest; we don't need to add the pat_tvs to the envt -- because they all appear in the pat_ids's types tcExtendLocalValEnv new_val_env ( - tcStmts do_or_lc m stmts elt_ty - ) `thenTc` \ (stmts', stmts_lie) -> + tcStmts do_or_lc m elt_ty loc stmts + ) `thenTc` \ ((stmts', rest_val_env), stmts_lie) -> -- Reinstate context for existential checks @@ -341,18 +365,24 @@ tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty (mkVarSet zonked_pat_tvs) lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) -> - returnTc (BindStmt pat' exp' src_loc : - consLetStmt (mkMonoBind dict_binds [] Recursive) stmts', - lie_req `plusLIE` final_lie) + -- ZZ we have to be sure that concating the val_env lists preserves + -- shadowing properly... + returnTc ((BindStmt pat' exp' src_loc : + consLetStmt (mkMonoBind dict_binds [] Recursive) stmts', + rest_val_env ++ new_val_env), + lie_req `plusLIE` final_lie) -tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty +tcStmts do_or_lc m elt_ty loc (LetStmt binds : stmts) = tcBindsAndThen -- No error context, but a binding group is combine -- rather a large thing for an error context anyway binds - (tcStmts do_or_lc m stmts elt_ty) + (tcStmts do_or_lc m elt_ty loc stmts) `thenTc` \ ((stmts', rest_val_env), lie) -> + -- ZZ fix val_env + returnTc ((stmts', rest_val_env), lie) where - combine is_rec binds' stmts' = consLetStmt (mkMonoBind binds' [] is_rec) stmts' + combine is_rec binds' (stmts', val_env) = (consLetStmt (mkMonoBind binds' [] is_rec) stmts', undefined) +tcStmts do_or_lc m elt_ty loc [] = returnTc (([], []), emptyLIE) isDoStmt DoStmt = True isDoStmt other = False diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 7e63ec1..1018843 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -131,7 +131,6 @@ tcModule :: PersistentCompilerState tcModule pcs hst get_fixity this_mod decls unf_env = -- Type-check the type and class decls - traceTc (text "Tc1") `thenTc_` tcTyAndClassDecls unf_env decls `thenTc` \ env -> tcSetEnv env $ let @@ -140,14 +139,12 @@ tcModule pcs hst get_fixity this_mod decls unf_env in -- Typecheck the instance decls, includes deriving - traceTc (text "Tc2") `thenTc_` tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) hst unf_env get_fixity this_mod tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) -> tcSetInstEnv inst_env $ -- Default declarations - traceTc (text "Tc3") `thenTc_` tcDefaults decls `thenTc` \ defaulting_tys -> tcSetDefaultTys defaulting_tys $ @@ -160,9 +157,7 @@ tcModule pcs hst get_fixity this_mod decls unf_env -- We must do this before mkImplicitDataBinds (which comes next), since -- the latter looks up unpackCStringId, for example, which is usually -- imported - traceTc (text "Tc3") `thenTc_` tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> - traceTc (text "Tc5") `thenTc_` ( tcExtendGlobalValEnv sig_ids $ tcGetEnv `thenTc` \ unf_env -> @@ -185,18 +180,15 @@ tcModule pcs hst get_fixity this_mod decls unf_env tcExtendGlobalValEnv cls_ids $ -- Foreign import declarations next - traceTc (text "Tc6") `thenTc_` tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) -> tcExtendGlobalValEnv fo_ids $ -- Value declarations next. -- We also typecheck any extra binds that came out of the "deriving" process - traceTc (text "Tc7") `thenTc_` tcTopBinds (get_binds decls `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) -> tcSetEnv env $ -- Foreign export declarations next - traceTc (text "Tc8") `thenTc_` tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) -> -- Second pass over class and instance declarations, diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index ff2b84f..2a05b8c 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -4,8 +4,9 @@ \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} -module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, - tcContext, tcClassContext, checkAmbiguity, +module TcMonoType ( tcHsType, tcHsRecType, + tcHsSigType, tcHsBoxedSigType, + tcRecClassContext, checkAmbiguity, -- Kind checking kcHsTyVar, kcHsTyVars, mkTyClTyVars, @@ -24,13 +25,11 @@ import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig ) import TcHsSyn ( TcId ) import TcMonad -import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, - tcLookupGlobal, tcLookup, - tcEnvTcIds, tcEnvTyVars, - tcGetGlobalTyVars, - TyThing(..), TcTyThing(..) +import TcEnv ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal, + tcGetGlobalTyVars, tcEnvTcIds, tcEnvTyVars, + TyThing(..), TcTyThing(..), tcExtendKindEnv ) -import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType, +import TcType ( TcKind, TcTyVar, TcThetaType, TcTauType, newKindVar, tcInstSigVar, zonkKindEnv, zonkTcType, zonkTcTyVars, zonkTcTyVar ) @@ -47,25 +46,25 @@ import Type ( Type, Kind, PredType(..), ThetaType, mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe, tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, tyVarsOfType, tyVarsOfPred, mkForAllTys, - classesOfPreds, + classesOfPreds, isUnboxedTupleType, isForAllTy ) import PprType ( pprType, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) -import Id ( Id, mkVanillaId, idName, idType, idFreeTyVars ) -import Var ( Var, TyVar, mkTyVar, tyVarKind ) +import Id ( mkVanillaId, idName, idType, idFreeTyVars ) +import Var ( Id, Var, TyVar, mkTyVar, tyVarKind ) import VarEnv import VarSet import ErrUtils ( Message ) import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind ) import Class ( ClassContext, classArity, classTyCon ) -import Name ( Name ) +import Name ( Name, isLocallyDefined ) import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon ) import UniqFM ( elemUFM ) -import BasicTypes ( Boxity(..) ) +import BasicTypes ( Boxity(..), RecFlag(..), isRec ) import SrcLoc ( SrcLoc ) import Util ( mapAccumL, isSingleton ) import Outputable -import HscTypes ( TyThing(..) ) + \end{code} @@ -185,25 +184,20 @@ kcHsBoxedSigType = kcBoxedType --------------------------- kcHsType :: RenamedHsType -> TcM TcKind kcHsType (HsTyVar name) = kcTyVar name -kcHsType (HsUsgTy _ ty) = kcHsType ty -kcHsType (HsUsgForAllTy _ ty) = kcHsType ty kcHsType (HsListTy ty) = kcBoxedType ty `thenTc` \ tau_ty -> returnTc boxedTypeKind -kcHsType (HsTupleTy (HsTupCon _ Boxed) tys) - = mapTc kcBoxedType tys `thenTc_` - returnTc boxedTypeKind - -kcHsType ty@(HsTupleTy (HsTupCon _ Unboxed) tys) - = failWithTc (unboxedTupleErr ty) - -- Unboxed tuples are illegal everywhere except - -- just after a function arrow (see kcFunResType) +kcHsType (HsTupleTy (HsTupCon _ boxity) tys) + = mapTc kcTypeType tys `thenTc_` + returnTc (case boxity of + Boxed -> boxedTypeKind + Unboxed -> unboxedTypeKind) kcHsType (HsFunTy ty1 ty2) = kcTypeType ty1 `thenTc_` - kcFunResType ty2 `thenTc_` + kcTypeType ty2 `thenTc_` returnTc boxedTypeKind kcHsType ty@(HsOpTy ty1 op ty2) @@ -228,27 +222,8 @@ kcHsType (HsForAllTy (Just tv_names) context ty) = kcHsTyVars tv_names `thenNF_Tc` \ kind_env -> tcExtendKindEnv kind_env $ kcHsContext context `thenTc_` - - -- Context behaves like a function type - -- This matters. Return-unboxed-tuple analysis can - -- give overloaded functions like - -- f :: forall a. Num a => (# a->a, a->a #) - -- And we want these to get through the type checker - if null context then - kcHsType ty - else - kcFunResType ty `thenTc_` - returnTc boxedTypeKind - ---------------------------- -kcFunResType :: RenamedHsType -> TcM TcKind --- The only place an unboxed tuple type is allowed --- is at the right hand end of an arrow -kcFunResType (HsTupleTy (HsTupCon _ Unboxed) tys) - = mapTc kcTypeType tys `thenTc_` - returnTc unboxedTypeKind - -kcFunResType ty = kcHsType ty + kcHsType ty `thenTc_` + returnTc boxedTypeKind --------------------------- kcAppKind fun_kind arg_kind @@ -276,7 +251,7 @@ kcHsPred pred@(HsPClass cls tys) mapTc kcHsType tys `thenTc` \ arg_kinds -> unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) ---------------------------- + --------------------------- kcTyVar name -- Could be a tyvar or a tycon = tcLookup name `thenTc` \ thing -> case thing of @@ -313,141 +288,161 @@ tcHsSigType and tcHsBoxedSigType are used for type signatures written by the pro so the kind returned is indeed a Kind not a TcKind \begin{code} -tcHsSigType :: RenamedHsType -> TcM TcType -tcHsSigType ty - = kcTypeType ty `thenTc_` - tcHsType ty `thenTc` \ ty' -> - returnTc (hoistForAllTys ty') - -tcHsBoxedSigType :: RenamedHsType -> TcM Type -tcHsBoxedSigType ty - = kcBoxedType ty `thenTc_` - tcHsType ty `thenTc` \ ty' -> - returnTc (hoistForAllTys ty') +tcHsSigType, tcHsBoxedSigType :: RenamedHsType -> TcM Type + -- Do kind checking, and hoist for-alls to the top +tcHsSigType ty = kcTypeType ty `thenTc_` tcHsType ty +tcHsBoxedSigType ty = kcBoxedType ty `thenTc_` tcHsType ty + +tcHsType :: RenamedHsType -> TcM Type +tcHsRecType :: RecFlag -> RenamedHsType -> TcM Type + -- Don't do kind checking, but do hoist for-alls to the top +tcHsType ty = tc_type NonRecursive ty `thenTc` \ ty' -> returnTc (hoistForAllTys ty') +tcHsRecType wimp_out ty = tc_type wimp_out ty `thenTc` \ ty' -> returnTc (hoistForAllTys ty') \end{code} -tcHsType, the main work horse +%************************************************************************ +%* * +\subsection{tc_type} +%* * +%************************************************************************ + +tc_type, the main work horse ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ------------------- + *** BIG WARNING *** + ------------------- + +tc_type is used to typecheck the types in the RHS of data +constructors. In the case of recursive data types, that means that +the type constructors themselves are (partly) black holes. e.g. + + data T a = MkT a [T a] + +While typechecking the [T a] on the RHS, T itself is not yet fully +defined. That in turn places restrictions on what you can check in +tcHsType; if you poke on too much you get a black hole. I keep +forgetting this, hence this warning! + +The wimp_out argument tells when we are in a mutually-recursive +group of type declarations, so omit various checks else we +get a black hole. They'll be done again later, in TcTyClDecls.tcGroup. + + -------------------------- + *** END OF BIG WARNING *** + -------------------------- + + \begin{code} -tcHsType :: RenamedHsType -> TcM Type -tcHsType ty@(HsTyVar name) - = tc_app ty [] +tc_type :: RecFlag -> RenamedHsType -> TcM Type + +tc_type wimp_out ty@(HsTyVar name) + = tc_app wimp_out ty [] -tcHsType (HsListTy ty) - = tcHsType ty `thenTc` \ tau_ty -> +tc_type wimp_out (HsListTy ty) + = tc_arg_type wimp_out ty `thenTc` \ tau_ty -> returnTc (mkListTy tau_ty) -tcHsType (HsTupleTy (HsTupCon _ boxity) tys) - = mapTc tcHsType tys `thenTc` \ tau_tys -> +tc_type wimp_out (HsTupleTy (HsTupCon _ boxity) tys) + = mapTc tc_tup_arg tys `thenTc` \ tau_tys -> returnTc (mkTupleTy boxity (length tys) tau_tys) - -tcHsType (HsFunTy ty1 ty2) - = tcHsType ty1 `thenTc` \ tau_ty1 -> - tcHsType ty2 `thenTc` \ tau_ty2 -> + where + tc_tup_arg = case boxity of + Boxed -> tc_arg_type wimp_out + Unboxed -> tc_type wimp_out + -- Unboxed tuples can have polymorphic or unboxed args. + -- This happens in the workers for functions returning + -- product types with polymorphic components + +tc_type wimp_out (HsFunTy ty1 ty2) + = tc_type wimp_out ty1 `thenTc` \ tau_ty1 -> + -- Function argument can be polymorphic, but + -- must not be an unboxed tuple + checkTc (not (isUnboxedTupleType tau_ty1)) + (ubxArgTyErr ty1) `thenTc_` + tc_type wimp_out ty2 `thenTc` \ tau_ty2 -> returnTc (mkFunTy tau_ty1 tau_ty2) -tcHsType (HsNumTy n) +tc_type wimp_out (HsNumTy n) = ASSERT(n== 1) returnTc (mkTyConApp genUnitTyCon []) -tcHsType (HsOpTy ty1 op ty2) = - tcHsType ty1 `thenTc` \ tau_ty1 -> - tcHsType ty2 `thenTc` \ tau_ty2 -> +tc_type wimp_out (HsOpTy ty1 op ty2) = + tc_arg_type wimp_out ty1 `thenTc` \ tau_ty1 -> + tc_arg_type wimp_out ty2 `thenTc` \ tau_ty2 -> tc_fun_type op [tau_ty1,tau_ty2] -tcHsType (HsAppTy ty1 ty2) - = tc_app ty1 [ty2] +tc_type wimp_out (HsAppTy ty1 ty2) + = tc_app wimp_out ty1 [ty2] -tcHsType (HsPredTy pred) - = tcClassAssertion True pred `thenTc` \ pred' -> +tc_type wimp_out (HsPredTy pred) + = tc_pred wimp_out pred `thenTc` \ pred' -> returnTc (mkPredTy pred') -tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty) +tc_type wimp_out full_ty@(HsForAllTy (Just tv_names) ctxt ty) = let - kind_check = kcHsContext ctxt `thenTc_` kcFunResType ty + kind_check = kcHsContext ctxt `thenTc_` kcHsType ty in - tcHsTyVars tv_names kind_check $ \ tyvars -> - tcContext ctxt `thenTc` \ theta -> - tcHsType ty `thenTc` \ tau -> - checkAmbiguity is_source tyvars theta tau + tcHsTyVars tv_names kind_check $ \ tyvars -> + tc_context wimp_out ctxt `thenTc` \ theta -> + + -- Context behaves like a function type + -- This matters. Return-unboxed-tuple analysis can + -- give overloaded functions like + -- f :: forall a. Num a => (# a->a, a->a #) + -- And we want these to get through the type checker + (if null theta then + tc_arg_type wimp_out ty + else + tc_type wimp_out ty + ) `thenTc` \ tau -> + + checkAmbiguity wimp_out is_source tyvars theta tau where is_source = case tv_names of (UserTyVar _ : _) -> True other -> False -checkAmbiguity :: Bool -> [TyVar] -> ThetaType -> Type -> TcM Type - -- Check for ambiguity - -- forall V. P => tau - -- is ambiguous if P contains generic variables - -- (i.e. one of the Vs) that are not mentioned in tau + + -- tc_arg_type checks that the argument of a + -- type appplication isn't a for-all type or an unboxed tuple type + -- For example, we want to reject things like: -- - -- However, we need to take account of functional dependencies - -- when we speak of 'mentioned in tau'. Example: - -- class C a b | a -> b where ... - -- Then the type - -- forall x y. (C x y) => x - -- is not ambiguous because x is mentioned and x determines y + -- instance Ord a => Ord (forall s. T s a) + -- and + -- g :: T s (forall b.b) -- - -- NOTE: In addition, GHC insists that at least one type variable - -- in each constraint is in V. So we disallow a type like - -- forall a. Eq b => b -> b - -- even in a scope where b is in scope. - -- This is the is_free test below. - - -- Notes on the 'is_source_polytype' test above - -- Check ambiguity only for source-program types, not - -- for types coming from inteface files. The latter can - -- legitimately have ambiguous types. Example - -- class S a where s :: a -> (Int,Int) - -- instance S Char where s _ = (1,1) - -- f:: S a => [a] -> Int -> (Int,Int) - -- f (_::[a]) x = (a*x,b) - -- where (a,b) = s (undefined::a) - -- Here the worker for f gets the type - -- fw :: forall a. S a => Int -> (# Int, Int #) - -- - -- If the list of tv_names is empty, we have a monotype, - -- and then we don't need to check for ambiguity either, - -- because the test can't fail (see is_ambig). - -checkAmbiguity is_source_polytype forall_tyvars theta tau - = mapTc_ check_pred theta `thenTc_` - returnTc sigma_ty - where - sigma_ty = mkSigmaTy forall_tyvars theta tau - tau_vars = tyVarsOfType tau - fds = instFunDepsOfTheta theta - tvFundep = tyVarFunDep fds - extended_tau_vars = oclose tvFundep tau_vars + -- Other unboxed types are very occasionally allowed as type + -- arguments depending on the kind of the type constructor - is_ambig ct_var = (ct_var `elem` forall_tyvars) && - not (ct_var `elemUFM` extended_tau_vars) - is_free ct_var = not (ct_var `elem` forall_tyvars) - - check_pred pred = checkTc (not any_ambig) (ambigErr pred sigma_ty) `thenTc_` - checkTc (not all_free) (freeErr pred sigma_ty) - where - ct_vars = varSetElems (tyVarsOfPred pred) - all_free = all is_free ct_vars - any_ambig = is_source_polytype && any is_ambig ct_vars +tc_arg_type wimp_out arg_ty + | isRec wimp_out + = tc_type wimp_out arg_ty + + | otherwise + = tc_type wimp_out arg_ty `thenTc` \ arg_ty' -> + checkTc (not (isForAllTy arg_ty')) (polyArgTyErr arg_ty) `thenTc_` + checkTc (not (isUnboxedTupleType arg_ty')) (ubxArgTyErr arg_ty) `thenTc_` + returnTc arg_ty' + +tc_arg_types wimp_out arg_tys = mapTc (tc_arg_type wimp_out) arg_tys \end{code} Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tc_app :: RenamedHsType -> [RenamedHsType] -> TcM Type -tc_app (HsAppTy ty1 ty2) tys - = tc_app ty1 (ty2:tys) +tc_app :: RecFlag -> RenamedHsType -> [RenamedHsType] -> TcM Type +tc_app wimp_out (HsAppTy ty1 ty2) tys + = tc_app wimp_out ty1 (ty2:tys) -tc_app ty tys +tc_app wimp_out ty tys = tcAddErrCtxt (appKindCtxt pp_app) $ - mapTc tcHsType tys `thenTc` \ arg_tys -> + tc_arg_types wimp_out tys `thenTc` \ arg_tys -> case ty of HsTyVar fun -> tc_fun_type fun arg_tys - other -> tcHsType ty `thenTc` \ fun_ty -> + other -> tc_type wimp_out ty `thenTc` \ fun_ty -> returnNF_Tc (mkAppTys fun_ty arg_tys) where pp_app = ppr ty <+> sep (map pprParendHsType tys) @@ -464,9 +459,9 @@ tc_fun_type name arg_tys AGlobal (ATyCon tc) | isSynTyCon tc -> checkTc arity_ok err_msg `thenTc_` returnTc (mkAppTys (mkSynTy tc (take arity arg_tys)) - (drop arity arg_tys)) + (drop arity arg_tys)) - | otherwise -> returnTc (mkTyConApp tc arg_tys) + | otherwise -> returnTc (mkTyConApp tc arg_tys) where arity_ok = arity <= n_args @@ -485,21 +480,21 @@ tc_fun_type name arg_tys Contexts ~~~~~~~~ \begin{code} -tcClassContext :: RenamedContext -> TcM ClassContext +tcRecClassContext :: RecFlag -> RenamedContext -> TcM ClassContext -- Used when we are expecting a ClassContext (i.e. no implicit params) -tcClassContext context - = tcContext context `thenTc` \ theta -> +tcRecClassContext wimp_out context + = tc_context wimp_out context `thenTc` \ theta -> returnTc (classesOfPreds theta) -tcContext :: RenamedContext -> TcM ThetaType -tcContext context = mapTc (tcClassAssertion False) context +tc_context :: RecFlag -> RenamedContext -> TcM ThetaType +tc_context wimp_out context = mapTc (tc_pred wimp_out) context -tcClassAssertion ccall_ok assn@(HsPClass class_name tys) +tc_pred wimp_out assn@(HsPClass class_name tys) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ - mapTc tcHsType tys `thenTc` \ arg_tys -> + tc_arg_types wimp_out tys `thenTc` \ arg_tys -> tcLookupGlobal class_name `thenTc` \ thing -> case thing of - AClass clas -> checkTc (arity == n_tys) err `thenTc_` + AClass clas -> checkTc (arity == n_tys) err `thenTc_` returnTc (Class clas arg_tys) where arity = classArity clas @@ -508,13 +503,74 @@ tcClassAssertion ccall_ok assn@(HsPClass class_name tys) other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name) -tcClassAssertion ccall_ok assn@(HsPIParam name ty) +tc_pred wimp_out assn@(HsPIParam name ty) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ - tcHsType ty `thenTc` \ arg_ty -> + tc_arg_type wimp_out ty `thenTc` \ arg_ty -> returnTc (IParam name arg_ty) \end{code} +Check for ambiguity +~~~~~~~~~~~~~~~~~~~ + forall V. P => tau +is ambiguous if P contains generic variables +(i.e. one of the Vs) that are not mentioned in tau + +However, we need to take account of functional dependencies +when we speak of 'mentioned in tau'. Example: + class C a b | a -> b where ... +Then the type + forall x y. (C x y) => x +is not ambiguous because x is mentioned and x determines y + +NOTE: In addition, GHC insists that at least one type variable +in each constraint is in V. So we disallow a type like + forall a. Eq b => b -> b +even in a scope where b is in scope. +This is the is_free test below. + +Notes on the 'is_source_polytype' test above +Check ambiguity only for source-program types, not +for types coming from inteface files. The latter can +legitimately have ambiguous types. Example + class S a where s :: a -> (Int,Int) + instance S Char where s _ = (1,1) + f:: S a => [a] -> Int -> (Int,Int) + f (_::[a]) x = (a*x,b) + where (a,b) = s (undefined::a) +Here the worker for f gets the type + fw :: forall a. S a => Int -> (# Int, Int #) + +If the list of tv_names is empty, we have a monotype, +and then we don't need to check for ambiguity either, +because the test can't fail (see is_ambig). + +\begin{code} +checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau + | isRec wimp_out = returnTc sigma_ty + | otherwise = mapTc_ check_pred theta `thenTc_` + returnTc sigma_ty + where + sigma_ty = mkSigmaTy forall_tyvars theta tau + tau_vars = tyVarsOfType tau + fds = instFunDepsOfTheta theta + tvFundep = tyVarFunDep fds + extended_tau_vars = oclose tvFundep tau_vars + + is_ambig ct_var = (ct_var `elem` forall_tyvars) && + not (ct_var `elemUFM` extended_tau_vars) + is_free ct_var = not (ct_var `elem` forall_tyvars) + + check_pred pred = checkTc (not any_ambig) (ambigErr pred sigma_ty) `thenTc_` + checkTc (is_ip pred || not all_free) (freeErr pred sigma_ty) + where + ct_vars = varSetElems (tyVarsOfPred pred) + all_free = all is_free ct_vars + any_ambig = is_source_polytype && any is_ambig ct_vars + is_ip (IParam _ _) = True + is_ip _ = False +\end{code} + %************************************************************************ %* * \subsection{Type variables, with knot tying!} @@ -724,10 +780,10 @@ checkSigTyVars sig_tyvars free_tyvars -- from the zonked tyvar to the in-scope one -- If any of the in-scope tyvars zonk to a type, then ignore them; -- that'll be caught later when we back up to their type sig - tcGetEnv `thenNF_Tc` \ env -> - let - in_scope_tvs = tcEnvTyVars env - in + tcGetEnv `thenNF_Tc` \ env -> + let + in_scope_tvs = tcEnvTyVars env + in zonkTcTyVars in_scope_tvs `thenNF_Tc` \ in_scope_tys -> let in_scope_assoc = [ (zonked_tv, in_scope_tv) @@ -772,8 +828,8 @@ checkSigTyVars sig_tyvars free_tyvars -- a) get the local TcIds from the environment, -- and pass them to find_globals (they might have tv free) -- b) similarly, find any free_tyvars that mention tv - then tcGetEnv `thenNF_Tc` \ tc_env -> - find_globals tv tidy_env [] (tcEnvTcIds tc_env) `thenNF_Tc` \ (tidy_env1, globs) -> + then tcGetEnv `thenNF_Tc` \ ve -> + find_globals tv tidy_env [] (tcEnvTcIds ve) `thenNF_Tc` \ (tidy_env1, globs) -> find_frees tv tidy_env1 [] (varSetElems free_tyvars) `thenNF_Tc` \ (tidy_env2, frees) -> returnNF_Tc (tidy_env2, acc, escape_msg sig_tyvar tv globs frees : msgs) @@ -796,7 +852,8 @@ find_globals tv tidy_env acc [] = returnNF_Tc (tidy_env, acc) find_globals tv tidy_env acc (id:ids) - | isEmptyVarSet (idFreeTyVars id) + | not (isLocallyDefined id) || + isEmptyVarSet (idFreeTyVars id) = find_globals tv tidy_env acc ids | otherwise @@ -922,6 +979,6 @@ freeErr pred ty nest 4 (ptext SLIT("in the type") <+> quotes (ppr ty)) ] -unboxedTupleErr ty - = sep [ptext (SLIT("Illegal unboxed tuple as a function or contructor argument:")), nest 4 (ppr ty)] +polyArgTyErr ty = ptext SLIT("Illegal polymorphic type as argument:") <+> ppr ty +ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as argument:") <+> ppr ty \end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 6cd8799..12bc8e9 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -19,7 +19,7 @@ import HsSyn ( HsDecl(..), TyClDecl(..), isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, tyClDeclFVs ) -import BasicTypes ( RecFlag(..), NewOrData(..) ) +import BasicTypes ( RecFlag(..), NewOrData(..), isRec ) import TcMonad import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..), @@ -103,9 +103,17 @@ Step 4: buildTyConOrClass Step 5: tcTyClDecl1 In this environment, walk over the decls, constructing the TyCons and Classes. This uses in a strict way items (a)-(c) above, which is why they must - be constructed in Step 4. - Feed the results back to Step 4. + be constructed in Step 4. Feed the results back to Step 4. + For this step, pass the is-recursive flag as the wimp-out flag + to tcTyClDecl1. + +Step 6: tcTyClDecl1 again + For a recursive group only, check all the decls again, just + but this time with the wimp flag off. Now we can check things + like whether a function argument is an unboxed tuple, looking + through type synonyms properly. We can't do that in Step 5. + The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. @@ -144,11 +152,23 @@ tcGroup unf_env scc rec_vrcs = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss] in -- Step 5 - tcExtendGlobalEnv all_tyclss $ - mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details -> - tcGetEnv `thenNF_Tc` \ env -> + tcExtendGlobalEnv all_tyclss $ + mapTc (tcTyClDecl1 is_rec unf_env) decls `thenTc` \ tycls_details -> + + -- Return results + tcGetEnv `thenNF_Tc` \ env -> returnTc (tycls_details, env) ) `thenTc` \ (_, env) -> + + -- Step 6 + -- For a recursive group, check all the types again, + -- this time with the wimp flag off + (if isRec is_rec then + tcSetEnv env (mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls) + else + returnTc () + ) `thenTc_` + returnTc env where is_rec = case scc of @@ -159,12 +179,9 @@ tcGroup unf_env scc AcyclicSCC decl -> [decl] CyclicSCC decls -> decls -tcTyClDecl1 unf_env decl - = tcAddDeclCtxt decl $ - if isClassDecl decl then - tcClassDecl1 unf_env decl - else - tcTyDecl1 decl +tcTyClDecl1 is_rec unf_env decl + | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl) + | otherwise = tcAddDeclCtxt decl (tcTyDecl1 is_rec decl) \end{code} @@ -221,7 +238,7 @@ kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc) kcHsType rhs `thenTc` \ rhs_kind -> unifyKind result_kind rhs_kind -kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ loc _ _) +kcTyClDecl decl@(TyData new_or_data context tycon_name hs_tyvars con_decls _ _ loc _ _) = tcAddDeclCtxt decl $ kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind -> kcHsContext context `thenTc_` @@ -231,7 +248,7 @@ kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ loc _ _) = tcAddSrcLoc loc $ kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env -> tcExtendKindEnv kind_env $ - kcConDetails ex_ctxt details + kcConDetails new_or_data ex_ctxt details kcTyClDecl decl@(ClassDecl context class_name hs_tyvars fundeps class_sigs @@ -406,7 +423,6 @@ mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name]) mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt]) mkClassEdges other_decl = Nothing ----------------------------------------------------- mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name]) mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl) \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 76b91d5..7815057 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -14,14 +14,14 @@ module TcTyDecls ( import HsSyn ( MonoBinds(..), TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..), - getBangType + getBangType, conDetailsTys ) import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) -import BasicTypes ( NewOrData(..) ) +import BasicTypes ( NewOrData(..), RecFlag ) -import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, tcHsTyVars, tcClassContext, - kcHsContext, kcHsSigType +import TcMonoType ( tcHsRecType, tcHsTyVars, tcRecClassContext, + kcHsContext, kcHsSigType, kcHsBoxedSigType ) import TcEnv ( tcExtendTyVarEnv, tcLookupTyCon, tcLookupGlobalId, @@ -60,12 +60,12 @@ import ListSetOps ( equivClasses ) %************************************************************************ \begin{code} -tcTyDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails) -tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc) +tcTyDecl1 :: RecFlag -> RenamedTyClDecl -> TcM (Name, TyThingDetails) +tcTyDecl1 is_rec (TySynonym tycon_name tyvar_names rhs src_loc) = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> tcExtendTyVarEnv (tyConTyVars tycon) $ - tcHsType rhs `thenTc` \ rhs_ty -> - -- Note tcHsType not tcHsSigType; we allow type synonyms + tcHsRecType is_rec rhs `thenTc` \ rhs_ty -> + -- Note tcHsRecType not tcHsRecSigType; we allow type synonyms -- that aren't types; e.g. type List = [] -- -- If the RHS mentions tyvars that aren't in scope, we'll @@ -79,7 +79,7 @@ tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc) returnTc (tycon_name, SynTyDetails rhs_ty) -tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc name1 name2) +tcTyDecl1 is_rec (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc name1 name2) = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> let tyvars = tyConTyVars tycon @@ -87,9 +87,8 @@ tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc tcExtendTyVarEnv tyvars $ -- Typecheck the pieces - tcClassContext context `thenTc` \ ctxt -> - mapTc (tcConDecl new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons -> - + tcRecClassContext is_rec context `thenTc` \ ctxt -> + mapTc (tcConDecl is_rec new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons -> returnTc (tycon_name, DataTyDetails ctxt data_cons) \end{code} @@ -122,42 +121,35 @@ mkNewTyConRep tc %************************************************************************ \begin{code} -kcConDetails :: RenamedContext -> ConDetails Name -> TcM () -kcConDetails ex_ctxt details +kcConDetails :: NewOrData -> RenamedContext -> ConDetails Name -> TcM () +kcConDetails new_or_data ex_ctxt details = kcHsContext ex_ctxt `thenTc_` - kc_con_details details + mapTc_ kc_sig_type (conDetailsTys details) where - kc_con_details (VanillaCon btys) = mapTc_ kc_bty btys - kc_con_details (InfixCon bty1 bty2) = mapTc_ kc_bty [bty1,bty2] - kc_con_details (RecCon flds) = mapTc_ kc_field flds - - kc_field (_, bty) = kc_bty bty + kc_sig_type = case new_or_data of + DataType -> kcHsSigType + NewType -> kcHsBoxedSigType + -- Can't allow an unboxed type here, because we're effectively + -- going to remove the constructor while coercing it to a boxed type. - kc_bty bty = kcHsSigType (getBangType bty) -tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM DataCon +tcConDecl :: RecFlag -> NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM DataCon -tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc) - = tcAddSrcLoc src_loc $ - tcHsTyVars ex_tvs (kcConDetails ex_ctxt details) $ \ ex_tyvars -> - tcClassContext ex_ctxt `thenTc` \ ex_theta -> +tcConDecl is_rec new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc) + = tcAddSrcLoc src_loc $ + tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details) $ \ ex_tyvars -> + tcRecClassContext is_rec ex_ctxt `thenTc` \ ex_theta -> case details of VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2] RecCon fields -> tc_rec_con ex_tyvars ex_theta fields where - tc_sig_type = case new_or_data of - DataType -> tcHsSigType - NewType -> tcHsBoxedSigType - -- Can't allow an unboxed type here, because we're effectively - -- going to remove the constructor while coercing it to a boxed type. - tc_datacon ex_tyvars ex_theta btys = let arg_stricts = map getBangStrictness btys tys = map getBangType btys in - mapTc tc_sig_type tys `thenTc` \ arg_tys -> + mapTc (tcHsRecType is_rec) tys `thenTc` \ arg_tys -> mk_data_con ex_tyvars ex_theta arg_stricts arg_tys [] tc_rec_con ex_tyvars ex_theta fields @@ -174,7 +166,7 @@ tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt de (map fieldLabelType field_labels) field_labels tc_field ((field_label_names, bty), tag) - = tc_sig_type (getBangType bty) `thenTc` \ field_ty -> + = tcHsRecType is_rec (getBangType bty) `thenTc` \ field_ty -> returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names] mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 58aac30..9710d72 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -44,8 +44,8 @@ module TcType ( -- friends: import TypeRep ( Type(..), Kind, TyNote(..) ) -- friend import Type ( PredType(..), - getTyVar, mkAppTy, - splitPredTy_maybe, splitForAllTys, isNotUsgTy, + getTyVar, mkAppTy, mkUTy, + splitPredTy_maybe, splitForAllTys, isTyVarTy, mkTyVarTy, mkTyVarTys, openTypeKind, boxedTypeKind, superKind, superBoxity, @@ -92,6 +92,7 @@ tcSplitRhoTy t case maybe_ty of Just ty | not (isTyVarTy ty) -> go syn_t ty ts other -> returnNF_Tc (reverse ts, syn_t) + go syn_t (UsageTy _ t) ts = go syn_t t ts go syn_t t ts = returnNF_Tc (reverse ts, syn_t) \end{code} @@ -206,7 +207,8 @@ tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType) Putting is easy: \begin{code} -tcPutTyVar tyvar ty = tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_` +tcPutTyVar tyvar ty = UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty ) + tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_` returnNF_Tc ty \end{code} @@ -401,12 +403,6 @@ zonkType unbound_var_fn ty go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations - 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 (PredTy p) = go_pred p `thenNF_Tc` \ p' -> returnNF_Tc (PredTy p') @@ -418,6 +414,10 @@ zonkType unbound_var_fn ty go arg `thenNF_Tc` \ arg' -> returnNF_Tc (mkAppTy fun' arg') + go (UsageTy u ty) = go u `thenNF_Tc` \ u' -> + go ty `thenNF_Tc` \ ty' -> + returnNF_Tc (mkUTy u' ty') + -- The two interesting cases! go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar @@ -443,7 +443,6 @@ zonkTyVar unbound_var_fn tyvar = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of Nothing -> unbound_var_fn tyvar -- Mutable and unbound - Just other_ty -> ASSERT( isNotUsgTy other_ty ) - zonkType unbound_var_fn other_ty -- Bound + Just other_ty -> zonkType unbound_var_fn other_ty -- Bound \end{code} diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 0944e63..f9ebae4 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -21,7 +21,7 @@ import Type ( unboxedTypeKind, boxedTypeKind, openTypeKind, typeCon, openKindCon, hasMoreBoxityInfo, tyVarsOfType, typeKind, mkFunTy, splitFunTy_maybe, splitTyConApp_maybe, - isNotUsgTy, splitAppTy_maybe, mkTyConApp, + splitAppTy_maybe, mkTyConApp, tidyOpenType, tidyOpenTypes, tidyTyVar ) import TyCon ( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity ) @@ -148,10 +148,14 @@ uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1 -> TcM () -- Always expand synonyms (see notes at end) - -- (this also throws away FTVs and usage annots) + -- (this also throws away FTVs) uTys ps_ty1 (NoteTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 uTys ps_ty1 ty1 ps_ty2 (NoteTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 + -- Ignore usage annotations inside typechecker +uTys ps_ty1 (UsageTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 +uTys ps_ty1 ty1 ps_ty2 (UsageTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 + -- Variables; go for uVar uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2 uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1 @@ -279,7 +283,7 @@ uVar swapped tv1 ps_ty2 ty2 | otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order other -> uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2 - -- Expand synonyms; ignore FTVs; ignore usage annots + -- Expand synonyms; ignore FTVs uUnboundVar swapped tv1 maybe_ty1 ps_ty2 (NoteTy _ ty2) = uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2 @@ -306,8 +310,7 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) | otherwise -> WARN( not (k2 `hasMoreBoxityInfo` k1), (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) ) - (ASSERT( isNotUsgTy ps_ty2 ) - tcPutTyVar tv1 ps_ty2 `thenNF_Tc_` + (tcPutTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc ()) where k1 = tyVarKind tv1 diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 89e36c4..7b65447 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -8,12 +8,12 @@ import RnHsSyn ( RenamedHsExpr ) import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch ) import Type ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes, - mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys, - mkFunTy, isTyVarTy, - splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon + mkTyVarTys, mkForAllTys, mkTyConApp, + mkFunTy, isTyVarTy, getTyVar_maybe, + splitSigmaTy, splitTyConApp_maybe, funTyCon ) -import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId ) +import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId, isExistentialDataCon ) import TyCon ( TyCon, tyConTyVars, tyConDataConsIfAvailable, tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon @@ -23,7 +23,7 @@ import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..), mkConApp, Alt, mkTyApps, mkVarApps ) import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) -import VarSet ( isEmptyVarSet ) +import VarSet ( varSetElems ) import Id ( Id, mkTemplateLocal, idType, idName, mkTemplateLocalsNum, mkId ) @@ -197,17 +197,24 @@ validGenericMethodType :: Type -> Bool -- * function arrow -- * boxed tuples -- * an arbitrary type not involving the class type variables -validGenericMethodType ty = valid ty - -valid ty - | isTyVarTy ty = True - | not (null arg_tys) = all valid arg_tys && valid res_ty - | no_tyvars_in_ty = True - | otherwise = isBoxedTupleTyCon tc && all valid tys + -- e.g. this is ok: forall b. Ord b => [b] -> a + -- where a is the class variable +validGenericMethodType ty + = valid tau where - (arg_tys, res_ty) = splitFunTys ty - no_tyvars_in_ty = isEmptyVarSet (tyVarsOfType ty) - Just (tc,tys) = splitTyConApp_maybe ty + (local_tvs, _, tau) = splitSigmaTy ty + + valid ty + | isTyVarTy ty = True + | no_tyvars_in_ty = True + | otherwise = case splitTyConApp_maybe ty of + Just (tc,tys) -> valid_tycon tc && all valid tys + Nothing -> False + where + no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty)) + + valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc + -- Compare bimapApp, below \end{code} @@ -233,11 +240,13 @@ mkTyConGenInfo tycon from_name to_name | null datacons -- Abstractly imported types don't have = Nothing -- to/from operations, (and should not need them) - -- If any of the constructor has an unboxed type as argument + -- If any of the constructor has an unboxed type as argument, -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors - | any (any isUnLiftedType . dataConOrigArgTys) datacons + -- Nor can we do the job if it's an existential data constructor, + | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc + | dc <- datacons ] = Nothing | otherwise @@ -403,7 +412,51 @@ splitInHalf list = (left, right) Generating the Generic default method. Uses the bimaps to generate the actual method. All of this is rather incomplete, but it would be nice -to make even this work. +to make even this work. Example + + class Foo a where + op :: Op a + + instance Foo T + +Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs: + + instance Foo T where + op = + +To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where + + toOp :: Op Trep -> Op T + fromOp :: Op T -> Op Trep + +(the bimap) and then fill in the RHS with + + instance Foo T where + op = toOp op + +Remember, we're generating a RenamedHsExpr, so the result of all this +will be fed to the type checker. So the 'op' on the RHS will be +at the representation type for T, Trep. + + +A note about polymorphism. Suppose the class op is polymorphic: + + class Baz a where + op :: forall b. Ord b => a -> b -> b + +Then we can still generate a bimap with + + toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b) + +and fill in the instance decl thus + + instance Foo T where + op = toOp op + +By the time the type checker has done its stuff we'll get + + instance Foo T where + op = \b. \dict::Ord b. toOp b (op Trep b dict) \begin{code} mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr @@ -415,37 +468,51 @@ mkGenericRhs sel_id tyvar tycon Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed ep = EP (HsVar (idName from)) (HsVar (idName to)) - -- Takes out the ForAll and the Class rstrictions in front of the - -- type of the method. + -- Takes out the ForAll and the Class restrictions + -- in front of the type of the method. (_,_,op_ty) = splitSigmaTy (idType sel_id) + -- Do it again! This deals with the case where the method type + -- is polymorphic -- see notes above + (local_tvs,_,final_ty) = splitSigmaTy op_ty + -- Now we probably have a tycon in front -- of us, quite probably a FunTyCon. - bimap = generate_bimap (tyvar, ep) op_ty + bimap = generate_bimap (tyvar, ep, local_tvs) final_ty --- EP is the environment of to/from bimaps, but as we only have one type --- variable at the moment, there is only one EP. +type EPEnv = (TyVar, -- The class type variable + EP RenamedHsExpr, -- The EP it maps to + [TyVar] -- Other in-scope tyvars; they have an identity EP + ) ------------------- -generate_bimap :: (TyVar, EP RenamedHsExpr) -> Type -> EP RenamedHsExpr +generate_bimap :: EPEnv + -> Type + -> EP RenamedHsExpr -- Top level case - splitting the TyCon. -generate_bimap (tv,ep) ty | isTyVarTy ty = ASSERT( getTyVar "Generics.generate_bimap" ty == tv) ep - | otherwise = bimapApp (tv,ep) (splitTyConApp_maybe ty) +generate_bimap env@(tv,ep,local_tvs) ty + = case getTyVar_maybe ty of + Just tv1 | tv == tv1 -> ep -- The class tyvar + | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method + idEP + Nothing -> bimapApp env (splitTyConApp_maybe ty) ------------------- -bimapApp :: (TyVar, EP RenamedHsExpr) -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr -bimapApp ep Nothing = panic "TcClassDecl: Type Application!" -bimapApp ep (Just (tycon, ty_args)) +bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr +bimapApp env Nothing = panic "TcClassDecl: Type Application!" +bimapApp env (Just (tycon, ty_args)) | tycon == funTyCon = bimapArrow arg_eps | isBoxedTupleTyCon tycon = bimapTuple arg_eps | otherwise = -- Otherwise validGenericMethodType will -- have checked that the type is a constant type - ASSERT( isEmptyVarSet (tyVarsOfTypes ty_args) ) - EP idexpr idexpr + ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) ) + idEP where - arg_eps = map (generate_bimap ep) ty_args + arg_eps = map (generate_bimap env) ty_args + (_,_,local_tvs) = env ------------------- +-- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b') bimapArrow [ep1, ep2] = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body, toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body } @@ -470,5 +537,9 @@ genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- (g1:g2:g3:_) = genericNames mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc)) -idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3) + +idEP :: EP RenamedHsExpr +idEP = EP idexpr idexpr + where + idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3) \end{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 637ea1f..fc80b50 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -18,23 +18,22 @@ module PprType( -- friends: -- (PprType can see all the representations it's trying to print) -import TypeRep ( Type(..), TyNote(..), Kind, UsageAnn(..), - boxedTypeKind, - ) -- friend +import TypeRep ( Type(..), TyNote(..), Kind, boxedTypeKind ) -- friend import Type ( PredType(..), ThetaType, splitPredTy_maybe, splitForAllTys, splitSigmaTy, splitRhoTy, isDictTy, splitTyConApp_maybe, splitFunTy_maybe, - splitUsForAllTys, predRepTy + predRepTy, isUTyVar ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, maybeTyConSingleCon, isEnumerationTyCon, - tyConArity + tyConArity, tyConName ) import Class ( Class ) -- others: +import CmdLineOpts ( opt_PprStyle_RawTypes ) import Maybes ( maybeToBool ) import Name ( getOccString, getOccName ) import Outputable @@ -100,9 +99,9 @@ The precedence levels are: \begin{code} -tOP_PREC = (0 :: Int) -fUN_PREC = (1 :: Int) -tYCON_PREC = (2 :: Int) +tOP_PREC = (0 :: Int) -- type in ParseIface.y +fUN_PREC = (1 :: Int) -- btype in ParseIface.y +tYCON_PREC = (2 :: Int) -- atype in ParseIface.y maybeParen ctxt_prec inner_prec pretty | ctxt_prec < inner_prec = pretty @@ -124,7 +123,12 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) TyConApp bx [] -> ppr (getOccName bx) -- Always unqualified other -> maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces]) - + + -- USAGE CASE + | (tycon `hasKey` usOnceTyConKey || tycon `hasKey` usManyTyConKey) && n_tys == 0 + = -- For usages (! and .), always print bare OccName, without pkg/mod/uniq + ppr (getOccName (tyConName tycon)) + -- TUPLE CASE (boxed and unboxed) | isTupleTyCon tycon && length tys == tyConArity tycon -- no magic if partially applied @@ -165,15 +169,20 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) ppr_ty env ctxt_prec ty@(ForAllTy _ _) = getPprStyle $ \ sty -> maybeParen ctxt_prec fUN_PREC $ - sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), + sep [ ptext SLIT("forall") <+> pp_tyvars sty <> ptext SLIT("."), ppr_theta theta, ppr_ty env tOP_PREC tau ] where - (tyvars, rho) = splitForAllTys ty -- don't treat theta specially any more (KSW 1999-04) + (tyvars, rho) = splitForAllTys ty (theta, tau) = splitRhoTy rho - pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars) + pp_tyvars sty = hsep (map (pBndr env LambdaBind) some_tyvars) + where + some_tyvars | userStyle sty && not opt_PprStyle_RawTypes + = filter (not . isUTyVar) tyvars -- hide uvars from user + | otherwise + = tyvars ppr_theta [] = empty ppr_theta theta = parens (hsep (punctuate comma (map (ppr_pred env) theta))) @@ -181,17 +190,22 @@ ppr_ty env ctxt_prec ty@(ForAllTy _ _) ppr_ty env ctxt_prec (FunTy ty1 ty2) - = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest ty2)) -- we don't want to lose usage annotations or synonyms, -- so we mustn't use splitFunTys here. - where - pp_rest (FunTy ty1 ty2) = pp_codom ty1 : pp_rest ty2 - pp_rest ty = [pp_codom ty] - pp_codom ty = ptext SLIT("->") <+> ppr_ty env fUN_PREC ty + = maybeParen ctxt_prec fUN_PREC $ + sep [ ppr_ty env fUN_PREC ty1 + , ptext SLIT("->") <+> ppr_ty env tOP_PREC ty2 + ] ppr_ty env ctxt_prec (AppTy ty1 ty2) = maybeParen ctxt_prec tYCON_PREC $ - ppr_ty env tOP_PREC ty1 <+> ppr_ty env tYCON_PREC ty2 + ppr_ty env fUN_PREC ty1 <+> ppr_ty env tYCON_PREC ty2 + +ppr_ty env ctxt_prec (UsageTy u ty) + = maybeParen ctxt_prec tYCON_PREC $ + ptext SLIT("__u") <+> ppr_ty env tYCON_PREC u + <+> ppr_ty env tYCON_PREC ty + -- fUN_PREC would be logical for u, but it yields a reduce/reduce conflict with AppTy ppr_ty env ctxt_prec (NoteTy (SynNote ty) expansion) = ppr_ty env ctxt_prec ty @@ -199,19 +213,6 @@ 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 $ - ptext SLIT("__u") <+> ppr u <+> ppr_ty env tYCON_PREC ty - ppr_ty env ctxt_prec (PredTy p) = braces (ppr_pred env p) ppr_pred env (Class clas tys) = ppr clas <+> @@ -226,13 +227,6 @@ pprTyEnv = initPprEnv b (Just ppr) b (Just (\site -> pprTyVarBndr)) b b = panic "PprType:init_ppr_env" \end{code} -\begin{code} -instance Outputable UsageAnn where - ppr UsOnce = ptext SLIT("-") - ppr UsMany = ptext SLIT("!") - ppr (UsVar uv) = ppr uv -\end{code} - %************************************************************************ %* * @@ -279,7 +273,6 @@ getTyDescription ty TyConApp tycon _ -> getOccString tycon NoteTy (FTVNote _) ty -> getTyDescription ty NoteTy (SynNote ty1) _ -> getTyDescription ty1 - NoteTy (UsgNote _) ty -> getTyDescription ty PredTy p -> getTyDescription (predRepTy p) ForAllTy _ ty -> getTyDescription ty } diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index ccd7618..bee967c 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -169,8 +169,6 @@ data TyCon } type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] - -- *NB*: this is tyvar variance info, *not* - -- termvar usage info. data AlgTyConFlavour = DataTyCon -- Data type diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index dde73b1..18f4b8e 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -18,6 +18,11 @@ module Type ( funTyCon, + usageKindCon, -- :: KX + usageTypeKind, -- :: KX + usOnceTyCon, usManyTyCon, -- :: $ + usOnce, usMany, -- :: $ + -- exports from this module: hasMoreBoxityInfo, defaultKind, @@ -31,19 +36,20 @@ module Type ( mkTyConApp, mkTyConTy, splitTyConApp_maybe, splitAlgTyConApp_maybe, splitAlgTyConApp, + mkUTy, splitUTy, splitUTy_maybe, + isUTy, uaUTy, unUTy, liftUTy, mkUTyM, + isUsageKind, isUsage, isUTyVar, + -- Predicates and the like mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe, splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy, - mkSynTy, isSynTy, deNoteType, + mkSynTy, deNoteType, repType, splitRepFunTys, splitNewType_maybe, typePrimRep, - UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg, - mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, - mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - applyTy, applyTys, hoistForAllTys, + applyTy, applyTys, hoistForAllTys, isForAllTy, TauType, RhoType, SigmaType, PredType(..), ThetaType, ClassPred, ClassContext, mkClassPred, @@ -57,7 +63,7 @@ module Type ( -- Free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - namesOfType, typeKind, addFreeTyVars, + namesOfType, usageAnnOfType, typeKind, addFreeTyVars, -- Tidying up for printing tidyType, tidyTypes, @@ -84,9 +90,7 @@ import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy ) -- friends: -import Var ( TyVar, UVar, - tyVarKind, tyVarName, setTyVarName, - ) +import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName ) import VarEnv import VarSet @@ -102,6 +106,7 @@ import TyCon ( TyCon, ) -- others +import Maybes ( maybeToBool ) import SrcLoc ( noSrcLoc ) import PrimRep ( PrimRep(..), isFollowableRep ) import Unique ( Uniquable(..) ) @@ -151,18 +156,21 @@ getTyVar :: String -> Type -> TyVar getTyVar msg (TyVarTy tv) = tv getTyVar msg (PredTy p) = getTyVar msg (predRepTy p) getTyVar msg (NoteTy _ t) = getTyVar msg t +getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty) getTyVar msg other = panic ("getTyVar: " ++ msg) getTyVar_maybe :: Type -> Maybe TyVar getTyVar_maybe (TyVarTy tv) = Just tv getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t getTyVar_maybe (PredTy p) = getTyVar_maybe (predRepTy p) +getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty) getTyVar_maybe other = Nothing isTyVarTy :: Type -> Bool isTyVarTy (TyVarTy tv) = True isTyVarTy (NoteTy _ ty) = isTyVarTy ty isTyVarTy (PredTy p) = isTyVarTy (predRepTy p) +isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty) isTyVarTy other = False \end{code} @@ -176,33 +184,36 @@ invariant: use it. \begin{code} mkAppTy orig_ty1 orig_ty2 - = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 ) - ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind * + = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind * + UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 ) + -- argument must be unannotated mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) + mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty) mk_app ty1 = AppTy orig_ty1 orig_ty2 mkAppTys :: Type -> [Type] -> Type mkAppTys orig_ty1 [] = orig_ty1 -- This check for an empty list of type arguments - -- avoids the needless of a type synonym constructor. + -- avoids the needless loss of a type synonym constructor. -- For example: mkAppTys Rational [] -- returns to (Ratio Integer), which has needlessly lost -- the Rational part. mkAppTys orig_ty1 orig_tys2 - = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 ) - ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind * + = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind * + UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) ) + -- arguments must be unannotated mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) - mk_app ty1 = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) ) - foldl AppTy orig_ty1 orig_tys2 + mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty) + mk_app ty1 = foldl AppTy orig_ty1 orig_tys2 splitAppTy_maybe :: Type -> Maybe (Type, Type) -splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) +splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2) splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predRepTy p) @@ -212,6 +223,7 @@ splitAppTy_maybe (TyConApp tc tys) = split tys [] split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) split (ty:tys) acc = split tys (ty:acc) +splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty) splitAppTy_maybe other = Nothing splitAppTy :: Type -> (Type, Type) @@ -226,8 +238,9 @@ splitAppTys ty = split ty ty [] split orig_ty (NoteTy _ ty) args = split orig_ty ty args split orig_ty (PredTy p) args = split orig_ty (predRepTy p) args split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) - (TyConApp funTyCon [], [ty1,ty2]) + (TyConApp funTyCon [], [unUTy ty1,unUTy ty2]) split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) + split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty) split orig_ty ty args = (orig_ty, args) \end{code} @@ -238,20 +251,24 @@ splitAppTys ty = split ty ty [] \begin{code} mkFunTy :: Type -> Type -> Type -mkFunTy arg res = FunTy arg res +mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res ) + FunTy arg res mkFunTys :: [Type] -> Type -> Type -mkFunTys tys ty = foldr FunTy ty tys +mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) ) + foldr FunTy ty tys splitFunTy :: Type -> (Type, Type) splitFunTy (FunTy arg res) = (arg, res) splitFunTy (NoteTy _ ty) = splitFunTy ty splitFunTy (PredTy p) = splitFunTy (predRepTy p) +splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty) splitFunTy_maybe :: Type -> Maybe (Type, Type) splitFunTy_maybe (FunTy arg res) = Just (arg, res) splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predRepTy p) +splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty) splitFunTy_maybe other = Nothing splitFunTys :: Type -> ([Type], Type) @@ -260,6 +277,7 @@ splitFunTys ty = split [] ty ty split args orig_ty (FunTy arg res) = split (arg:args) res res split args orig_ty (NoteTy _ ty) = split args orig_ty ty split args orig_ty (PredTy p) = split args orig_ty (predRepTy p) + split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty) split args orig_ty ty = (reverse args, orig_ty) splitFunTysN :: String -> Int -> Type -> ([Type], Type) @@ -269,6 +287,7 @@ splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty split n args syn_ty (PredTy p) = split n args syn_ty (predRepTy p) + split n args syn_ty (UsageTy _ _) = pprPanic "splitFunTysN: UTy:" (pprType orig_ty) split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty) zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) @@ -278,18 +297,21 @@ zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res split acc xs nty (NoteTy _ ty) = split acc xs nty ty split acc xs nty (PredTy p) = split acc xs nty (predRepTy p) + split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty) split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty) funResultTy :: Type -> Type funResultTy (FunTy arg res) = res funResultTy (NoteTy _ ty) = funResultTy ty funResultTy (PredTy p) = funResultTy (predRepTy p) +funResultTy (UsageTy _ ty) = funResultTy ty funResultTy ty = pprPanic "funResultTy" (pprType ty) funArgTy :: Type -> Type funArgTy (FunTy arg res) = arg funArgTy (NoteTy _ ty) = funArgTy ty funArgTy (PredTy p) = funArgTy (predRepTy p) +funArgTy (UsageTy _ ty) = funArgTy ty funArgTy ty = pprPanic "funArgTy" (pprType ty) \end{code} @@ -303,10 +325,11 @@ mkTyConApp :: TyCon -> [Type] -> Type mkTyConApp tycon tys | isFunTyCon tycon && length tys == 2 = case tys of - (ty1:ty2:_) -> FunTy ty1 ty2 + (ty1:ty2:_) -> FunTy (mkUTyM ty1) (mkUTyM ty2) | otherwise = ASSERT(not (isSynTyCon tycon)) + UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) ) TyConApp tycon tys mkTyConTy :: TyCon -> Type @@ -319,9 +342,10 @@ mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res]) splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p) +splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty splitTyConApp_maybe other = Nothing -- splitAlgTyConApp_maybe looks for @@ -335,6 +359,7 @@ splitAlgTyConApp_maybe (TyConApp tc tys) tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc) splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty splitAlgTyConApp_maybe (PredTy p) = splitAlgTyConApp_maybe (predRepTy p) +splitAlgTyConApp_maybe (UsageTy _ ty)= splitAlgTyConApp_maybe ty splitAlgTyConApp_maybe other = Nothing splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon]) @@ -343,6 +368,7 @@ splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == l (tc, tys, tyConDataCons tc) splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty splitAlgTyConApp (PredTy p) = splitAlgTyConApp (predRepTy p) +splitAlgTyConApp (UsageTy _ ty) = splitAlgTyConApp ty #ifdef DEBUG splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty) #endif @@ -356,25 +382,26 @@ splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty) \begin{code} mkSynTy syn_tycon tys = ASSERT( isSynTyCon syn_tycon ) - ASSERT( isNotUsgTy body ) ASSERT( length tyvars == length tys ) NoteTy (SynNote (TyConApp syn_tycon tys)) (substTy (mkTyVarSubst tyvars tys) body) where (tyvars, body) = getSynTyConDefn syn_tycon -isSynTy (NoteTy (SynNote _) _) = True -isSynTy other = False - deNoteType :: Type -> Type -- Remove synonyms, but not Preds deNoteType ty@(TyVarTy tyvar) = ty deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) -deNoteType (PredTy p) = PredTy p +deNoteType (PredTy p) = PredTy (deNotePred p) deNoteType (NoteTy _ ty) = deNoteType ty deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) +deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty) + +deNotePred :: PredType -> PredType +deNotePred (Class c tys) = Class c (map deNoteType tys) +deNotePred (IParam n ty) = IParam n (deNoteType ty) \end{code} Notes on type synonyms @@ -400,6 +427,7 @@ repType looks through (b) newtypes (c) synonyms (d) predicates + (e) usage annotations It's useful in the back end where we're not interested in newtypes anymore. @@ -408,6 +436,7 @@ repType :: Type -> Type repType (ForAllTy _ ty) = repType ty repType (NoteTy _ ty) = repType ty repType (PredTy p) = repType (predRepTy p) +repType (UsageTy _ ty) = repType ty repType ty = case splitNewType_maybe ty of Just ty' -> repType ty' -- Still re-apply repType in case of for-all Nothing -> ty @@ -431,6 +460,7 @@ splitNewType_maybe :: Type -> Maybe Type -- Looks through multiple levels of newtype, but does not look through for-alls splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty splitNewType_maybe (PredTy p) = splitNewType_maybe (predRepTy p) +splitNewType_maybe (UsageTy _ ty) = splitNewType_maybe ty splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of Just rep_ty -> ASSERT( length tys == tyConArity tc ) -- The assert should hold because repType should @@ -443,194 +473,90 @@ splitNewType_maybe other = Nothing --------------------------------------------------------------------- - UsgNote - ~~~~~~~ - -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 "rho = generalised -usage-annotated type; sigma = usage-annotated type; tau = -usage-annotated type except on top"; unfortunately this conflicts with -the rho/tau/theta/sigma usage in the rest of the compiler. (KSW -1999-07) - -\begin{code} -mkUsgTy :: UsageAnn -> Type -> Type -#ifndef USMANY -mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty ) - ty -#endif -mkUsgTy usg ty = ASSERT2( isNotUsgTy ty, pprType ty ) - NoteTy (UsgNote usg) ty - --- The isUsgTy function is utterly useless if UsManys are omitted. --- Be warned! KSW 1999-04. -isUsgTy :: Type -> Bool -#ifndef USMANY -isUsgTy _ = True -#else -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 (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, --- however. KSW 1999-04. -splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type) -splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 ) - Just (usg,ty2) -splitUsgTy_maybe ty@(NoteTy (UsgForAll _) _) = pprPanic "splitUsgTy_maybe:" $ pprType ty -splitUsgTy_maybe ty = Nothing - -splitUsgTy :: Type -> (UsageAnn,Type) -splitUsgTy ty = case splitUsgTy_maybe ty of - Just ans -> ans - Nothing -> -#ifndef USMANY - (UsMany,ty) -#else - pprPanic "splitUsgTy: no usage annot:" $ pprType ty -#endif - -tyUsg :: Type -> UsageAnn -tyUsg = fst . splitUsgTy - -unUsgTy :: Type -> Type --- strip outer usage annotation if present -unUsgTy ty = case splitUsgTy_maybe ty of - Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty ) - ty1 - Nothing -> ty - -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 (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1)) (substUsTy ve ty2) -substUsTy ve (NoteTy note ty) = NoteTy note (substUsTy ve ty) - -substUsTy ve (PredTy (Class c tys)) = PredTy (Class c (map (substUsTy ve) tys)) -substUsTy ve (PredTy (IParam n ty)) = PredTy (IParam n (substUsTy ve ty)) -substUsTy ve (TyVarTy tv) = TyVarTy tv -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} - - ---------------------------------------------------------------------- ForAllTy ~~~~~~~~ -We need to be clever here with usage annotations; they need to be -lifted or lowered through the forall as appropriate. - \begin{code} mkForAllTy :: TyVar -> Type -> Type -mkForAllTy tyvar ty = case splitUsgTy_maybe ty of - Just (usg,ty') -> NoteTy (UsgNote usg) - (ForAllTy tyvar ty') - Nothing -> ForAllTy tyvar ty +mkForAllTy tyvar ty + = mkForAllTys [tyvar] ty mkForAllTys :: [TyVar] -> Type -> Type -mkForAllTys tyvars ty = case splitUsgTy_maybe ty of - Just (usg,ty') -> NoteTy (UsgNote usg) - (foldr ForAllTy ty' tyvars) - Nothing -> foldr ForAllTy ty tyvars +mkForAllTys tyvars ty + = case splitUTy_maybe ty of + Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u), + ptext SLIT("mkForAllTys: usage scope") + <+> ppr tyvars <+> pprType ty ) + mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls + Nothing -> foldr ForAllTy ty tyvars + +isForAllTy :: Type -> Bool +isForAllTy (NoteTy _ ty) = isForAllTy ty +isForAllTy (ForAllTy _ _) = True +isForAllTy (UsageTy _ ty) = isForAllTy ty +isForAllTy other_ty = False splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) -splitForAllTy_maybe ty = case splitUsgTy_maybe ty of - Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty' - return (tyvar, NoteTy (UsgNote usg) ty'') - Nothing -> splitFAT_m ty +splitForAllTy_maybe ty = splitFAT_m ty where splitFAT_m (NoteTy _ ty) = splitFAT_m ty splitFAT_m (PredTy p) = splitFAT_m (predRepTy p) splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) + splitFAT_m (UsageTy _ ty) = splitFAT_m ty splitFAT_m _ = Nothing splitForAllTys :: Type -> ([TyVar], Type) -splitForAllTys ty = case splitUsgTy_maybe ty of - Just (usg,ty') -> let (tvs,ty'') = split ty' ty' [] - in (tvs, NoteTy (UsgNote usg) ty'') - Nothing -> split ty ty [] +splitForAllTys ty = split ty ty [] where split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs split orig_ty (PredTy p) tvs = split orig_ty (predRepTy p) tvs + split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs split orig_ty t tvs = (reverse tvs, orig_ty) \end{code} -- (mkPiType now in CoreUtils) -Applying a for-all to its arguments +Applying a for-all to its arguments. Lift usage annotation as required. \begin{code} applyTy :: Type -> Type -> Type -applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg) -applyTy (NoteTy note@(UsgForAll _) fun) arg = NoteTy note (applyTy fun arg) applyTy (PredTy p) arg = applyTy (predRepTy p) arg applyTy (NoteTy _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg ) +applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg), + ptext SLIT("applyTy") + <+> pprType ty <+> pprType arg ) substTy (mkTyVarSubst [tv] [arg]) ty +applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg) applyTy other arg = panic "applyTy" applyTys :: Type -> [Type] -> Type applyTys fun_ty arg_tys - = substTy (mkTyVarSubst tvs arg_tys) ty + = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty ) + (case mu of + Just u -> UsageTy u + Nothing -> id) $ + substTy (mkTyVarSubst tvs arg_tys) ty where - (tvs, ty) = split fun_ty arg_tys + (mu, 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 fun_ty [] = (Nothing, [], fun_ty) split (NoteTy _ fun_ty) args = split fun_ty args split (PredTy p) args = split (predRepTy p) 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 (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of + (mu, tvs, ty) -> (mu, tv:tvs, ty) + split (UsageTy u ty) args = case split ty args of + (Nothing, tvs, ty) -> (Just u, tvs, ty) + (Just _ , _ , _ ) -> pprPanic "applyTys:" + (pprType fun_ty) split other_ty 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. - \begin{code} hoistForAllTys :: Type -> Type -- Move all the foralls to the top -- e.g. T -> forall a. a ==> forall a. T -> a + -- Careful: LOSES USAGE ANNOTATIONS! hoistForAllTys ty = case hoist ty of { (tvs, body) -> mkForAllTys tvs body } where @@ -644,6 +570,84 @@ hoistForAllTys ty \end{code} +--------------------------------------------------------------------- + UsageTy + ~~~~~~~ + +Constructing and taking apart usage types. + +\begin{code} +mkUTy :: Type -> Type -> Type +mkUTy u ty + = ASSERT2( typeKind u == usageTypeKind, ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty ) + UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty ) + -- if u == usMany then ty else : ToDo? KSW 2000-10 +#ifdef DO_USAGES + UsageTy u ty +#else + ty +#endif + +splitUTy :: Type -> (Type {- :: $ -}, Type) +splitUTy orig_ty + = case splitUTy_maybe orig_ty of + Just (u,ty) -> (u,ty) +#ifdef DO_USAGES + Nothing -> pprPanic "splitUTy:" (pprType orig_ty) +#else + Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10 +#endif + +splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type) +splitUTy_maybe (UsageTy u ty) = Just (u,ty) +splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty +splitUTy_maybe other_ty = Nothing + +isUTy :: Type -> Bool + -- has usage annotation +isUTy = maybeToBool . splitUTy_maybe + +uaUTy :: Type -> Type + -- extract annotation +uaUTy = fst . splitUTy + +unUTy :: Type -> Type + -- extract unannotated type +unUTy = snd . splitUTy +\end{code} + +\begin{code} +liftUTy :: (Type -> Type) -> Type -> Type + -- lift outer usage annot over operation on unannotated types +liftUTy f ty + = let + (u,ty') = splitUTy ty + in + mkUTy u (f ty') +\end{code} + +\begin{code} +mkUTyM :: Type -> Type + -- put TOP (no info) annotation on unannotated type +mkUTyM ty = mkUTy usMany ty +\end{code} + +\begin{code} +isUsageKind :: Kind -> Bool +isUsageKind k + = ASSERT( typeKind k == superKind ) + k == usageTypeKind + +isUsage :: Type -> Bool +isUsage ty + = isUsageKind (typeKind ty) + +isUTyVar :: Var -> Bool +isUTyVar v + = isUsageKind (tyVarKind v) +\end{code} + + %************************************************************************ %* * \subsection{Stuff to do with the source-language types} @@ -657,10 +661,12 @@ ClassPred and ClassContext are used in class and instance declarations. tell from the type constructor whether it's a dictionary or not. \begin{code} -mkClassPred clas tys = Class clas tys +mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) + Class clas tys mkDictTy :: Class -> [Type] -> Type -mkDictTy clas tys = mkPredTy (Class clas tys) +mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) + mkPredTy (Class clas tys) mkDictTys :: ClassContext -> [Type] mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt] @@ -677,16 +683,19 @@ predRepTy (IParam n ty) = ty isPredTy :: Type -> Bool isPredTy (NoteTy _ ty) = isPredTy ty isPredTy (PredTy _) = True +isPredTy (UsageTy _ ty)= isPredTy ty isPredTy _ = False isDictTy :: Type -> Bool isDictTy (NoteTy _ ty) = isDictTy ty isDictTy (PredTy (Class _ _)) = True +isDictTy (UsageTy _ ty) = isDictTy ty isDictTy other = False splitPredTy_maybe :: Type -> Maybe PredType splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty splitPredTy_maybe (PredTy p) = Just p +splitPredTy_maybe (UsageTy _ ty)= splitPredTy_maybe ty splitPredTy_maybe other = Nothing splitDictTy :: Type -> (Class, [Type]) @@ -727,12 +736,14 @@ isTauTy (AppTy a b) = isTauTy a && isTauTy b isTauTy (FunTy a b) = isTauTy a && isTauTy b isTauTy (PredTy p) = isTauTy (predRepTy p) isTauTy (NoteTy _ ty) = isTauTy ty +isTauTy (UsageTy _ ty) = isTauTy ty isTauTy other = False \end{code} \begin{code} mkRhoTy :: [PredType] -> Type -> Type -mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta +mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty ) + foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta splitRhoTy :: Type -> ([PredType], Type) splitRhoTy ty = split ty ty [] @@ -741,6 +752,7 @@ splitRhoTy ty = split ty ty [] Just p -> split res res (p:ts) Nothing -> (reverse ts, orig_ty) split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts + split orig_ty (UsageTy _ ty) ts = split orig_ty ty ts split orig_ty ty ts = (reverse ts, orig_ty) \end{code} @@ -756,6 +768,7 @@ isSigmaTy :: Type -> Bool isSigmaTy (ForAllTy tyvar ty) = True isSigmaTy (FunTy a b) = isPredTy a isSigmaTy (NoteTy _ ty) = isSigmaTy ty +isSigmaTy (UsageTy _ ty) = isSigmaTy ty isSigmaTy _ = False splitSigmaTy :: Type -> ([TyVar], [PredType], Type) @@ -775,6 +788,7 @@ getDFunTyKey (AppTy fun _) = getDFunTyKey fun getDFunTyKey (NoteTy _ t) = getDFunTyKey t getDFunTyKey (FunTy arg _) = getOccName funTyCon getDFunTyKey (ForAllTy _ t) = getDFunTyKey t +getDFunTyKey (UsageTy _ t) = getDFunTyKey t -- PredTy shouldn't happen \end{code} @@ -812,6 +826,7 @@ typeKind (FunTy arg res) = fix_up (typeKind res) -- a strange kind like (*->*). typeKind (ForAllTy tv ty) = typeKind ty +typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann \end{code} @@ -825,12 +840,11 @@ tyVarsOfType (TyVarTy tv) = unitVarSet tv 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 (PredTy p) = tyVarsOfPred p 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 +tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys @@ -843,10 +857,7 @@ tyVarsOfTheta :: ThetaType -> TyVarSet tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet -- 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 (NoteTy note@(UsgForAll _) ty) = NoteTy note (addFreeTyVars ty) addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty @@ -861,10 +872,34 @@ namesOfType (PredTy p) = namesOfType (predRepTy p) namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar +namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys \end{code} +Usage annotations of a type +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Get a list of usage annotations of a type, *in left-to-right pre-order*. + +\begin{code} +usageAnnOfType :: Type -> [Type] +usageAnnOfType ty + = goS ty + where + goT (TyVarTy _) = [] + goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2 + goT (TyConApp tc tys) = concatMap goT tys + goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2 + goT (ForAllTy mv ty) = goT ty + goT (PredTy p) = goT (predRepTy p) + goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty) + goT (NoteTy note ty) = goT ty + + goS sty = case splitUTy sty of + (u,tty) -> u : goT tty +\end{code} + %************************************************************************ %* * @@ -917,11 +952,10 @@ tidyType env@(tidy_env, subst) ty go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty) where (envp, tvp) = tidyTyVar env tv + go (UsageTy u ty) = (UsageTy SAPPLY (go u)) SAPPLY (go ty) go_note (SynNote ty) = SynNote SAPPLY (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 go_pred (Class c tys) = Class c (tidyTypes env tys) go_pred (IParam n ty) = IParam n (go ty) @@ -970,6 +1004,7 @@ isUnLiftedType :: Type -> Bool isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc +isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty isUnLiftedType other = False isUnboxedTupleType :: Type -> Bool @@ -1014,6 +1049,7 @@ seqType (NoteTy note t2) = seqNote note `seq` seqType t2 seqType (PredTy p) = seqPred p seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty +seqType (UsageTy u ty) = seqType u `seq` seqType ty seqTypes :: [Type] -> () seqTypes [] = () @@ -1022,7 +1058,6 @@ seqTypes (ty:tys) = seqType ty `seq` seqTypes tys seqNote :: TyNote -> () seqNote (SynNote ty) = seqType ty seqNote (FTVNote set) = sizeUniqSet set `seq` () -seqNote (UsgNote usg) = usg `seq` () seqPred :: PredType -> () seqPred (Class c tys) = c `seq` seqTypes tys @@ -1037,9 +1072,6 @@ seqPred (IParam n ty) = n `seq` seqType ty %************************************************************************ -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 `compare` ty2 of { EQ -> True; other -> False } @@ -1070,8 +1102,9 @@ cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2 +cmpTy env (UsageTy u1 t1) (UsageTy u2 t2) = cmpTy env u1 u2 `thenCmp` cmpTy env t1 t2 - -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy + -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < UsageTy cmpTy env (AppTy _ _) (TyVarTy _) = GT cmpTy env (FunTy _ _) (TyVarTy _) = GT @@ -1081,7 +1114,12 @@ cmpTy env (TyConApp _ _) (TyVarTy _) = GT cmpTy env (TyConApp _ _) (AppTy _ _) = GT cmpTy env (TyConApp _ _) (FunTy _ _) = GT -cmpTy env (ForAllTy _ _) other = GT +cmpTy env (ForAllTy _ _) (TyVarTy _) = GT +cmpTy env (ForAllTy _ _) (AppTy _ _) = GT +cmpTy env (ForAllTy _ _) (FunTy _ _) = GT +cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT + +cmpTy env (UsageTy _ _) other = GT cmpTy env _ _ = LT diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 400ae46..4ea6cba 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -5,7 +5,7 @@ \begin{code} module TypeRep ( - Type(..), TyNote(..), PredType(..), UsageAnn(..), -- Representation visible to friends + Type(..), TyNote(..), PredType(..), -- Representation visible to friends Kind, ThetaType, RhoType, TauType, SigmaType, -- Synonyms TyVarSubst, @@ -17,27 +17,31 @@ module TypeRep ( boxedTypeKind, unboxedTypeKind, openTypeKind, -- :: KX mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX + usageKindCon, -- :: KX + usageTypeKind, -- :: KX + usOnceTyCon, usManyTyCon, -- :: $ + usOnce, usMany, -- :: $ + funTyCon ) where #include "HsVersions.h" -- friends: -import Var ( TyVar, UVar ) +import Var ( TyVar ) import VarEnv import VarSet import Name ( Name, mkGlobalName, mkKindOccFS, tcName ) import OccName ( tcName ) -import TyCon ( TyCon, KindCon, - mkFunTyCon, mkKindCon, mkSuperKindCon, - ) +import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon ) import Class ( Class ) -- others import SrcLoc ( builtinSrcLoc ) -import PrelNames ( pREL_GHC, kindConKey, boxityConKey, boxedConKey, - unboxedConKey, typeConKey, anyBoxConKey, funTyConName +import PrelNames ( pREL_GHC, superKindName, superBoxityName, boxedConName, + unboxedConName, typeConName, openKindConName, funTyConName, + usageKindConName, usOnceTyConName, usManyTyConName ) \end{code} @@ -125,6 +129,10 @@ data Type | PredTy -- A Haskell predicate PredType + | UsageTy -- A usage-annotated type + Type -- - Annotation of kind $ (i.e., usage annotation) + Type -- - Annotated type + | NoteTy -- A type with a note attached TyNote Type -- The expanded version @@ -132,14 +140,6 @@ data Type 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) - type ThetaType = [PredType] type RhoType = Type @@ -147,6 +147,10 @@ type TauType = Type type SigmaType = Type \end{code} +INVARIANT: UsageTys are optional, but may *only* appear immediately +under a FunTy (either argument), or at top-level of a Type permitted +to be annotated (such as the type of an Id). NoteTys are transparent +for the purposes of this rule. ------------------------------------- Predicates @@ -186,9 +190,12 @@ represented by evidence (a dictionary, for example, of type (predRepTy p). Kinds ~~~~~ kind :: KX = kind -> kind + | Type boxity -- (Type *) is printed as just * -- (Type #) is printed as just # + | UsageKind -- Printed '$'; used for usage annotations + | OpenKind -- Can be boxed or unboxed -- Printed '?' @@ -235,11 +242,9 @@ Define KX, the type of a kind \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} @@ -248,20 +253,16 @@ Define boxities: @*@ and @#@ \begin{code} boxedBoxity, unboxedBoxity :: Kind -- :: BX - -boxedConName = mk_kind_name boxedConKey SLIT("*") boxedBoxity = TyConApp (mkKindCon boxedConName superBoxity) [] -unboxedConName = mk_kind_name unboxedConKey SLIT("#") unboxedBoxity = TyConApp (mkKindCon unboxedConName superBoxity) [] \end{code} ------------------------------------------ -Define kinds: Type, Type *, Type #, and OpenKind +Define kinds: Type, Type *, Type #, OpenKind, and UsageKind \begin{code} typeCon :: KindCon -- :: BX -> KX -typeConName = mk_kind_name typeConKey SLIT("Type") typeCon = mkKindCon typeConName (superBoxity `FunTy` superKind) boxedTypeKind, unboxedTypeKind, openTypeKind :: Kind -- Of superkind superKind @@ -269,9 +270,11 @@ boxedTypeKind, unboxedTypeKind, openTypeKind :: Kind -- Of superkind superKind boxedTypeKind = TyConApp typeCon [boxedBoxity] unboxedTypeKind = TyConApp typeCon [unboxedBoxity] -openKindConName = mk_kind_name anyBoxConKey SLIT("?") openKindCon = mkKindCon openKindConName superKind openTypeKind = TyConApp openKindCon [] + +usageKindCon = mkKindCon usageKindConName superKind +usageTypeKind = TyConApp usageKindCon [] \end{code} ------------------------------------------ @@ -298,4 +301,18 @@ We define a few wired-in type constructors here to avoid module knots funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind) \end{code} +------------------------------------------ +Usage tycons @.@ and @!@ + +The usage tycons are of kind usageTypeKind (`$'). The types contain +no values, and are used purely for usage annotation. mk_kind_name is +used (hackishly) to avoid z-encoding of the names. + +\begin{code} +usOnceTyCon = mkKindCon usOnceTyConName usageTypeKind +usOnce = TyConApp usOnceTyCon [] + +usManyTyCon = mkKindCon usManyTyConName usageTypeKind +usMany = TyConApp usManyTyCon [] +\end{code} diff --git a/ghc/compiler/types/Unify.lhs b/ghc/compiler/types/Unify.lhs index c107209..d576aaa 100644 --- a/ghc/compiler/types/Unify.lhs +++ b/ghc/compiler/types/Unify.lhs @@ -11,8 +11,12 @@ module Unify ( unifyTysX, unifyTyListsX, match, matchTy, matchTys ) where +#include "HsVersions.h" + import TypeRep ( Type(..) ) -- friend -import Type ( typeKind, tyVarsOfType, splitAppTy_maybe ) +import Type ( typeKind, tyVarsOfType, splitAppTy_maybe, + splitUTy, isUTy, deNoteType + ) import PprType () -- Instances -- This import isn't strictly necessary, but it makes sure that @@ -25,16 +29,17 @@ import VarEnv ( TyVarSubstEnv, emptySubstEnv, lookupSubstEnv, extendSubstEnv, SubstResult(..) ) -import Outputable( panic ) +import Outputable \end{code} %************************************************************************ %* * -\subsection{Unification wih a explicit substitution} +\subsection{Unification with an explicit substitution} %* * %************************************************************************ Unify types with an explicit substitution and no monad. +Ignore usage annotations. \begin{code} type MySubst @@ -103,6 +108,10 @@ uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)" uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)" #endif + -- Ignore usages +uTysX (UsageTy _ t1) t2 k subst = uTysX t1 t2 k subst +uTysX t1 (UsageTy _ t2) k subst = uTysX t1 t2 k subst + -- Anything else fails uTysX ty1 ty2 k subst = Nothing @@ -123,7 +132,8 @@ uVarX tv1 ty2 k subst@(tmpls, env) | typeKind ty2 == tyVarKind tv1 && occur_check_ok ty2 -> -- No kind mismatch nor occur check - k (tmpls, extendSubstEnv env tv1 (DoneTy ty2)) + UASSERT( not (isUTy ty2) ) + k (tmpls, extendSubstEnv env tv1 (DoneTy ty2)) | otherwise -> Nothing -- Fail if kind mis-match or occur check where @@ -149,7 +159,8 @@ template, so that it simply returns a mapping of type variables to types. It also fails on nested foralls. @matchTys@ matches corresponding elements of a list of templates and -types. +types. It and @matchTy@ both ignore usage annotations, unlike the +main function @match@. \begin{code} matchTy :: TyVarSet -- Template tyvars @@ -164,17 +175,19 @@ matchTys :: TyVarSet -- Template tyvars -> Maybe (TyVarSubstEnv, -- Matching substitution [Type]) -- Left over instance types -matchTy tmpls ty1 ty2 = match ty1 ty2 tmpls (\ senv -> Just senv) emptySubstEnv +matchTy tmpls ty1 ty2 = match False ty1 ty2 tmpls (\ senv -> Just senv) emptySubstEnv -matchTys tmpls tys1 tys2 = match_list tys1 tys2 tmpls +matchTys tmpls tys1 tys2 = match_list False tys1 tys2 tmpls (\ (senv,tys) -> Just (senv,tys)) emptySubstEnv \end{code} -@match@ is the main function. +@match@ is the main function. It takes a flag indicating whether +usage annotations are to be respected. \begin{code} -match :: Type -> Type -- Current match pair +match :: Bool -- Respect usages? + -> Type -> Type -- Current match pair -> TyVarSet -- Template vars -> (TyVarSubstEnv -> Maybe result) -- Continuation -> TyVarSubstEnv -- Current subst @@ -184,49 +197,67 @@ match :: Type -> Type -- Current match pair -- has already been bound. If so, check that what it's bound to -- is the same as ty; if not, bind it and carry on. -match (TyVarTy v) ty tmpls k senv +match uflag (TyVarTy v) ty tmpls k senv | v `elemVarSet` tmpls = -- v is a template variable case lookupSubstEnv senv v of - Nothing -> k (extendSubstEnv senv v (DoneTy ty)) + Nothing -> UASSERT( not (isUTy ty) ) + k (extendSubstEnv senv v (DoneTy ty)) Just (DoneTy ty') | ty' == ty -> k senv -- Succeeds | otherwise -> Nothing -- Fails | otherwise = -- v is not a template variable; ty had better match -- Can't use (==) because types differ - case ty of + case deNoteType ty of TyVarTy v' | v == v' -> k senv -- Success other -> Nothing -- Failure + -- This deNoteType is *required* and cost me much pain. I guess + -- the reason the Note-stripping case is *last* rather than first + -- is to preserve type synonyms etc., so I'm not moving it to the + -- top; but this means that (without the deNotetype) a type + -- variable may not match the pattern (TyVarTy v') as one would + -- expect, due to an intervening Note. KSW 2000-06. -match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv - = match arg1 arg2 tmpls (match res1 res2 tmpls k) senv +match uflag (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv + = match uflag arg1 arg2 tmpls (match uflag res1 res2 tmpls k) senv -match (AppTy fun1 arg1) ty2 tmpls k senv +match uflag (AppTy fun1 arg1) ty2 tmpls k senv = case splitAppTy_maybe ty2 of - Just (fun2,arg2) -> match fun1 fun2 tmpls (match arg1 arg2 tmpls k) senv + Just (fun2,arg2) -> match uflag fun1 fun2 tmpls (match uflag arg1 arg2 tmpls k) senv Nothing -> Nothing -- Fail -match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv +match uflag (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv | tc1 == tc2 - = match_list tys1 tys2 tmpls k' senv + = match_list uflag tys1 tys2 tmpls k' senv where k' (senv', tys2') | null tys2' = k senv' -- Succeed | otherwise = Nothing -- Fail +match False (UsageTy _ ty1) ty2 tmpls k senv = match False ty1 ty2 tmpls k senv +match False ty1 (UsageTy _ ty2) tmpls k senv = match False ty1 ty2 tmpls k senv + +match True (UsageTy u1 ty1) (UsageTy u2 ty2) tmpls k senv + = match True u1 u2 tmpls (match True ty1 ty2 tmpls k) senv +match True ty1@(UsageTy _ _) ty2 tmpls k senv + = case splitUTy ty2 of { (u,ty2') -> match True ty1 ty2' tmpls k senv } +match True ty1 ty2@(UsageTy _ _) tmpls k senv + = case splitUTy ty1 of { (u,ty1') -> match True ty1' ty2 tmpls k senv } + -- With type synonyms, we have to be careful for the exact -- same reasons as in the unifier. Please see the -- considerable commentary there before changing anything -- here! (WDP 95/05) -match (NoteTy _ ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv -match ty1 (NoteTy _ ty2) tmpls k senv = match ty1 ty2 tmpls k senv +match uflag (NoteTy _ ty1) ty2 tmpls k senv = match uflag ty1 ty2 tmpls k senv +match uflag ty1 (NoteTy _ ty2) tmpls k senv = match uflag ty1 ty2 tmpls k senv -- Catch-all fails -match _ _ _ _ _ = Nothing +match _ _ _ _ _ _ = Nothing -match_list [] tys2 tmpls k senv = k (senv, tys2) -match_list (ty1:tys1) [] tmpls k senv = Nothing -- Not enough arg tys => failure -match_list (ty1:tys1) (ty2:tys2) tmpls k senv = match ty1 ty2 tmpls (match_list tys1 tys2 tmpls k) senv +match_list uflag [] tys2 tmpls k senv = k (senv, tys2) +match_list uflag (ty1:tys1) [] tmpls k senv = Nothing -- Not enough arg tys => failure +match_list uflag (ty1:tys1) (ty2:tys2) tmpls k senv + = match uflag ty1 ty2 tmpls (match_list uflag tys1 tys2 tmpls k) senv \end{code} diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs index 724d9d8..420f8f1 100644 --- a/ghc/compiler/types/Variance.lhs +++ b/ghc/compiler/types/Variance.lhs @@ -49,7 +49,7 @@ calcTyConArgVrcs tycons initial_oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons initial tc = if isAlgTyCon tc && null (tyConDataConsIfAvailable tc) then -- make pessimistic assumption (and warn) - take (tyConArity tc) abstractVrcs + abstractVrcs tc else replicate (tyConArity tc) (False,False) @@ -74,7 +74,7 @@ calcTyConArgVrcs tycons tcaoIter oi tc | isAlgTyCon tc = if null data_cons then -- Abstract types get uninformative variances - abstractVrcs + abstractVrcs tc else map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys) vs @@ -96,11 +96,18 @@ calcTyConArgVrcs tycons 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) +abstractVrcs :: TyCon -> ArgVrcs +abstractVrcs tc = +#ifdef DEBUG + pprTrace "Vrc: abstract tycon:" (ppr tc) $ +#endif + warn_abstract_vrcs `seq` replicate (tyConArity tc) (True,True) + +warn_abstract_vrcs +-- we pull the message out as a CAF so the warning only appears *once* + = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n" + ++ " Use -fno-prune-tydecls to fix.") $ + () \end{code} @@ -118,10 +125,6 @@ vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out -> 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 @@ -144,9 +147,9 @@ vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False) -- 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 (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1) + `orVrc` + vrcInTy fao v ty2 vrcInTy fao v (ForAllTy v' ty) = if v==v' then (False,False) @@ -155,6 +158,8 @@ vrcInTy fao v (ForAllTy v' ty) = if v==v' vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys pms2 = fao tc in orVrcs (zipWith timesVrc pms1 pms2) + +vrcInTy fao v (UsageTy u ty) = vrcInTy fao v u `orVrc` vrcInTy fao v ty \end{code} @@ -179,6 +184,9 @@ orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2) orVrcs :: [(Bool,Bool)] -> (Bool,Bool) orVrcs = foldl orVrc (False,False) +negVrc :: (Bool,Bool) -> (Bool,Bool) +negVrc (p1,m1) = (m1,p1) + anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool) anyVrc p as = foldl (\ pm a -> pm `orVrc` p a) (False,False) as diff --git a/ghc/compiler/usageSP/UConSet.lhs b/ghc/compiler/usageSP/UConSet.lhs index 2c5cc00..95cd836 100644 --- a/ghc/compiler/usageSP/UConSet.lhs +++ b/ghc/compiler/usageSP/UConSet.lhs @@ -9,24 +9,30 @@ February 1998 .. April 1999. Keith Wansbrough 1998-02-16..1999-04-29 \begin{code} -module UConSet ( UConSet, +module UConSet ( {- SEE BELOW: -- KSW 2000-10-13 + UConSet, emptyUConSet, eqManyUConSet, eqUConSet, leqUConSet, unionUCS, unionUCSs, - solveUCS, + solveUCS, -} ) where #include "HsVersions.h" import VarEnv -import Type ( UsageAnn(..) ) -import Var ( UVar ) import Bag ( Bag, unitBag, emptyBag, unionBags, foldlBag, bagToList ) import Outputable import PprType + +{- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13 + + This monomorphic version of the analysis is outdated. I'm + currently ripping out the old one and inserting the new one. For + now, I'm simply commenting out this entire file. + \end{code} ====================================================================== @@ -334,6 +340,8 @@ instance Outputable UConSet where ppr (UConFail d) = hang (text "UConSet inconsistent:") 4 d + +END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -} \end{code} ====================================================================== diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index d0e55fa..5ef0c4b 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -21,15 +21,12 @@ import CoreSyn import CoreFVs ( mustHaveLocalBinding ) import Rules ( RuleBase ) import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type ( UsageAnn(..), - applyTy, applyTys, +import Type ( applyTy, applyTys, splitFunTy_maybe, splitFunTys, splitTyConApp_maybe, - mkUsgTy, splitUsgTy, isUsgTy, isNotUsgTy, unUsgTy, tyUsg, - splitUsForAllTys, substUsTy, mkFunTy, mkForAllTy ) import TyCon ( tyConArgVrcs_maybe, isFunTyCon ) import Literal ( Literal(..), literalType ) -import Var ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo ) +import Var ( Var, varType, setVarType, modifyIdInfo ) import IdInfo ( setLBVarInfo, LBVarInfo(..) ) import Id ( isExportedId ) import VarEnv @@ -99,7 +96,14 @@ doUsageSPInf dflags us binds = do { printErrs (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ; return binds } - + +{- ENTIRE PASS COMMENTED OUT FOR NOW -- KSW 2000-10-13 + + This monomorphic version of the analysis is outdated. I'm + currently ripping out the old one and inserting the new one. For + now, I'm simply commenting out this entire pass. + + | otherwise = do let binds1 = doUnAnnotBinds binds @@ -660,6 +664,9 @@ isUnAnnotated (AppTy ty1 ty2) = isUnAnnotated ty1 && isUnAnnotated ty2 isUnAnnotated (TyConApp tc tys) = all isUnAnnotated tys isUnAnnotated (FunTy ty1 ty2) = isUnAnnotated ty1 && isUnAnnotated ty2 isUnAnnotated (ForAllTy tyv ty) = isUnAnnotated ty + + +END OF ENTIRELY-COMMENTED-OUT PASS -- KSW 2000-10-13 -} \end{code} ====================================================================== diff --git a/ghc/compiler/usageSP/UsageSPLint.lhs b/ghc/compiler/usageSP/UsageSPLint.lhs index 6fb6b05..bfbb5e7 100644 --- a/ghc/compiler/usageSP/UsageSPLint.lhs +++ b/ghc/compiler/usageSP/UsageSPLint.lhs @@ -9,10 +9,11 @@ September 1998 .. May 1999. Keith Wansbrough 1998-09-04..1999-06-25 \begin{code} -module UsageSPLint ( doLintUSPAnnotsBinds, +module UsageSPLint ( {- SEE BELOW: -- KSW 2000-10-13 + doLintUSPAnnotsBinds, doLintUSPConstBinds, doLintUSPBinds, - doCheckIfWorseUSP, + doCheckIfWorseUSP, -} ) where #include "HsVersions.h" @@ -20,7 +21,7 @@ module UsageSPLint ( doLintUSPAnnotsBinds, import UsageSPUtils import CoreSyn import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type ( UsageAnn(..), isUsgTy, tyUsg ) +import Type ( ) import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon ) import Var ( Var, varType ) import Id ( idLBVarInfo ) @@ -29,6 +30,13 @@ import ErrUtils ( ghcExit ) import Util ( zipWithEqual ) import Bag import Outputable + +{- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13 + + This monomorphic version of the analysis is outdated. I'm + currently ripping out the old one and inserting the new one. For + now, I'm simply commenting out this entire file. + \end{code} ====================================================================== @@ -419,6 +427,8 @@ runULM m = case (unULintM m) (panic "runULM: no location") of (_,errs) -> if isEmptyBag errs then Nothing else Just (vcat (map pprULintErr (bagToList errs))) + +END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -} \end{code} ====================================================================== diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index 9ad57cc..95ccf3a 100644 --- a/ghc/compiler/usageSP/UsageSPUtils.lhs +++ b/ghc/compiler/usageSP/UsageSPUtils.lhs @@ -9,7 +9,8 @@ September 1998 .. May 1999. Keith Wansbrough 1998-09-04..1999-07-07 \begin{code} -module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, +module UsageSPUtils ( {- SEE BELOW: -- KSW 2000-10-13 + AnnotM(AnnotM), initAnnotM, genAnnotBinds, MungeFlags(isSigma,isLocal,isExp,hasUsg,mfLoc), @@ -19,24 +20,32 @@ module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, newVarUs, newVarUSMM, UniqSMM, usToUniqSMM, uniqSMMToUs, - primOpUsgTys, + primOpUsgTys, -} ) where #include "HsVersions.h" +{- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13 import CoreSyn import CoreFVs ( mustHaveLocalBinding ) import Var ( Var, varType, setVarType, mkUVar ) import Id ( isExportedId ) import Name ( isLocallyDefined ) import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type ( UsageAnn(..), isUsgTy, splitFunTys ) +import Type ( splitFunTys ) import Subst ( substTy, mkTyVarSubst ) import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon ) import VarEnv import PrimOp ( PrimOp, primOpUsg ) import UniqSupply ( UniqSupply, UniqSM, initUs, getUniqueUs, thenUs, returnUs ) import Outputable + + + This monomorphic version of the analysis is outdated. I'm + currently ripping out the old one and inserting the new one. For + now, I'm simply commenting out this entire file. + + \end{code} ====================================================================== @@ -628,6 +637,9 @@ primOpUsgTys p tys = let (tyvs,ty0us,rtyu) = primOpUsg p -- substitution may reveal more args in ((map (substTy s) ty0us) ++ ty1us, rty1u) + + +END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -} \end{code} ====================================================================== -- 1.7.10.4