summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Builtin/PrimOps.hs8
-rw-r--r--compiler/GHC/Builtin/Types.hs5
-rw-r--r--compiler/GHC/Builtin/Types.hs-boot2
-rw-r--r--compiler/GHC/Builtin/Types/Prim.hs48
-rw-r--r--compiler/GHC/Builtin/primops.txt.pp17
-rw-r--r--compiler/GHC/Types/Id/Make.hs2
-rw-r--r--docs/users_guide/9.4.1-notes.rst19
-rw-r--r--libraries/ghc-prim/changelog.md20
-rw-r--r--testsuite/tests/codeGen/should_fail/T13233.hs7
-rw-r--r--testsuite/tests/codeGen/should_fail/T13233.stderr12
-rw-r--r--testsuite/tests/codeGen/should_fail/T13233_elab.hs10
-rw-r--r--testsuite/tests/codeGen/should_fail/T13233_elab.stderr10
-rw-r--r--testsuite/tests/typecheck/should_compile/T17817b.hs21
-rw-r--r--testsuite/tests/typecheck/should_compile/all.T1
-rw-r--r--testsuite/tests/typecheck/should_fail/T17817.hs16
-rw-r--r--testsuite/tests/typecheck/should_fail/T17817.stderr13
-rw-r--r--testsuite/tests/typecheck/should_fail/T17817_elab.hs17
-rw-r--r--testsuite/tests/typecheck/should_fail/T17817_elab.stderr10
-rw-r--r--testsuite/tests/typecheck/should_fail/all.T2
-rw-r--r--utils/genprimopcode/Main.hs14
20 files changed, 191 insertions, 63 deletions
diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs
index bbedb6f2c8..067f0e0d7c 100644
--- a/compiler/GHC/Builtin/PrimOps.hs
+++ b/compiler/GHC/Builtin/PrimOps.hs
@@ -109,14 +109,14 @@ data PrimOpInfo
= Compare OccName -- string :: T -> T -> Int#
Type
| GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T
- [TyVar]
+ [TyVarBinder]
[Type]
Type
mkCompare :: FastString -> Type -> PrimOpInfo
mkCompare str ty = Compare (mkVarOccFS str) ty
-mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo
+mkGenPrimOp :: FastString -> [TyVarBinder] -> [Type] -> Type -> PrimOpInfo
mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty
{-
@@ -607,7 +607,7 @@ primOpType op
Compare _occ ty -> compare_fun_ty ty
GenPrimOp _occ tyvars arg_tys res_ty ->
- mkSpecForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)
+ mkForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)
primOpResultType :: PrimOp -> Type
primOpResultType op
@@ -722,7 +722,7 @@ isComparisonPrimOp op = case primOpInfo op of
-- (type variables, argument types, result type)
-- It also gives arity, strictness info
-primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, DmdSig)
+primOpSig :: PrimOp -> ([TyVarBinder], [Type], Type, Arity, DmdSig)
primOpSig op
= (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity)
where
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index e6f988e841..dd0c8f4a0b 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -114,7 +114,7 @@ module GHC.Builtin.Types (
runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon,
boxedRepDataConTyCon,
- runtimeRepTy, liftedRepTy, unliftedRepTy,
+ runtimeRepTy, levityTy, liftedRepTy, unliftedRepTy,
vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,
@@ -1478,8 +1478,9 @@ unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->
-- For information about the usage of the following type,
-- see Note [TYPE and RuntimeRep] in module GHC.Builtin.Types.Prim
-runtimeRepTy :: Type
+runtimeRepTy, levityTy :: Type
runtimeRepTy = mkTyConTy runtimeRepTyCon
+levityTy = mkTyConTy levityTyCon
-- Type synonyms; see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim
-- and Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep.
diff --git a/compiler/GHC/Builtin/Types.hs-boot b/compiler/GHC/Builtin/Types.hs-boot
index 1c341de418..e2b279d7ae 100644
--- a/compiler/GHC/Builtin/Types.hs-boot
+++ b/compiler/GHC/Builtin/Types.hs-boot
@@ -28,7 +28,7 @@ unliftedRepTyCon :: TyCon
constraintKind :: Kind
runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon :: TyCon
-runtimeRepTy :: Type
+runtimeRepTy, levityTy :: Type
boxedRepDataConTyCon :: TyCon
liftedDataConTyCon :: TyCon
diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index 45140e60f2..eaeda97f69 100644
--- a/compiler/GHC/Builtin/Types/Prim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -20,15 +20,21 @@ module GHC.Builtin.Types.Prim(
mkTemplateAnonTyConBinders,
alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
+ alphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec, deltaTyVarSpec,
alphaTys, alphaTy, betaTy, gammaTy, deltaTy,
alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep,
alphaTysUnliftedRep, alphaTyUnliftedRep,
runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar,
+ runtimeRep1TyVarInf, runtimeRep2TyVarInf,
runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty,
+ levity1TyVar, levity1TyVarInf, levity1Ty,
openAlphaTyVar, openBetaTyVar, openGammaTyVar,
+ openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec,
openAlphaTy, openBetaTy, openGammaTy,
+ levPolyTyVar1, levPolyTyVar1Spec, levPolyTy1,
+
multiplicityTyVar1, multiplicityTyVar2,
-- Kind constructors...
@@ -97,8 +103,8 @@ module GHC.Builtin.Types.Prim(
import GHC.Prelude
import {-# SOURCE #-} GHC.Builtin.Types
- ( runtimeRepTy, unboxedTupleKind, liftedTypeKind
- , vecRepDataConTyCon, tupleRepDataConTyCon
+ ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind
+ , boxedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon
, liftedRepTy, unliftedRepTy
, intRepDataConTy
, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy
@@ -114,7 +120,8 @@ import {-# SOURCE #-} GHC.Builtin.Types
, doubleElemRepDataConTy
, mkPromotedListTy, multiplicityTy )
-import GHC.Types.Var ( TyVar, mkTyVar )
+import GHC.Types.Var ( TyVarBinder, TyVar
+ , mkTyVar, mkTyVarBinder, mkTyVarBinders )
import GHC.Types.Name
import {-# SOURCE #-} GHC.Types.TyThing
import GHC.Core.TyCon
@@ -127,7 +134,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid
-- import loops which show up if you import Type instead
-import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, tYPE )
+import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, mkTyConApp, tYPE )
import Data.Char
@@ -360,6 +367,9 @@ alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind
alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar
(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars
+alphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec, deltaTyVarSpec :: TyVarBinder
+(alphaTyVarSpec:betaTyVarSpec:gammaTyVarSpec:deltaTyVarSpec:_) = mkTyVarBinders Specified alphaTyVars
+
alphaTys :: [Type]
alphaTys = mkTyVarTys alphaTyVars
alphaTy, betaTy, gammaTy, deltaTy :: Type
@@ -380,11 +390,14 @@ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar :: TyVar
(runtimeRep1TyVar : runtimeRep2TyVar : runtimeRep3TyVar : _)
= drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r'
+runtimeRep1TyVarInf, runtimeRep2TyVarInf :: TyVarBinder
+runtimeRep1TyVarInf = mkTyVarBinder Inferred runtimeRep1TyVar
+runtimeRep2TyVarInf = mkTyVarBinder Inferred runtimeRep2TyVar
+
runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: Type
runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar
runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar
runtimeRep3Ty = mkTyVarTy runtimeRep3TyVar
-
openAlphaTyVar, openBetaTyVar, openGammaTyVar :: TyVar
-- alpha :: TYPE r1
-- beta :: TYPE r2
@@ -392,11 +405,36 @@ openAlphaTyVar, openBetaTyVar, openGammaTyVar :: TyVar
[openAlphaTyVar,openBetaTyVar,openGammaTyVar]
= mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty, tYPE runtimeRep3Ty]
+openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec :: TyVarBinder
+openAlphaTyVarSpec = mkTyVarBinder Specified openAlphaTyVar
+openBetaTyVarSpec = mkTyVarBinder Specified openBetaTyVar
+openGammaTyVarSpec = mkTyVarBinder Specified openGammaTyVar
+
openAlphaTy, openBetaTy, openGammaTy :: Type
openAlphaTy = mkTyVarTy openAlphaTyVar
openBetaTy = mkTyVarTy openBetaTyVar
openGammaTy = mkTyVarTy openGammaTyVar
+levity1TyVar :: TyVar
+(levity1TyVar : _)
+ = drop 11 (mkTemplateTyVars (repeat levityTy)) -- selects 'l'
+
+levity1TyVarInf :: TyVarBinder
+levity1TyVarInf = mkTyVarBinder Inferred levity1TyVar
+
+levity1Ty :: Type
+levity1Ty = mkTyVarTy levity1TyVar
+
+levPolyTyVar1 :: TyVar
+[levPolyTyVar1] = mkTemplateTyVars [tYPE (mkTyConApp boxedRepDataConTyCon [levity1Ty])]
+-- tv :: TYPE ('BoxedRep l)
+
+levPolyTyVar1Spec :: TyVarBinder
+levPolyTyVar1Spec = mkTyVarBinder Specified levPolyTyVar1
+
+levPolyTy1 :: Type
+levPolyTy1 = mkTyVarTy levPolyTyVar1
+
multiplicityTyVar1, multiplicityTyVar2 :: TyVar
(multiplicityTyVar1 : multiplicityTyVar2 : _)
= drop 13 (mkTemplateTyVars (repeat multiplicityTy)) -- selects 'n', 'm'
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 3bddd10285..f56687c351 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -2463,8 +2463,9 @@ primop CatchOp "catch#" GenPrimOp
has_side_effects = True
primop RaiseOp "raise#" GenPrimOp
- b -> o
- -- NB: the type variable "o" is "a", but with OpenKind
+ a -> p
+ -- NB: "p" is the same as "b" except it is representation-polymorphic
+ -- (we shouldn't use "o" here as that would conflict with "a")
with
-- In contrast to 'raiseIO#', which throws a *precise* exception,
-- exceptions thrown by 'raise#' are considered *imprecise*.
@@ -2831,10 +2832,10 @@ section "Weak pointers"
primtype Weak# b
--- note that tyvar "o" denotes openAlphaTyVar
+-- Note: "v" denotes a levity-polymorphic type variable
primop MkWeakOp "mkWeak#" GenPrimOp
- o -> b -> (State# RealWorld -> (# State# RealWorld, c #))
+ v -> b -> (State# RealWorld -> (# State# RealWorld, c #))
-> State# RealWorld -> (# State# RealWorld, Weak# b #)
{ {\tt mkWeak# k v finalizer s} creates a weak reference to value {\tt k},
with an associated reference to some value {\tt v}. If {\tt k} is still
@@ -2846,7 +2847,7 @@ primop MkWeakOp "mkWeak#" GenPrimOp
out_of_line = True
primop MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp
- o -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+ v -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
with
has_side_effects = True
out_of_line = True
@@ -2883,7 +2884,7 @@ primop FinalizeWeakOp "finalizeWeak#" GenPrimOp
out_of_line = True
primop TouchOp "touch#" GenPrimOp
- o -> State# RealWorld -> State# RealWorld
+ v -> State# RealWorld -> State# RealWorld
with
code_size = { 0 }
has_side_effects = True
@@ -3131,8 +3132,10 @@ section "Controlling object lifetime"
------------------------------------------------------------------------
-- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.
+-- NB: "v" is the same as "a" except levity-polymorphic,
+-- and "p" is the same as "b" except representation-polymorphic
primop KeepAliveOp "keepAlive#" GenPrimOp
- o -> State# RealWorld -> (State# RealWorld -> p) -> p
+ v -> State# RealWorld -> (State# RealWorld -> p) -> p
{ \tt{keepAlive# x s k} keeps the value \tt{x} alive during the execution
of the computation \tt{k}. }
with
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index b34c0fc8cb..d179c53ed3 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -1311,7 +1311,7 @@ mkPrimOpId prim_op
= id
where
(tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
- ty = mkSpecForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)
+ ty = mkForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)
name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
(mkPrimOpIdUnique (primOpTag prim_op))
(AnId id) UserSyntax
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 8d92d57eec..73901ad8be 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -21,3 +21,22 @@ Version 9.4.1
Note that the explicit type applications are required, as the call to
``withDict`` would be ambiguous otherwise.
+
+``ghc-prim`` library
+~~~~~~~~~~~~~~~~~~~~
+
+- ``GHC.Exts.mkWeak#``, ``GHC.Exts.mkWeakNoFinalizer#``, ``GHC.Exts.touch#``
+ and ``GHC.Exts.keepAlive#`` are now levity-polymorphic instead of
+ representation-polymorphic. For instance: ::
+
+ mkWeakNoFinalizer#
+ :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) (b :: Type)
+ . a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+
+ That is, the type signature now quantifies over a variable of type ``GHC.Exts.Levity``
+ instead of ``GHC.Exts.RuntimeRep``. In addition, this variable is now inferred,
+ instead of specified, meaning that it is no longer eligible for visible type application.
+
+- The ``GHC.Exts.RuntimeRep`` parameter to ``GHC.Exts.raise#`` is now inferred: ::
+
+ raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b
diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index 1ce61e2e61..122856346f 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -20,6 +20,26 @@
Note that the explicit type applications are required, as the call to
`withDict` would be ambiguous otherwise.
+- `mkWeak#`, `mkWeakNoFinalizer#`, `touch#` and `keepAlive#` are now
+ levity-polymorphic instead of representation-polymorphic. For instance:
+
+ ```
+ mkWeakNoFinalizer#
+ :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) (b :: Type)
+ . a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+ ```
+
+ That is, the type signature now quantifies over a variable of type `Levity`
+ instead of `RuntimeRep`. In addition, this variable is now inferred,
+ instead of specified, meaning that it is no longer eligible for visible type application.
+
+- The `RuntimeRep` parameter to `raise#` is now inferred:
+
+ ```
+ raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b
+ ```
+
+
## 0.8.0 (edit as necessary)
- Change array access primops to use type with size maxing the element size:
diff --git a/testsuite/tests/codeGen/should_fail/T13233.hs b/testsuite/tests/codeGen/should_fail/T13233.hs
index f24fc03bfb..c4c0480a75 100644
--- a/testsuite/tests/codeGen/should_fail/T13233.hs
+++ b/testsuite/tests/codeGen/should_fail/T13233.hs
@@ -5,7 +5,7 @@
{-# LANGUAGE MagicHash #-}
module Bug where
-import GHC.Exts (TYPE, RuntimeRep, Weak#, State#, RealWorld, mkWeak# )
+import GHC.Exts ( TYPE, RuntimeRep )
class Foo (a :: TYPE rep) where
bar :: forall rep2 (b :: TYPE rep2). (a -> a -> b) -> a -> a -> b
@@ -20,8 +20,3 @@ obscure _ = ()
quux :: ()
quux = obscure (#,#)
-
-primop :: forall (rep :: RuntimeRep) (a :: TYPE rep) b c.
- a -> b -> (State# RealWorld -> (# State# RealWorld, c #))
- -> State# RealWorld -> (# State# RealWorld, Weak# b #)
-primop = mkWeak#
diff --git a/testsuite/tests/codeGen/should_fail/T13233.stderr b/testsuite/tests/codeGen/should_fail/T13233.stderr
index 0208b2695a..2609e41d97 100644
--- a/testsuite/tests/codeGen/should_fail/T13233.stderr
+++ b/testsuite/tests/codeGen/should_fail/T13233.stderr
@@ -18,15 +18,3 @@ T13233.hs:22:16: error:
Levity-polymorphic arguments:
a :: TYPE rep1
b :: TYPE rep2
-
-T13233.hs:27:10: error:
- Cannot use function with levity-polymorphic arguments:
- mkWeak# :: a
- -> b
- -> (State# RealWorld -> (# State# RealWorld, c #))
- -> State# RealWorld
- -> (# State# RealWorld, Weak# b #)
- (Note that levity-polymorphic primops such as 'coerce' and unboxed tuples
- are eta-expanded internally because they must occur fully saturated.
- Use -fprint-typechecker-elaboration to display the full expression.)
- Levity-polymorphic arguments: a :: TYPE rep
diff --git a/testsuite/tests/codeGen/should_fail/T13233_elab.hs b/testsuite/tests/codeGen/should_fail/T13233_elab.hs
index 8f62332af6..96adc5ff9a 100644
--- a/testsuite/tests/codeGen/should_fail/T13233_elab.hs
+++ b/testsuite/tests/codeGen/should_fail/T13233_elab.hs
@@ -8,7 +8,7 @@
{-# LANGUAGE MagicHash #-}
module Bug where
-import GHC.Exts (TYPE, RuntimeRep, Weak#, State#, RealWorld, mkWeak# )
+import GHC.Exts ( TYPE, RuntimeRep )
class Foo (a :: TYPE rep) where
bar :: forall rep2 (b :: TYPE rep2). (a -> a -> b) -> a -> a -> b
@@ -23,11 +23,3 @@ obscure _ = ()
quux :: ()
quux = obscure (#,#)
-
--- It used to be that primops has no binding. However, as described in
--- Note [Primop wrappers] in GHC.Builtin.PrimOps we now rewrite unsaturated primop
--- applications to their wrapper, which allows safe use of levity polymorphism.
-primop :: forall (rep :: RuntimeRep) (a :: TYPE rep) b c.
- a -> b -> (State# RealWorld -> (# State# RealWorld, c #))
- -> State# RealWorld -> (# State# RealWorld, Weak# b #)
-primop = mkWeak#
diff --git a/testsuite/tests/codeGen/should_fail/T13233_elab.stderr b/testsuite/tests/codeGen/should_fail/T13233_elab.stderr
index ec9a04d726..1b84b9bf95 100644
--- a/testsuite/tests/codeGen/should_fail/T13233_elab.stderr
+++ b/testsuite/tests/codeGen/should_fail/T13233_elab.stderr
@@ -12,13 +12,3 @@ T13233_elab.hs:25:16: error:
Levity-polymorphic arguments:
a :: TYPE rep1
b :: TYPE rep2
-
-T13233_elab.hs:33:10: error:
- Cannot use function with levity-polymorphic arguments:
- mkWeak# @rep @a @b @c
- :: a
- -> b
- -> (State# RealWorld -> (# State# RealWorld, c #))
- -> State# RealWorld
- -> (# State# RealWorld, Weak# b #)
- Levity-polymorphic arguments: a :: TYPE rep
diff --git a/testsuite/tests/typecheck/should_compile/T17817b.hs b/testsuite/tests/typecheck/should_compile/T17817b.hs
new file mode 100644
index 0000000000..b4fac8ba87
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T17817b.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeApplications #-}
+module Bug where
+
+import GHC.Exts ( Weak#, State#, RealWorld, mkWeak# )
+import GHC.Types ( UnliftedType )
+
+primop1 :: forall a b c.
+ a -> b -> (State# RealWorld -> (# State# RealWorld, c #))
+ -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+primop1 = mkWeak# @a @b @c
+
+primop2 :: forall (a :: UnliftedType) b c.
+ a -> b -> (State# RealWorld -> (# State# RealWorld, c #))
+ -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+primop2 = mkWeak# @a @b @c
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 7ebb9ae65c..8183fe06a7 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -789,3 +789,4 @@ test('T19742', normal, compile, [''])
test('T18481', normal, compile, [''])
test('T18481a', normal, compile, [''])
test('T19775', normal, compile, [''])
+test('T17817b', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T17817.hs b/testsuite/tests/typecheck/should_fail/T17817.hs
new file mode 100644
index 0000000000..b87178f909
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T17817.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MagicHash #-}
+module Bug where
+
+import GHC.Exts ( TYPE, RuntimeRep(BoxedRep), Levity
+ , Weak#, State#, RealWorld, mkWeak#
+ )
+
+primop :: forall (l :: Levity) (a :: TYPE ('BoxedRep l)) b c.
+ a -> b -> (State# RealWorld -> (# State# RealWorld, c #))
+ -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+primop = mkWeak#
diff --git a/testsuite/tests/typecheck/should_fail/T17817.stderr b/testsuite/tests/typecheck/should_fail/T17817.stderr
new file mode 100644
index 0000000000..56753cb34b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T17817.stderr
@@ -0,0 +1,13 @@
+
+T17817.hs:16:10: error:
+ Cannot use function with levity-polymorphic arguments:
+ mkWeak#
+ :: a
+ -> b
+ -> (State# RealWorld -> (# State# RealWorld, c #))
+ -> State# RealWorld
+ -> (# State# RealWorld, Weak# b #)
+ (Note that levity-polymorphic primops such as 'coerce' and unboxed tuples
+ are eta-expanded internally because they must occur fully saturated.
+ Use -fprint-typechecker-elaboration to display the full expression.)
+ Levity-polymorphic arguments: a :: TYPE ('BoxedRep l)
diff --git a/testsuite/tests/typecheck/should_fail/T17817_elab.hs b/testsuite/tests/typecheck/should_fail/T17817_elab.hs
new file mode 100644
index 0000000000..7c0b09a98c
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T17817_elab.hs
@@ -0,0 +1,17 @@
+-- Same as T17817, but we compile with -fprint-typechecker-elaboration.
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MagicHash #-}
+module Bug where
+
+import GHC.Exts ( TYPE, RuntimeRep(BoxedRep), Levity
+ , Weak#, State#, RealWorld, mkWeak#
+ )
+
+primop :: forall (l :: Levity) (a :: TYPE ('BoxedRep l)) b c.
+ a -> b -> (State# RealWorld -> (# State# RealWorld, c #))
+ -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+primop = mkWeak#
diff --git a/testsuite/tests/typecheck/should_fail/T17817_elab.stderr b/testsuite/tests/typecheck/should_fail/T17817_elab.stderr
new file mode 100644
index 0000000000..aaa48448d2
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T17817_elab.stderr
@@ -0,0 +1,10 @@
+
+T17817_elab.hs:17:10: error:
+ Cannot use function with levity-polymorphic arguments:
+ mkWeak# @l @a @b @c
+ :: a
+ -> b
+ -> (State# RealWorld -> (# State# RealWorld, c #))
+ -> State# RealWorld
+ -> (# State# RealWorld, Weak# b #)
+ Levity-polymorphic arguments: a :: TYPE ('BoxedRep l)
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 65f80a1e13..54af02c6f5 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -629,3 +629,5 @@ test('T19397E4', extra_files(['T19397S.hs']), multimod_compile_fail,
['T19397E4.hs', '-v0 -main-is foo'])
test('T19415', normal, compile_fail, [''])
test('T19615', normal, compile_fail, [''])
+test('T17817', normal, compile_fail, [''])
+test('T17817_elab', normal, compile_fail, ['-fprint-typechecker-elaboration'])
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index a0ea019923..f5eaf757e2 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -848,12 +848,13 @@ sl_name :: Entry -> String
sl_name i = "(fsLit \"" ++ name i ++ "\") "
ppTyVar :: String -> String
-ppTyVar "a" = "alphaTyVar"
-ppTyVar "b" = "betaTyVar"
-ppTyVar "c" = "gammaTyVar"
-ppTyVar "s" = "deltaTyVar"
-ppTyVar "o" = "runtimeRep1TyVar, openAlphaTyVar"
-ppTyVar "p" = "runtimeRep2TyVar, openBetaTyVar"
+ppTyVar "a" = "alphaTyVarSpec"
+ppTyVar "b" = "betaTyVarSpec"
+ppTyVar "c" = "gammaTyVarSpec"
+ppTyVar "s" = "deltaTyVarSpec"
+ppTyVar "o" = "runtimeRep1TyVarInf, openAlphaTyVarSpec"
+ppTyVar "p" = "runtimeRep2TyVarInf, openBetaTyVarSpec"
+ppTyVar "v" = "levity1TyVarInf, levPolyTyVar1Spec"
ppTyVar _ = error "Unknown type var"
ppType :: Ty -> String
@@ -888,6 +889,7 @@ ppType (TyVar "c") = "gammaTy"
ppType (TyVar "s") = "deltaTy"
ppType (TyVar "o") = "openAlphaTy"
ppType (TyVar "p") = "openBetaTy"
+ppType (TyVar "v") = "levPolyTy1"
ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x
ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x