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

add box-cas! and vector-cas!

Browse Source 
original commit: a416f68a7a02c777881f4848599deefb120d33ae
This commit is contained in:
Matthew Flatt 2017-11-10 21:01:51 -07:00
parent ee967194d7
commit 8fdf68f10a
18 changed files with 386 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
LOG
View File

@ -971,3 +971,9 @@
bootstrap failures after small changes like the recent change to
procedure names, so we don't have to rebuild the boot files as often.
Mf-base
- added box-cas! and vector-cas!
prims.ss, cpnanopass.ss, np-languages.ss,
cmacros.ss, library.ss, primdata.ss
x86_64.ss x86.ss, ppc32.ss, arm32.ss,
5_6.ms, 5_8.ms, root-experr*,
objects.stex, release_notes.stex

45
csug/objects.stex
View File

@ -651,6 +651,29 @@ See also the description of fixnum-only vectors (fxvectors) below.
v) ;=> #(1 2 73 4 5)
\endschemedisplay
%----------------------------------------------------------------------------
\entryheader
\formdef{vector-cas!}{\categoryprocedure}{(vector-cas! \var{vector} \var{n} \var{old-obj} \var{new-obj})}
\returns \scheme{#t} if \var{vector} is changed, \scheme{#f} otherwise
\listlibraries
\endentryheader
\noindent
\var{vector} must be mutable.
\scheme{vector-cas!} atomically changes the \var{n}th element of \var{vector} to \var{new-obj}
if the replaced \var{n}th element is \scheme{eq?} to \var{old-obj}.
If the \var{n}th element of \var{vector} that would be replaced
is not \scheme{eq?} to \var{old-obj}, then
\var{vector} is unchanged.
\schemedisplay
(define v (vector 'old0 'old1 'old2))
(vector-cas! v 1 'old1 'new1) ;=> #t
(vector-ref v 1) ;=> 'new1
(vector-cas! v 2 'old1 'new2) ;=> #f
(vector-ref v 2) ;=> 'old2
\endschemedisplay
%----------------------------------------------------------------------------
\entryheader
\formdef{mutable-vector?}{\categoryprocedure}{(mutable-vector? \var{obj})}
@ -1260,6 +1283,28 @@ Any attempt to modify an immutable box causes an exception to be raised.
(unbox b))) ;=> 4
\endschemedisplay
%----------------------------------------------------------------------------
\entryheader
\formdef{box-cas!}{\categoryprocedure}{(box-cas! \var{box} \var{old-obj} \var{new-obj})}
\returns \scheme{#t} if \var{box} is changed, \scheme{#f} otherwise
\listlibraries
\endentryheader
\noindent
\var{box} must be mutable.
\scheme{box-cas!} atomically changes the content of \var{box} to \var{new-obj}
if the replaced content is \scheme{eq?} to \var{old-obj}.
If the content of \var{box} that would be replaced is not \scheme{eq?} to \var{old-obj}, then
\var{box} is unchanged.
\schemedisplay
(define b (box 'old))
(box-cas! b 'old 'new) ;=> #t
(unbox b) ;=> 'new
(box-cas! b 'other 'wrong) ;=> #f
(unbox b) ;=> 'new
\endschemedisplay
%----------------------------------------------------------------------------
\entryheader
\formdef{mutable-box?}{\categoryprocedure}{(mutable-box? \var{obj})}

46
mats/5_6.ms
View File

@ -1220,3 +1220,49 @@
(error? (fxvector-set! immutable-123-fxvector 0 1))
(error? (fxvector-fill! immutable-123-fxvector 0))
)
(mat vector-cas!
(begin
(define vec1 (vector 1 2 3))
(define vec2 (vector 'apple 'banana 'coconut))
(eq? 1 (vector-ref vec1 0)))
(not (vector-cas! vec1 0 0 1))
(eq? 1 (vector-ref vec1 0))
(vector-cas! vec1 0 1 4)
(eq? 4 (vector-ref vec1 0))
(not (vector-cas! vec1 0 1 5))
(not (vector-cas! vec1 1 0 1))
(eq? 2 (vector-ref vec1 1))
(vector-cas! vec1 1 2 5)
(eq? 5 (vector-ref vec1 1))
(not (vector-cas! vec2 0 'banana 'donut))
(vector-cas! vec2 0 'apple 'donut)
(not (vector-cas! vec2 0 'apple 'eclair))
(eq? 'donut (vector-ref vec2 0))
(not (vector-cas! vec2 1 'apple 'fig))
(vector-cas! vec2 1 'banana 'fig)
(not (vector-cas! vec2 1 'banana 'grape))
(eq? 'fig (vector-ref vec2 1))
(error? (vector-cas! vec1)) ; arity
(error? (vector-cas! vec1 1)) ; arity
(error? (vector-cas! vec1 1 2)) ; arity
(error? (vector-cas! 1 vec1 2 3)) ; not a vector
(error? (vector-cas! (vector->immutable-vector vec1) 1 2 3)) ; not a mutable vector
(error? (vector-cas! vec1 vec1 2 3)) ; not a fixnum
(error? (vector-cas! vec1 (expt 2 100) 2 3)) ; not a fixnum
(error? (vector-cas! vec1 -1 2 3)) ; out of range
(error? (vector-cas! vec1 5 2 3)) ; out of range
;; make sure `vector-cas!` works with GC generations:
(begin
(collect 0)
(let ([g1 (gensym)])
(and (vector-cas! vec2 2 'coconut g1)
(begin
(collect 0)
(eq? g1 (vector-ref vec2 2))))))
)

34
mats/5_8.ms
View File

@ -30,3 +30,37 @@
(set-box! x 4)
(and (equal? x '#&4) (equal? (unbox x) 4)))
)
(mat box-cas!
(begin
(define bx1 (box 1))
(define bx2 (box 'apple))
(eq? 1 (unbox bx1)))
(not (box-cas! bx1 0 1))
(eq? 1 (unbox bx1))
(box-cas! bx1 1 2)
(eq? 2 (unbox bx1))
(not (box-cas! bx2 #f 'banana))
(box-cas! bx2 'apple 'banana)
(not (box-cas! bx2 'apple 'banana))
(eq? 'banana (unbox bx2))
(not (box-cas! (box (bitwise-arithmetic-shift-left 1 40))
(bitwise-arithmetic-shift-left 2 40)
'wrong))
(error? (box-cas! bx1)) ; arity
(error? (box-cas! bx1 1)) ; arity
(error? (box-cas! 1 bx1 2)) ; not a box
(error? (box-cas! (box-immutable 1) 1 2)) ; not a mutable box
;; make sure `box-cas!` works with GC generations:
(begin
(collect 0)
(let ([g1 (gensym)])
(and (box-cas! bx2 'banana g1)
(begin
(collect 0)
(eq? g1 (unbox bx2))))))
)

13
mats/root-experr-compile-0-f-f-f
View File

@ -3954,6 +3954,15 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
5_6.mo:Expected error in mat vector->immutable-vector: "vector-sort!: #(1 2 3) is not a mutable vector".
5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-set!: #vfx(1 2 3) is not a mutable fxvector".
5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-fill!: #vfx(1 2 3) is not a mutable fxvector".
5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1)".
5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1)".
5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1 2)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1 is not a mutable vector".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a mutable vector".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a valid index for #(4 5 3)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1267650600228229401496703205376 is not a valid index for #(4 5 3)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: -1 is not a valid index for #(4 5 3)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 5 is not a valid index for #(4 5 3)".
5_7.mo:Expected error in mat string->symbol: "string->symbol: 3 is not a string".
5_7.mo:Expected error in mat string->symbol: "string->symbol: a is not a string".
5_7.mo:Expected error in mat gensym: "gensym: #(a b c) is not a string".
@ -3976,6 +3985,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
5_7.mo:Expected error in mat putprop-getprop: "getprop: 3 is not a symbol".
5_7.mo:Expected error in mat putprop-getprop: "putprop: "hi" is not a symbol".
5_7.mo:Expected error in mat putprop-getprop: "property-list: (a b c) is not a symbol".
5_8.mo:Expected error in mat box-cas!: "incorrect argument count in call (box-cas! bx1)".
5_8.mo:Expected error in mat box-cas!: "incorrect argument count in call (box-cas! bx1 1)".
5_8.mo:Expected error in mat box-cas!: "box-cas!: 1 is not a mutable box".
5_8.mo:Expected error in mat box-cas!: "box-cas!: #&1 is not a mutable box".
6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory".
6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory".
6.mo:Expected error in mat port-operations: "open-output-file: failed for /nonexistent/directory/nonexistent/file: no such file or directory".

13
mats/root-experr-compile-2-f-f-f
View File

@ -3954,6 +3954,15 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
5_6.mo:Expected error in mat vector->immutable-vector: "vector-sort!: #(1 2 3) is not a mutable vector".
5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-set!: #vfx(1 2 3) is not a mutable fxvector".
5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-fill!: #vfx(1 2 3) is not a mutable fxvector".
5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1)".
5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1)".
5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1 2)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1 is not a mutable vector".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a mutable vector".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a valid index for #(4 5 3)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1267650600228229401496703205376 is not a valid index for #(4 5 3)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: -1 is not a valid index for #(4 5 3)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 5 is not a valid index for #(4 5 3)".
5_7.mo:Expected error in mat string->symbol: "string->symbol: 3 is not a string".
5_7.mo:Expected error in mat string->symbol: "string->symbol: a is not a string".
5_7.mo:Expected error in mat gensym: "gensym: #(a b c) is not a string".
@ -3976,6 +3985,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
5_7.mo:Expected error in mat putprop-getprop: "getprop: 3 is not a symbol".
5_7.mo:Expected error in mat putprop-getprop: "putprop: "hi" is not a symbol".
5_7.mo:Expected error in mat putprop-getprop: "property-list: (a b c) is not a symbol".
5_8.mo:Expected error in mat box-cas!: "incorrect argument count in call (box-cas! bx1)".
5_8.mo:Expected error in mat box-cas!: "incorrect argument count in call (box-cas! bx1 1)".
5_8.mo:Expected error in mat box-cas!: "box-cas!: 1 is not a mutable box".
5_8.mo:Expected error in mat box-cas!: "box-cas!: #&1 is not a mutable box".
6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory".
6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory".
6.mo:Expected error in mat port-operations: "open-output-file: failed for /nonexistent/directory/nonexistent/file: no such file or directory".

36
mats/thread.ms
View File

@ -1486,4 +1486,40 @@
(equal? (condition-irritants c) (list 'a)))])
(p 'a)))
)
(mat cas
(begin
(define (check container container-ref container-cas!)
(let ([N 1000]
[M 4]
[done 0]
[m (make-mutex)]
[c (make-condition)])
(define (bump)
(let loop ([i 0])
(unless (= i N)
(let ([v (container-ref container)])
(if (container-cas! container v (add1 v))
(loop (add1 i))
(loop i)))))
(mutex-acquire m)
(set! done (add1 done))
(condition-signal c)
(mutex-release m))
(let loop ([j 0])
(when (< j M)
(fork-thread bump)
(loop (add1 j))))
(mutex-acquire m)
(let loop ()
(cond
[(= done M)
(mutex-release m)]
[else
(condition-wait c m)
(loop)]))
(= (container-ref container) (* M N))))
(check (box 0) unbox box-cas!))
(check (vector 1 0 2) (lambda (v) (vector-ref v 1)) (lambda (v o n) (vector-cas! v 1 o n))))
)

8
release_notes/release_notes.stex
View File

@ -58,6 +58,14 @@ Online versions of both books can be found at
%-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality}
\subsection{Atomic compare-and-set (9.5.1)}
The new procedures \scheme{box-cas!} and \scheme{vector-cas!}
atomically update a box or vector with a given new value when the
current content is \scheme{eq?} to a given old value. Atomicity is
guaranteed even if multiple threads attempt to update the same box or
vector.
\subsection{Foreign-procedure thread activation (9.5.1)}
A new \scheme{__collect_safe} foreign-procedure convention, which can

29
s/arm32.ss
View File

@ -845,7 +845,16 @@
(seq
`(set! ,(make-live-info) ,u1 (asm ,null-info ,asm-kill))
`(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
`(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))]))
`(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))])
(define-instruction effect (cas)
[(op (x ur) (y ur) (w funky12) (old ur) (new ur))
(lea->reg x y w
(lambda (r)
(let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])
(seq
`(set! ,(make-live-info) ,u1 (asm ,null-info ,asm-kill))
`(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
`(asm ,info ,asm-cas ,r ,old ,new ,u1 ,u2)))))]))
(define-instruction effect (pause)
; NB: user sqrt or something like that?
@ -888,7 +897,7 @@
asm-indirect-call asm-condition-code
asm-fl-load/store
asm-fl-load/cvt asm-fl-store/cvt asm-flt asm-trunc
asm-lock asm-lock+/-
asm-lock asm-lock+/- asm-cas
asm-flop-2 asm-flsqrt 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
@ -1956,6 +1965,22 @@
[(locked-decr!) (emit subi #f tmp1 tmp1 1 code*)]
[else (sorry! who "unexpected op ~s" op)])))))))
(define-who asm-cas
; tmp = ldrex src
; cmp tmp, old
; bne L (+2)
; tmp2 = strex new, src
; cmp tmp2, 0
; L:
(lambda (code* src old new tmp1 tmp2)
(Trivit (src old new tmp1 tmp2)
(emit ldrex tmp1 src
(emit cmp tmp1 old
(emit bnei 1
(emit strex tmp2 new src
(emit cmpi tmp2 0
code*))))))))
(define asm-fl-relop
(lambda (info)
(lambda (l1 l2 offset x y)

2
s/cmacros.ss
View File

@ -2340,6 +2340,7 @@
(cdr #f 1 #t #t)
(unbox #f 1 #t #t)
(set-box! #f 2 #t #t)
(box-cas! #f 3 #t #t)
(= #f 2 #f #t)
(< #f 2 #f #t)
(> #f 2 #f #t)
@ -2423,6 +2424,7 @@
(map2 #f 3 #f #t)
(for-each1 #f 2 #f #t)
(vector-ref #f 2 #t #t)
(vector-cas! #f 4 #t #t)
(vector-set! #f 3 #t #t)
(vector-length #f 1 #t #t)
(string-ref #f 2 #t #t)

55
s/cpnanopass.ss
View File

@ -2974,11 +2974,14 @@
(define build-dirty-store
(case-lambda
[(base offset e) (build-dirty-store base %zero offset e)]
[(base index 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) `(seq ,s ,r)))]
[(base index offset e build-assign build-seq)
(if (nanopass-case (L7 Expr) e
[(quote ,d) (ptr->imm d)]
[else #f])
`(set! ,(%mref ,base ,index ,offset) ,e)
(build-assign base index offset e)
(let ([a (if (eq? index %zero)
(%lea ,base offset)
(%lea ,base ,index offset))])
@ -2990,17 +2993,28 @@
(bind #f ([e e])
; eval a second so the address is not live across any calls
(bind #t ([a a])
`(seq
(set! ,(%mref ,a 0) ,e)
,(%inline remember ,a))))
(build-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])
`(seq
(set! ,(%mref ,a 0) ,e)
(if ,(%type-check mask-fixnum type-fixnum ,e)
(build-seq
(build-assign a %zero 0 e)
`(if ,(%type-check mask-fixnum type-fixnum ,e)
,(%constant svoid)
,(%inline remember ,a))))))))]))
(define make-build-cas
(lambda (old-v)
(lambda (base index offset v)
`(seq
,(%inline cas ,base ,index (immediate ,offset) ,old-v ,v)
(inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code)))))
(define build-cas-seq
(lambda (cas remember)
`(if ,cas
(seq ,remember ,(%constant strue))
,(%constant sfalse))))
(define build-$record
(lambda (tag args)
(bind #f (tag)
@ -5063,6 +5077,10 @@
[(e1 e2) (build-dirty-store e1 (constant pair-cdr-disp) e2)])
(define-inline 3 set-box!
[(e1 e2) (build-dirty-store e1 (constant box-ref-disp) e2)])
(define-inline 3 box-cas!
[(e1 e2 e3)
(bind #t (e2)
(build-dirty-store e1 %zero (constant box-ref-disp) e3 (make-build-cas e2) build-cas-seq))])
(define-inline 3 $set-symbol-name!
[(e1 e2) (build-dirty-store e1 (constant symbol-name-disp) e2)])
(define-inline 3 $set-symbol-property-list!
@ -5079,6 +5097,12 @@
`(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box)
,(build-dirty-store e-box (constant box-ref-disp) e-new)
,(build-libcall #t src sexpr set-box! e-box e-new)))])
(define-inline 2 box-cas!
[(e-box e-old e-new)
(bind #t (e-box e-old e-new)
`(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box)
,(build-dirty-store e-box %zero (constant box-ref-disp) e-new (make-build-cas e-old) build-cas-seq)
,(build-libcall #t src sexpr box-cas! e-box e-old e-new)))])
(define-inline 2 set-car!
[(e-pair e-new)
(bind #t (e-pair e-new)
@ -7884,6 +7908,21 @@
,(build-libcall #t src sexpr vector-set! e-v e-i e-new)))])
(define-inline 3 $vector-set-immutable!
[(e-fv) ((build-set-immutable! vector-type-disp vector-immutable-flag) e-fv)]))
(let ()
(define (go e-v e-i e-old e-new)
(nanopass-case (L7 Expr) e-i
[(quote ,d)
(guard (target-fixnum? d))
(build-dirty-store e-v %zero (+ (fix d) (constant vector-data-disp)) e-new (make-build-cas e-old) build-cas-seq)]
[else (build-dirty-store e-v e-i (constant vector-data-disp) e-new (make-build-cas e-old) build-cas-seq)]))
(define-inline 3 vector-cas!
[(e-v e-i e-old e-new) (go e-v e-i e-old e-new)])
(define-inline 2 vector-cas!
[(e-v e-i e-old e-new)
(bind #t (e-v e-i e-old e-new)
`(if ,(build-vector-set!-check e-v e-i #f)
,(go e-v e-i e-old e-new)
,(build-libcall #t src sexpr vector-cas! e-v e-i e-old e-new)))]))
(let ()
(define (go e-v e-i e-new)
`(set!

8
s/library.ss
View File

@ -304,6 +304,11 @@
(define-library-entry (vector-length v)
(vector-oops 'vector-length v))
(define-library-entry (vector-cas! v i old-x new-x)
(if (mutable-vector? v)
(index-oops 'vector-cas! v i)
(mutable-vector-oops 'vector-cas! v)))
(define-library-entry (fxvector-ref v i)
(if (fxvector? v)
(index-oops 'fxvector-ref v i)
@ -416,6 +421,9 @@
(define-library-entry (set-box! b v)
($oops 'set-box! "~s is not a mutable box" b))
(define-library-entry (box-cas! b old-v new-v)
($oops 'box-cas! "~s is not a mutable box" b))
(let ()
(define (fxnonfixnum1 who x)
($oops who "~s is not a fixnum" x))

1
s/np-languages.ss
View File

@ -520,6 +520,7 @@
(declare-primitive store-with-update effect #f) ; ppc
(declare-primitive unactivate-thread effect #f) ; threaded version only
(declare-primitive vpush-multiple effect #f) ; arm
(declare-primitive cas effect #f)
(declare-primitive < pred #t)
(declare-primitive <= pred #t)

27
s/ppc32.ss
View File

@ -786,7 +786,15 @@
(let ([u (make-tmp 'u)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
`(asm ,null-info ,(asm-lock+/- op) ,base ,index ,u)))))]))
`(asm ,null-info ,(asm-lock+/- op) ,base ,index ,u)))))])
(define-instruction effect (cas)
[(op (x ur) (y ur) (w shifted-integer16 integer16) (old ur) (new ur))
(lea->reg x y w
(lambda (base index)
(let ([u (make-tmp 'u)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
`(asm ,info ,asm-cas ,base ,index ,old ,new ,u)))))]))
(define-instruction effect (pause)
[(op) `(asm ,info ,asm-isync)])
@ -831,7 +839,7 @@
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header
asm-indirect-call asm-condition-code
asm-trunc asm-flt
asm-lock asm-lock+/-
asm-lock asm-lock+/- asm-cas
asm-fl-load/store
asm-flop-2 asm-c-simple-call
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
@ -1777,6 +1785,21 @@
(emit bne -3
(emit cmpi tmp `(imm 0) code*))))))))))
(define-who asm-cas
; tmp = lwarx [base,index]
; cmp tmp, old
; bc (ne) L 2
; stwcx. new [base,index] -- also sets condition code
; L:
(lambda (code* base index old new tmp)
(assert (not (eq? tmp %real-zero)))
(Trivit (base index old new tmp)
(emit lwarx tmp base index
(emit cmpl tmp old
(emit bne 2
(emit stwcx. new base index
code*)))))))
(define asm-fl-relop
(lambda (info)
(lambda (l1 l2 offset x y)

2
s/primdata.ss
View File

@ -1140,6 +1140,7 @@
(block-write [sig [(textual-output-port string) (textual-output-port string length) -> (void)]] [flags true])
(box [sig [(ptr) -> (box)]] [flags unrestricted alloc])
(box? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(box-cas! [sig [(box ptr ptr) -> (boolean)]] [flags])
(box-immutable [sig [(ptr) -> (box)]] [flags unrestricted alloc])
(break [sig [(ptr ...) -> (ptr ...)]] [flags])
(bwp-object? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
@ -1686,6 +1687,7 @@
(utf-16-codec [sig [() -> (codec)] [(sub-symbol) -> (codec)]] [flags pure true]) ; has optional eness argument
(utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true])
(utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true])
(vector-cas! [sig [(vector sub-index ptr ptr) -> (boolean)]] [flags])
(vector-copy [sig [(vector) -> (vector)]] [flags alloc])
(vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc])
(vector-set-fixnum! [sig [(vector sub-index fixnum) -> (void)]] [flags true])

10
s/prims.ss
View File

@ -1070,6 +1070,10 @@
(lambda (v i x)
(#2%vector-set! v i x)))
(define vector-cas!
(lambda (v i old-x new-x)
(#2%vector-cas! v i old-x new-x)))
(define vector-set-fixnum!
(lambda (v i x)
(#2%vector-set-fixnum! v i x)))
@ -1148,6 +1152,12 @@
(set-box! b v)
($oops 'set-box! "~s is not a mutable box" b))))
(define-who box-cas!
(lambda (b old-v new-v)
(if (mutable-box? b)
(box-cas! b old-v new-v)
($oops who "~s is not a mutable box" b))))
(define mutable-box?
(lambda (b)
(#3%mutable-box? b)))

32
s/x86.ss
View File

@ -882,6 +882,15 @@
[(op (x ur) (y ur) (w imm32))
`(asm ,info ,asm-locked-decr ,x ,y ,w)])
(define-instruction effect (cas)
[(op (x ur) (y ur) (w imm32) (old ur) (new ur))
(let ([ueax (make-precolored-unspillable 'ueax %eax)])
(with-output-language (L15d Effect)
(seq
`(set! ,(make-live-info) ,ueax ,old)
;; NB: may modify %eax:
`(asm ,info ,asm-locked-cmpxchg ,x ,y ,w ,ueax ,new))))])
(define-instruction effect (pause)
[(op) `(asm ,info ,asm-pause)])
@ -931,7 +940,7 @@
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header
asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code
asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div
asm-exchange asm-pause asm-locked-incr asm-locked-decr
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
asm-flop-2 asm-flsqrt 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
@ -1077,6 +1086,8 @@
(define-op locked-dec (b *) locked-unary-op #b1111111 #b001)
(define-op locked-inc (b *) locked-unary-op #b1111111 #b000)
(define-op locked-cmpxchg (*) locked-cmpxchg-op)
; also do inc-reg dec-reg
(define-op call jump-op #b010)
@ -1224,6 +1235,20 @@
(ax-ea-sib dest-ea)
(ax-ea-addr-disp dest-ea))))
(define locked-cmpxchg-op
(lambda (op size dest-ea new-reg code*)
(begin
(emit-code (op dest-ea new-reg code*)
(build byte #xf0) ; lock prefix
(build byte #x0f)
(build byte
(byte-fields
[1 #b1011000]
[0 (ax-size-code size)]))
(ax-ea-modrm-reg dest-ea new-reg)
(ax-ea-sib dest-ea)
(ax-ea-addr-disp dest-ea)))))
(define pushil-op
(lambda (op imm-ea code*)
(if (ax-range? -128 imm-ea 127)
@ -1914,6 +1939,11 @@
(let ([dest (build-mem-opnd base index offset)])
(emit locked-dec dest code*))))
(define asm-locked-cmpxchg
(lambda (code* base index offset old-v new-v)
(let ([dest (build-mem-opnd base index offset)])
(emit locked-cmpxchg dest (cons 'reg new-v) code*))))
(define asm-pause
(lambda (code*)
(emit pause code*)))

33
s/x86_64.ss
View File

@ -939,6 +939,15 @@
[(op (x ur) (y ur) (w imm32))
`(asm ,info ,asm-locked-decr ,x ,y ,w)])
(define-instruction effect (cas)
[(op (x ur) (y ur) (w imm32) (old ur) (new ur))
(let ([urax (make-precolored-unspillable 'urax %rax)])
(with-output-language (L15d Effect)
(seq
`(set! ,(make-live-info) ,urax ,old)
;; NB: may modify %rax:
`(asm ,info ,asm-locked-cmpxchg ,x ,y ,w ,urax ,new))))])
(define-instruction effect (pause)
[(op) `(asm ,info ,asm-pause)])
@ -989,7 +998,7 @@
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header
asm-lea1 asm-lea2 asm-indirect-call asm-condition-code
asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div
asm-exchange asm-pause asm-locked-incr asm-locked-decr
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
asm-flop-2 asm-flsqrt 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
@ -1127,6 +1136,8 @@
(define-op locked-dec (#;b *) locked-unary-op #b1111111 #b001)
(define-op locked-inc (#;b *) locked-unary-op #b1111111 #b000)
(define-op locked-cmpxchg (*) locked-cmpxchg-op)
; also do inc-reg dec-reg
; the following are forms of the call instruction and push the return address
@ -1270,6 +1281,21 @@
(ax-ea-sib dest-ea)
(ax-ea-addr-disp dest-ea))))
(define locked-cmpxchg-op
(lambda (op size dest-ea new-reg code*)
(begin
(emit-code (op dest-ea new-reg code*)
(build byte #xf0) ; lock prefix
(ax-ea-rex (if (eq? size 'quad) 1 0) dest-ea new-reg size)
(build byte #x0f)
(build byte
(byte-fields
[1 #b1011000]
[0 (ax-size-code size)]))
(ax-ea-modrm-reg dest-ea new-reg)
(ax-ea-sib dest-ea)
(ax-ea-addr-disp dest-ea)))))
(define pushi-op
(lambda (op imm-ea code*)
(if (ax-range? -128 imm-ea 127)
@ -2019,6 +2045,11 @@
(let ([dest (build-mem-opnd base index offset)])
(emit locked-dec dest code*))))
(define asm-locked-cmpxchg
(lambda (code* base index offset old-v new-v)
(let ([dest (build-mem-opnd base index offset)])
(emit locked-cmpxchg dest (cons 'reg new-v) code*))))
(define asm-pause
(lambda (code*)
(emit pause code*)))