Skip to content
GitLab
Commit ee2dd59c authored by Simon Marlow's avatar Simon Marlow
Browse files

the unlifted kind

parent 24ce1351
Hide whitespace changes
Inline Side-by-side
compiler/coreSyn/ExternalCore.lhs
View file @ ee2dd59c
......@@ -57,6 +57,7 @@ data Ty
data Kind
= Klifted
| Kunlifted
| Kunboxed
| Kopen
| Karrow Kind Kind
......
compiler/coreSyn/MkExternalCore.lhs
View file @ ee2dd59c
......@@ -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
View file @ ee2dd59c
......@@ -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
View file @ ee2dd59c
......@@ -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
View file @ ee2dd59c
......@@ -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
View file @ ee2dd59c
......@@ -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
View file @ ee2dd59c
......@@ -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
View file @ ee2dd59c
......@@ -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("(#)")
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment