From 5d670abd1c2c53a6c0918b1fe52b8ff581b9a394 Mon Sep 17 00:00:00 2001 From: sheaf Date: Mon, 12 Jul 2021 11:49:48 +0200 Subject: Generalise reallyUnsafePtrEquality# and use it fixes #9192 and #17126 updates containers submodule 1. Changes the type of the primop `reallyUnsafePtrEquality#` to the most general version possible (heterogeneous as well as levity-polymorphic): > reallyUnsafePtrEquality# > :: forall {l :: Levity} {k :: Levity} > (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)) > . a -> b -> Int# 2. Adds a new internal module, `GHC.Ext.PtrEq`, which contains pointer equality operations that are now subsumed by `reallyUnsafePtrEquality#`. These functions are then re-exported by `GHC.Exts` (so that no function goes missing from the export list of `GHC.Exts`, which is user-facing). More specifically, `GHC.Ext.PtrEq` defines: - A new function: * reallyUnsafePtrEquality :: forall (a :: Type). a -> a -> Int# - Library definitions of ex-primops: * `sameMutableArray#` * `sameSmallMutableArray` * `sameMutableByteArray#` * `sameMutableArrayArray#` * `sameMutVar#` * `sameTVar#` * `sameMVar#` * `sameIOPort#` * `eqStableName#` - New functions for comparing non-mutable arrays: * `sameArray#` * `sameSmallArray#` * `sameByteArray#` * `sameArrayArray#` These were requested in #9192. Generally speaking, existing libraries that use `reallyUnsafePtrEquality#` will continue to work with the new, levity-polymorphic version. But not all! Some (`containers`, `unordered-containers`, `dependent-map`) contain the following: > unsafeCoerce# reallyUnsafePtrEquality# a b If we make `reallyUnsafePtrEquality#` levity-polymorphic, this code fails the current GHC representation-polymorphism checks. We agreed that the right solution here is to modify the library; in this case by deleting the call to `unsafeCoerce#`, since `reallyUnsafePtrEquality#` is now type-heterogeneous too. --- compiler/GHC/Builtin/Types/Prim.hs | 48 ++++--- compiler/GHC/Builtin/primops.txt.pp | 143 +++++++++++++++------ compiler/GHC/StgToCmm/Prim.hs | 27 +--- docs/users_guide/9.4.1-notes.rst | 26 ++++ libraries/base/GHC/Base.hs | 8 +- libraries/base/GHC/Exts.hs | 20 ++- libraries/containers | 2 +- libraries/ghc-prim/GHC/Prim/PtrEq.hs | 140 ++++++++++++++++++++ libraries/ghc-prim/changelog.md | 29 +++++ libraries/ghc-prim/ghc-prim.cabal | 1 + .../primops/should_fail/LevPolyPtrEquality3.hs | 11 ++ .../primops/should_fail/LevPolyPtrEquality3.stderr | 11 ++ testsuite/tests/primops/should_fail/all.T | 1 + .../primops/should_run/LevPolyPtrEquality1.hs | 25 ++++ .../primops/should_run/LevPolyPtrEquality1.stdout | 2 + .../primops/should_run/LevPolyPtrEquality2.hs | 28 ++++ .../primops/should_run/LevPolyPtrEquality2.stdout | 3 + testsuite/tests/primops/should_run/all.T | 3 + utils/genprimopcode/Main.hs | 10 +- 19 files changed, 447 insertions(+), 91 deletions(-) create mode 100644 libraries/ghc-prim/GHC/Prim/PtrEq.hs create mode 100644 testsuite/tests/primops/should_fail/LevPolyPtrEquality3.hs create mode 100644 testsuite/tests/primops/should_fail/LevPolyPtrEquality3.stderr create mode 100644 testsuite/tests/primops/should_fail/all.T create mode 100644 testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs create mode 100644 testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout create mode 100644 testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs create mode 100644 testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index c339125e9a..ce4f1e5dc0 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -28,13 +28,17 @@ module GHC.Builtin.Types.Prim( runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar, runtimeRep1TyVarInf, runtimeRep2TyVarInf, runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty, - levity1TyVar, levity1TyVarInf, levity1Ty, + levity1TyVar, levity2TyVar, + levity1TyVarInf, levity2TyVarInf, + levity1Ty, levity2Ty, openAlphaTyVar, openBetaTyVar, openGammaTyVar, openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec, openAlphaTy, openBetaTy, openGammaTy, - levPolyTyVar1, levPolyTyVar1Spec, levPolyTy1, + levPolyAlphaTyVar, levPolyBetaTyVar, + levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec, + levPolyAlphaTy, levPolyBetaTy, multiplicityTyVar1, multiplicityTyVar2, @@ -416,25 +420,35 @@ openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy = mkTyVarTy openBetaTyVar openGammaTy = mkTyVarTy openGammaTyVar -levity1TyVar :: TyVar -(levity1TyVar : _) - = drop 11 (mkTemplateTyVars (repeat levityTy)) -- selects 'l' +levity1TyVar, levity2TyVar :: TyVar +(levity2TyVar : levity1TyVar : _) -- NB: levity2TyVar before levity1TyVar + = drop 10 (mkTemplateTyVars (repeat levityTy)) -- selects 'k', 'l' +-- The ordering of levity2TyVar before levity1TyVar is chosen so that +-- the more common levity1TyVar uses the levity variable 'l'. -levity1TyVarInf :: TyVarBinder +levity1TyVarInf, levity2TyVarInf :: TyVarBinder levity1TyVarInf = mkTyVarBinder Inferred levity1TyVar +levity2TyVarInf = mkTyVarBinder Inferred levity2TyVar -levity1Ty :: Type +levity1Ty, levity2Ty :: 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 +levity2Ty = mkTyVarTy levity2TyVar + +levPolyAlphaTyVar, levPolyBetaTyVar :: TyVar +[levPolyAlphaTyVar, levPolyBetaTyVar] = + mkTemplateTyVars + [tYPE (mkTyConApp boxedRepDataConTyCon [levity1Ty]) + ,tYPE (mkTyConApp boxedRepDataConTyCon [levity2Ty])] +-- alpha :: TYPE ('BoxedRep l) +-- beta :: TYPE ('BoxedRep k) + +levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec :: TyVarBinder +levPolyAlphaTyVarSpec = mkTyVarBinder Specified levPolyAlphaTyVar +levPolyBetaTyVarSpec = mkTyVarBinder Specified levPolyBetaTyVar + +levPolyAlphaTy, levPolyBetaTy :: Type +levPolyAlphaTy = mkTyVarTy levPolyAlphaTyVar +levPolyBetaTy = mkTyVarTy levPolyBetaTyVar multiplicityTyVar1, multiplicityTyVar2 :: TyVar (multiplicityTyVar1 : multiplicityTyVar2 : _) diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index 25e673b192..5f5cd64cfa 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -187,6 +187,41 @@ defaults -- description fields should be legal latex. Descriptions can contain -- matched pairs of embedded curly brackets. +-- Note [Levity and representation polymorphic primops] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In the types of primops in this module, +-- +-- * The names `a,b,c,s` stand for type variables of kind Type +-- +-- * The names `v` and `w` stand for levity-polymorphic +-- type variables. +-- For example: +-- op :: v -> w -> Int +-- really means +-- op :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) +-- {k :: Levity} (b :: TYPE (BoxedRep k)). +-- a -> b -> Int +-- Two important things to note: +-- - `v` and `w` have independent levities `l` and `k` (respectively), and +-- these are inferred (not specified), as seen from the curly brackets. +-- - `v` and `w` end up written as `a` and `b` (respectively) in types, +-- which means that one shouldn't write a primop type involving both +-- `a` and `v`, nor `b` and `w`. +-- +-- * The names `o` and `p` stand for representation-polymorphic +-- type variables, similarly to `v` and `w` above. For example: +-- op :: o -> p -> Int +-- really means +-- op :: forall {q :: RuntimeRep} (a :: TYPE q) +-- {r :: RuntimeRep} (b :: TYPE r) +-- a -> b -> Int +-- We note: +-- - `o` and `p` have independent `RuntimeRep`s `q` and `r`, which are +-- inferred type variables (like for `v` and `w` above). +-- - `o` and `p` share textual names with `a` and `b` (respectively). +-- This means one shouldn't write a type involving both `a` and `o`, +-- nor `b` and `p`, nor `o` and `v`, etc. + #include "MachDeps.h" section "The word size story." @@ -1360,9 +1395,6 @@ primop NewArrayOp "newArray#" GenPrimOp out_of_line = True has_side_effects = True -primop SameMutableArrayOp "sameMutableArray#" GenPrimOp - MutableArray# s a -> MutableArray# s a -> Int# - primop ReadArrayOp "readArray#" GenPrimOp MutableArray# s a -> Int# -> State# s -> (# State# s, a #) {Read from specified index of mutable array. Result is not yet evaluated.} @@ -1538,9 +1570,6 @@ primop NewSmallArrayOp "newSmallArray#" GenPrimOp out_of_line = True has_side_effects = True -primop SameSmallMutableArrayOp "sameSmallMutableArray#" GenPrimOp - SmallMutableArray# s a -> SmallMutableArray# s a -> Int# - primop ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp SmallMutableArray# s a -> Int# -> State# s -> State# s {Shrink mutable array to new specified size, in @@ -1741,9 +1770,6 @@ primop MutableByteArrayContents_Char "mutableByteArrayContents#" GenPrimOp MutableByteArray# s -> Addr# {Intended for use with pinned arrays; otherwise very unsafe!} -primop SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp - MutableByteArray# s -> MutableByteArray# s -> Int# - primop ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp MutableByteArray# s -> Int# -> State# s -> State# s {Shrink mutable byte array to new specified size (in bytes), in @@ -1972,9 +1998,6 @@ primop NewArrayArrayOp "newArrayArray#" GenPrimOp out_of_line = True has_side_effects = True -primop SameMutableArrayArrayOp "sameMutableArrayArray#" GenPrimOp - MutableArrayArray# s -> MutableArrayArray# s -> Int# - primop UnsafeFreezeArrayArrayOp "unsafeFreezeArrayArray#" GenPrimOp MutableArrayArray# s -> State# s -> (# State# s, ArrayArray# #) {Make a mutable array of arrays immutable, without copying.} @@ -2469,9 +2492,6 @@ primop WriteMutVarOp "writeMutVar#" GenPrimOp has_side_effects = True code_size = { primOpCodeSizeForeignCall } -- for the write barrier -primop SameMutVarOp "sameMutVar#" GenPrimOp - MutVar# s a -> MutVar# s a -> Int# - -- Note [Why not an unboxed tuple in atomicModifyMutVar2#?] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -2548,6 +2568,7 @@ primop RaiseOp "raise#" GenPrimOp 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") + -- See Note [Levity and representation polymorphic primops] with -- In contrast to 'raiseIO#', which throws a *precise* exception, -- exceptions thrown by 'raise#' are considered *imprecise*. @@ -2690,9 +2711,6 @@ primop WriteTVarOp "writeTVar#" GenPrimOp out_of_line = True has_side_effects = True -primop SameTVarOp "sameTVar#" GenPrimOp - TVar# s a -> TVar# s a -> Int# - ------------------------------------------------------------------------ section "Synchronized Mutable Variables" @@ -2760,9 +2778,6 @@ primop TryReadMVarOp "tryReadMVar#" GenPrimOp out_of_line = True has_side_effects = True -primop SameMVarOp "sameMVar#" GenPrimOp - MVar# s a -> MVar# s a -> Int# - primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp MVar# s a -> State# s -> (# State# s, Int# #) {Return 1 if {\tt MVar\#} is empty; 0 otherwise.} @@ -2805,10 +2820,6 @@ primop WriteIOPortOp "writeIOPort#" GenPrimOp out_of_line = True has_side_effects = True -primop SameIOPortOp "sameIOPort#" GenPrimOp - IOPort# s a -> IOPort# s a -> Int# - - ------------------------------------------------------------------------ section "Delay/wait operations" ------------------------------------------------------------------------ @@ -2922,6 +2933,7 @@ section "Weak pointers" primtype Weak# b -- Note: "v" denotes a levity-polymorphic type variable +-- See Note [Levity and representation polymorphic primops] primop MkWeakOp "mkWeak#" GenPrimOp v -> b -> (State# RealWorld -> (# State# RealWorld, c #)) @@ -3009,9 +3021,6 @@ primop MakeStableNameOp "makeStableName#" GenPrimOp has_side_effects = True out_of_line = True -primop EqStableNameOp "eqStableName#" GenPrimOp - StableName# a -> StableName# b -> Int# - primop StableNameToIntOp "stableNameToInt#" GenPrimOp StableName# a -> Int# @@ -3143,25 +3152,74 @@ section "Unsafe pointer equality" -- (#1 Bad Guy: Alastair Reid :) ------------------------------------------------------------------------ +-- `v` and `w` are levity-polymorphic type variables with independent levities. +-- See Note [Levity and representation polymorphic primops] primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp - a -> a -> Int# + v -> w -> Int# { Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. } with - can_fail = True -- See Note [reallyUnsafePtrEquality#] - + can_fail = True -- See Note [reallyUnsafePtrEquality# can_fail] --- Note [reallyUnsafePtrEquality#] +-- Note [Pointer comparison operations] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The primop `reallyUnsafePtrEquality#` does a direct pointer +-- equality between two (boxed) values. Several things to note: +-- +-- * It is levity-polymorphic. It works for TYPE (BoxedRep Lifted) and +-- TYPE (BoxedRep Unlifted). But not TYPE IntRep, for example. +-- This levity-polymorphism comes from the use of the type variables +-- "v" and "w". See Note [Levity and representation polymorphic primops] +-- +-- * It does not evaluate its arguments. The user of the primop is responsible +-- for doing so. +-- +-- * It is hetero-typed; you can compare pointers of different types. +-- This is used in various packages such as containers & unordered-containers. +-- +-- * It is obviously very dangerous, because +-- let x = f y in reallyUnsafePtrEquality# x x +-- will probably return True, whereas +-- reallyUnsafePtrEquality# (f y) (f y) +-- will probably return False. ("probably", because it's affected +-- by CSE and inlining). +-- +-- * reallyUnsafePtrEquality# can't fail, but it is marked as such +-- to prevent it from floating out. +-- See Note [reallyUnsafePtrEquality# can_fail] +-- +-- The library GHC.Exts provides several less Wild-West functions +-- for use in specific cases, namely: +-- +-- reallyUnsafePtrEquality :: a -> a -> Int# -- not levity-polymorphic, nor hetero-typed +-- sameArray# :: Array# a -> Array# a -> Int# +-- sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int# +-- sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int# +-- sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int# +-- sameByteArray# :: ByteArray# -> ByteArray# -> Int# +-- sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int# +-- sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int# +-- sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int# +-- sameMutVar# :: MutVar# s a -> MutVar# s a -> Int# +-- sameTVar# :: TVar# s a -> TVar# s a -> Int# +-- sameMVar# :: MVar# s a -> MVar# s a -> Int# +-- sameIOPort# :: IOPort# s a -> IOPort# s a -> Int# +-- eqStableName# :: StableName# a -> StableName# b -> Int# +-- +-- These operations are all specialisations of reallyUnsafePtrEquality#. + +-- Note [reallyUnsafePtrEquality# can_fail] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- --- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it can_fail --- anyway. Until 5a9a1738023a, GHC considered primops okay for speculation only --- when their arguments were known to be forced. This was unnecessarily --- conservative, but it prevented reallyUnsafePtrEquality# from floating out of --- places where its arguments were known to be forced. Unfortunately, GHC could --- sometimes lose track of whether those arguments were forced, leading to let/app --- invariant failures (see #13027 and the discussion in #11444). Now that --- ok_for_speculation skips over lifted arguments, we need to explicitly prevent --- reallyUnsafePtrEquality# from floating out. Imagine if we had +-- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it +-- can_fail anyway. Until 5a9a1738023a, GHC considered primops okay for +-- speculation only when their arguments were known to be forced. This was +-- unnecessarily conservative, but it prevented reallyUnsafePtrEquality# from +-- floating out of places where its arguments were known to be forced. +-- Unfortunately, GHC could sometimes lose track of whether those arguments +-- were forced, leading to let/app invariant failures (see #13027 and the +-- discussion in #11444). Now that ok_for_speculation skips over lifted +-- arguments, we need to explicitly prevent reallyUnsafePtrEquality# +-- from floating out. Imagine if we had -- -- \x y . case x of x' -- DEFAULT -> @@ -3222,7 +3280,8 @@ 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 +-- and "p" is the same as "b" except representation-polymorphic. +-- See Note [Levity and representation polymorphic primops] primop KeepAliveOp "keepAlive#" GenPrimOp v -> State# RealWorld -> (State# RealWorld -> p) -> p { \tt{keepAlive# x s k} keeps the value \tt{x} alive during the execution diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 542372105e..d61880a0e2 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -342,6 +342,8 @@ emitPrimOp dflags primop = case primop of StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) + EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform) + ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) @@ -1462,20 +1464,6 @@ emitPrimOp dflags primop = case primop of FloatToDoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64) DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32) --- Word comparisons masquerading as more exotic things. - - SameMutVarOp -> \args -> opTranslate args (mo_wordEq platform) - SameMVarOp -> \args -> opTranslate args (mo_wordEq platform) - SameIOPortOp -> \args -> opTranslate args (mo_wordEq platform) - SameMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform) - SameMutableByteArrayOp -> \args -> opTranslate args (mo_wordEq platform) - SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform) - SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform) - SameTVarOp -> \args -> opTranslate args (mo_wordEq platform) - EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform) --- See Note [Comparing stable names] - EqStableNameOp -> \args -> opTranslate args (mo_wordEq platform) - IntQuotRemOp -> \args -> opCallishHandledLater args $ if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem (wordWidth platform)) @@ -2092,17 +2080,6 @@ genericFabsOp w [res_r] [aa] genericFabsOp _ _ _ = panic "genericFabsOp" --- Note [Comparing stable names] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- A StableName# is actually a pointer to a stable name object (SNO) --- containing an index into the stable name table (SNT). We --- used to compare StableName#s by following the pointers to the --- SNOs and checking whether they held the same SNT indices. However, --- this is not necessary: there is a one-to-one correspondence --- between SNOs and entries in the SNT, so simple pointer equality --- does the trick. - ------------------------------------------------------------------------------ -- Helpers for translating various minor variants of array indexing. diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst index 68417b0a6b..655e672a1b 100644 --- a/docs/users_guide/9.4.1-notes.rst +++ b/docs/users_guide/9.4.1-notes.rst @@ -41,6 +41,32 @@ Version 9.4.1 raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b +- ``GHC.Exts.reallyUnsafePtrEquality#`` has been made more general, as it is now + both levity-polymorphic and heterogeneous: :: + + reallyUnsafePtrEquality# + :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) + {k :: Levity} (b :: TYPE (BoxedRep k)) + . a -> b -> Int# + + This means that ``GHC.Exts.reallyUnsafePtrEquality#`` can be used + on primitive arrays such as ``GHC.Exts.Array#`` and ``GHC.Exts.ByteArray#``. + It can also be used on values of different types, without needing to call + ``GHC.Exts.unsafeCoerce#``. + +- Added ``GHC.Exts.reallyUnsafePtrEquality`` which recovers the + previous behaviour of ``GHC.Exts.reallyUnsafePtrEquality#``: :: + + reallyUnsafePtrEquality :: forall (a :: Type). a -> a -> Int# + +- Added ``GHC.Exts.sameArray#``, ``GHC.Exts.sameSmallArray#``, + ``GHC.Exts.sameByteArray#`` and ``GHC.Exts.sameArrayArray#``: :: + + sameArray# :: Array# a -> Array# a -> Int# + sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int# + sameByteArray# :: ByteArray# -> ByteArray# -> Int# + sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int# + ``ghc`` library ~~~~~~~~~~~~~~~ diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index b037951fa8..5a9d38f147 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -102,9 +102,10 @@ module GHC.Base module GHC.Magic, module GHC.Magic.Dict, module GHC.Types, - module GHC.Prim, -- Re-export GHC.Prim and [boot] GHC.Err, - module GHC.Prim.Ext, -- to avoid lots of people having to - module GHC.Err, -- import it explicitly + module GHC.Prim, -- Re-export GHC.Prim, GHC.Prim.Ext, + module GHC.Prim.Ext, -- GHC.Prim.PtrEq and [boot] GHC.Err + module GHC.Prim.PtrEq, -- to avoid lots of people having to + module GHC.Err, -- import these modules explicitly module GHC.Maybe ) where @@ -116,6 +117,7 @@ import GHC.Magic import GHC.Magic.Dict import GHC.Prim import GHC.Prim.Ext +import GHC.Prim.PtrEq import GHC.Err import GHC.Maybe import {-# SOURCE #-} GHC.IO (mkUserError, mplusIO) diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index 86890b6a8b..29f6bdaca0 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -38,7 +38,24 @@ module GHC.Exts module GHC.Prim.Ext, shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#, isTrue#, - Void#, -- Previously exported by GHC.Prim + Void#, -- Previously exported by GHC.Prim + + -- * Pointer comparison operations + -- See `Note [Pointer comparison operations]` in primops.txt.pp + reallyUnsafePtrEquality, + eqStableName#, + sameArray#, + sameMutableArray#, + sameSmallArray#, + sameSmallMutableArray#, + sameByteArray#, + sameMutableByteArray#, + sameArrayArray#, + sameMutableArrayArray#, + sameMVar#, + sameMutVar#, + sameTVar#, + sameIOPort#, -- * Compat wrapper atomicModifyMutVar#, @@ -345,3 +362,4 @@ resizeSmallMutableArray# arr0 szNew a s0 = -- accessible\" by word. considerAccessible :: Bool considerAccessible = True + diff --git a/libraries/containers b/libraries/containers index 7fb91ca53b..f90e38cb17 160000 --- a/libraries/containers +++ b/libraries/containers @@ -1 +1 @@ -Subproject commit 7fb91ca53b1aca7c077b36a0c1f8f785d177da34 +Subproject commit f90e38cb170dcd68de8660dfd9d0e879921acc28 diff --git a/libraries/ghc-prim/GHC/Prim/PtrEq.hs b/libraries/ghc-prim/GHC/Prim/PtrEq.hs new file mode 100644 index 0000000000..5e9d2e564b --- /dev/null +++ b/libraries/ghc-prim/GHC/Prim/PtrEq.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Prim.PtrEq +-- License : see libraries/ghc-prim/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Comparing underlying pointers for equality. +-- +-- Use GHC.Exts from the base package instead of importing this +-- module directly. +-- +----------------------------------------------------------------------------- + +module GHC.Prim.PtrEq + ( reallyUnsafePtrEquality, + sameArray#, + sameMutableArray#, + sameSmallArray#, + sameSmallMutableArray#, + sameByteArray#, + sameMutableByteArray#, + sameArrayArray#, + sameMutableArrayArray#, + sameMutVar#, + sameTVar#, + sameMVar#, + sameIOPort#, + eqStableName# + ) where + +import GHC.Prim +import GHC.Types () -- Make implicit dependency known to build system +default () -- Double and Integer aren't available yet + +{- ********************************************************************** +* * +* Pointer equality * +* * +********************************************************************** -} + +{- Note [Pointer equality operations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Many primitive types - such as Array#, ByteArray#, MVar#, ... - are boxed: +they are represented by pointers to the underlying data. It is thus possible +to directly compare these pointers for equality, as opposed to comparing +the underlying data that the pointers refer to (for instance, comparing +two arrays element-wise). + +To do this, GHC provides the primop reallyUnsafePtrEquality#, which is +both levity-polymorphic and heterogeneous. As its name indicates, it is an +unsafe operation which can yield unpredictable results, as explained in + Note [Pointer comparison operations] in primops.txt.pp + +For a more user-friendly interface, this module defines specialisations of +the reallyUnsafePtrEquality# primop at various primitive types, such as +Array#, ByteArray#, MVar#, ... +-} + +-- | Compare the underlying pointers of two values for equality. +-- +-- Returns @1@ if the pointers are equal and @0@ otherwise. +-- +-- The two values must be of the same type, of kind 'Type'. +-- See also 'GHC.Exts.reallyUnsafePtrEquality#', which doesn't have +-- such restrictions. +reallyUnsafePtrEquality :: a -> a -> Int# +reallyUnsafePtrEquality = reallyUnsafePtrEquality# +-- See Note [Pointer comparison operations] +-- in primops.txt.pp + +-- | Compare the underlying pointers of two arrays. +sameArray# :: Array# a -> Array# a -> Int# +sameArray# = reallyUnsafePtrEquality# + +-- | Compare the underlying pointers of two mutable arrays. +sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int# +sameMutableArray# = reallyUnsafePtrEquality# + +-- | Compare the underlying pointers of two small arrays. +sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int# +sameSmallArray# = reallyUnsafePtrEquality# + +-- | Compare the underlying pointers of two small mutable arrays. +sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int# +sameSmallMutableArray# = reallyUnsafePtrEquality# + +-- | Compare the pointers of two byte arrays. +sameByteArray# :: ByteArray# -> ByteArray# -> Int# +sameByteArray# = reallyUnsafePtrEquality# + +-- | Compare the underlying pointers of two mutable byte arrays. +sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int# +sameMutableByteArray# = reallyUnsafePtrEquality# + +-- | Compare the underlying pointers of two arrays of arrays. +sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int# +sameArrayArray# = reallyUnsafePtrEquality# + +-- | Compare the underlying pointers of two mutable arrays of arrays. +sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int# +sameMutableArrayArray# = reallyUnsafePtrEquality# + +-- | Compare the underlying pointers of two 'MutVar#'s. +sameMutVar# :: MutVar# s a -> MutVar# s a -> Int# +sameMutVar# = reallyUnsafePtrEquality# + +-- | Compare the underlying pointers of two 'TVar#'s. +sameTVar# :: TVar# s a -> TVar# s a -> Int# +sameTVar# = reallyUnsafePtrEquality# + +-- | Compare the underlying pointers of two 'MVar#'s. +sameMVar# :: MVar# s a -> MVar# s a -> Int# +sameMVar# = reallyUnsafePtrEquality# + +-- | Compare the underlying pointers of two 'IOPort#'s. +sameIOPort# :: IOPort# s a -> IOPort# s a -> Int# +sameIOPort# = reallyUnsafePtrEquality# + +-- Note [Comparing stable names] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- A StableName# is actually a pointer to a stable name object (SNO) +-- containing an index into the stable name table (SNT). We +-- used to compare StableName#s by following the pointers to the +-- SNOs and checking whether they held the same SNT indices. However, +-- this is not necessary: there is a one-to-one correspondence +-- between SNOs and entries in the SNT, so simple pointer equality +-- does the trick. + +-- | Compare two stable names for equality. +eqStableName# :: StableName# a -> StableName# b -> Int# +eqStableName# = reallyUnsafePtrEquality# diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md index 122856346f..5d27ec197a 100644 --- a/libraries/ghc-prim/changelog.md +++ b/libraries/ghc-prim/changelog.md @@ -39,6 +39,35 @@ raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b ``` +- `reallyUnsafePtrEquality#` has been made more general, as it is now + both levity-polymorphic and heterogeneous: + + ``` + reallyUnsafePtrEquality# + :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) + {k :: Levity} (b :: TYPE (BoxedRep k)) + . a -> b -> Int# + ``` + + This means that `reallyUnsafePtrEquality#` can be used on primitive arrays + such as `Array#` and `ByteArray#`. It can also be used on values of + different types, without needing to call `unsafeCoerce#`. + +- The following functions have been moved from `GHC.Prim` to `GHC.Exts`: + - `sameMutableArray#`, `sameSmallMutableArray#`, `sameMutableByteArray#` + and `sameMutableArrayArray#`, + - `sameMutVar#`, `sameTVar#` and`sameMVar#`, + - `sameIOPort#`, + - `eqStableName#`. + +- The following functions have been added to `GHC.Exts`: + + ``` + sameArray# :: Array# a -> Array# a -> Int# + sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int# + sameByteArray# :: ByteArray# -> ByteArray# -> Int# + sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int# + ``` ## 0.8.0 (edit as necessary) diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal index 812324e117..e207b3f24c 100644 --- a/libraries/ghc-prim/ghc-prim.cabal +++ b/libraries/ghc-prim/ghc-prim.cabal @@ -48,6 +48,7 @@ Library GHC.Prim.Ext GHC.Prim.Panic GHC.Prim.Exception + GHC.Prim.PtrEq GHC.PrimopWrappers GHC.Tuple GHC.Types diff --git a/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.hs b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.hs new file mode 100644 index 0000000000..b5c3da4f91 --- /dev/null +++ b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MagicHash #-} + +module LevPolyPtrEquality3 where + +import GHC.Exts + ( Int# + , unsafeCoerce#, reallyUnsafePtrEquality# + ) + +f :: a -> b -> Int# +f a b = unsafeCoerce# reallyUnsafePtrEquality# a b diff --git a/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.stderr b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.stderr new file mode 100644 index 0000000000..279f32428b --- /dev/null +++ b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.stderr @@ -0,0 +1,11 @@ + +LevPolyPtrEquality3.hs:11:23: error: + Cannot use function with representation-polymorphic arguments: + reallyUnsafePtrEquality# :: GHC.Types.Any -> GHC.Types.Any -> Int# + (Note that representation-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.) + Representation-polymorphic arguments: + GHC.Types.Any :: TYPE ('GHC.Types.BoxedRep GHC.Types.Any) + GHC.Types.Any :: TYPE ('GHC.Types.BoxedRep GHC.Types.Any) diff --git a/testsuite/tests/primops/should_fail/all.T b/testsuite/tests/primops/should_fail/all.T new file mode 100644 index 0000000000..f599102c23 --- /dev/null +++ b/testsuite/tests/primops/should_fail/all.T @@ -0,0 +1 @@ +test('LevPolyPtrEquality3', normal, compile_fail, ['']) diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs new file mode 100644 index 0000000000..bbd4819c7d --- /dev/null +++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Exts +import GHC.IO + +data ByteArray = ByteArray ByteArray# + +mkTwoByteArrays :: IO ( ByteArray, ByteArray ) +mkTwoByteArrays = IO \ s1 -> case newPinnedByteArray# 32# s1 of + (# s2, mba1 #) -> case unsafeFreezeByteArray# mba1 s2 of + (# s3, ba1 #) -> case newPinnedByteArray# 32# s3 of + (# s4, mba2 #) -> case unsafeFreezeByteArray# mba2 s4 of + (# s5, ba2 #) -> (# s5, ( ByteArray ba1, ByteArray ba2 ) #) + +main :: IO () +main = do + ( ByteArray ba1, ByteArray ba2 ) <- mkTwoByteArrays + putStr "eq 1 2: " + print $ isTrue# ( reallyUnsafePtrEquality# ba1 ba2 ) + putStr "eq 1 1: " + print $ isTrue# ( reallyUnsafePtrEquality# ba1 ba1 ) diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout new file mode 100644 index 0000000000..aaf2e46dcf --- /dev/null +++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout @@ -0,0 +1,2 @@ +eq 1 2: False +eq 1 1: True diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs new file mode 100644 index 0000000000..ef52bd3de1 --- /dev/null +++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.Types + +data PEither a b :: UnliftedType where + PLeft :: a -> PEither a b + PRight :: b -> PEither a b + +main :: IO () +main = do + let + a, b, c :: PEither Bool Int + a = PRight 1 + b = case a of { PLeft a -> PLeft (not a) ; r -> r } + c = PLeft False + d :: Either Bool Int + d = Right 1 + putStr "eq a b: " + print $ isTrue# ( reallyUnsafePtrEquality# a b ) + putStr "eq a c: " + print $ isTrue# ( reallyUnsafePtrEquality# a c ) + putStr "eq a d: " + print $ isTrue# ( reallyUnsafePtrEquality# a d ) diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout new file mode 100644 index 0000000000..b06eeb90d0 --- /dev/null +++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout @@ -0,0 +1,3 @@ +eq a b: True +eq a c: False +eq a d: False diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index cad58c1909..ef046f34ae 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -38,3 +38,6 @@ test('T14664', normal, compile_and_run, ['']) test('CStringLength', normal, compile_and_run, ['-O2']) test('NonNativeSwitch', normal, compile_and_run, ['-O2']) test('Sized', normal, compile_and_run, ['']) + +test('LevPolyPtrEquality1', normal, compile_and_run, ['']) +test('LevPolyPtrEquality2', normal, compile_and_run, ['']) diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index f5eaf757e2..06a4922aa3 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -854,8 +854,11 @@ ppTyVar "c" = "gammaTyVarSpec" ppTyVar "s" = "deltaTyVarSpec" ppTyVar "o" = "runtimeRep1TyVarInf, openAlphaTyVarSpec" ppTyVar "p" = "runtimeRep2TyVarInf, openBetaTyVarSpec" -ppTyVar "v" = "levity1TyVarInf, levPolyTyVar1Spec" +ppTyVar "v" = "levity1TyVarInf, levPolyAlphaTyVarSpec" +ppTyVar "w" = "levity2TyVarInf, levPolyBetaTyVarSpec" ppTyVar _ = error "Unknown type var" +-- o, p, v and w have a special meaning. See primops.txt.pp +-- Note [Levity and representation polymorphic primops] ppType :: Ty -> String ppType (TyApp (TyCon "Any") []) = "anyTy" @@ -889,7 +892,10 @@ ppType (TyVar "c") = "gammaTy" ppType (TyVar "s") = "deltaTy" ppType (TyVar "o") = "openAlphaTy" ppType (TyVar "p") = "openBetaTy" -ppType (TyVar "v") = "levPolyTy1" +ppType (TyVar "v") = "levPolyAlphaTy" +ppType (TyVar "w") = "levPolyBetaTy" +-- o, p, v and w have a special meaning. See primops.txt.pp +-- Note [Levity and representation polymorphic primops] ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x -- cgit v1.2.1