...
  View open merge request
Commits (10)
......@@ -89,9 +89,9 @@
ignore = untracked
[submodule "utils/haddock"]
path = utils/haddock
url = https://gitlab.haskell.org/ghc/haddock.git
url = https://github.com/sgraf812/haddock/
ignore = untracked
branch = ghc-head
branch = wip/unlifted-data
[submodule "nofib"]
path = nofib
url = https://gitlab.haskell.org/ghc/nofib.git
......
......@@ -1171,6 +1171,7 @@ data HsDataDefn pass -- The payload of a data type defn
-- @
HsDataDefn { dd_ext :: XCHsDataDefn pass,
dd_ND :: NewOrData,
dd_levity :: Maybe Levity,
dd_ctxt :: LHsContext pass, -- ^ Context
dd_cType :: Maybe (Located CType),
dd_kindSig:: Maybe (LHsKind pass),
......@@ -1444,24 +1445,23 @@ pp_data_defn :: (OutputableBndrId p)
=> (LHsContext (GhcPass p) -> SDoc) -- Printing the header
-> HsDataDefn (GhcPass p)
-> SDoc
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data
, dd_levity = lev
, dd_ctxt = context
, dd_cType = mb_ct
, dd_kindSig = mb_sig
, dd_cons = condecls, dd_derivs = derivings })
| null condecls
= ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig
= ppr new_or_data <+> pp_lev <+> pp_ct <+> pp_hdr context <+> pp_sig
<+> pp_derivings derivings
| otherwise
= hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig)
2 (pp_condecls condecls $$ pp_derivings derivings)
where
pp_ct = case mb_ct of
Nothing -> empty
Just ct -> ppr ct
pp_sig = case mb_sig of
Nothing -> empty
Just kind -> dcolon <+> ppr kind
pp_lev = ppJustWith pprUnlifted lev
pp_ct = ppJustWith ppr mb_ct
pp_sig = ppJustWith (\kind -> dcolon <+> ppr kind) mb_sig
pp_derivings (L _ ds) = vcat (map ppr ds)
pp_data_defn _ (XHsDataDefn x) = ppr x
......
......@@ -34,7 +34,7 @@ import GHC.StgToCmm.Closure
import CLabel
import BlockId
import CmmExpr
import CmmExpr hiding (isGcPtrType) -- we want the one from Type
import CmmUtils
import DynFlags
import Id
......@@ -131,12 +131,15 @@ getCgIdInfo id
let name = idName id
; if isExternalName name then
let ext_lbl
| isUnliftedType (idType id) =
| isGcPtrType (idType id)
= mkClosureLabel name $ idCafInfo id
| isUnliftedType (idType id)
-- An unlifted external Id must refer to a top-level
-- string literal. See Note [Bytes label] in CLabel.
ASSERT( idType id `eqType` addrPrimTy )
mkBytesLabel name
| otherwise = mkClosureLabel name $ idCafInfo id
= ASSERT( idType id `eqType` addrPrimTy )
mkBytesLabel name
| otherwise
= pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id))
in return $
litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)
else
......
......@@ -223,7 +223,9 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext = noExtField
, dd_ND = DataType, dd_cType = Nothing
, dd_ND = DataType
, dd_levity = Nothing
, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' }
......@@ -239,7 +241,9 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext = noExtField
, dd_ND = NewType, dd_cType = Nothing
, dd_ND = NewType
, dd_levity = Nothing
, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = [con']
......@@ -308,7 +312,9 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext = noExtField
, dd_ND = DataType, dd_cType = Nothing
, dd_ND = DataType
, dd_levity = Nothing
, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' }
......@@ -329,7 +335,9 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext = noExtField
, dd_ND = NewType, dd_cType = Nothing
, dd_ND = NewType
, dd_levity = Nothing
, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = [con'], dd_derivs = derivs' }
......
......@@ -49,6 +49,8 @@ module BasicTypes(
OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
Levity(..), isLifted, pprUnlifted,
Boxity(..), isBoxed,
PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
......@@ -524,6 +526,31 @@ instance Outputable TopLevelFlag where
ppr TopLevel = text "<TopLevel>"
ppr NotTopLevel = text "<NotTopLevel>"
{-
************************************************************************
* *
Levity
* *
************************************************************************
-}
data Levity
= Lifted
| Unlifted
deriving( Eq, Data )
isLifted :: Levity -> Bool
isLifted Lifted = True
isLifted Unlifted = False
instance Outputable Levity where
ppr Lifted = text "Lifted"
ppr Unlifted = text "Unlifted"
pprUnlifted :: Levity -> SDoc
pprUnlifted Unlifted = text "unlifted"
pprUnlifted Lifted = empty
{-
************************************************************************
* *
......
......@@ -1377,7 +1377,7 @@ instance ToHie (LInjectivityAnn GhcRn) where
]
instance ToHie (HsDataDefn GhcRn) where
toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
toHie (HsDataDefn _ _ _ ctx _ mkind cons derivs) = concatM
[ toHie ctx
, toHie mkind
, toHie cons
......
......@@ -4558,6 +4558,7 @@ xFlagsDeps = [
flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax,
flagSpec "UnliftedFFITypes" LangExt.UnliftedFFITypes,
flagSpec "UnliftedNewtypes" LangExt.UnliftedNewtypes,
flagSpec "UnliftedDatatypes" LangExt.UnliftedDatatypes,
flagSpec "ViewPatterns" LangExt.ViewPatterns
]
......
......@@ -282,6 +282,7 @@ data AnnKeywordId
| AnnTilde -- ^ '~'
| AnnType
| AnnUnit -- ^ '()' for types
| AnnUnlifted -- ^ @unlifted@ keyword
| AnnUsing
| AnnVal -- ^ e.g. INTEGER
| AnnValStr -- ^ String value, will need quotes when output
......
......@@ -635,6 +635,7 @@ data Token
| ITstock
| ITanyclass
| ITvia
| ITunlifted
-- Backpack tokens
| ITunit
......@@ -833,6 +834,7 @@ reservedWordsFM = listToUFM $
( "stock", ITstock, 0 ),
( "anyclass", ITanyclass, 0 ),
( "via", ITvia, 0 ),
( "unlifted", ITunlifted, 0 ),
( "group", ITgroup, xbit TransformComprehensionsBit),
( "by", ITby, xbit TransformComprehensionsBit),
( "using", ITusing, xbit TransformComprehensionsBit),
......
This diff is collapsed.
......@@ -191,36 +191,40 @@ mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls
mkTyData :: SrcSpan
-> NewOrData
-> Maybe Levity
-> Maybe (Located CType)
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LTyClDecl GhcPs)
mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr))
mkTyData loc new_or_data levity cType (dL->L _ (mcxt, tycl_hdr))
ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; defn <- mkDataDefn new_or_data levity cType mcxt ksig data_cons maybe_deriv
; return (cL loc (DataDecl { tcdDExt = noExtField,
tcdLName = tc, tcdTyVars = tyvars,
tcdFixity = fixity,
tcdDataDefn = defn })) }
mkDataDefn :: NewOrData
-> Maybe Levity
-> Maybe (Located CType)
-> Maybe (LHsContext GhcPs)
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (HsDataDefn GhcPs)
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
mkDataDefn new_or_data levity cType mcxt ksig data_cons maybe_deriv
= do { checkDatatypeContext mcxt
; let cxt = fromMaybe (noLoc []) mcxt
; return (HsDataDefn { dd_ext = noExtField
, dd_ND = new_or_data, dd_cType = cType
, dd_ND = new_or_data
, dd_levity = levity
, dd_cType = cType
, dd_ctxt = cxt
, dd_cons = data_cons
, dd_kindSig = ksig
......@@ -282,6 +286,7 @@ mkTyFamInstEqn bndrs lhs rhs
mkDataFamInst :: SrcSpan
-> NewOrData
-> Maybe Levity
-> Maybe (Located CType)
-> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs]
, LHsType GhcPs)
......@@ -289,11 +294,11 @@ mkDataFamInst :: SrcSpan
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
-> P (LInstDecl GhcPs)
mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
mkDataFamInst loc new_or_data levity cType (mcxt, bndrs, tycl_hdr)
ksig data_cons maybe_deriv
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; defn <- mkDataDefn new_or_data levity cType mcxt ksig data_cons maybe_deriv
; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs
(FamEqn { feqn_ext = noExtField
, feqn_tycon = tc
......
......@@ -2022,11 +2022,12 @@ sumRepDataConKey = mkPreludeDataConUnique 73
-- See Note [Wiring in RuntimeRep] in TysWiredIn
runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique]
liftedRepDataConKey :: Unique
runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys)
liftedRepDataConKey, unliftedRepDataConKey :: Unique
runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedRepDataConKey : unliftedSimpleRepDataConKeys)
= map mkPreludeDataConUnique [74..88]
unliftedRepDataConKeys = vecRepDataConKey :
unliftedRepDataConKeys = unliftedRepDataConKey :
vecRepDataConKey :
tupleRepDataConKey :
sumRepDataConKey :
unliftedSimpleRepDataConKeys
......
......@@ -93,7 +93,7 @@ module TysWiredIn (
-- * Kinds
typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
isLiftedTypeKindTyConName, liftedTypeKind,
typeToTypeKind, constraintKind,
unliftedTypeKind, typeToTypeKind, constraintKind,
liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName,
liftedTypeKindTyConName,
......@@ -105,7 +105,7 @@ module TysWiredIn (
-- * RuntimeRep and friends
runtimeRepTyCon, vecCountTyCon, vecElemTyCon,
runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon,
runtimeRepTy, liftedRepTy, unliftedRepTy, liftedRepDataCon, liftedRepDataConTyCon,
vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,
......@@ -613,8 +613,9 @@ typeSymbolKind = mkTyConTy typeSymbolKindCon
constraintKindTyCon :: TyCon
constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
liftedTypeKind, typeToTypeKind, constraintKind :: Kind
liftedTypeKind, unliftedTypeKind, typeToTypeKind, constraintKind :: Kind
liftedTypeKind = tYPE liftedRepTy
unliftedTypeKind = tYPE unliftedRepTy
typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
constraintKind = mkTyConApp constraintKindTyCon []
......@@ -1151,7 +1152,7 @@ runtimeRepTy = mkTyConTy runtimeRepTyCon
liftedTypeKindTyCon :: TyCon
liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName
[] liftedTypeKind []
(tYPE liftedRepTy)
liftedTypeKind
runtimeRepTyCon :: TyCon
runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []
......@@ -1295,6 +1296,10 @@ liftedRepDataConTyCon = promoteDataCon liftedRepDataCon
liftedRepTy :: Type
liftedRepTy = liftedRepDataConTy
-- The type ('UnliftedRep)
unliftedRepTy :: Type
unliftedRepTy = unliftedRepDataConTy
{- *********************************************************************
* *
The boxed primitive types: Char, Int, etc
......
......@@ -15,6 +15,7 @@ coercibleTyCon, heqTyCon :: TyCon
unitTy :: Type
liftedTypeKind :: Kind
unliftedTypeKind :: Kind
constraintKind :: Kind
runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon
......
......@@ -1717,9 +1717,10 @@ rnTySyn doc rhs = rnLHsType doc rhs
rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
-> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = context, dd_cons = condecls
, dd_kindSig = m_sig, dd_derivs = derivs })
rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_levity = levity
, dd_cType = cType, dd_ctxt = context
, dd_cons = condecls, dd_kindSig = m_sig
, dd_derivs = derivs })
= do { checkTc (h98_style || null (unLoc context))
(badGadtStupidTheta doc)
......@@ -1742,7 +1743,9 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
con_fvs `plusFV` sig_fvs
; return ( HsDataDefn { dd_ext = noExtField
, dd_ND = new_or_data, dd_cType = cType
, dd_ND = new_or_data
, dd_levity = levity
, dd_cType = cType
, dd_ctxt = context', dd_kindSig = m_sig'
, dd_cons = condecls'
, dd_derivs = derivs' }
......
......@@ -24,7 +24,7 @@ module StgLiftLams.LiftM (
import GhcPrelude
import BasicTypes
import BasicTypes hiding ( isLifted )
import CostCentre ( isCurrentCCS, dontCareCCS )
import DynFlags
import FastString
......
......@@ -8,7 +8,7 @@ module StgLiftLams.Transformation (stgLiftLams) where
import GhcPrelude
import BasicTypes
import BasicTypes hiding ( isLifted )
import DynFlags
import Id
import IdInfo
......
......@@ -465,15 +465,16 @@ mkStgAltType bndr alts
| otherwise
= case prim_reps of
[LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of
Just tc
| isAbstractTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
| otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
PolyAlt
Nothing -> PolyAlt
[unlifted] -> PrimAlt unlifted
not_unary -> MultiValAlt (length not_unary)
[rep] | isGcPtrRep rep ->
case tyConAppTyCon_maybe (unwrapType bndr_ty) of
Just tc
| isAbstractTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
| otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
PolyAlt
Nothing -> PolyAlt
[non_gcd] -> PrimAlt non_gcd
not_unary -> MultiValAlt (length not_unary)
where
bndr_ty = idType bndr
prim_reps = typePrimRep bndr_ty
......
......@@ -575,7 +575,7 @@ type GenStgAlt pass
GenStgExpr pass) -- ...right-hand side.
data AltType
= PolyAlt -- Polymorphic (a lifted type variable)
= PolyAlt -- Polymorphic (a boxed type variable, lifted or unlifted)
| MultiValAlt Int -- Multi value of this arity (unboxed tuple or sum)
-- the arity could indeed be 1 for unary unboxed tuple
-- or enum-like unboxed sums
......
......@@ -2899,10 +2899,20 @@ etaExpandAlgTyCon tc_bndrs kind
--
-- At present, this data type is only consumed by 'checkDataKindSig'.
data DataSort
= DataDeclSort NewOrData
| DataInstanceSort NewOrData
= DataDeclSort NewOrData (Maybe Levity)
| DataInstanceSort NewOrData (Maybe Levity)
| DataFamilySort
data AllowedDataResKind
= AnyTYPEKind
| UnliftedKind
| LiftedKind
isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool
isAllowedDataResKind AnyTYPEKind kind = tcIsRuntimeTypeKind kind
isAllowedDataResKind UnliftedKind kind = tcIsUnliftedTypeKind kind
isAllowedDataResKind LiftedKind kind = tcIsLiftedTypeKind kind
-- | Checks that the return kind in a data declaration's kind signature is
-- permissible. There are three cases:
--
......@@ -2923,23 +2933,32 @@ data DataSort
checkDataKindSig :: DataSort -> Kind -> TcM ()
checkDataKindSig data_sort kind = do
dflags <- getDynFlags
checkTc (is_TYPE_or_Type dflags || is_kind_var) (err_msg dflags)
checkTc (tYPE_ok dflags || is_kind_var) (err_msg dflags)
where
pp_dec :: SDoc
pp_dec = text $
case data_sort of
DataDeclSort DataType -> "data type"
DataDeclSort NewType -> "newtype"
DataInstanceSort DataType -> "data instance"
DataInstanceSort NewType -> "newtype instance"
DataFamilySort -> "data family"
DataDeclSort DataType (Just Unlifted) -> "unlifted data type"
DataDeclSort DataType _ -> "data type"
DataDeclSort NewType _ -> "newtype"
DataInstanceSort DataType (Just Unlifted) -> "unlifted data instance"
DataInstanceSort DataType _ -> "data instance"
DataInstanceSort NewType _ -> "newtype instance"
DataFamilySort -> "data family"
is_newtype :: Bool
is_newtype =
case data_sort of
DataDeclSort new_or_data -> new_or_data == NewType
DataInstanceSort new_or_data -> new_or_data == NewType
DataFamilySort -> False
DataDeclSort new_or_data _ -> new_or_data == NewType
DataInstanceSort new_or_data _ -> new_or_data == NewType
DataFamilySort -> False
is_unlifted_datatype :: Bool
is_unlifted_datatype =
case data_sort of
DataDeclSort DataType (Just Unlifted) -> True
DataInstanceSort DataType (Just Unlifted) -> True
_ -> False
is_data_family :: Bool
is_data_family =
......@@ -2948,24 +2967,28 @@ checkDataKindSig data_sort kind = do
DataInstanceSort{} -> False
DataFamilySort -> True
allowed_kind :: DynFlags -> AllowedDataResKind
allowed_kind dflags
| is_newtype && xopt LangExt.UnliftedNewtypes dflags
-- With UnliftedNewtypes, we allow kinds other than Type, but they
-- must still be of the form `TYPE r` since we don't want to accept
-- Constraint or Nat.
-- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls.
= AnyTYPEKind
| is_data_family
-- If this is a `data family` declaration, we don't need to check if
-- UnliftedNewtypes is enabled, since data family declarations can
-- have return kind `TYPE r` unconditionally (#16827).
= AnyTYPEKind
| is_unlifted_datatype && xopt LangExt.UnliftedDatatypes dflags
-- With UnliftedDatatypes, we allow a kind sig the result kind of
-- which reduces to `TYPE 'UnliftedRep`.
= UnliftedKind
| otherwise
= LiftedKind
tYPE_ok :: DynFlags -> Bool
tYPE_ok dflags =
(is_newtype && xopt LangExt.UnliftedNewtypes dflags)
-- With UnliftedNewtypes, we allow kinds other than Type, but they
-- must still be of the form `TYPE r` since we don't want to accept
-- Constraint or Nat.
-- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls.
|| is_data_family
-- If this is a `data family` declaration, we don't need to check if
-- UnliftedNewtypes is enabled, since data family declarations can
-- have return kind `TYPE r` unconditionally (#16827).
is_TYPE :: Bool
is_TYPE = tcIsRuntimeTypeKind kind
is_TYPE_or_Type :: DynFlags -> Bool
is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE
| otherwise = tcIsLiftedTypeKind kind
tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) kind
-- In the particular case of a data family, permit a return kind of the
-- form `:: k` (where `k` is a bare kind variable).
......@@ -2973,17 +2996,32 @@ checkDataKindSig data_sort kind = do
is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe kind)
| otherwise = False
pp_allowed_kind dflags =
case allowed_kind dflags of
AnyTYPEKind -> text "TYPE"
UnliftedKind -> ppr unliftedTypeKind
LiftedKind -> ppr liftedTypeKind
err_msg :: DynFlags -> SDoc
err_msg dflags =
sep [ (sep [ text "Kind signature on" <+> pp_dec <+>
text "declaration has non-" <>
(if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind)
, (if is_data_family then text "and non-variable" else empty) <+>
text "return kind" <+> quotes (ppr kind) ])
, if not (tYPE_ok dflags) && is_TYPE && is_newtype &&
not (xopt LangExt.UnliftedNewtypes dflags)
then text "Perhaps you intended to use UnliftedNewtypes"
else empty ]
sep [ sep [ text "Kind signature on" <+> pp_dec <+>
text "declaration has non-" <>
pp_allowed_kind dflags
, (if is_data_family then text "and non-variable" else empty) <+>
text "return kind" <+> quotes (ppr kind) ]
, ext_hint dflags ]
ext_hint dflags
| tcIsRuntimeTypeKind kind
, is_newtype
, not (xopt LangExt.UnliftedNewtypes dflags)
= text "Perhaps you intended to use UnliftedNewtypes"
| tcIsUnliftedTypeKind kind
, is_unlifted_datatype
, not (xopt LangExt.UnliftedDatatypes dflags)
= text "Perhaps you intended to use UnliftedDatatypes"
| otherwise
= empty
-- | Checks that the result kind of a class is exactly `Constraint`, rejecting
-- type synonyms and type families that reduce to `Constraint`. See #16826.
......
......@@ -642,6 +642,7 @@ tcDataFamInstDecl mb_clsinfo
, feqn_tycon = lfam_name@(L _ fam_name)
, feqn_fixity = fixity
, feqn_rhs = HsDataDefn { dd_ND = new_or_data
, dd_levity = levity
, dd_cType = cType
, dd_ctxt = hs_ctxt
, dd_cons = hs_cons
......@@ -661,7 +662,7 @@ tcDataFamInstDecl mb_clsinfo
; (qtvs, pats, res_kind, stupid_theta)
<- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs
fixity hs_ctxt hs_pats m_ksig hs_cons
new_or_data
new_or_data levity
-- Eta-reduce the axiom if possible
-- Quite tricky: see Note [Eta-reduction for data families]
......@@ -686,7 +687,7 @@ tcDataFamInstDecl mb_clsinfo
-- we did it before the "extra" tvs from etaExpandAlgTyCon
-- would always be eta-reduced
; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind
; checkDataKindSig (DataInstanceSort new_or_data) final_res_kind
; checkDataKindSig (DataInstanceSort new_or_data levity) final_res_kind
; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs
all_pats = pats `chkAppend` extra_pats
orig_res_ty = mkTyConApp fam_tc all_pats
......@@ -787,13 +788,14 @@ tcDataFamInstHeader
-> LexicalFixity -> LHsContext GhcRn
-> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]
-> NewOrData
-> Maybe Levity
-> TcM ([TyVar], [Type], Kind, ThetaType)
-- The "header" of a data family instance is the part other than
-- the data constructors themselves
-- e.g. data instance D [a] :: * -> * where ...
-- Here the "header" is the bit before the "where"
tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity
hs_ctxt hs_pats m_ksig hs_cons new_or_data
hs_ctxt hs_pats m_ksig hs_cons new_or_data levity
= do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty)))
<- pushTcLevelM_ $
solveEqualities $
......@@ -846,11 +848,16 @@ tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity
exp_bndrs = mb_bndrs `orElse` []
-- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls, wrinkle (2).
-- See Note [Implementation of UnliftedDatatypes] TODO
tc_kind_sig Nothing
= do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes
; if unlifted_newtypes && new_or_data == NewType
then newOpenTypeKind
else pure liftedTypeKind
= do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes
; unlifted_datatypes <- xoptM LangExt.UnliftedDatatypes
; case (new_or_data, levity) of
(NewType, _)
| unlifted_newtypes -> newOpenTypeKind
(DataType, Just Unlifted)
| unlifted_datatypes -> pure unliftedTypeKind
_ -> pure liftedTypeKind
}
-- See Note [Result kind signature for a data family instance]
......
......@@ -1075,13 +1075,14 @@ getInitialKind strategy
(DataDecl { tcdLName = dL->L _ name
, tcdTyVars = ktvs
, tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
, dd_ND = new_or_data } })
, dd_ND = new_or_data
, dd_levity = levity } })
= do { let flav = newOrDataToFlavour new_or_data
ctxt = DataKindCtxt name
; tc <- kcDeclHeader strategy name flav ktvs $
case m_sig of
Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
Nothing -> dataDeclDefaultResultKind new_or_data
Nothing -> dataDeclDefaultResultKind new_or_data levity
; return [tc] }
getInitialKind InitialKindInfer (FamDecl { tcdFam = decl })
......@@ -1196,13 +1197,18 @@ have before standalone kind signatures:
-}
-- See Note [Data declaration default result kind]
dataDeclDefaultResultKind :: NewOrData -> TcM ContextKind
dataDeclDefaultResultKind new_or_data = do
dataDeclDefaultResultKind :: NewOrData -> Maybe Levity -> TcM ContextKind
dataDeclDefaultResultKind new_or_data levity = do
-- See Note [Implementation of UnliftedNewtypes]
unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes
return $ case new_or_data of
NewType | unlifted_newtypes -> OpenKind
_ -> TheKind liftedTypeKind
unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes
-- See Note [Implementation of UnliftedDatatypes] TODO
unlifted_datatypes <- xoptM LangExt.UnliftedDatatypes
return $ case (new_or_data, levity) of
(NewType, _)
| unlifted_newtypes -> OpenKind
(DataType, Just Unlifted)
| unlifted_datatypes -> TheKind unliftedTypeKind
_ -> TheKind liftedTypeKind
{- Note [Data declaration default result kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -2215,7 +2221,9 @@ tcDataDefn :: SDoc
tcDataDefn err_ctxt
roles_info
tc_name tycon_binders res_kind
(HsDataDefn { dd_ND = new_or_data, dd_cType = cType
(HsDataDefn { dd_ND = new_or_data
, dd_levity = levity
, dd_cType = cType
, dd_ctxt = ctxt
, dd_kindSig = mb_ksig -- Already in tc's kind
-- via inferInitialKinds
......@@ -2227,7 +2235,7 @@ tcDataDefn err_ctxt
; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind
; let hsc_src = tcg_src tcg_env
; unless (mk_permissive_kind hsc_src cons) $
checkDataKindSig (DataDeclSort new_or_data) final_res_kind
checkDataKindSig (DataDeclSort new_or_data levity) final_res_kind
; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt
; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta
......
......@@ -1437,7 +1437,7 @@ data PrimRep
| FloatRep
| DoubleRep
| VecRep Int PrimElemRep -- ^ A vector
deriving( Show )
deriving( Eq, Show )
data PrimElemRep
= Int8ElemRep
......
......@@ -114,9 +114,9 @@ module Type (
-- *** Levity and boxity
isLiftedType_maybe,
isLiftedTypeKind, isUnliftedTypeKind,
isLiftedRuntimeRep, isUnliftedRuntimeRep,
isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType,
isLiftedTypeKind, isUnliftedTypeKind, isGcPtrTypeKind,
isLiftedRuntimeRep, isUnliftedRuntimeRep, isGcPtrRuntimeRep,
isUnliftedType, isGcPtrType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType,
isAlgType, isDataFamilyAppType,
isPrimitiveType, isStrictType,
isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,
......@@ -129,10 +129,10 @@ module Type (
-- ** Finding the kind of a type
typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly,
tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,
tcIsRuntimeTypeKind,
tcIsUnliftedTypeKind, tcIsRuntimeTypeKind,
-- ** Common Kind
liftedTypeKind,
liftedTypeKind, unliftedTypeKind,
-- * Type free variables
tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,
......@@ -238,7 +238,7 @@ import TyCon
import TysPrim
import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind
, typeSymbolKind, liftedTypeKind
, constraintKind )
, unliftedTypeKind, constraintKind )
import PrelNames
import CoAxiom
import {-# SOURCE #-} Coercion( mkNomReflCo, mkGReflCo, mkReflCo
......@@ -536,6 +536,26 @@ isUnliftedRuntimeRep rep
| otherwise {- Variables, applications -}
= False
-- | Returns True if the kind classifies types which are allocated on the
-- Haskell heap and False otherwise. Note that this returns False for
-- levity-polymorphic kinds, which may be specialized to a kind that classifies
-- AddrRep or even unboxed kinds.
isGcPtrTypeKind :: Kind -> Bool
isGcPtrTypeKind kind
= case kindRep_maybe kind of
Just rep -> isGcPtrRuntimeRep rep
Nothing -> False
isGcPtrRuntimeRep :: Type -> Bool
-- True <=> LiftedRep or UnliftedRep, which are represented by pointers to the
-- Haskell heap
isGcPtrRuntimeRep rep
| Just rep' <- coreView rep = isGcPtrRuntimeRep rep'
| TyConApp rr_tc _ <- rep
= rr_tc `hasKey` liftedRepDataConKey || rr_tc `hasKey` unliftedRepDataConKey
| otherwise
= False
-- | Is this the type 'RuntimeRep'?
isRuntimeRepTy :: Type -> Bool
isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty'
......@@ -1982,6 +2002,13 @@ mightBeUnliftedType ty
Just is_lifted -> not is_lifted
Nothing -> True
-- | See "Type#type_classification" for what an unlifted type is.
-- Panics on levity polymorphic types; See 'mightBeUnliftedType' for
-- a more approximate predicate that behaves better in the presence of
-- levity polymorphism.
isGcPtrType :: Type -> Bool
isGcPtrType ty = isGcPtrRuntimeRep (getRuntimeRep ty)
-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep)
isRuntimeRepKindedTy :: Type -> Bool
isRuntimeRepKindedTy = isRuntimeRepTy . typeKind
......@@ -2531,6 +2558,15 @@ tcIsLiftedTypeKind ty
| otherwise
= False
-- | Is this kind equivalent to @TYPE 'UnliftedRep@?
tcIsUnliftedTypeKind :: Kind -> Bool
tcIsUnliftedTypeKind ty
| Just (tc, [arg]) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here
, tc `hasKey` tYPETyConKey
= isUnliftedRuntimeRep arg
| otherwise
= False
-- | Is this kind equivalent to @TYPE r@ (for some unknown r)?
--
-- This considers 'Constraint' to be distinct from @*@.
......
......@@ -33,7 +33,7 @@ module Outputable (
($$), ($+$), vcat,
sep, cat,
fsep, fcat,
hang, hangNotEmpty, punctuate, ppWhen, ppUnless,
hang, hangNotEmpty, punctuate, ppWhen, ppUnless, ppJustWith,
speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes,
unicodeSyntax,
......@@ -741,6 +741,10 @@ ppWhen False _ = empty
ppUnless True _ = empty
ppUnless False doc = doc
ppJustWith :: (a -> SDoc) -> Maybe a -> SDoc
ppJustWith _ Nothing = empty
ppJustWith f (Just a) = f a
-- | Apply the given colour\/style for the argument.
--
-- Only takes effect if colours are enabled.
......
......@@ -50,6 +50,7 @@ data Extension
| UnboxedTuples
| UnboxedSums
| UnliftedNewtypes
| UnliftedDatatypes
| BangPatterns
| TypeFamilies
| TypeFamilyDependencies
......
......@@ -40,6 +40,7 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
"AlternativeLayoutRule",
"AlternativeLayoutRuleTransitional",
"UnliftedNewtypes",
"UnliftedDatatypes",
"CUSKs",
"StandaloneKindSignatures",
"ImportQualifiedPost"]
......
......@@ -35,6 +35,7 @@
(HsDataDefn
(NoExtField)
(DataType)
(Nothing)
({ <no location info> }
[])
(Nothing)
......@@ -235,6 +236,7 @@
(HsDataDefn
(NoExtField)
(DataType)
(Nothing)
({ <no location info> }
[])
(Nothing)
......
......@@ -74,6 +74,7 @@
(HsDataDefn
(NoExtField)
(DataType)
(Nothing)
({ <no location info> }
[])
(Nothing)
......@@ -320,6 +321,7 @@
(HsDataDefn
(NoExtField)
(NewType)
(Nothing)
({ <no location info> }
[])
(Nothing)
......@@ -469,6 +471,7 @@
(HsDataDefn
(NoExtField)
(DataType)
(Nothing)
({ <no location info> }
[])
(Nothing)
......
......@@ -27,6 +27,7 @@
(HsDataDefn
(NoExtField)
(DataType)
(Nothing)
({ <no location info> }
[])
(Nothing)
......
......@@ -28,6 +28,7 @@
(HsDataDefn
(NoExtField)
(DataType)
(Nothing)
({ <no location info> }
[])
(Nothing)
......
haddock @ cdccaceb
Subproject commit 46c288ea42c50302d708fa7a2495f3544aafac35
Subproject commit cdccacebd8dba276106b00ee919c1b87263433ed