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

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
......@@ -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"
......
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