[Git][ghc/ghc][wip/andreask/xchg_primop] winio: Add Atomic Exchange PrimOp and implement Atomic Ptr exchanges.

Andreas Klebinger gitlab at gitlab.haskell.org
Mon May 25 15:44:31 UTC 2020



Andreas Klebinger pushed to branch wip/andreask/xchg_primop at Glasgow Haskell Compiler / GHC


Commits:
2c76f51f by Tamar Christina at 2020-05-25T17:43:34+02:00
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 at gmx.at>

- - - - -


27 changed files:

- aclocal.m4
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm/CPrim.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/Utils/Panic/Plain.hs
- configure.ac
- docs/users_guide/8.12.1-notes.rst
- includes/stg/Prim.h
- libraries/base/GHC/Ptr.hs
- libraries/ghc-prim/cbits/atomic.c
- libraries/ghc-prim/changelog.md
- rts/package.conf.in
- rts/rts.cabal.in
- testsuite/tests/codeGen/should_compile/all.T
- + testsuite/tests/codeGen/should_compile/cg009.hs
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/codeGen/should_run/cgrun080.hs
- + testsuite/tests/codeGen/should_run/cgrun080.stdout


Changes:

=====================================
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


=====================================
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.}


=====================================
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.


=====================================
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?


=====================================
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


=====================================
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
 


=====================================
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
 


=====================================
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


=====================================
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"


=====================================
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


=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -831,6 +831,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)


=====================================
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
@@ -1943,10 +1954,10 @@ toIWord platform = mkIntLit (llvmWord platform)
 
 
 -- | Error functions
-panic :: String -> a
+panic :: HasDebugCallStack => String -> a
 panic s = Outputable.panic $ "GHC.CmmToLlvm.CodeGen." ++ s
 
-pprPanic :: String -> SDoc -> a
+pprPanic :: HasDebugCallStack => String -> SDoc -> a
 pprPanic s d = Outputable.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d
 
 


=====================================
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


=====================================
compiler/GHC/Utils/Panic/Plain.hs
=====================================
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}
+{-# LANGUAGE ConstraintKinds, KindSignatures #-}
 
 -- | Defines a simple exception type and utilities to throw it. The
 -- 'PlainGhcException' type is a subset of the 'Panic.GhcException'
@@ -33,6 +34,7 @@ import GHC.Stack
 import GHC.Prelude
 import System.Environment
 import System.IO.Unsafe
+import Data.Kind (Constraint)
 
 -- | This type is very similar to 'Panic.GhcException', but it omits
 -- the constructors that involve pretty-printing via
@@ -110,13 +112,22 @@ showPlainGhcException =
 throwPlainGhcException :: PlainGhcException -> a
 throwPlainGhcException = Exception.throw
 
+-- | A call stack constraint, but only when 'isDebugOn'.
+-- Redefined here to avoid import cycles.
+#if defined(DEBUG)
+type HasDebugCallStack = HasCallStack
+#else
+type HasDebugCallStack = (() :: Constraint)
+#endif
+
 -- | Panics and asserts.
-panic, sorry, pgmError :: String -> a
+panic, sorry, pgmError :: HasDebugCallStack => String -> a
 panic    x = unsafeDupablePerformIO $ do
    stack <- ccsToStrings =<< getCurrentCCS x
+   let strCallStack = prettyCallStack callStack
    if null stack
-      then throwPlainGhcException (PlainPanic x)
-      else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack))
+      then throwPlainGhcException (PlainPanic (x ++ "\n" ++ strCallStack))
+      else throwPlainGhcException (PlainPanic (x ++ "\n" ++ strCallStack ++ "\n" ++ renderStack stack))
 
 sorry    x = throwPlainGhcException (PlainSorry x)
 pgmError x = throwPlainGhcException (PlainProgramError x)


=====================================
configure.ac
=====================================
@@ -730,6 +730,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


=====================================
docs/users_guide/8.12.1-notes.rst
=====================================
@@ -148,11 +148,11 @@ Arrow notation
    ``hsGroupTopLevelFixitySigs`` function, which collects all top-level fixity
    signatures, including those for class methods defined inside classes.
 
-- The ``Exception`` module was boiled down acknowledging the existence of 
+- The ``Exception`` module was boiled down acknowledging the existence of
   the ``exceptions`` dependency. In particular, the ``ExceptionMonad``
   class is not a proper class anymore, but a mere synonym for ``MonadThrow``,
-  ``MonadCatch``, ``MonadMask`` (all from ``exceptions``) and ``MonadIO``. 
-  All of ``g*``-functions from the module (``gtry``, ``gcatch``, etc.) are 
+  ``MonadCatch``, ``MonadMask`` (all from ``exceptions``) and ``MonadIO``.
+  All of ``g*``-functions from the module (``gtry``, ``gcatch``, etc.) are
   erased, and their ``exceptions``-alternatives are meant to be used in the
   GHC code instead.
 
@@ -162,6 +162,12 @@ Arrow notation
 Build system
 ~~~~~~~~~~~~
 
+Bootstrapping requirements
+--------------------------
+
+Starting with 8.12.1 GHC requires a C compiler which supports
+__atomic_op_n builtins. This raises the requirement for GCC to 4.7.
+
 Included libraries
 ------------------
 


=====================================
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(StgPtr x, StgWord val);
+StgWord hs_xchg16(StgPtr x, StgWord val);
+StgWord hs_xchg32(StgPtr x, StgWord val);
+StgWord hs_xchg64(StgPtr x, StgWord val);
 
 /* libraries/ghc-prim/cbits/bswap.c */
 StgWord16 hs_bswap16(StgWord16 x);


=====================================
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


=====================================
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(StgPtr x, StgWord val);
+StgWord
+hs_xchg8(StgPtr x, StgWord val)
+{
+  return (StgWord) __atomic_exchange_n((StgWord8 *) x, (StgWord8) val, __ATOMIC_SEQ_CST);
+}
+
+extern StgWord hs_xchg16(StgPtr x, StgWord val);
+StgWord
+hs_xchg16(StgPtr x, StgWord val)
+{
+  return (StgWord) __atomic_exchange_n((StgWord16 *)x, (StgWord16) val, __ATOMIC_SEQ_CST);
+}
+
+extern StgWord hs_xchg32(StgPtr x, StgWord val);
+StgWord
+hs_xchg32(StgPtr 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(StgPtr x, StgWord val);
+StgWord
+hs_xchg64(StgPtr 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


=====================================
libraries/ghc-prim/changelog.md
=====================================
@@ -1,3 +1,12 @@
+## TBD
+
+- Shipped with GHC 8.12.1
+
+- 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


=====================================
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"


=====================================
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"


=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -6,6 +6,7 @@ test('cg005', only_ways(['optasm']), compile, [''])
 test('cg006', normal, compile, [''])
 test('cg007', normal, compile, [''])
 test('cg008', normal, compile, [''])
+test('cg009', normal, compile, [''])
 
 test('T1916', normal, compile, [''])
 test('T2388', normal, compile, [''])


=====================================
testsuite/tests/codeGen/should_compile/cg009.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 #) -> (# #)


=====================================
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, [''])


=====================================
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 #)
+


=====================================
testsuite/tests/codeGen/should_run/cgrun080.stdout
=====================================
@@ -0,0 +1 @@
+[1,2,3]



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c76f51fac5711fe1019e0944351cff063894fea

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c76f51fac5711fe1019e0944351cff063894fea
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200525/0a9d20dd/attachment-0001.html>


More information about the ghc-commits mailing list