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

Merge branch 'cas' of github.com:mflatt/ChezScheme

Browse Source 
original commit: d9a3e7a9906649406673f49c951137db2a94de8c
This commit is contained in:
Matthew Flatt 2017-11-14 11:18:28 -07:00
commit bb1a3b0c45
18 changed files with 396 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
LOG
View File

@ -763,3 +763,9 @@
schlib.c, prim.c, externs.h
mats/foreign4.c, mats/foreign.ms mats/Mf-*
foreign.stex, release_notes.stex
- 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

47
csug/objects.stex
View File

@ -1,4 +1,4 @@
% Copyright 2005-2017 Cisco Systems, Inc.
<% Copyright 2005-2017 Cisco Systems, Inc.
%
% Licensed under the Apache License, Version 2.0 (the "License");
% you may not use this file except in compliance with the License.
@ -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

@ -1190,3 +1190,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

@ -3930,6 +3930,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".
@ -3952,6 +3961,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

@ -3930,6 +3930,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".
@ -3952,6 +3961,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))))
)

25
release_notes/release_notes.stex
View File

@ -58,6 +58,15 @@ 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 struct arguments and results (9.5.1)}
A new \scheme{(& \var{ftype})} form allows a struct or union to be
@ -70,6 +79,14 @@ address. When \scheme{(& \var{ftype})} is used as a result type,
an extra \scheme{(* \var{ftype})} argument must be provided to receive
the copied result, and the directly returned result is unspecified.
\subsection{Ordered guardians (9.5.1)}
The \scheme{make-guardian} function now accepts an optional argument to
indicate whether the guardian is ordered or unordered. A guardian is
unordered by default. An ordered guardian's objects are classified as
inaccessible only when they are not reachable from the represetative
of any inaccessible object in any other guardian.
\subsection{Record equality and hashing (9.5)}
The new procedures \scheme{record-type-equal-procedure} and
@ -90,14 +107,6 @@ procedures.
Immutable boxes are created via \scheme{box-immutable}.
Any attempt to modify an immutable object causes an exception to be raised.
\subsection{Ordered guardians (9.5.1)}
The \scheme{make-guardian} function now accepts an optional argument to
indicate whether the guardian is ordered or unordered. A guardian is
unordered by default. An ordered guardian's objects are classified as
inaccessible only when they are not reachable from the represetative
of any inaccessible object in any other guardian.
\subsection{Ephemeron pairs and hashtables (9.5)}
Support for ephemeron pairs has been added, along with eq and eqv

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

@ -2336,6 +2336,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)
@ -2419,6 +2420,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

@ -522,6 +522,7 @@
(declare-primitive store-single->double effect #f)
(declare-primitive store-with-update effect #f) ; ppc
(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

@ -762,7 +762,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)])
@ -807,7 +815,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
@ -1753,6 +1761,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

@ -1137,6 +1137,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])
@ -1682,6 +1683,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

@ -869,6 +869,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)])
@ -918,7 +927,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
@ -1064,6 +1073,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)
@ -1211,6 +1222,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)
@ -1901,6 +1926,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

@ -925,6 +925,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)])
@ -975,7 +984,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
@ -1113,6 +1122,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
@ -1256,6 +1267,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)
@ -2005,6 +2031,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*)))