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>

6 files changed, 41 insertions, 0 deletions

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