suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add memory-order-acquire and memory-order-release

Browse Source 
original commit: ea879863f2141ac30532586ff435f16dc4339a8b
This commit is contained in:
Matthew Flatt 2020-07-11 09:31:10 -06:00
parent 32c5af0442
commit 802daa10b1
10 changed files with 159 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
csug/threads.stex
View File

@ -568,6 +568,36 @@ allocation of the containing object and decremented upon freeing
of the containing object.
\section{Memory Consistency\label{SECTSMGMTMEMMODEL}}
Scheme threads can expose the memory-consistency model of the
underlying processor, except to the degree that it would interefere
with the memory safety of Scheme programs. For example, if two threads
share a vector, then a \scheme{vector-set!} in one thread will not
allow the other thread to read the vector and see a partially
constructed primitive object installed into the vector; the Scheme
system includes a memory fence around operations and on platforms as
needed to preserve safety. There's no guarantee, for example, that
assigning to multiple slots in an fxvector will become visible in the
same order to other threads that share the vector, because no such
ordering is required to preserve memory safety.
%----------------------------------------------------------------------------
\entryheader
\formdef{memory-order-acquire}{\categoryprocedure}{(memory-order-acquire)}
\formdef{memory-order-release}{\categoryprocedure}{(memory-order-release)}
\returns unspecified
\listlibraries
\endnoskipentryheader
These procedures fence memory operations in a way that is consistent
with acquire--release patterns. Specifically,
\scheme{memory-order-acquire} ensures at least a load--load and
load--store fence, and \scheme{memory-order-release} ensures at least
a store--store and store--load fence.
\section{Thread Parameters\label{SECTTHREADPARAMETERS}}
%----------------------------------------------------------------------------

2
makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point #
###############################################################################
Version=csv9.5.3.31
Version=csv9.5.3.32
Include=boot/$m
PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot

47
mats/thread.ms
View File

@ -1568,6 +1568,51 @@
(set! done? #t)
(condition-broadcast c))
(equal? gc-ids (list (get-thread-id)))))
)
(mat memory-consistency
(equal? (memory-order-acquire) (void))
(equal? (memory-order-release) (void))
;; Try to make a thread see a partially constructed box
(let ([ids '(one two three four)])
(let ([m (make-mutex)]
[c (make-condition)]
[ok? #t]
[running (length ids)]
[v (make-vector 1000 (box (car ids)))])
(let loop ([i running])
(unless (= i 0)
(fork-thread (lambda ()
(let ([id (list-ref ids (sub1 i))]
[failed? #f])
(let loop ([j 10000])
(cond
[(fx= j 0)
(mutex-acquire m)
(set! running (sub1 running))
(condition-signal c)
(set! ok? (and ok? (not failed?)))
(mutex-release m)]
[else
(let loop ([i 0])
(unless (fx= i (vector-length v))
(let ([b (vector-ref v i)])
(unless (and (box? b)
(memq (unbox b) ids))
(set! failed? #t)))
(vector-set! v i (box id))
(loop (fx+ i 1))))
(loop (fx- j 1))])))))
(loop (sub1 i))))
(mutex-acquire m)
(let loop ()
(cond
[(not (zero? running))
(condition-wait c m)
(loop)]
[else
(mutex-release m)]))
ok?))
)
(mat wait-for-threads
@ -1581,6 +1626,6 @@
(sleep (make-time 'time-duration 10000 0))
(loop))))
#t)
)
)
)

30
s/arm32.ss
View File

@ -985,9 +985,17 @@
`(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
`(asm ,info ,asm-cas ,r ,old ,new ,u1 ,u2)))))]))
(define-instruction effect (write-write-fence)
(define-instruction effect (store-store-fence)
[(op)
`(asm ,info ,asm-write-write-fence)])
`(asm ,info ,(asm-fence 'store-store))])
(define-instruction effect (acquire-fence)
[(op)
`(asm ,info ,(asm-fence 'acquire))])
(define-instruction effect (release-fence)
[(op)
`(asm ,info ,(asm-fence 'release))])
(define-instruction effect (pause)
; NB: user sqrt or something like that?
@ -1033,7 +1041,7 @@
asm-rp-header asm-rp-compact-header
asm-indirect-call asm-condition-code
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
asm-lock asm-lock+/- asm-cas asm-write-write-fence
asm-lock asm-lock+/- asm-cas asm-fence
asm-fpop-2 asm-fpsqrt asm-c-simple-call
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
asm-enter asm-foreign-call asm-foreign-callable
@ -1186,7 +1194,9 @@
(define-op ldrex ldrex-op #b00011001)
(define-op strex strex-op #b00011000)
(define-op dmbst dmb-op #b1110)
(define-op dmbst dmb-op #b1110)
(define-op dmbish dmb-op #b1011)
(define-op dmbishst dmb-op #b1010)
(define-op bnei branch-imm-op (ax-cond 'ne))
(define-op brai branch-imm-op (ax-cond 'al))
@ -2182,9 +2192,15 @@
(emit cmpi tmp2 0
code*))))))))
(define asm-write-write-fence
(lambda (code*)
(emit dmbst code*)))
;; Based in part on https://www.cl.cam.ac.uk/~pes20/cpp/cpp0xmappings.html
(define-who asm-fence
(lambda (kind)
(lambda (code*)
(case kind
[(store-store) (emit dmbishst code*)]
[(acquire) (emit dmbish code*)]
[(release) (emit dmbish code*)]
[else (sorry! who "unexpected kind ~s" kind)]))))
(define asm-fp-relop
(lambda (info)

31
s/arm64.ss
View File

@ -822,9 +822,17 @@
`(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
`(asm ,info ,asm-cas ,r ,old ,new ,u1 ,u2)))))]))
(define-instruction effect (write-write-fence)
(define-instruction effect (store-store-fence)
[(op)
`(asm ,info ,asm-write-write-fence)])
`(asm ,info ,(asm-fence 'store-store))])
(define-instruction effect (acquire-fence)
[(op)
`(asm ,info ,(asm-fence 'acquire))])
(define-instruction effect (release-fence)
[(op)
`(asm ,info ,(asm-fence 'release))])
(define-instruction effect (pause)
;; NB: use sqrt or something like that?
@ -870,7 +878,7 @@
asm-rp-header asm-rp-compact-header
asm-indirect-call asm-condition-code
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
asm-lock asm-lock+/- asm-cas asm-write-write-fence
asm-lock asm-lock+/- asm-cas asm-fence
asm-fpop-2 asm-fpsqrt asm-c-simple-call
asm-return asm-c-return asm-size
asm-enter asm-foreign-call asm-foreign-callable
@ -1062,7 +1070,10 @@
(define-op ldxr ldxr-op #b1 `(reg . ,%real-zero))
(define-op stxr ldxr-op #b0)
(define-op dmbst dmb-op #b1110)
(define-op dmbst dmb-op #b1110)
(define-op dmbish dmb-op #b1011)
(define-op dmbishld dmb-op #b1001)
(define-op dmbishst dmb-op #b1010)
(define-op bnei branch-imm-op (ax-cond 'ne))
(define-op beqi branch-imm-op (ax-cond 'eq))
@ -2105,9 +2116,15 @@
(emit cmpi tmp2 0
code*))))))))
(define asm-write-write-fence
(lambda (code*)
(emit dmbst code*)))
;; Based in part on https://www.cl.cam.ac.uk/~pes20/cpp/cpp0xmappings.html
(define-who asm-fence
(lambda (kind)
(lambda (code*)
(case kind
[(store-store) (emit dmbishst code*)]
[(acquire) (emit dmbishld code*)]
[(release) (emit dmbish code*)]
[else (sorry! who "unexpected kind ~s" kind)]))))
(define asm-fp-relop
(lambda (info)

2
s/cmacros.ss
View File

@ -348,7 +348,7 @@
;; ---------------------------------------------------------------------
;; Version and machine types:
(define-constant scheme-version #x0905031F)
(define-constant scheme-version #x09050320)
(define-syntax define-machine-types
(lambda (x)

28
s/cpnanopass.ss
View File

@ -3702,11 +3702,13 @@
,(%inline sll ,e
(immediate ,(fx- (constant char-data-offset) (constant fixnum-offset))))
,(%constant type-char))))
(define add-write-fence
(define add-store-fence
;; A store--store fence should be good enough for safety on a platform that
;; orders load dependencies (which is anything except Alpha)
(lambda (e)
(if-feature pthreads
(constant-case architecture
[(arm32 arm64) `(seq ,(%inline write-write-fence) ,e)]
[(arm32 arm64) `(seq ,(%inline store-store-fence) ,e)]
[else e])
e)))
(define build-dirty-store
@ -3714,8 +3716,8 @@
[(base offset e) (build-dirty-store base %zero offset e)]
[(base index offset e) (build-dirty-store base index offset e
(lambda (base index offset e) `(set! ,(%mref ,base ,index ,offset) ,e))
(lambda (s r) (add-write-fence `(seq ,s ,r))))]
[(base index offset e build-assign build-seq)
(lambda (s r) (add-store-fence `(seq ,s ,r))))]
[(base index offset e build-assign build-barrier-seq)
(if (nanopass-case (L7 Expr) e
[(quote ,d) (ptr->imm d)]
[else #f])
@ -3731,13 +3733,13 @@
(bind #f ([e e])
; eval a second so the address is not live across any calls
(bind #t ([a a])
(build-seq
(build-barrier-seq
(build-assign a %zero 0 e)
(%inline remember ,a))))
(bind #t ([e e])
; eval a second so the address is not live across any calls
(bind #t ([a a])
(build-seq
(build-barrier-seq
(build-assign a %zero 0 e)
`(if ,(%type-check mask-fixnum type-fixnum ,e)
,(%constant svoid)
@ -3750,7 +3752,7 @@
(inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code)))))
(define build-cas-seq
(lambda (cas remember)
(add-write-fence
(add-store-fence
`(if ,cas
(seq ,remember ,(%constant strue))
,(%constant sfalse)))))
@ -6121,6 +6123,18 @@
(define-inline 3 $set-symbol-hash!
; no need for dirty store---e2 should be a fixnum
[(e1 e2) `(set! ,(%mref ,e1 ,(constant symbol-hash-disp)) ,e2)])
(define-inline 2 memory-order-acquire
[() (if-feature pthreads
(constant-case architecture
[(arm32 arm64) (%seq ,(%inline acquire-fence) (quote ,(void)))]
[else `(quote ,(void))])
`(quote ,(void)))])
(define-inline 2 memory-order-release
[() (if-feature pthreads
(constant-case architecture
[(arm32 arm64) (%seq ,(%inline release-fence) (quote ,(void)))]
[else `(quote ,(void))])
`(quote ,(void)))])
(let ()
(define-syntax define-tlc-parameter
(syntax-rules ()

4
s/np-languages.ss
View File

@ -563,7 +563,9 @@
(declare-primitive push-fpmultiple effect #f) ; arm64
(declare-primitive pop-fpmultiple effect #f) ; arm64
(declare-primitive cas effect #f)
(declare-primitive write-write-fence effect #f)
(declare-primitive store-store-fence effect #f)
(declare-primitive acquire-fence effect #f)
(declare-primitive release-fence effect #f)
(declare-primitive < pred #t)
(declare-primitive <= pred #t)

2
s/primdata.ss
View File

@ -1504,6 +1504,8 @@
(maybe-compile-file [sig [(pathname) (pathname pathname) -> (void)]] [flags true])
(maybe-compile-library [sig [(pathname) (pathname pathname) -> (void)]] [flags true])
(maybe-compile-program [sig [(pathname) (pathname pathname) -> (void)]] [flags true])
(memory-order-acquire [sig [() -> (void)]] [flags true])
(memory-order-release [sig [() -> (void)]] [flags true])
(merge [sig [(procedure list list) -> (list)]] [flags true])
(merge! [sig [(procedure list list) -> (list)]] [flags true])
(mkdir [sig [(pathname) (pathname sub-uint) -> (void)]] [flags])

8
s/prims.ss
View File

@ -1167,6 +1167,14 @@
($top-level-bound? s)
($oops '$top-level-bound? "~s is not a symbol" s))))
(define memory-order-acquire
(lambda ()
(memory-order-acquire)))
(define memory-order-release
(lambda ()
(memory-order-release)))
(define-who $bignum-length
(lambda (n)
(unless (bignum? n) ($oops who "~s is not a bignum" n))