the unlifted kind

diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs
index 09a6e7f..948f595 100644 (file)
--- a/compiler/coreSyn/ExternalCore.lhs
+++ b/compiler/coreSyn/ExternalCore.lhs
@@ -57,6 +57,7 @@ data Ty
 data Kind 
   = Klifted
   | Kunlifted
 data Kind 
   = Klifted
   | Kunlifted

+  | Kunboxed

   | Kopen
   | Karrow Kind Kind
 
   | Kopen
   | Karrow Kind Kind
 

diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index ce09288..3315240 100644 (file)
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/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 :: 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"
 make_kind UnliftedTypeKind = C.Kunlifted
 make_kind OpenTypeKind     = C.Kopen
 make_kind _ = error "MkExternalCore died: make_kind"

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 6b56119..631a286 100644 (file)
--- a/compiler/iface/BinIface.hs
+++ b/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
 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 
     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)
            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
            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)
              _ -> do k1 <- get bh
                      k2 <- get bh
                      return (FunKind k1 k2)

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 1a20fa8..a750397 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -32,7 +32,7 @@ import SrcLoc         ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
                          mkSrcLoc, mkSrcSpan )
 import Module
 import StaticFlags     ( opt_SccProfilingOn )
                          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
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
                          Activation(..), defaultInlineSpec )
 import OrdList

@@ -850,6 +850,7 @@ kind        :: { Kind }
 
 akind  :: { Kind }
        : '*'                   { liftedTypeKind }
 
 akind  :: { Kind }
        : '*'                   { liftedTypeKind }

+       | '!'                   { unliftedTypeKind }

        | '(' kind ')'          { $2 }
 
 
        | '(' kind ')'          { $2 }
 
 

diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 2f6168b..55ee249 100644 (file)
--- a/compiler/prelude/TysPrim.lhs
+++ b/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,
 import TyCon           ( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon,
                          PrimRep(..) )
 import Type            ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,

-                         unliftedTypeKind, liftedTypeKind, openTypeKind, 
+                         unliftedTypeKind, unboxedTypeKind, 
+                         liftedTypeKind, openTypeKind, 

                          Kind, mkArrowKinds,
                          TyThing(..)
                        )
                          Kind, mkArrowKinds,
                          TyThing(..)
                        )

@@ -196,13 +197,17 @@ pcPrimTyCon name arg_vrcs rep
   where
     arity       = length arg_vrcs
     kind        = mkArrowKinds (replicate arity liftedTypeKind) result_kind
   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
 
 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
 
 charPrimTy     = mkTyConTy charPrimTyCon
 charPrimTyCon  = pcPrimTyCon0 charPrimTyConName WordRep

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 4ebeeb7..9cc9170 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/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
   --------------------------------
   -- 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, 
 
   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(..),
 import Type            (       -- Re-exports
                          tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
                          tyVarsOfTheta, Kind, PredType(..),

-                         ThetaType, unliftedTypeKind, 
+                         ThetaType, unliftedTypeKind, unboxedTypeKind,

                          liftedTypeKind, openTypeKind, mkArrowKind,
                          isLiftedTypeKind, isUnliftedTypeKind, 
                          mkArrowKinds, mkForAllTy, mkForAllTys,
                          liftedTypeKind, openTypeKind, mkArrowKind,
                          isLiftedTypeKind, isUnliftedTypeKind, 
                          mkArrowKinds, mkForAllTy, mkForAllTys,

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index f22d2bc..e00c8ef 100644 (file)
--- a/compiler/typecheck/TcUnify.lhs
+++ b/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,
                          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 )
                          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 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)
     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)

diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index fa24fec..79999c2 100644 (file)
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -5,10 +5,10 @@
 \begin{code}
 module Kind (
        Kind(..), SimpleKind, 
 \begin{code}
 module Kind (
        Kind(..), SimpleKind, 

-       openTypeKind, liftedTypeKind, unliftedTypeKind, 
+       openTypeKind, liftedTypeKind, unliftedTypeKind, unboxedTypeKind,

        argTypeKind, ubxTupleKind,
 
        argTypeKind, ubxTupleKind,
 

-       isLiftedTypeKind, isUnliftedTypeKind, 
+       isLiftedTypeKind, isUnliftedTypeKind, isUnliftedBoxedTypeKind,

        isArgTypeKind, isOpenTypeKind,
        mkArrowKind, mkArrowKinds,
 
        isArgTypeKind, isOpenTypeKind,
        mkArrowKind, mkArrowKinds,
 

@@ -37,11 +37,11 @@ There's a little subtyping at the kind level:
                / \
               /   \
              ??   (#)
                / \
               /   \
              ??   (#)

-            /  \
-            *   #
+           / | \
+          *  !  #

 
 where  *    [LiftedTypeKind]   means boxed type
 
 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
        (#)  [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     --  *
 \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 )
 
   | KindVar KindVar
   deriving( Eq )
 

@@ -120,6 +121,7 @@ less-informative one to the more informative one.  Neat, eh?
 
 \begin{code}
 liftedTypeKind   = LiftedTypeKind
 
 \begin{code}
 liftedTypeKind   = LiftedTypeKind

+unboxedTypeKind  = UnboxedTypeKind

 unliftedTypeKind = UnliftedTypeKind
 openTypeKind     = OpenTypeKind
 argTypeKind      = ArgTypeKind
 unliftedTypeKind = UnliftedTypeKind
 openTypeKind     = OpenTypeKind
 argTypeKind      = ArgTypeKind

@@ -152,13 +154,18 @@ isLiftedTypeKind, isUnliftedTypeKind :: Kind -> Bool
 isLiftedTypeKind LiftedTypeKind = True
 isLiftedTypeKind other         = False
 
 isLiftedTypeKind LiftedTypeKind = True
 isLiftedTypeKind other         = False
 

+isUnliftedBoxedTypeKind UnliftedTypeKind = True
+isUnliftedBoxedTypeKind other      = False
+

 isUnliftedTypeKind UnliftedTypeKind = True
 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
 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
 
 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
 -- (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
 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 (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("(#)")
 pprKind OpenTypeKind     = ptext SLIT("?")
 pprKind ArgTypeKind      = ptext SLIT("??")
 pprKind UbxTupleKind     = ptext SLIT("(#)")