diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h
index 3da1db12238d311797e30f7c73598ca1f5db6092..abcaa994c975d9663365e2ef47d3a22613b50e7c 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 28bc5dae519f50a1a031b16e85c661a37a571660..7faafbac3c75184148d7bdfe0898f9f391cb9590 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
@@ -331,6 +344,14 @@ setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info)
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
@@ -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 3fe281acff42f13a2e65d4af7835d8a239c3227e..1fdf18e034412d28f485b68996c4b8d8b88b92f9 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,
@@ -348,6 +361,83 @@ instance Show InlinePragInfo where
\end{code}
+%************************************************************************
+%* *
+\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 022877ce6d6c3601ca6a12f51effea0d5638a8b8..1f29b86401abb91f859497ed1a10f229abb3620c 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 ea370e26fdeb3fc8861f88ae3fe382430581cde1..a794b7550a4bf4e866410daf76cafc66445cac0e 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 cc6684b6918c05bcf621067190ab53e3b80f17bf..f7cf7c043acde12c2f2c157ccf2db31975c53a34 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 65ba3fa9b492f40277858de812b2eef8827682a1..ee50bf29a740a504fd57f196c0943dcec845082e 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 89bef36a2445aef5d00bb323f77f8f982ddef297..2d9f0688344a21b048cb7a71d1ce3cc1a12af9e3 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.
@@ -212,43 +206,6 @@ isSigTyVar other = False
\end{code}
-%************************************************************************
-%* *
-\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 03ec1ead05f54a80c046d5fbdd914034ad855c2f..e90ed25d7964977aea343b1d9b1a330f5a8f0be4 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 2bca305bddb663d47219e3e916354ebe29c23762..ecd4a1cd014dff448ad0c8a119e7319b9358ed73 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 2c06210263b8a1af5ad5e6aa70b957a36a38ec25..3cce2d5053e8c133ac877dbbdcc1603d78783287 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 012075c38a4d2bc2740116ccafeae7b2f6e1eaa4..b5e7133705bf8e79b70846aa2f8b7453358149fb 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 bed901bbd3b750251b4f1080cc222eef88ff2a6a..e195c5396fed2d4826018d2a1cfe634b8709cb19 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 1e7fc2273765919d51c12e403c4671ec96e55b60..186695684c38da26ecaae6f1260537b46e50812b 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 c692b2daa2a84bf9a155ce061a493080222f2991..4fcc01a77fb8504dc8ed7fa1108d8f6b22894c7f 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 da86ba8e14695158205efbadcd0db52ffbbf6aac..ff55523bb46362db97327628cd23c50b8f8ee26d 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 a5dbf5316651fae152df68ca2d39dc88fad01638..c56b1d48f1a741c8fb2ec442246f215a0066c7ca 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 c39cddd55acde9c9d6bc8afd9f6d9d972c7e5250..2d532e39ebb36716ef82b6201337f5c37c464379 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 f27b78cc4e6eb655a2eb9fb7545b88bb91c8aef4..7344cd7e4c61aecca301814bad16d4b36196ac49 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 e3e58c0f6b06cdf23ae24835747fb655feb36370..43146b569c473a4a64c6bce174fd77d282b9c402 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 c2bd4536134d7efbd1e3847590f1c6f4784cb042..67d5c247e3c0773974c80087dbfe3b865ef559bf 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 25921364bbd9750f54ae98ca2bc0a35bce4cb673..db29d444d975a6d99b125ff05017c93a57095258 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 8cbc038544144d3766c6f8fdab7c7fe94f059331..43592185cd77bdd20212c06226a242785f8fbf1c 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 4a3c1f6748c7453b600c0ebd6933a601915f472a..f2ad080c1aa1bf769579361293071f091cde31c3 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 bd5178112fcf0818e6e04409b53251cb7bb9001d..aeb4f28a2a61f881c807e21f4b5b427ae03e98bc 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
@@ -429,12 +445,6 @@ eq_hsPred env (HsPIParam n1 ty1) (HsPIParam n2 ty2)
= n1 == n2 && eq_hsType env ty1 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
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 69b856595bc7105ab542e897c417b38386abc341..a1012cd44a1fd57f945869b88e73d80d0e8deb7a 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 63a090e82c3bd41aa37520042900e90ff848b51b..a8a1a0a3b354097b6794cc4ac5eb15440ab69976 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 fce6c581ef799a44c267bcf1d4ef237c4491dd63..779c235abef19fab56dbeff967a10ca31e8c4025 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 54e940879f9d114bd174976fa3d99076a728e9a3..8870c143895c227b1c607782f80f84bbe7412b8c 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 4b10236072edefd86336bda9009234c30fc00132..391a77d20cc47803f41d8f427b532700fcd5ae99 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 e334fa1afcc40baddd61a4058865bed881bcb5a4..70386d48c5cf600f3e592542107140c5b7df9ad1 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 6eaa3c6f796146ba2baddc6d412a793b353fb4ef..05feb3b069598f7a613621cc122e1d14147dde46 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 5eff2f57a244bfe7729a609f5d160a064b60ebe0..fb3a5221dc1c4ccbf8c98741f3b94856bbeb54c5 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 c1419389721449e30e6f6ac93146bcab901f8e98..1bf43a217f88e3c78ac97032c02dc3222339a288 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,
@@ -670,28 +687,16 @@ qcls_name :: { RdrName }
: cls_name { $1 }
| 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 b991dc881949e3d5b0be7462fecf8044f714949e..782ae26d96e5737a54789cd6b2eb4a37a1563737 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 ->
@@ -401,10 +407,6 @@ bindLocalsFVRn doc rdr_names enclosed_scope
enclosed_scope names `thenRn` \ (thing, fvs) ->
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
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 382f4299e73bc2086736778bd2ae57e36ea3e3ad..a881534cf166d7f2587760275b13d4dc65a47e2a 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 dc4bd87fea0aa85a313cf8c5584d47f112207549..d883716b07ec473f8bd66157e1541c7599ffe99c 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 d4a6f32cf04cf36c7e9a8c020aab97521163dfd4..43e3cd9b01b5638641a1fcc56a487bf7abd8b3e3 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 efeef3da288750ffc3a97688cb95fe3d82942462..42f8ce7f870de53adaa907585625de87e7742a99 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 72ca33cddc415a4fc4724011d911180539d8aa69..796cddf9fa11127ab3f7822cd74610df61fa6839 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 05c989cc84631a9a04ea9b7bd5217fa3ccbab459..5c7d33db77dc24631b59dc95d8457eda73117173 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 c972821eca85997dbfab4204f6e329c716529d18..e654e0d7bfce79d21e9df626ac11858f53e9cfc9 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 760cd797177a41a3c54f1b3d9fa4cd0b4b4592ab..9fa73812a5da7225a8d7fe9c59517e5aba8b5ca5 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 bcb1d9dcdb54f7639230339747525cabf9283b92..4e1ab82995463a17daf33411ebdbe477a4cf080b 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 67b17c470efc316cc2dd490040473a245d42a29c..5d30b11daa17fb860102899dddb532412f378ded 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 64430f8ba8109d66a5eee207e30cc0aec30cb98d..48f97dc5412d05877b756df026745703761d59c6 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 9dc5fcafce8701b98794b08e743b12c51e3d9ef3..a9a89e416218b2d2b754d9feed2b4632900a8584 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 ed543f6b67eecdf07859d16ea8e3c19e496bf24b..727a3c21453ddeed0a8b0febec3132e739de082b 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 54967ac78c85ff3682e10be0e48b934cca532f8d..ca18b67284481f7baa51e472dabfbd7e2fa3e1ce 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 51723ec0d2f88a3fec78b4383acf53f737913397..8ac55c51494678e56985bff63b1f4837dec359df 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 7e63ec1f4a99684cf820fe97be7f4282a201d464..10188434f1b3754f844d836cbe58ab3aea714ecc 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 ff2b84f795ebfb50e085cc8b99148bf8acb8b759..2a05b8c4931058dec19789f866bf65d166d60aea 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 6cd8799f87ab265b6411994ebfb9ababa7f41db6..12bc8e922c2a935278751c885a319e27f2fbaa40 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 76b91d5223a2ded278abe838cb79157beec67cb6..7815057da2be52c72c84bd88bcc9d1eb4ae9d035 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 58aac30c12d0763a5a932f703f4e51e41592f930..9710d72e70c63a82f6b974e5219c9ab504889bf0 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 0944e639f7af06a2b3e055956882f37d8b1b3aab..f9ebae4fd26f8053262b5f2703097c2f419c5681 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 89e36c4fa1af209f7df621cb3a4079410e6b141e..7b65447017c16cb3f6a718fb57ebf2f113db0420 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 = <mkGenericRhs op a T>
+
+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 637ea1f812ba5e49004ab5078633924ec796be8a..fc80b5035d163858644449ae01e1d52d493ca49c 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 ccd7618832ef843a68226320e49d0720722e6b79..bee967c94d0c60f020d31286c95843d1362f2aa0 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 dde73b12fd14853bc8d6408ed27b83b7fc8859f1..18f4b8e1b1343a6dcc21f9a78f490d8b46c27599 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
@@ -442,195 +472,91 @@ 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 400ae46eec7a0680f2e4f601ebad5c7f8adffb04..4ea6cba08fc5856190d515b9507abcb0436b7a3f 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 c10720973528f9c7187c14fed2d8a8c8cf452096..d576aaacb04be8523e3b834f14e36fd97b1bb280 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 724d9d8cff39422d8135b3460bcaedf63c140f68..420f8f1af673c1c261890324cacff356007e95cd 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 2c5cc0038a3067ac0f3859c23272a8d4ce98c7ac..95cd83619b9b072e0cc61b6af8db96ff640b7418 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 d0e55fa1eb9d51a5fd8cb76c31c547b7f69621d6..5ef0c4b5b59e9a5e45b579f1c812cf3ec028075d 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 6fb6b058a23d1d4c172c20429dec6b3cd27f930c..bfbb5e7988aba3137a5760c5f0adbc496a4fdfd9 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 9ad57cc32039e2633322e273c4200aad961defa7..95ccf3aab135bf52af8943eb0f94056a3ad6a116 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}
======================================================================