import UniqFM
import UniqSet
import FastString
-import FastTypes
import Outputable
import Binary
import Data.Char
OccEnvs are used mainly for the envts in ModIfaces.
+Note [The Unique of an OccName]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
They are efficient, because FastStrings have unique Int# keys. We assume
-this key is less than 2^24, so we can make a Unique using
+this key is less than 2^24, and indeed FastStrings are allocated keys
+sequentially starting at 0.
+
+So we can make a Unique using
mkUnique ns key :: Unique
where 'ns' is a Char reprsenting the name space. This in turn makes it
easy to build an OccEnv.
\begin{code}
instance Uniquable OccName where
- getUnique (OccName ns fs)
- = mkUnique char (iBox (uniqueOfFS fs))
- where -- See notes above about this getUnique function
- char = case ns of
- VarName -> 'i'
- DataName -> 'd'
- TvName -> 'v'
- TcClsName -> 't'
+ -- See Note [The Unique of an OccName]
+ getUnique (OccName VarName fs) = mkVarOccUnique fs
+ getUnique (OccName DataName fs) = mkDataOccUnique fs
+ getUnique (OccName TvName fs) = mkTvOccUnique fs
+ getUnique (OccName TcClsName fs) = mkTcOccUnique fs
newtype OccEnv a = A (UniqFM a)
pprUnique,
- mkUnique, -- Used in UniqSupply
mkUniqueGrimily, -- Used in UniqSupply only!
getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only!
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
+ mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
+ mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
+
mkBuiltinUnique,
mkPseudoUniqueC,
mkPseudoUniqueD,
The stuff about unique *supplies* is handled further down this module.
\begin{code}
-mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
unpkUnique :: Unique -> (Char, Int) -- The reverse
mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
-- and as long as the Char fits in 8 bits, which we assume anyway!
+mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
+-- NOT EXPORTED, so that we can see all the Chars that
+-- are used in this one module
mkUnique c i
= MkUnique (tag `bitOrFastInt` bits)
where
mkPrimOpIdUnique op = mkUnique '9' op
mkPreludeMiscIdUnique i = mkUnique '0' i
--- No numbers left anymore, so I pick something different for the character
--- tag
+-- No numbers left anymore, so I pick something different for the character tag
mkPArrDataConUnique a = mkUnique ':' (2*a)
-- The "tyvar uniques" print specially nicely: a, b, c, etc.
mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs
mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs
mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs
+
+mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique
+mkRegSingleUnique = mkUnique 'R'
+mkRegSubUnique = mkUnique 'S'
+mkRegPairUnique = mkUnique 'P'
+mkRegClassUnique = mkUnique 'L'
+
+mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique
+-- See Note [The Unique of an OccName] in OccName
+mkVarOccUnique fs = mkUnique 'i' (iBox (uniqueOfFS fs))
+mkDataOccUnique fs = mkUnique 'd' (iBox (uniqueOfFS fs))
+mkTvOccUnique fs = mkUnique 'v' (iBox (uniqueOfFS fs))
+mkTcOccUnique fs = mkUnique 'c' (iBox (uniqueOfFS fs))
\end{code}
import CoreUtils
import CoreFVs
-import TcHsSyn ( mkArbitraryType ) -- Mis-placed?
import TcType
+import TysPrim ( anyTypeOfKind )
import CostCentre
import Module
import Id
import MkId ( seqId )
-import Var ( Var, TyVar )
+import Var ( Var, TyVar, tyVarKind )
import VarSet
import Rules
import VarEnv
-- see if it has any impact; it is on by default
= -- Note [Abstracting over tyvars only]
do { core_prs <- ds_lhs_binds NoSccs binds
- ; arby_env <- mkArbitraryTypeEnv tyvars exports
- ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
+ ;
+ ; let arby_env = mkArbitraryTypeEnv tyvars exports
+ (lg_binds, core_prs') = mapAndUnzip do_one core_prs
bndrs = mkVarSet (map fst core_prs)
add_lets | core_prs `lengthExceeds` 10 = add_some
; let mk_bind ((tyvars, global, local, prags), n) -- locals!!n == local
= -- Need to make fresh locals to bind in the selector,
-- because some of the tyvars will be bound to 'Any'
- do { ty_args <- mapM mk_ty_arg all_tyvars
- ; let substitute = substTyWith all_tyvars ty_args
+ do { let ty_args = map mk_ty_arg all_tyvars
+ substitute = substTyWith all_tyvars ty_args
; locals' <- newSysLocalsDs (map substitute local_tys)
; tup_id <- newSysLocalDs (substitute tup_ty)
; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global
; return ((global', rhs) : spec_binds) }
where
mk_ty_arg all_tyvar
- | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
+ | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = dsMkArbitraryType all_tyvar
; export_binds_s <- mapM mk_bind (exports `zip` [0..])
bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
| otherwise -> do
- { f_body <- fix_up (Let mono_bind (Var mono_id))
+ { let f_body = fix_up (Let mono_bind (Var mono_id))
- ; let local_poly = setIdNotExported poly_id
+ local_poly = setIdNotExported poly_id
-- Very important to make the 'f' non-exported,
-- else it won't be inlined!
spec_id = mkLocalId spec_name spec_ty
where
-- Bind to Any any of all_ptvs that aren't
-- relevant for this particular function
- fix_up body | null void_tvs = return body
- | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs
- ; return (mkTyApps (mkLams void_tvs body) void_tys) }
+ fix_up body | null void_tvs = body
+ | otherwise = mkTyApps (mkLams void_tvs body) $
+ map dsMkArbitraryType void_tvs
void_tvs = all_tvs \\ tvs
2 (ppr spec_expr)
-mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
+mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
-- If any of the tyvars is missing from any of the lists in
-- the second arg, return a binding in the result
mkArbitraryTypeEnv tyvars exports
= go emptyVarEnv exports
where
- go env [] = return env
+ go env [] = env
go env ((ltvs, _, _, _) : exports)
- = do { env' <- foldlM extend env [tv | tv <- tyvars
- , not (tv `elem` ltvs)
- , not (tv `elemVarEnv` env)]
- ; go env' exports }
+ = go env' exports
+ where
+ env' = foldl extend env [tv | tv <- tyvars
+ , not (tv `elem` ltvs)
+ , not (tv `elemVarEnv` env)]
- extend env tv = do { ty <- dsMkArbitraryType tv
- ; return (extendVarEnv env tv ty) }
+ extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
-
-dsMkArbitraryType :: TcTyVar -> DsM Type
-dsMkArbitraryType tv = mkArbitraryType warn tv
- where
- warn span msg = putSrcSpanDs span (warnDs msg)
+dsMkArbitraryType :: TcTyVar -> Type
+dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
\end{code}
Note [Unused spec binders]
put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
+ put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k }
-- Generic cases
14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
+ 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
_ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
put_ bh IfaceArgTypeKindTc = putByte bh 10
put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
+ put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
get bh = do
h <- getByte bh
9 -> return IfaceUbxTupleKindTc
10 -> return IfaceArgTypeKindTc
11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
- _ -> do { ext <- get bh; return (IfaceTc ext) }
+ 12 -> do { ext <- get bh; return (IfaceTc ext) }
+ _ -> do { k <- get bh; return (IfaceAnyTc k) }
instance Binary IfacePredType where
put_ bh (IfaceClassP aa ab) = do
type IfaceContext = [IfacePredType]
--- NB: If you add a data constructor, remember to add a case to
--- IfaceSyn.eqIfTc!
data IfaceTyCon -- Abbreviations for common tycons with known names
= IfaceTc Name -- The common case
| IfaceIntTc | IfaceBoolTc | IfaceCharTc
| IfaceListTc | IfacePArrTc
| IfaceTupTc Boxity Arity
+ | IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim)
| IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
| IfaceUbxTupleKindTc | IfaceArgTypeKindTc
- deriving( Eq )
ifaceTyConName :: IfaceTyCon -> Name
-ifaceTyConName IfaceIntTc = intTyConName
-ifaceTyConName IfaceBoolTc = boolTyConName
-ifaceTyConName IfaceCharTc = charTyConName
-ifaceTyConName IfaceListTc = listTyConName
-ifaceTyConName IfacePArrTc = parrTyConName
-ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar)
+ifaceTyConName IfaceIntTc = intTyConName
+ifaceTyConName IfaceBoolTc = boolTyConName
+ifaceTyConName IfaceCharTc = charTyConName
+ifaceTyConName IfaceListTc = listTyConName
+ifaceTyConName IfacePArrTc = parrTyConName
+ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar)
ifaceTyConName IfaceLiftedTypeKindTc = liftedTypeKindTyConName
ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName
ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName
ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName
ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName
-ifaceTyConName (IfaceTc ext) = ext
+ifaceTyConName (IfaceTc ext) = ext
+ifaceTyConName (IfaceAnyTc kind) = pprPanic "ifaceTyConName" (ppr (IfaceAnyTc kind))
+ -- Note [The Name of an IfaceAnyTc]
\end{code}
+Note [The Name of an IfaceAnyTc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It isn't easy to get the Name of an IfaceAnyTc in a pure way. What you
+really need to do is to transform it to a TyCon, and get the Name of that.
+But doing so needs the monad.
+
+In fact, ifaceTyConName is only used for instances and rules, and we don't
+expect to instantiate those at these (internal-ish) Any types, so rather
+than solve this potential problem now, I'm going to defer it until it happens!
%************************************************************************
%* *
toIfaceTyCon :: TyCon -> IfaceTyCon
toIfaceTyCon tc
| isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc)
+ | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc))
| otherwise = toIfaceTyCon_name (tyConName tc)
toIfaceTyCon_name :: Name -> IfaceTyCon
toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon
toIfaceWiredInTyCon tc nm
- | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc)
+ | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc)
+ | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc))
| nm == intTyConName = IfaceIntTc
| nm == boolTyConName = IfaceBoolTc
| nm == charTyConName = IfaceCharTc
import TyCon
import DataCon
import TysWiredIn
+import TysPrim ( anyTyConOfKind )
import Var ( TyVar )
import qualified Var
import VarEnv
tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon
tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon
tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
+tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind
+ ; tcWiredInTyCon (anyTyConOfKind tc_kind) }
tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
; return (check_tc (tyThingTyCon thing)) }
where
instance Uniquable RealReg where
getUnique reg
= case reg of
- RealRegSingle i -> mkUnique 'S' i
- RealRegPair r1 r2 -> mkUnique 'P' (r1 * 65536 + r2)
+ RealRegSingle i -> mkRegSingleUnique i
+ RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2)
instance Outputable RealReg where
ppr reg
-- | so we can put regs in UniqSets
instance Uniquable Reg where
getUnique (Reg c i)
- = mkUnique 'R'
+ = mkRegSingleUnique
$ fromEnum c * 1000 + i
getUnique (RegSub s (Reg c i))
- = mkUnique 'S'
+ = mkRegSubUnique
$ fromEnum s * 10000 + fromEnum c * 1000 + i
getUnique (RegSub _ (RegSub _ _))
instance Uniquable Store where
getUnique (SReg r)
| RegReal (RealRegSingle i) <- r
- = mkUnique 'R' i
+ = mkRegSingleUnique i
| RegReal (RealRegPair r1 r2) <- r
- = mkUnique 'P' (r1 * 65535 + r2)
+ = mkRegPairUnique (r1 * 65535 + r2)
| otherwise
= error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected."
- getUnique (SSlot i) = mkUnique 'S' i
+ getUnique (SSlot i) = mkRegSubUnique i -- [SLPJ] I hope "SubUnique" is ok
instance Outputable Store where
ppr (SSlot i) = text "slot" <> int i
instance Uniquable RegClass where
- getUnique RcInteger = mkUnique 'L' 0
- getUnique RcFloat = mkUnique 'L' 1
- getUnique RcDouble = mkUnique 'L' 2
+ getUnique RcInteger = mkRegClassUnique 0
+ getUnique RcFloat = mkRegClassUnique 1
+ getUnique RcDouble = mkRegClassUnique 2
instance Outputable RegClass where
ppr RcInteger = Outputable.text "I"
listTyConKey, foreignObjPrimTyConKey, weakPrimTyConKey,
mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey,
orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey,
- realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey :: Unique
+ realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey,
+ anyTyConKey :: Unique
addrPrimTyConKey = mkPreludeTyConUnique 1
arrayPrimTyConKey = mkPreludeTyConUnique 3
boolTyConKey = mkPreludeTyConUnique 4
realWorldTyConKey = mkPreludeTyConUnique 34
stablePtrPrimTyConKey = mkPreludeTyConUnique 35
stablePtrTyConKey = mkPreludeTyConUnique 36
-
-anyPrimTyConKey, anyPrimTyCon1Key :: Unique
-anyPrimTyConKey = mkPreludeTyConUnique 37
-anyPrimTyCon1Key = mkPreludeTyConUnique 38
+anyTyConKey = mkPreludeTyConUnique 37
statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
mutVarPrimTyConKey, ioTyConKey,
%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
+
+
\section[TysPrim]{Wired-in knowledge about primitive types}
\begin{code}
+-- | This module defines TyCons that can't be expressed in Haskell.
+-- They are all, therefore, wired-in TyCons. C.f module TysWiredIn
module TysPrim(
alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
alphaTy, betaTy, gammaTy, deltaTy,
int64PrimTyCon, int64PrimTy,
word64PrimTyCon, word64PrimTy,
- anyPrimTyCon, anyPrimTy, anyPrimTyCon1, mkAnyPrimTyCon
+ -- * Any
+ anyTyCon, anyType, anyTyConOfKind, anyTypeOfKind
) where
#include "HsVersions.h"
import Var ( TyVar, mkTyVar )
import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
+import OccName ( mkTcOcc )
import OccName ( mkTyVarOccFS, mkTcOccFS )
-import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon )
+import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon )
import Type
import SrcLoc
-import Unique ( mkAlphaTyVarUnique, pprUnique )
+import Unique ( mkAlphaTyVarUnique )
import PrelNames
-import StaticFlags
import FastString
import Outputable
, wordPrimTyCon
, word32PrimTyCon
, word64PrimTyCon
- , anyPrimTyCon, anyPrimTyCon1
+ , anyTyCon
]
mkPrimTc :: FastString -> Unique -> TyCon -> Name
(ATyCon tycon) -- Relevant TyCon
UserSyntax -- None are built-in syntax
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, anyPrimTyConName, anyPrimTyCon1Name :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName :: Name
charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon
int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon
weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon
threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
-anyPrimTyConName = mkPrimTc (fsLit "Any") anyPrimTyConKey anyPrimTyCon
-anyPrimTyCon1Name = mkPrimTc (fsLit "Any1") anyPrimTyCon1Key anyPrimTyCon1
\end{code}
%************************************************************************
%************************************************************************
%* *
+ Any
+%* *
+%************************************************************************
+
+Note [Any types]
+~~~~~~~~~~~~~~~~
+The type constructor Any::* has these properties
+
+ * It is defined in module GHC.Prim, and exported so that it is
+ available to users. For this reason it's treated like any other
+ primitive type:
+ - has a fixed unique, anyTyConKey,
+ - lives in the global name cache
+ - built with TyCon.PrimTyCon
+
+ * It is lifted, and hence represented by a pointer
+
+ * It is inhabited by at least one value, namely bottom
+
+ * You can unsafely coerce any lifted type to Ayny, and back.
+
+ * It does not claim to be a *data* type, and that's important for
+ the code generator, because the code gen may *enter* a data value
+ but never enters a function value.
+
+ * It is used to instantiate otherwise un-constrained type variables of kind *
+ For example length Any []
+ See Note [Strangely-kinded void TyCons]
+
+In addition, we have a potentially-infinite family of types, one for
+each kind /other than/ *, needed to instantiate otherwise
+un-constrained type variables of kinds other than *. This is a bit
+like tuples; there is a potentially-infinite family. They have slightly
+different characteristics to Any::*:
+
+ * They are built with TyCon.AnyTyCon
+ * They have non-user-writable names like "Any(*->*)"
+ * They are not exported by GHC.Prim
+ * They are uninhabited (of course; not kind *)
+ * They have a unique derived from their OccName (see Note [Uniques of Any])
+ * Their Names do not live in the global name cache
+
+Note [Uniques of Any]
+~~~~~~~~~~~~~~~~~~~~~
+Although Any(*->*), say, doesn't have a binding site, it still needs
+to have a Unique. Unlike tuples (which are also an infinite family)
+there is no convenient way to index them, so we use the Unique from
+their OccName instead. That should be unique! (But in principle we
+must take care: it does not include the module/package.)
+
+Note [Strangely-kinded void TyCons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #959 for more examples
+
+When the type checker finds a type variable with no binding, which
+means it can be instantiated with an arbitrary type, it usually
+instantiates it to Void. Eg.
+
+ length []
+===>
+ length Any (Nil Any)
+
+But in really obscure programs, the type variable might have a kind
+other than *, so we need to invent a suitably-kinded type.
+
+This commit uses
+ Any for kind *
+ Any(*->*) for kind *->*
+ etc
+
+\begin{code}
+anyTyConName :: Name
+anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon
+
+anyTyCon :: TyCon
+anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
+
+anyType :: Type
+anyType = mkTyConApp anyTyCon []
+
+anyTypeOfKind :: Kind -> Type
+anyTypeOfKind kind
+ | isLiftedTypeKind kind = anyType
+ | otherwise = mkTyConApp (mk_any_tycon kind) []
+
+anyTyConOfKind :: Kind -> TyCon
+anyTyConOfKind kind
+ | isLiftedTypeKind kind = anyTyCon
+ | otherwise = mk_any_tycon kind
+
+mk_any_tycon :: Kind -> TyCon
+mk_any_tycon kind -- Kind other than *
+ = tycon
+ where
+ -- Derive the name from the kind, thus:
+ -- Any(*->*), Any(*->*->*)
+ -- These are names that can't be written by the user,
+ -- and are not allocated in the global name cache
+ str = "Any" ++ showSDoc (pprParendKind kind)
+
+ occ = mkTcOcc str
+ uniq = getUnique occ -- See Note [Uniques of Any]
+ name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax
+ tycon = mkAnyTyCon name kind
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)}
%* *
%************************************************************************
%************************************************************************
%* *
- Any
-%* *
-%************************************************************************
-
-The type constructor Any is type to which you can unsafely coerce any
-lifted type, and back.
-
- * It is lifted, and hence represented by a pointer
-
- * It does not claim to be a *data* type, and that's important for
- the code generator, because the code gen may *enter* a data value
- but never enters a function value.
-
-It's also used to instantiate un-constrained type variables after type
-checking. For example
- length Any []
-Annoyingly, we sometimes need Anys of other kinds, such as (*->*) etc.
-This is a bit like tuples. We define a couple of useful ones here,
-and make others up on the fly. If any of these others end up being exported
-into interface files, we'll get a crash; at least until we add interface-file
-syntax to support them.
-
-\begin{code}
-anyPrimTy :: Type
-anyPrimTy = mkTyConApp anyPrimTyCon []
-
-anyPrimTyCon :: TyCon -- Kind *
-anyPrimTyCon = mkLiftedPrimTyCon anyPrimTyConName liftedTypeKind 0 PtrRep
-
-anyPrimTyCon1 :: TyCon -- Kind *->*
-anyPrimTyCon1 = mkLiftedPrimTyCon anyPrimTyCon1Name kind 0 PtrRep
- where
- kind = mkArrowKind liftedTypeKind liftedTypeKind
-
-mkAnyPrimTyCon :: Unique -> Kind -> TyCon
--- Grotesque hack alert: the client gives the unique; so equality won't work
-mkAnyPrimTyCon unique kind
- = WARN( opt_PprStyle_Debug, ptext (sLit "Urk! Inventing strangely-kinded Any TyCon:") <+> ppr unique <+> ppr kind )
- -- See Note [Strangely-kinded void TyCons] in TcHsSyn
- tycon
- where
- name = mkPrimTc (mkFastString ("Any" ++ showSDoc (pprUnique unique))) unique tycon
- tycon = mkLiftedPrimTyCon name kind 0 PtrRep
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[TysPrim-arrays]{The primitive array types}
%* *
%************************************************************************
%
\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types}
-This module tracks the ``state interface'' document, ``GHC prelude:
-types and operations.''
-
\begin{code}
-- | This module is about types that can be defined in Haskell, but which
--- must be wired into the compiler nonetheless.
+-- must be wired into the compiler nonetheless. C.f module TysPrim
module TysWiredIn (
-- * All wired in things
wiredInTyCons,
unboxedPairDataCon = tupleCon Unboxed 2
\end{code}
+
%************************************************************************
%* *
\subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)}
| isUnLiftedTyCon tc -> PrimAlt tc
| isHiBootTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
- | otherwise -> ASSERT( _is_poly_alt_tycon tc )
+ | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
PolyAlt
Nothing -> PolyAlt
nlHsIntLit,
shortCutLit, hsOverLitName,
- mkArbitraryType, -- Put this elsewhere?
-
-- re-exported from TcMonad
TcId, TcIdSet, TcDictBinds,
import TcMType
import TysPrim
import TysWiredIn
-import TyCon
import DataCon
import Name
import Var
import Util
import Bag
import Outputable
-import FastString
\end{code}
\begin{code}
-- mutable tyvar to a fresh immutable one. So the mutable store
-- plays the role of an environment. If we come across a mutable
-- type variable that isn't so bound, it must be completely free.
- zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv
+ zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
; writeMetaTyVar tv ty
; return ty }
- where
- warn span msg = setSrcSpan span (addWarnTc msg)
-
-
-{- Note [Strangely-kinded void TyCons]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- See Trac #959 for more examples
-
-When the type checker finds a type variable with no binding, which
-means it can be instantiated with an arbitrary type, it usually
-instantiates it to Void. Eg.
-
- length []
-===>
- length Void (Nil Void)
-
-But in really obscure programs, the type variable might have a kind
-other than *, so we need to invent a suitably-kinded type.
-
-This commit uses
- Void for kind *
- List for kind *->*
- Tuple for kind *->...*->*
-
-which deals with most cases. (Previously, it only dealt with
-kind *.)
-
-In the other cases, it just makes up a TyCon with a suitable kind. If
-this gets into an interface file, anyone reading that file won't
-understand it. This is fixable (by making the client of the interface
-file make up a TyCon too) but it is tiresome and never happens, so I
-am leaving it.
-
-Meanwhile I have now fixed GHC to emit a civilized warning.
- -}
-
-mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain
- -> TcTyVar
- -> TcRnIf g l Type -- Used by desugarer too
--- Make up an arbitrary type whose kind is the same as the tyvar.
--- We'll use this to instantiate the (unbound) tyvar.
---
--- Also used by the desugarer; hence the (tiresome) parameter
--- to use when generating a warning
-mkArbitraryType warn tv
- | liftedTypeKind `isSubKind` kind -- The vastly common case
- = return anyPrimTy
- | eqKind kind (tyConKind anyPrimTyCon1) -- @*->*@
- = return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size
- | all isLiftedTypeKind args -- @*-> ... ->*->*@
- , isLiftedTypeKind res -- Horrible hack to make less use
- = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon
- | otherwise
- = do { _ <- warn (getSrcSpan tv) msg
- ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
- -- Same name as the tyvar, apart from making it start with a colon (sigh)
- -- I dread to think what will happen if this gets out into an
- -- interface file. Catastrophe likely. Major sigh.
- where
- kind = tyVarKind tv
- (args,res) = splitKindFunTys kind
- tup_tc = tupleTyCon Boxed (length args)
-
- msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon"))
- 2 (ptext (sLit "of kind") <+> quotes (ppr kind))
- , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv))
- , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv)
- , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway)."))
- , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ]
-\end{code}
+\end{code}
\ No newline at end of file
mkClassTyCon,
mkFunTyCon,
mkPrimTyCon,
- mkVoidPrimTyCon,
+ mkKindTyCon,
mkLiftedPrimTyCon,
mkTupleTyCon,
mkSynTyCon,
mkSuperKindTyCon,
mkCoercionTyCon,
mkForeignTyCon,
+ mkAnyTyCon,
-- ** Predicates on TyCons
isAlgTyCon,
isSynTyCon, isClosedSynTyCon, isOpenSynTyCon,
isSuperKindTyCon,
isCoercionTyCon, isCoercionTyCon_maybe,
- isForeignTyCon,
+ isForeignTyCon, isAnyTyCon,
isInjectiveTyCon,
isDataTyCon, isProductTyCon, isEnumerationTyCon,
%************************************************************************
\begin{code}
--- | Represents type constructors. Type constructors are introduced by things such as:
+-- | TyCons represent type constructors. Type constructors are introduced by things such as:
--
-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of kind @*@
--
-- that doesn't mean it's a true GADT; only that the "where"
-- form was used. This field is used only to guide
-- pretty-printing
+
algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type (always empty for GADTs).
-- A \"stupid theta\" is the context to the left of an algebraic type
-- declaration, e.g. @Eq a@ in the declaration @data Eq a => T a ...@.
tyConUnique :: Unique,
tyConName :: Name,
tyConKind :: Kind,
- tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance
- -- of the arity of a primtycon is!
+ tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance
+ -- of the arity of a primtycon is!
+
+ primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are
+ -- boxed (represented by pointers). This 'PrimRep' holds
+ -- that information.
+ -- Only relevant if tyConKind = *
- primTyConRep :: PrimRep,
- -- ^ Many primitive tycons are unboxed, but some are
- -- boxed (represented by pointers). This 'PrimRep' holds
- -- that information
+ isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted (may not contain bottom)
+ -- but foreign-imported ones may be lifted
- isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted (may not contain bottom)
- -- but foreign-imported ones may be lifted
- tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, holds the name of the imported thing
+ tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types,
+ -- holds the name of the imported thing
}
-- | Type coercions, such as @(~)@, @sym@, @trans@, @left@ and @right@.
-- the kind as a pair of types: @(ta, tc)@
}
+ -- | Any types. Like tuples, this is a potentially-infinite family of TyCons
+ -- one for each distinct Kind. They have no values at all.
+ -- Because there are infinitely many of them (like tuples) they are
+ -- defined in GHC.Prim and have names like "Any(*->*)".
+ -- Their Unique is derived from the OccName.
+ -- See Note [Any types] in TysPrim
+ | AnyTyCon {
+ tyConUnique :: Unique,
+ tyConName :: Name,
+ tyConKind :: Kind -- Never = *; that is done via PrimTyCon
+ -- See Note [Any types] in TysPrim
+ }
+
-- | Super-kinds. These are "kinds-of-kinds" and are never seen in Haskell source programs.
-- There are only two super-kinds: TY (aka "box"), which is the super-kind of kinds that
-- construct types eventually, and CO (aka "diamond"), which is the super-kind of kinds
mkPrimTyCon name kind arity rep
= mkPrimTyCon' name kind arity rep True
--- | Create the special void 'TyCon' which is unlifted and has 'VoidRep'
-mkVoidPrimTyCon :: Name -> Kind -> Arity -> TyCon
-mkVoidPrimTyCon name kind arity
- = mkPrimTyCon' name kind arity VoidRep True
+-- | Kind constructors
+mkKindTyCon :: Name -> Kind -> TyCon
+mkKindTyCon name kind
+ = mkPrimTyCon' name kind 0 VoidRep True
-- | Create a lifted primitive 'TyCon' such as @RealWorld@
mkLiftedPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon
coKindFun = kindRule
}
+mkAnyTyCon :: Name -> Kind -> TyCon
+mkAnyTyCon name kind
+ = AnyTyCon { tyConName = name,
+ tyConKind = kind,
+ tyConUnique = nameUnique name }
+
-- | Create a super-kind 'TyCon'
mkSuperKindTyCon :: Name -> TyCon -- Super kinds always have arity zero
mkSuperKindTyCon name
isSuperKindTyCon (SuperKindTyCon {}) = True
isSuperKindTyCon _ = False
+-- | Is this an AnyTyCon?
+isAnyTyCon :: TyCon -> Bool
+isAnyTyCon (AnyTyCon {}) = True
+isAnyTyCon _ = False
+
-- | Attempt to pull a 'TyCon' apart into the arity and 'coKindFun' of
-- a coercion 'TyCon'. Returns @Nothing@ if the 'TyCon' is not of the
-- appropriate kind
tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName
coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName
-liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName
-openTypeKindTyCon = mkKindTyCon openTypeKindTyConName
-unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName
-ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName
-argTypeKindTyCon = mkKindTyCon argTypeKindTyConName
-
-mkKindTyCon :: Name -> TyCon
-mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0
+liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind
+openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind
+unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
+ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind
+argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind
--------------------------
-- ... and now their names
mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
voidType :: VM Type
-voidType = mkBuiltinTyConApp voidTyCon []
+voidType = mkBuiltinTyConApp VectMonad.voidTyCon []
mkWrapType :: Type -> VM Type
mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]
projects / ghc-hetmet.git / commitdiff