summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorTamar Christina <tamar@zhox.com>2019-06-01 11:20:39 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-06-14 09:07:44 -0400
commitc0e6dee99242eff08420176a36d77b715972f1f2 (patch)
tree4899be6a2dc500f79b9f67300362ba8a702a6b7a
parenta31218f7737a65b6333ec7905e88dc094703f025 (diff)
downloadhaskell-c0e6dee99242eff08420176a36d77b715972f1f2.tar.gz
winio: Add Atomic Exchange PrimOp and implement Atomic Ptr exchanges.
The initial version was rewritten by Tamar Christina. It was rewritten in large parts by Andreas Klebinger. Co-authored-by: Andreas Klebinger <klebinger.andreas@gmx.at>
-rw-r--r--aclocal.m45
-rw-r--r--compiler/GHC/Builtin/primops.txt.pp12
-rw-r--r--compiler/GHC/Cmm/MachOp.hs3
-rw-r--r--compiler/GHC/Cmm/Parser.y7
-rw-r--r--compiler/GHC/CmmToAsm/CPrim.hs10
-rw-r--r--compiler/GHC/CmmToAsm/PPC/CodeGen.hs1
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen.hs1
-rw-r--r--compiler/GHC/CmmToAsm/X86/CodeGen.hs22
-rw-r--r--compiler/GHC/CmmToAsm/X86/Instr.hs4
-rw-r--r--compiler/GHC/CmmToAsm/X86/Ppr.hs3
-rw-r--r--compiler/GHC/CmmToC.hs1
-rw-r--r--compiler/GHC/CmmToLlvm/CodeGen.hs15
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs6
-rw-r--r--configure.ac2
-rw-r--r--docs/users_guide/8.12.1-notes.rst6
-rw-r--r--includes/stg/Prim.h4
-rw-r--r--libraries/base/GHC/Ptr.hs15
-rw-r--r--libraries/ghc-prim/cbits/atomic.c33
-rw-r--r--libraries/ghc-prim/changelog.md5
-rw-r--r--rts/package.conf.in8
-rw-r--r--rts/rts.cabal.in8
-rw-r--r--testsuite/tests/codeGen/should_compile/all.T2
-rw-r--r--testsuite/tests/codeGen/should_compile/cg011.hs11
-rw-r--r--testsuite/tests/codeGen/should_run/all.T1
-rw-r--r--testsuite/tests/codeGen/should_run/cgrun080.hs51
-rw-r--r--testsuite/tests/codeGen/should_run/cgrun080.stdout1
26 files changed, 231 insertions, 6 deletions
diff --git a/aclocal.m4 b/aclocal.m4
index bce0f577bd..cd5fcc1ec0 100644
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -1341,8 +1341,9 @@ AC_DEFUN([FP_GCC_VERSION], [
AC_MSG_CHECKING([version of gcc])
fp_cv_gcc_version="`$CC -v 2>&1 | sed -n -e '1,/version /s/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/p'`"
AC_MSG_RESULT([$fp_cv_gcc_version])
- FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.6],
- [AC_MSG_ERROR([Need at least gcc version 4.6 (4.7+ recommended)])])
+ # 4.7 is needed for __atomic_ builtins.
+ FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.7],
+ [AC_MSG_ERROR([Need at least gcc version 4.7 (newer recommended)])])
])
AC_SUBST([GccVersion], [$fp_cv_gcc_version])
else
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 859fb99ae7..ee7bdac29a 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -2473,6 +2473,18 @@ primop WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp
with has_side_effects = True
can_fail = True
+primop InterlockedExchange_Addr "interlockedExchangeAddr#" GenPrimOp
+ Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
+ {The atomic exchange operation. Atomically exchanges the value at the first address
+ with the Addr# given as second argument. Implies a read barrier.}
+ with has_side_effects = True
+
+primop InterlockedExchange_Int "interlockedExchangeInt#" GenPrimOp
+ Addr# -> Int# -> State# s -> (# State# s, Int# #)
+ {The atomic exchange operation. Atomically exchanges the value at the address
+ with the given value. Returns the old value. Implies a read barrier.}
+ with has_side_effects = True
+
------------------------------------------------------------------------
section "Mutable variables"
{Operations on MutVar\#s.}
diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs
index 1b3dd2a531..077f663161 100644
--- a/compiler/GHC/Cmm/MachOp.hs
+++ b/compiler/GHC/Cmm/MachOp.hs
@@ -632,6 +632,9 @@ data CallishMachOp
| MO_AtomicRead Width
| MO_AtomicWrite Width
| MO_Cmpxchg Width
+ -- Should be an AtomicRMW variant eventually.
+ -- Sequential consistent.
+ | MO_Xchg Width
deriving (Eq, Show)
-- | The operation to perform atomically.
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index bb502f8cbe..41d5d3d6d6 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -1022,7 +1022,12 @@ callishMachOps = listToUFM $
( "cmpxchg8", (MO_Cmpxchg W8,)),
( "cmpxchg16", (MO_Cmpxchg W16,)),
( "cmpxchg32", (MO_Cmpxchg W32,)),
- ( "cmpxchg64", (MO_Cmpxchg W64,))
+ ( "cmpxchg64", (MO_Cmpxchg W64,)),
+
+ ( "xchg8", (MO_Xchg W8,)),
+ ( "xchg16", (MO_Xchg W16,)),
+ ( "xchg32", (MO_Xchg W32,)),
+ ( "xchg64", (MO_Xchg W64,))
-- ToDo: the rest, maybe
-- edit: which rest?
diff --git a/compiler/GHC/CmmToAsm/CPrim.hs b/compiler/GHC/CmmToAsm/CPrim.hs
index fc2d06262b..826a6e2224 100644
--- a/compiler/GHC/CmmToAsm/CPrim.hs
+++ b/compiler/GHC/CmmToAsm/CPrim.hs
@@ -4,6 +4,7 @@ module GHC.CmmToAsm.CPrim
, atomicWriteLabel
, atomicRMWLabel
, cmpxchgLabel
+ , xchgLabel
, popCntLabel
, pdepLabel
, pextLabel
@@ -105,6 +106,15 @@ atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w
pprFunName AMO_Or = "or"
pprFunName AMO_Xor = "xor"
+xchgLabel :: Width -> String
+xchgLabel w = "hs_xchg" ++ pprWidth w
+ where
+ pprWidth W8 = "8"
+ pprWidth W16 = "16"
+ pprWidth W32 = "32"
+ pprWidth W64 = "64"
+ pprWidth w = pprPanic "xchgLabel: Unsupported word width " (ppr w)
+
cmpxchgLabel :: Width -> String
cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w
where
diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
index 764945c2bc..367faa25bc 100644
--- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
@@ -2024,6 +2024,7 @@ genCCall' config gcp target dest_regs args
MO_Ctz _ -> unsupported
MO_AtomicRMW {} -> unsupported
MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)
+ MO_Xchg w -> (fsLit $ xchgLabel w, False)
MO_AtomicRead _ -> unsupported
MO_AtomicWrite _ -> unsupported
diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
index 2112983e73..9ecb0fcc76 100644
--- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
@@ -677,6 +677,7 @@ outOfLineMachOp_table mop
MO_Ctz w -> fsLit $ ctzLabel w
MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop
MO_Cmpxchg w -> fsLit $ cmpxchgLabel w
+ MO_Xchg w -> fsLit $ xchgLabel w
MO_AtomicRead w -> fsLit $ atomicReadLabel w
MO_AtomicWrite w -> fsLit $ atomicWriteLabel w
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index dab4c62122..d842bcc94a 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -2518,6 +2518,22 @@ genCCall' _ is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = d
where
format = intFormat width
+genCCall' config is32Bit (PrimTarget (MO_Xchg width)) [dst] [addr, value] _
+ | (is32Bit && width == W64) = panic "gencCall: 64bit atomic exchange not supported on 32bit platforms"
+ | otherwise = do
+ let dst_r = getRegisterReg platform (CmmLocal dst)
+ Amode amode addr_code <- getSimpleAmode is32Bit addr
+ (newval, newval_code) <- getSomeReg value
+ -- Copy the value into the target register, perform the exchange.
+ let code = toOL
+ [ MOV format (OpReg newval) (OpReg dst_r)
+ , XCHG format (OpAddr amode) dst_r
+ ]
+ return $ addr_code `appOL` newval_code `appOL` code
+ where
+ format = intFormat width
+ platform = ncgPlatform config
+
genCCall' _ is32Bit target dest_regs args bid = do
platform <- ncgPlatform <$> getConfig
case (target, dest_regs) of
@@ -3213,6 +3229,7 @@ outOfLineCmmOp bid mop res args
MO_AtomicRead _ -> fsLit "atomicread"
MO_AtomicWrite _ -> fsLit "atomicwrite"
MO_Cmpxchg _ -> fsLit "cmpxchg"
+ MO_Xchg _ -> should_be_inline
MO_UF_Conv _ -> unsupported
@@ -3232,6 +3249,11 @@ outOfLineCmmOp bid mop res args
(MO_Prefetch_Data _ ) -> unsupported
unsupported = panic ("outOfLineCmmOp: " ++ show mop
++ " not supported here")
+ -- If we generate a call for the given primop
+ -- something went wrong.
+ should_be_inline = panic ("outOfLineCmmOp: " ++ show mop
+ ++ " should be handled inline")
+
-- -----------------------------------------------------------------------------
-- Generating a table-branch
diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs
index 67a6ffb930..eafe7198e6 100644
--- a/compiler/GHC/CmmToAsm/X86/Instr.hs
+++ b/compiler/GHC/CmmToAsm/X86/Instr.hs
@@ -329,6 +329,7 @@ data Instr
| LOCK Instr -- lock prefix
| XADD Format Operand Operand -- src (r), dst (r/m)
| CMPXCHG Format Operand Operand -- src (r), dst (r/m), eax implicit
+ | XCHG Format Operand Reg -- src (r/m), dst (r/m)
| MFENCE
data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2
@@ -431,6 +432,7 @@ x86_regUsageOfInstr platform instr
LOCK i -> x86_regUsageOfInstr platform i
XADD _ src dst -> usageMM src dst
CMPXCHG _ src dst -> usageRMM src dst (OpReg eax)
+ XCHG _ src dst -> usageMM src (OpReg dst)
MFENCE -> noUsage
_other -> panic "regUsage: unrecognised instr"
@@ -460,6 +462,7 @@ x86_regUsageOfInstr platform instr
usageMM :: Operand -> Operand -> RegUsage
usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst]
usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src]
+ usageMM (OpAddr ea) (OpReg dst) = mkRU (use_EA ea [dst]) [dst]
usageMM _ _ = panic "X86.RegInfo.usageMM: no match"
-- 3 operand form; first operand Read; second Modified; third Modified
@@ -589,6 +592,7 @@ x86_patchRegsOfInstr instr env
LOCK i -> LOCK (x86_patchRegsOfInstr i env)
XADD fmt src dst -> patch2 (XADD fmt) src dst
CMPXCHG fmt src dst -> patch2 (CMPXCHG fmt) src dst
+ XCHG fmt src dst -> XCHG fmt (patchOp src) (env dst)
MFENCE -> instr
_other -> panic "patchRegs: unrecognised instr"
diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs
index 6ed5842389..6be1c8ef4d 100644
--- a/compiler/GHC/CmmToAsm/X86/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs
@@ -824,6 +824,9 @@ pprInstr platform i = case i of
SETCC cond op
-> pprCondInstr (sLit "set") cond (pprOperand platform II8 op)
+ XCHG format src val
+ -> pprFormatOpReg (sLit "xchg") format src val
+
JXX cond blockid
-> pprCondInstr (sLit "j") cond (ppr lab)
where lab = blockLbl blockid
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index d7b3fb05eb..bcead719a9 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -835,6 +835,7 @@ pprCallishMachOp_for_C mop
(MO_Ctz w) -> ptext (sLit $ ctzLabel w)
(MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)
(MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w)
+ (MO_Xchg w) -> ptext (sLit $ xchgLabel w)
(MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w)
(MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)
(MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w)
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 672fc84e43..53f17f545c 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -281,6 +281,16 @@ genCall (PrimTarget (MO_Cmpxchg _width))
retVar' <- doExprW targetTy $ ExtractV retVar 0
statement $ Store retVar' dstVar
+genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do
+ dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar
+ addrVar <- exprToVarW addr
+ valVar <- exprToVarW val
+ let ptrTy = pLift $ getVarType valVar
+ ptrExpr = Cast LM_Inttoptr addrVar ptrTy
+ ptrVar <- doExprW ptrTy ptrExpr
+ resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst)
+ statement $ Store resVar dstV
+
genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do
addrVar <- exprToVarW addr
valVar <- exprToVarW val
@@ -856,6 +866,7 @@ cmmPrimOpFunctions mop = do
MO_AtomicRMW _ _ -> unsupported
MO_AtomicWrite _ -> unsupported
MO_Cmpxchg _ -> unsupported
+ MO_Xchg _ -> unsupported
-- | Tail function calls
genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
@@ -1946,10 +1957,10 @@ toIWord platform = mkIntLit (llvmWord platform)
-- | Error functions
-panic :: String -> a
+panic :: HasCallStack => String -> a
panic s = Outputable.panic $ "GHC.CmmToLlvm.CodeGen." ++ s
-pprPanic :: String -> SDoc -> a
+pprPanic :: HasCallStack => String -> SDoc -> a
pprPanic s d = Outputable.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index e70f50ee84..fee96f31f8 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -856,6 +856,12 @@ emitPrimOp dflags = \case
Word2DoubleOp -> \[w] -> opAllDone $ \[res] -> do
emitPrimCall [res] (MO_UF_Conv W64) [w]
+-- Atomic operations
+ InterlockedExchange_Addr -> \[src, value] -> opAllDone $ \[res] ->
+ emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
+ InterlockedExchange_Int -> \[src, value] -> opAllDone $ \[res] ->
+ emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
+
-- SIMD primops
(VecBroadcastOp vcat n w) -> \[e] -> opAllDone $ \[res] -> do
checkVecCompatibility dflags vcat n w
diff --git a/configure.ac b/configure.ac
index f7b02e8dcf..84880d8cb4 100644
--- a/configure.ac
+++ b/configure.ac
@@ -744,6 +744,8 @@ dnl unregisterised, Sparc, and PPC backends.
FP_GCC_SUPPORTS__ATOMICS
if test $CONF_GCC_SUPPORTS__ATOMICS = YES ; then
AC_DEFINE([HAVE_C11_ATOMICS], [1], [Does GCC support __atomic primitives?])
+else
+ AC_MSG_ERROR([C compiler needs to support __atomic primitives.])
fi
FP_GCC_EXTRA_FLAGS
diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst
index bc8450417f..0117b537d9 100644
--- a/docs/users_guide/8.12.1-notes.rst
+++ b/docs/users_guide/8.12.1-notes.rst
@@ -244,6 +244,12 @@ Arrow notation
Build system
~~~~~~~~~~~~
+Bootstrapping requirements
+--------------------------
+
+- GHC now requires a C compiler which supports
+ ``__atomic_op_n`` builtins. This raises the requirement for GCC to 4.7.
+
Included libraries
------------------
diff --git a/includes/stg/Prim.h b/includes/stg/Prim.h
index badbde4dfa..5f432b6f9b 100644
--- a/includes/stg/Prim.h
+++ b/includes/stg/Prim.h
@@ -50,6 +50,10 @@ void hs_atomicwrite8(StgWord x, StgWord val);
void hs_atomicwrite16(StgWord x, StgWord val);
void hs_atomicwrite32(StgWord x, StgWord val);
void hs_atomicwrite64(StgWord x, StgWord64 val);
+StgWord hs_xchg8(StgWord x, StgWord val);
+StgWord hs_xchg16(StgWord x, StgWord val);
+StgWord hs_xchg32(StgWord x, StgWord val);
+StgWord hs_xchg64(StgWord x, StgWord val);
/* libraries/ghc-prim/cbits/bswap.c */
StgWord16 hs_bswap16(StgWord16 x);
diff --git a/libraries/base/GHC/Ptr.hs b/libraries/base/GHC/Ptr.hs
index 00e226bbb3..1bc4cac1ea 100644
--- a/libraries/base/GHC/Ptr.hs
+++ b/libraries/base/GHC/Ptr.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE Unsafe #-}
{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, RoleAnnotations #-}
+{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
@@ -22,7 +23,10 @@ module GHC.Ptr (
nullFunPtr, castFunPtr,
-- * Unsafe functions
- castFunPtrToPtr, castPtrToFunPtr
+ castFunPtrToPtr, castPtrToFunPtr,
+
+ -- * Atomic operations
+ exchangePtr
) where
import GHC.Base
@@ -162,6 +166,15 @@ castFunPtrToPtr (FunPtr addr) = Ptr addr
castPtrToFunPtr :: Ptr a -> FunPtr b
castPtrToFunPtr (Ptr addr) = FunPtr addr
+------------------------------------------------------------------------
+-- Atomic operations for Ptr
+
+{-# INLINE exchangePtr #-}
+exchangePtr :: Ptr (Ptr a) -> Ptr b -> IO (Ptr c)
+exchangePtr (Ptr dst) (Ptr val) =
+ IO $ \s ->
+ case (interlockedExchangeAddr# dst val s) of
+ (# s2, old_val #) -> (# s2, Ptr old_val #)
------------------------------------------------------------------------
-- Show instances for Ptr and FunPtr
diff --git a/libraries/ghc-prim/cbits/atomic.c b/libraries/ghc-prim/cbits/atomic.c
index d196ef23c7..18451016ea 100644
--- a/libraries/ghc-prim/cbits/atomic.c
+++ b/libraries/ghc-prim/cbits/atomic.c
@@ -318,6 +318,39 @@ hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new)
}
#endif
+// Atomic exchange operations
+
+extern StgWord hs_xchg8(StgWord x, StgWord val);
+StgWord
+hs_xchg8(StgWord x, StgWord val)
+{
+ return (StgWord) __atomic_exchange_n((StgWord8 *) x, (StgWord8) val, __ATOMIC_SEQ_CST);
+}
+
+extern StgWord hs_xchg16(StgWord x, StgWord val);
+StgWord
+hs_xchg16(StgWord x, StgWord val)
+{
+ return (StgWord) __atomic_exchange_n((StgWord16 *)x, (StgWord16) val, __ATOMIC_SEQ_CST);
+}
+
+extern StgWord hs_xchg32(StgWord x, StgWord val);
+StgWord
+hs_xchg32(StgWord x, StgWord val)
+{
+ return (StgWord) __atomic_exchange_n((StgWord32 *) x, (StgWord32) val, __ATOMIC_SEQ_CST);
+}
+
+#if WORD_SIZE_IN_BITS == 64
+//GCC provides this even on 32bit, but StgWord is still 32 bits.
+extern StgWord hs_xchg64(StgWord x, StgWord val);
+StgWord
+hs_xchg64(StgWord x, StgWord val)
+{
+ return (StgWord) __atomic_exchange_n((StgWord64 *) x, (StgWord64) val, __ATOMIC_SEQ_CST);
+}
+#endif
+
// AtomicReadByteArrayOp_Int
// Implies a full memory barrier (see compiler/GHC/Builtin/primops.txt.pp)
// __ATOMIC_SEQ_CST: Full barrier in both directions (hoisting and sinking
diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index 0973959910..effa32479f 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -19,6 +19,11 @@
- Renamed the singleton tuple `GHC.Tuple.Unit` to `GHC.Tuple.Solo`.
+- Add primops for atomic exchange:
+
+ interlockedExchangeAddr# :: Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
+ interlockedExchangeInt# :: Addr# -> Int# -> State# s -> (# State# s, Int# #)
+
## 0.6.1 (edit as necessary)
- Shipped with GHC 8.10.1
diff --git a/rts/package.conf.in b/rts/package.conf.in
index 4c7a2a9b8f..45866a1ecd 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -168,6 +168,10 @@ ld-options:
#if WORD_SIZE_IN_BITS == 64
, "-Wl,-u,_hs_cmpxchg64"
#endif
+ , "-Wl,-u,_hs_xchg8"
+ , "-Wl,-u,_hs_xchg16"
+ , "-Wl,-u,_hs_xchg32"
+ , "-Wl,-u,_hs_xchg64"
, "-Wl,-u,_hs_atomicread8"
, "-Wl,-u,_hs_atomicread16"
, "-Wl,-u,_hs_atomicread32"
@@ -273,6 +277,10 @@ ld-options:
#if WORD_SIZE_IN_BITS == 64
, "-Wl,-u,hs_cmpxchg64"
#endif
+ , "-Wl,-u,hs_xchg8"
+ , "-Wl,-u,hs_xchg16"
+ , "-Wl,-u,hs_xchg32"
+ , "-Wl,-u,hs_xchg64"
, "-Wl,-u,hs_atomicread8"
, "-Wl,-u,hs_atomicread16"
, "-Wl,-u,hs_atomicread32"
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index 615260efd8..7895ae26f5 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -264,6 +264,10 @@ library
"-Wl,-u,_hs_cmpxchg8"
"-Wl,-u,_hs_cmpxchg16"
"-Wl,-u,_hs_cmpxchg32"
+ "-Wl,-u,_hs_xchg8"
+ "-Wl,-u,_hs_xchg16"
+ "-Wl,-u,_hs_xchg32"
+ "-Wl,-u,_hs_xchg64"
"-Wl,-u,_hs_atomicread8"
"-Wl,-u,_hs_atomicread16"
"-Wl,-u,_hs_atomicread32"
@@ -339,6 +343,10 @@ library
"-Wl,-u,hs_cmpxchg8"
"-Wl,-u,hs_cmpxchg16"
"-Wl,-u,hs_cmpxchg32"
+ "-Wl,-u,hs_xchg8"
+ "-Wl,-u,hs_xchg16"
+ "-Wl,-u,hs_xchg32"
+ "-Wl,-u,hs_xchg64"
"-Wl,-u,hs_atomicread8"
"-Wl,-u,hs_atomicread16"
"-Wl,-u,hs_atomicread32"
diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T
index ce76ed388a..2d3d0beed0 100644
--- a/testsuite/tests/codeGen/should_compile/all.T
+++ b/testsuite/tests/codeGen/should_compile/all.T
@@ -6,6 +6,8 @@ test('cg005', only_ways(['optasm']), compile, [''])
test('cg006', normal, compile, [''])
test('cg007', normal, compile, [''])
test('cg008', normal, compile, [''])
+# 009/010 have their own all.T file
+test('cg011', normal, compile, [''])
test('T1916', normal, compile, [''])
test('T2388', normal, compile, [''])
diff --git a/testsuite/tests/codeGen/should_compile/cg011.hs b/testsuite/tests/codeGen/should_compile/cg011.hs
new file mode 100644
index 0000000000..5d80968547
--- /dev/null
+++ b/testsuite/tests/codeGen/should_compile/cg011.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE CPP, MagicHash, BlockArguments, UnboxedTuples #-}
+
+-- Tests compilation for interlockedExchange primop.
+
+module M where
+
+import GHC.Exts (interlockedExchangeInt#, Int#, Addr#, State# )
+
+swap :: Addr# -> Int# -> State# s -> (# #)
+swap ptr val s = case (interlockedExchangeInt# ptr val s) of
+ (# s2, old_val #) -> (# #)
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 98d77b7289..5db0dcff74 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -90,6 +90,7 @@ test('cgrun076', normal, compile_and_run, [''])
test('cgrun077', [when(have_cpu_feature('bmi2'), extra_hc_opts('-mbmi2'))], compile_and_run, [''])
test('cgrun078', omit_ways(['ghci']), compile_and_run, [''])
test('cgrun079', normal, compile_and_run, [''])
+test('cgrun080', normal, compile_and_run, [''])
test('T1852', normal, compile_and_run, [''])
test('T1861', extra_run_opts('0'), compile_and_run, [''])
diff --git a/testsuite/tests/codeGen/should_run/cgrun080.hs b/testsuite/tests/codeGen/should_run/cgrun080.hs
new file mode 100644
index 0000000000..5390dd11ae
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/cgrun080.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP, MagicHash, BlockArguments, UnboxedTuples #-}
+
+-- Test the atomic exchange primop.
+
+-- We initialize a value with 1, and then perform exchanges on it
+-- with two different values. At the end all the values should still
+-- be present.
+
+module Main ( main ) where
+
+import Data.Bits
+import GHC.Int
+import GHC.Prim
+import GHC.Word
+import Control.Monad
+import Control.Concurrent
+import Foreign.Marshal.Alloc
+import Foreign.Storable
+import Data.List (sort)
+
+import GHC.Exts
+import GHC.Types
+
+#include "MachDeps.h"
+
+main = do
+ alloca $ \ptr_i -> do
+ poke ptr_i (1 :: Int)
+ w1 <- newEmptyMVar :: IO (MVar Int)
+ forkIO $ do
+ v <- swapN 50000 2 ptr_i
+ putMVar w1 v
+
+ v2 <- swapN 50000 3 ptr_i
+ v1 <- takeMVar w1
+ v0 <- peek ptr_i
+ -- Should be [1,2,3]
+ print $ sort [v0,v1,v2]
+
+swapN :: Int -> Int -> Ptr Int -> IO Int
+swapN 0 val ptr = return val
+swapN n val ptr = do
+ val' <- swap ptr val
+ swapN (n-1) val' ptr
+
+
+swap :: Ptr Int -> Int -> IO Int
+swap (Ptr ptr) (I# val) = do
+ IO $ \s -> case (interlockedExchangeInt# ptr val s) of
+ (# s2, old_val #) -> (# s2, I# old_val #)
+
diff --git a/testsuite/tests/codeGen/should_run/cgrun080.stdout b/testsuite/tests/codeGen/should_run/cgrun080.stdout
new file mode 100644
index 0000000000..3cc0ecbedf
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/cgrun080.stdout
@@ -0,0 +1 @@
+[1,2,3]