[Git][ghc/ghc][wip/andreask/xchg_primop] 2 commits: Make exchange a sized operation as it should be.

Andreas Klebinger gitlab at gitlab.haskell.org
Tue May 19 13:37:03 UTC 2020



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


Commits:
23d9413e by Andreas Klebinger at 2020-05-19T15:18:37+02:00
Make exchange a sized operation as it should be.

- - - - -
440eb15b by Andreas Klebinger at 2020-05-19T15:36:01+02:00
Make 64bit version a error on 32bit platforms. Add Exchange on Int#.

- - - - -


18 changed files:

- 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/codeGen/StgCmmPrim.hs
- configure.ac
- includes/stg/Prim.h
- libraries/ghc-prim/cbits/atomic.c
- rts/package.conf.in
- rts/rts.cabal.in


Changes:

=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2475,8 +2475,14 @@ primop  WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp
 
 primop  InterlockedExchangeAddr "interlockedExchangeAddr#" GenPrimOp
    Addr# -> Addr# -> Addr#
-   {The atomic exchange operation. Atomically exchanges a pair of addresses and
-    returns the old value.}
+   {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  InterlockedExchangeInt "interlockedExchangeInt#" GenPrimOp
+   Addr# -> Int# -> 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
 
 ------------------------------------------------------------------------


=====================================
compiler/GHC/Cmm/MachOp.hs
=====================================
@@ -632,7 +632,9 @@ data CallishMachOp
   | MO_AtomicRead Width
   | MO_AtomicWrite Width
   | MO_Cmpxchg Width
-  | MO_Xchg
+  -- Should be an AtomicRMW variant eventually.
+  -- Has at least aquire semantics.
+  | 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
=====================================
@@ -106,8 +106,14 @@ atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w
     pprFunName AMO_Or   = "or"
     pprFunName AMO_Xor  = "xor"
 
-xchgLabel :: String
-xchgLabel = "hs_xchg"
+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


=====================================
compiler/GHC/CmmToAsm/PPC/CodeGen.hs
=====================================
@@ -2024,7 +2024,7 @@ genCCall' config gcp target dest_regs args
                     MO_Ctz _     -> unsupported
                     MO_AtomicRMW {} -> unsupported
                     MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)
-                    MO_Xchg      -> (fsLit $ xchgLabel, False)
+                    MO_Xchg w    -> (fsLit $ xchgLabel w, False)
                     MO_AtomicRead _  -> unsupported
                     MO_AtomicWrite _ -> unsupported
 


=====================================
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
=====================================
@@ -677,7 +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 -> fsLit xchgLabel
+        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,10 +2518,13 @@ genCCall' _ is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = d
   where
     format = intFormat width
 
-genCCall' config is32Bit (PrimTarget MO_Xchg) [dst] [addr, value] _ = do
+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
@@ -2529,8 +2532,6 @@ genCCall' config is32Bit (PrimTarget MO_Xchg) [dst] [addr, value] _ = do
     return $ addr_code `appOL` newval_code `appOL` code
   where
     format = intFormat width
-    width | is32Bit   = W32
-          | otherwise = W64
     platform = ncgPlatform config
 
 genCCall' _ is32Bit target dest_regs args bid = do
@@ -3228,7 +3229,7 @@ outOfLineCmmOp bid mop res args
               MO_AtomicRead _  -> fsLit "atomicread"
               MO_AtomicWrite _ -> fsLit "atomicwrite"
               MO_Cmpxchg _     -> fsLit "cmpxchg"
-              MO_Xchg          -> fsLit "xchg"
+              MO_Xchg _        -> should_be_inline
 
               MO_UF_Conv _ -> unsupported
 
@@ -3248,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
=====================================
@@ -462,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


=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -824,7 +824,7 @@ pprInstr platform i = case i of
    SETCC cond op
       -> pprCondInstr (sLit "set") cond (pprOperand platform II8 op)
 
-   (XCHG format src val)
+   XCHG format src val
       -> pprFormatOpReg (sLit "xchg") format src val
 
    JXX cond blockid


=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -831,7 +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         -> ptext (sLit $ xchgLabel)
+        (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,7 +281,7 @@ genCall (PrimTarget (MO_Cmpxchg _width))
     retVar' <- doExprW targetTy $ ExtractV retVar 0
     statement $ Store retVar' dstVar
 
-genCall (PrimTarget MO_Xchg) [] [addr, val] = runStmtsDecls $ do
+genCall (PrimTarget (MO_Xchg _width)) [] [addr, val] = runStmtsDecls $ do
     addrVar <- exprToVarW addr
     valVar <- exprToVarW val
     let ptrTy = pLift $ getVarType valVar
@@ -864,7 +864,7 @@ cmmPrimOpFunctions mop = do
     MO_AtomicRMW _ _ -> unsupported
     MO_AtomicWrite _ -> unsupported
     MO_Cmpxchg _     -> unsupported
-    MO_Xchg          -> unsupported
+    MO_Xchg _        -> unsupported
 
 -- | Tail function calls
 genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData


=====================================
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
+  InterlockedExchangeAddr -> \[src, value] -> opAllDone $ \[res] ->
+    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
+  InterlockedExchangeInt -> \[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/codeGen/StgCmmPrim.hs deleted
=====================================
The diff for this file was not included because it is too large.

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


=====================================
includes/stg/Prim.h
=====================================
@@ -50,7 +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_xchg(StgPtr x, StgWord 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/ghc-prim/cbits/atomic.c
=====================================
@@ -10,6 +10,8 @@
 // according to the ABI and is not what GHC does when it generates
 // calls to these functions.
 
+//TODO: We now require gcc-5, so we should use __atomic__op variants.
+
 // FetchAddByteArrayOp_Int
 
 extern StgWord hs_atomic_add8(StgWord x, StgWord val);
@@ -320,13 +322,37 @@ hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new)
 
 // Atomic exchange operations
 
-extern StgWord hs_xchg(StgPtr x, StgWord val);
+extern StgWord hs_xchg8(StgPtr x, StgWord val);
+StgWord
+hs_xchg8(StgPtr x, StgWord val)
+{
+  return (StgWord) __atomic_exchange_1((volatile StgPtr) x, val, __ATOMIC_ACQUIRE);
+}
+
+extern StgWord hs_xchg16(StgPtr x, StgWord val);
 StgWord
-hs_xchg(StgPtr x, StgWord val)
+hs_xchg16(StgPtr x, StgWord val)
 {
-  return __sync_lock_test_and_set((volatile StgPtr) x, val);
+  return (StgWord) __atomic_exchange_2(x, val, __ATOMIC_ACQUIRE);
 }
 
+extern StgWord hs_xchg32(StgPtr x, StgWord val);
+StgWord
+hs_xchg32(StgPtr x, StgWord val)
+{
+  return (StgWord) __atomic_exchange_4((volatile StgPtr) x, val, __ATOMIC_ACQUIRE);
+}
+
+#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_8((volatile StgPtr) x, val, __ATOMIC_ACQUIRE);
+}
+#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


=====================================
rts/package.conf.in
=====================================
@@ -168,7 +168,10 @@ ld-options:
 #if WORD_SIZE_IN_BITS == 64
          , "-Wl,-u,_hs_cmpxchg64"
 #endif
-         , "-Wl,-u,_hs_xchg"
+         , "-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"
@@ -274,7 +277,10 @@ ld-options:
 #if WORD_SIZE_IN_BITS == 64
          , "-Wl,-u,hs_cmpxchg64"
 #endif
-         , "-Wl,-u,hs_xchg"
+         , "-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,7 +264,10 @@ library
          "-Wl,-u,_hs_cmpxchg8"
          "-Wl,-u,_hs_cmpxchg16"
          "-Wl,-u,_hs_cmpxchg32"
-         "-Wl,-u,_hs_xchg"
+         "-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"
@@ -340,7 +343,10 @@ library
          "-Wl,-u,hs_cmpxchg8"
          "-Wl,-u,hs_cmpxchg16"
          "-Wl,-u,hs_cmpxchg32"
-         "-Wl,-u,hs_xchg"
+         "-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"



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e0df3d73f5c39b7cf4868c6493f6eec3d22b0ff5...440eb15b2fca58366a0a1df425f7fb4dfc27b36a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e0df3d73f5c39b7cf4868c6493f6eec3d22b0ff5...440eb15b2fca58366a0a1df425f7fb4dfc27b36a
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/20200519/25deba70/attachment-0001.html>


More information about the ghc-commits mailing list