the unlifted kind

compiler/coreSyn/ExternalCore.lhs

@@ -57,6 +57,7 @@ data Ty
 data Kind 
   = Klifted
   | Kunlifted
+  | Kunboxed
   | Kopen
   | Karrow Kind Kind
 

compiler/coreSyn/MkExternalCore.lhs

@@ -174,6 +174,7 @@ make_ty (NoteTy _ t) 	= make_ty t
 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"

compiler/iface/BinIface.hs

@@ -562,11 +562,12 @@ instance Binary IfaceBndr where
 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)
@@ -576,9 +577,10 @@ instance Binary Kind where
 	    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)

compiler/parser/Parser.y.pp

@@ -32,7 +32,7 @@ import SrcLoc		( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
 			  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
@@ -850,6 +850,7 @@ kind	:: { Kind }
 
 akind	:: { Kind }
 	: '*'			{ liftedTypeKind }
+	| '!'			{ unliftedTypeKind }
 	| '(' kind ')'		{ $2 }
 
 

compiler/prelude/TysPrim.lhs

@@ -50,7 +50,8 @@ import OccName		( mkOccNameFS, tcName, mkTyVarOcc )
 import TyCon		( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon,
 			  PrimRep(..) )
 import Type		( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
-			  unliftedTypeKind, liftedTypeKind, openTypeKind, 
+			  unliftedTypeKind, unboxedTypeKind, 
+			  liftedTypeKind, openTypeKind, 
 			  Kind, mkArrowKinds,
 			  TyThing(..)
 			)
@@ -196,13 +197,17 @@ pcPrimTyCon name arg_vrcs rep
   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

compiler/typecheck/TcType.lhs

@@ -88,7 +88,8 @@ module TcType (
   --------------------------------
   -- 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, 
 
@@ -131,7 +132,7 @@ import TypeRep		( Type(..), funTyCon )  -- friend
 import Type		(	-- Re-exports
 			  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
 			  tyVarsOfTheta, Kind, PredType(..),
-			  ThetaType, unliftedTypeKind, 
+			  ThetaType, unliftedTypeKind, unboxedTypeKind,
 			  liftedTypeKind, openTypeKind, mkArrowKind,
 		  	  isLiftedTypeKind, isUnliftedTypeKind, 
 			  mkArrowKinds, mkForAllTy, mkForAllTys,

compiler/typecheck/TcUnify.lhs

@@ -53,7 +53,8 @@ import TcType		( TcKind, TcType, TcTyVar, BoxyTyVar, TcTauType,
 			  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 )
@@ -1504,6 +1505,7 @@ kindSimpleKind orig_swapped orig_kind
     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)

compiler/types/Kind.lhs

@@ -5,10 +5,10 @@
 \begin{code}
 module Kind (
 	Kind(..), SimpleKind, 
-	openTypeKind, liftedTypeKind, unliftedTypeKind, 
+	openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,
 	argTypeKind, ubxTupleKind,
 
-	isLiftedTypeKind, isUnliftedTypeKind, 
+	isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,
 	isArgTypeKind, isOpenTypeKind,
 	mkArrowKind, mkArrowKinds,
 
@@ -37,11 +37,11 @@ There's a little subtyping at the kind level:
 		/ \
 	       /   \
 	      ??   (#)
-	     /  \
-            *   #
+	    / | \
+	   *  !  #
 
 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
@@ -55,11 +55,12 @@ In particular:
 \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 )
 
@@ -120,6 +121,7 @@ less-informative one to the more informative one.  Neat, eh?
 
 \begin{code}
 liftedTypeKind   = LiftedTypeKind
+unboxedTypeKind  = UnboxedTypeKind
 unliftedTypeKind = UnliftedTypeKind
 openTypeKind     = OpenTypeKind
 argTypeKind      = ArgTypeKind
@@ -152,13 +154,18 @@ isLiftedTypeKind, isUnliftedTypeKind :: Kind -> Bool
 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
 
@@ -174,6 +181,7 @@ isSubKind :: Kind -> Kind -> Bool
 -- (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
@@ -219,7 +227,8 @@ pprParendKind k		      = pprKind k
 
 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("(#)")