X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fprelude%2FTysPrim.lhs;h=056c5e47fd5bbac7eb111a59cf791f196ca7226e;hb=5ba62318965cc25b2aad20345d9b6acf665ea23d;hp=55ee249d4eb0c061964d238bcfec3f6054200e75;hpb=ee2dd59cf1c96437696b9ec39b35dd1beea259a1;p=ghc-hetmet.git diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 55ee249..056c5e4 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -4,10 +4,17 @@ \section[TysPrim]{Wired-in knowledge about primitive types} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TysPrim( alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTy, betaTy, gammaTy, deltaTy, - openAlphaTy, openAlphaTyVar, openAlphaTyVars, + openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, primTyCons, @@ -39,7 +46,9 @@ module TysPrim( word32PrimTyCon, word32PrimTy, int64PrimTyCon, int64PrimTy, - word64PrimTyCon, word64PrimTy + word64PrimTyCon, word64PrimTy, + + anyPrimTyCon, anyPrimTy, anyPrimTyCon1, mkAnyPrimTyCon ) where #include "HsVersions.h" @@ -47,18 +56,19 @@ module TysPrim( import Var ( TyVar, mkTyVar ) import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) import OccName ( mkOccNameFS, tcName, mkTyVarOcc ) -import TyCon ( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon, +import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, PrimRep(..) ) import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy, - unliftedTypeKind, unboxedTypeKind, + unliftedTypeKind, liftedTypeKind, openTypeKind, - Kind, mkArrowKinds, + Kind, mkArrowKinds, mkArrowKind, TyThing(..) ) -import SrcLoc ( noSrcLoc ) -import Unique ( mkAlphaTyVarUnique ) +import SrcLoc +import Unique ( mkAlphaTyVarUnique, pprUnique ) import PrelNames -import FastString ( FastString, mkFastString ) +import StaticFlags +import FastString import Outputable import Char ( ord, chr ) @@ -97,40 +107,42 @@ primTyCons , wordPrimTyCon , word32PrimTyCon , word64PrimTyCon + , anyPrimTyCon, anyPrimTyCon1 ] mkPrimTc :: FastString -> Unique -> TyCon -> Name mkPrimTc fs uniq tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName fs) uniq - Nothing -- No parent object (ATyCon tycon) -- Relevant TyCon UserSyntax -- None are built-in syntax -charPrimTyConName = mkPrimTc FSLIT("Char#") charPrimTyConKey charPrimTyCon -intPrimTyConName = mkPrimTc FSLIT("Int#") intPrimTyConKey intPrimTyCon -int32PrimTyConName = mkPrimTc FSLIT("Int32#") int32PrimTyConKey int32PrimTyCon -int64PrimTyConName = mkPrimTc FSLIT("Int64#") int64PrimTyConKey int64PrimTyCon -wordPrimTyConName = mkPrimTc FSLIT("Word#") wordPrimTyConKey wordPrimTyCon -word32PrimTyConName = mkPrimTc FSLIT("Word32#") word32PrimTyConKey word32PrimTyCon -word64PrimTyConName = mkPrimTc FSLIT("Word64#") word64PrimTyConKey word64PrimTyCon -addrPrimTyConName = mkPrimTc FSLIT("Addr#") addrPrimTyConKey addrPrimTyCon -floatPrimTyConName = mkPrimTc FSLIT("Float#") floatPrimTyConKey floatPrimTyCon -doublePrimTyConName = mkPrimTc FSLIT("Double#") doublePrimTyConKey doublePrimTyCon -statePrimTyConName = mkPrimTc FSLIT("State#") statePrimTyConKey statePrimTyCon -realWorldTyConName = mkPrimTc FSLIT("RealWorld") realWorldTyConKey realWorldTyCon -arrayPrimTyConName = mkPrimTc FSLIT("Array#") arrayPrimTyConKey arrayPrimTyCon -byteArrayPrimTyConName = mkPrimTc FSLIT("ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon -mutableArrayPrimTyConName = mkPrimTc FSLIT("MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon -mutableByteArrayPrimTyConName = mkPrimTc FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon -mutVarPrimTyConName = mkPrimTc FSLIT("MutVar#") mutVarPrimTyConKey mutVarPrimTyCon -mVarPrimTyConName = mkPrimTc FSLIT("MVar#") mVarPrimTyConKey mVarPrimTyCon -tVarPrimTyConName = mkPrimTc FSLIT("TVar#") tVarPrimTyConKey tVarPrimTyCon -stablePtrPrimTyConName = mkPrimTc FSLIT("StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon -stableNamePrimTyConName = mkPrimTc FSLIT("StableName#") stableNamePrimTyConKey stableNamePrimTyCon -bcoPrimTyConName = mkPrimTc FSLIT("BCO#") bcoPrimTyConKey bcoPrimTyCon -weakPrimTyConName = mkPrimTc FSLIT("Weak#") weakPrimTyConKey weakPrimTyCon -threadIdPrimTyConName = mkPrimTc FSLIT("ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon +charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon +intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon +int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon +int64PrimTyConName = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon +wordPrimTyConName = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon +word32PrimTyConName = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon +word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon +addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon +floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon +doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon +statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon +realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon +arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon +byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon +mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon +mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon +mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon +mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon +tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon +stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon +stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon +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 anyPrimTyCon \end{code} %************************************************************************ @@ -146,7 +158,7 @@ alphaTyVars is a list of type variables for use in templates: tyVarList :: Kind -> [TyVar] tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u) (mkTyVarOcc (mkFastString name)) - noSrcLoc) kind + noSrcSpan) kind | u <- [2..], let name | c <= 'z' = [c] | otherwise = 't':show u @@ -168,18 +180,10 @@ alphaTys = mkTyVarTys alphaTyVars -- to a lifted or unlifted type variable. It's used for the -- result type for "error", so that we can have (error Int# "Help") openAlphaTyVars :: [TyVar] -openAlphaTyVars@(openAlphaTyVar:_) = tyVarList openTypeKind +openAlphaTyVars@(openAlphaTyVar:openBetaTyVar:_) = tyVarList openTypeKind openAlphaTy = mkTyVarTy openAlphaTyVar - -vrcPos,vrcZero :: (Bool,Bool) -vrcPos = (True,False) -vrcZero = (False,False) - -vrcsP,vrcsZ,vrcsZP :: ArgVrcs -vrcsP = [vrcPos] -vrcsZ = [vrcZero] -vrcsZP = [vrcZero,vrcPos] +openBetaTy = mkTyVarTy openBetaTyVar \end{code} @@ -191,23 +195,18 @@ vrcsZP = [vrcZero,vrcPos] \begin{code} -- only used herein -pcPrimTyCon :: Name -> ArgVrcs -> PrimRep -> TyCon -pcPrimTyCon name arg_vrcs rep - = mkPrimTyCon name kind arity arg_vrcs rep +pcPrimTyCon :: Name -> Int -> PrimRep -> TyCon +pcPrimTyCon name arity rep + = mkPrimTyCon name kind arity rep where - arity = length arg_vrcs kind = mkArrowKinds (replicate arity liftedTypeKind) result_kind - result_kind = case rep of - PtrRep -> unliftedTypeKind - _other -> unboxedTypeKind + result_kind = unliftedTypeKind pcPrimTyCon0 :: Name -> PrimRep -> TyCon pcPrimTyCon0 name rep - = mkPrimTyCon name result_kind 0 [] rep + = mkPrimTyCon name result_kind 0 rep where - result_kind = case rep of - PtrRep -> unliftedTypeKind - _other -> unboxedTypeKind + result_kind = unliftedTypeKind charPrimTy = mkTyConTy charPrimTyCon charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep @@ -258,7 +257,7 @@ keep different state threads separate. It is represented by nothing at all. \begin{code} mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] -statePrimTyCon = pcPrimTyCon statePrimTyConName vrcsZ VoidRep +statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep \end{code} RealWorld is deeply magical. It is *primitive*, but it is not @@ -266,7 +265,7 @@ RealWorld is deeply magical. It is *primitive*, but it is not RealWorld; it's only used in the type system, to parameterise State#. \begin{code} -realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 [] PtrRep +realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 PtrRep realWorldTy = mkTyConTy realWorldTyCon realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld \end{code} @@ -277,15 +276,62 @@ defined in \tr{TysWiredIn.lhs}, not here. %************************************************************************ %* * + 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 = 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 uniq kind + = WARN( opt_PprStyle_Debug, ptext (sLit "Urk! Inventing strangely-kinded Any TyCon:") <+> ppr uniq <+> ppr kind ) + -- See Note [Strangely-kinded void TyCons] in TcHsSyn + tycon + where + name = mkPrimTc (mkFastString ("Any" ++ showSDoc (pprUnique uniq))) uniq tycon + tycon = mkLiftedPrimTyCon name kind 0 PtrRep +\end{code} + + +%************************************************************************ +%* * \subsection[TysPrim-arrays]{The primitive array types} %* * %************************************************************************ \begin{code} -arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName vrcsP PtrRep -mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName vrcsZP PtrRep -mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName vrcsZ PtrRep -byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName 1 PtrRep +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName 2 PtrRep +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName 1 PtrRep +byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt] byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon @@ -300,7 +346,7 @@ mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s] %************************************************************************ \begin{code} -mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName vrcsZP PtrRep +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] \end{code} @@ -312,7 +358,7 @@ mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName vrcsZP PtrRep +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] \end{code} @@ -324,7 +370,7 @@ mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName vrcsZP PtrRep +tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt] \end{code} @@ -336,7 +382,7 @@ mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName vrcsP AddrRep +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] \end{code} @@ -348,7 +394,7 @@ mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] %************************************************************************ \begin{code} -stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName vrcsP PtrRep +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty] \end{code} @@ -371,7 +417,7 @@ bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep %************************************************************************ \begin{code} -weakPrimTyCon = pcPrimTyCon weakPrimTyConName vrcsP PtrRep +weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v] \end{code}