data Kind
= Klifted
| Kunlifted
+ | Kunboxed
| Kopen
| Karrow Kind Kind
make_kind :: Kind -> C.Kind
make_kind (FunKind k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
make_kind LiftedTypeKind = C.Klifted
+make_kind UnboxedTypeKind = C.Kunboxed
make_kind UnliftedTypeKind = C.Kunlifted
make_kind OpenTypeKind = C.Kopen
make_kind _ = error "MkExternalCore died: make_kind"
instance Binary Kind where
put_ bh LiftedTypeKind = putByte bh 0
put_ bh UnliftedTypeKind = putByte bh 1
- put_ bh OpenTypeKind = putByte bh 2
- put_ bh ArgTypeKind = putByte bh 3
- put_ bh UbxTupleKind = putByte bh 4
+ put_ bh UnboxedTypeKind = putByte bh 2
+ put_ bh OpenTypeKind = putByte bh 3
+ put_ bh ArgTypeKind = putByte bh 4
+ put_ bh UbxTupleKind = putByte bh 5
put_ bh (FunKind k1 k2) = do
- putByte bh 5
+ putByte bh 6
put_ bh k1
put_ bh k2
put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
case h of
0 -> return LiftedTypeKind
1 -> return UnliftedTypeKind
- 2 -> return OpenTypeKind
- 3 -> return ArgTypeKind
- 4 -> return UbxTupleKind
+ 2 -> return UnboxedTypeKind
+ 3 -> return OpenTypeKind
+ 4 -> return ArgTypeKind
+ 5 -> return UbxTupleKind
_ -> do k1 <- get bh
k2 <- get bh
return (FunKind k1 k2)
mkSrcLoc, mkSrcSpan )
import Module
import StaticFlags ( opt_SccProfilingOn )
-import Type ( Kind, mkArrowKind, liftedTypeKind )
+import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
Activation(..), defaultInlineSpec )
import OrdList
akind :: { Kind }
: '*' { liftedTypeKind }
+ | '!' { unliftedTypeKind }
| '(' kind ')' { $2 }
import TyCon ( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon,
PrimRep(..) )
import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
- unliftedTypeKind, liftedTypeKind, openTypeKind,
+ unliftedTypeKind, unboxedTypeKind,
+ liftedTypeKind, openTypeKind,
Kind, mkArrowKinds,
TyThing(..)
)
where
arity = length arg_vrcs
kind = mkArrowKinds (replicate arity liftedTypeKind) result_kind
- result_kind = unliftedTypeKind -- all primitive types are unlifted
+ result_kind = case rep of
+ PtrRep -> unliftedTypeKind
+ _other -> unboxedTypeKind
pcPrimTyCon0 :: Name -> PrimRep -> TyCon
pcPrimTyCon0 name rep
= mkPrimTyCon name result_kind 0 [] rep
where
- result_kind = unliftedTypeKind -- all primitive types are unlifted
+ result_kind = case rep of
+ PtrRep -> unliftedTypeKind
+ _other -> unboxedTypeKind
charPrimTy = mkTyConTy charPrimTyCon
charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep
--------------------------------
-- Rexported from Type
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
- unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
+ unliftedTypeKind, liftedTypeKind, unboxedTypeKind,
+ openTypeKind, mkArrowKind, mkArrowKinds,
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isArgTypeKind, isSubKind, defaultKind,
import Type ( -- Re-exports
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
tyVarsOfTheta, Kind, PredType(..),
- ThetaType, unliftedTypeKind,
+ ThetaType, unliftedTypeKind, unboxedTypeKind,
liftedTypeKind, openTypeKind, mkArrowKind,
isLiftedTypeKind, isUnliftedTypeKind,
mkArrowKinds, mkForAllTy, mkForAllTys,
TvSubst, mkTvSubst, zipTyEnv, substTy, emptyTvSubst,
lookupTyVar, extendTvSubst )
import Kind ( Kind(..), SimpleKind, KindVar, isArgTypeKind,
- openTypeKind, liftedTypeKind, mkArrowKind, defaultKind,
+ openTypeKind, liftedTypeKind, unliftedTypeKind,
+ mkArrowKind, defaultKind,
isOpenTypeKind, argTypeKind, isLiftedTypeKind, isUnliftedTypeKind,
isSubKind, pprKind, splitKindFunTys )
import TysPrim ( alphaTy, betaTy )
go True OpenTypeKind = return liftedTypeKind
go True ArgTypeKind = return liftedTypeKind
go sw LiftedTypeKind = return liftedTypeKind
+ go sw UnliftedTypeKind = return unliftedTypeKind
go sw k@(KindVar _) = return k -- KindVars are always simple
go swapped kind = failWithTc (ptext SLIT("Unexpected kind unification failure:")
<+> ppr orig_swapped <+> ppr orig_kind)
\begin{code}
module Kind (
Kind(..), SimpleKind,
- openTypeKind, liftedTypeKind, unliftedTypeKind,
+ openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
argTypeKind, ubxTupleKind,
- isLiftedTypeKind, isUnliftedTypeKind,
+ isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
isArgTypeKind, isOpenTypeKind,
mkArrowKind, mkArrowKinds,
/ \
/ \
?? (#)
- / \
- * #
+ / | \
+ * ! #
where * [LiftedTypeKind] means boxed type
- # [UnliftedTypeKind] means unboxed type
+ # [UnboxedTypeKind] means unboxed type
(#) [UbxTupleKind] means unboxed tuple
?? [ArgTypeKind] is the lub of *,#
? [OpenTypeKind] means any type at all
\begin{code}
data Kind
= LiftedTypeKind -- *
- | OpenTypeKind -- ?
- | UnliftedTypeKind -- #
- | UbxTupleKind -- (##)
- | ArgTypeKind -- ??
- | FunKind Kind Kind -- k1 -> k2
+ | OpenTypeKind -- ?
+ | UnboxedTypeKind -- #
+ | UnliftedTypeKind -- !
+ | UbxTupleKind -- (##)
+ | ArgTypeKind -- ??
+ | FunKind Kind Kind -- k1 -> k2
| KindVar KindVar
deriving( Eq )
\begin{code}
liftedTypeKind = LiftedTypeKind
+unboxedTypeKind = UnboxedTypeKind
unliftedTypeKind = UnliftedTypeKind
openTypeKind = OpenTypeKind
argTypeKind = ArgTypeKind
isLiftedTypeKind LiftedTypeKind = True
isLiftedTypeKind other = False
+isUnliftedBoxedTypeKind UnliftedTypeKind = True
+isUnliftedBoxedTypeKind other = False
+
isUnliftedTypeKind UnliftedTypeKind = True
+isUnliftedTypeKind UnboxedTypeKind = True
isUnliftedTypeKind other = False
isArgTypeKind :: Kind -> Bool
-- True of any sub-kind of ArgTypeKind
isArgTypeKind LiftedTypeKind = True
isArgTypeKind UnliftedTypeKind = True
+isArgTypeKind UnboxedTypeKind = True
isArgTypeKind ArgTypeKind = True
isArgTypeKind other = False
-- (k1 `isSubKind` k2) checks that k1 <: k2
isSubKind LiftedTypeKind LiftedTypeKind = True
isSubKind UnliftedTypeKind UnliftedTypeKind = True
+isSubKind UnboxedTypeKind UnboxedTypeKind = True
isSubKind UbxTupleKind UbxTupleKind = True
isSubKind k1 OpenTypeKind = isOpenTypeKind k1
isSubKind k1 ArgTypeKind = isArgTypeKind k1
pprKind (KindVar v) = ppr v
pprKind LiftedTypeKind = ptext SLIT("*")
-pprKind UnliftedTypeKind = ptext SLIT("#")
+pprKind UnliftedTypeKind = ptext SLIT("!")
+pprKind UnboxedTypeKind = ptext SLIT("#")
pprKind OpenTypeKind = ptext SLIT("?")
pprKind ArgTypeKind = ptext SLIT("??")
pprKind UbxTupleKind = ptext SLIT("(#)")