From ee2dd59cf1c96437696b9ec39b35dd1beea259a1 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Fri, 23 Jun 2006 15:26:26 +0000 Subject: [PATCH] the unlifted kind --- compiler/coreSyn/ExternalCore.lhs | 1 + compiler/coreSyn/MkExternalCore.lhs | 1 + compiler/iface/BinIface.hs | 16 +++++++++------- compiler/parser/Parser.y.pp | 3 ++- compiler/prelude/TysPrim.lhs | 11 ++++++++--- compiler/typecheck/TcType.lhs | 5 +++-- compiler/typecheck/TcUnify.lhs | 4 +++- compiler/types/Kind.lhs | 31 ++++++++++++++++++++----------- 8 files changed, 47 insertions(+), 25 deletions(-) diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs index 09a6e7f..948f595 100644 --- a/compiler/coreSyn/ExternalCore.lhs +++ b/compiler/coreSyn/ExternalCore.lhs @@ -57,6 +57,7 @@ data Ty data Kind = Klifted | Kunlifted + | Kunboxed | Kopen | Karrow Kind Kind diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index ce09288..3315240 100644 --- 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 UnboxedTypeKind = C.Kunboxed 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 --- 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 - 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) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 1a20fa8..a750397 100644 --- 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 ) -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 } diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 2f6168b..55ee249 100644 --- 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, - 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 diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 4ebeeb7..9cc9170 100644 --- 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 - 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, diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index f22d2bc..e00c8ef 100644 --- 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, - 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) diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index fa24fec..79999c2 100644 --- a/compiler/types/Kind.lhs +++ b/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("(#)") -- 1.7.10.4