Commit c0e6dee9 authored by Tamar Christina's avatar Tamar Christina Committed by Marge Bot

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's avatarAndreas Klebinger <klebinger.andreas@gmx.at>
parent a31218f7
Pipeline #20894 passed with stages
in 370 minutes and 38 seconds
......@@ -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
......
......@@ -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.}
......
......@@ -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.
......
......@@ -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?
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
------------------
......
......@@ -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);
......
{-# 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
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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"
......
......@@ -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, [''])
......
{-# 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 #) -> (# #)
......@@ -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, [''])
......
{-# 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 #)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment