diff options
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 8 | ||||
| -rw-r--r-- | includes/stg/MiscClosures.h | 1 | ||||
| -rw-r--r-- | rts/Linker.c | 1 | ||||
| -rw-r--r-- | rts/PrimOps.cmm | 24 |
4 files changed, 32 insertions, 2 deletions
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 6e25d65488..6ee39c531a 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1118,6 +1118,14 @@ primop SetByteArrayOp "setByteArray#" GenPrimOp code_size = { primOpCodeSizeForeignCall + 4 } can_fail = True +primop CasByteArrayOp_Int "casIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Machine-level atomic compare and swap on a word within a ByteArray.} + with + out_of_line = True + has_side_effects = True + + ------------------------------------------------------------------------ section "Arrays of arrays" {Operations on {\tt ArrayArray\#}. An {\tt ArrayArray\#} contains references to {\em unpointed} diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index de5d32262c..ee973e46a9 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -368,6 +368,7 @@ RTS_FUN_DECL(stg_casArrayzh); RTS_FUN_DECL(stg_newByteArrayzh); RTS_FUN_DECL(stg_newPinnedByteArrayzh); RTS_FUN_DECL(stg_newAlignedPinnedByteArrayzh); +RTS_FUN_DECL(stg_casIntArrayzh); RTS_FUN_DECL(stg_newArrayzh); RTS_FUN_DECL(stg_newArrayArrayzh); diff --git a/rts/Linker.c b/rts/Linker.c index 1cb9b1f849..0a0996a844 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -1147,6 +1147,7 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_casArrayzh) \ SymI_HasProto(stg_newBCOzh) \ SymI_HasProto(stg_newByteArrayzh) \ + SymI_HasProto(stg_casIntArrayzh) \ SymI_HasProto_redirect(newCAF, newDynCAF) \ SymI_HasProto(stg_newMVarzh) \ SymI_HasProto(stg_newMutVarzh) \ diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 710330714e..cc22d2275f 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -137,6 +137,20 @@ stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment ) return (p); } +// RRN: This one does not use the "ticketing" approach because it +// deals in unboxed scalars, not heap pointers. +stg_casIntArrayzh( gcptr arr, W_ ind, W_ old, W_ new ) +/* MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) */ +{ + W_ len; + gcptr p,h; + + p = arr + SIZEOF_StgArrWords + WDS(ind); + (h) = ccall cas(p, old, new); + + return(h); +} + stg_newArrayzh ( W_ n /* words */, gcptr init ) { W_ words, size; @@ -206,6 +220,7 @@ stg_unsafeThawArrayzh ( gcptr arr ) } } +// RRN: Uses the ticketed approach; see casMutVar stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new ) /* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #) */ { @@ -224,7 +239,7 @@ stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new ) len = StgMutArrPtrs_ptrs(arr); // The write barrier. We must write a byte into the mark table: I8[arr + SIZEOF_StgMutArrPtrs + WDS(len) + (ind >> MUT_ARR_PTRS_CARD_BITS )] = 1; - return (0,h); + return (0,new); } } @@ -284,6 +299,11 @@ stg_newMutVarzh ( gcptr init ) return (mv); } +// RRN: To support the "ticketed" approach, we return the NEW rather +// than old value if the CAS is successful. This is received in an +// opaque form in the Haskell code, preventing the compiler from +// changing its pointer identity. The ticket can then be safely used +// in future CAS operations. stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new ) /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, a #) */ { @@ -297,7 +317,7 @@ stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new ) if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) { ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr"); } - return (0,h); + return (0,new); } } |