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

Chez Scheme: fix offset constraints on backend cas and related

Browse Source
This commit is contained in:
Matthew Flatt 2021-05-21 08:26:07 -06:00
parent 35bce0ac20
commit 4140627ed8
6 changed files with 114 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
racket/src/ChezScheme/mats/5_6.ms
View File

@ -1405,7 +1405,10 @@
(error? (vector-cas! vec1 vec1 2 3)) ; not a fixnum (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 (expt 2 100) 2 3)) ; not a fixnum
(error? (vector-cas! vec1 -1 2 3)) ; out of range (error? (vector-cas! vec1 -1 2 3)) ; out of range
(error? (vector-cas! vec1 -2 2 3)) ; out of range
(error? (vector-cas! vec1 5 2 3)) ; out of range (error? (vector-cas! vec1 5 2 3)) ; out of range
(error? (vector-cas! vec1 (expt 2 26) 2 3)) ; out of range
(error? (vector-cas! vec1 (expt 2 40) 2 3)) ; out of range
;; make sure `vector-cas!` works with GC generations: ;; make sure `vector-cas!` works with GC generations:
(begin (begin

3
racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f
View File

@ -4355,7 +4355,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
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!: #(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!: 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!: -1 is not a valid index for #(4 5 3)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: -2 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_6.mo:Expected error in mat vector-cas!: "vector-cas!: 5 is not a valid index for #(4 5 3)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 67108864 is not a valid index for #(4 5 3)".
5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1099511627776 is not a valid index for #(4 5 3)".
5_6.mo:Expected error in mat stencil-vector: "stencil-vector: invalid mask x". 5_6.mo:Expected error in mat stencil-vector: "stencil-vector: invalid mask x".
5_6.mo:Expected error in mat stencil-vector: "stencil-vector: invalid mask -1". 5_6.mo:Expected error in mat stencil-vector: "stencil-vector: invalid mask -1".
5_6.mo:Expected error in mat stencil-vector: "stencil-vector: mask 0 does not match given number of items 1". 5_6.mo:Expected error in mat stencil-vector: "stencil-vector: mask 0 does not match given number of items 1".

24
racket/src/ChezScheme/s/arm32.ss
View File

@ -748,12 +748,20 @@
(with-output-language (L15d Effect) (with-output-language (L15d Effect)
(define add-offset (define add-offset
(lambda (r) (lambda (r)
(if (eqv? (nanopass-case (L15d Triv) w [(immediate ,imm) imm]) 0) (let ([i (nanopass-case (L15d Triv) w [(immediate ,imm) imm])])
(k r) (cond
(let ([u (make-tmp 'u)]) [(eqv? i 0) (k r)]
(seq [(funky12 i)
(let ([u (make-tmp 'u)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,w)) `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,w))
(k u)))))) (k u)))]
[else
(let ([u (make-tmp 'u)])
(seq
`(set! ,(make-live-info) ,u ,w)
`(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,u))
(k u)))]))))
(if (eq? y %zero) (if (eq? y %zero)
(add-offset x) (add-offset x)
(let ([u (make-tmp 'u)]) (let ([u (make-tmp 'u)])
@ -762,7 +770,7 @@
(add-offset u))))))) (add-offset u)))))))
; NB: compiler ipmlements init-lock! and unlock! as 32-bit store of zero ; NB: compiler ipmlements init-lock! and unlock! as 32-bit store of zero
(define-instruction pred (lock!) (define-instruction pred (lock!)
[(op (x ur) (y ur) (w funky12)) [(op (x ur) (y ur) (w imm-constant))
(let ([u (make-tmp 'u)] (let ([u (make-tmp 'u)]
[u2 (make-tmp 'u2)]) [u2 (make-tmp 'u2)])
(values (values
@ -775,7 +783,7 @@
`(asm ,null-info ,asm-lock ,r ,u ,u2))))) `(asm ,null-info ,asm-lock ,r ,u ,u2)))))
`(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))]) `(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))])
(define-instruction effect (locked-incr! locked-decr!) (define-instruction effect (locked-incr! locked-decr!)
[(op (x ur) (y ur) (w funky12)) [(op (x ur) (y ur) (w imm-constant))
(lea->reg x y w (lea->reg x y w
(lambda (r) (lambda (r)
(let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])
@ -784,7 +792,7 @@
`(set! ,(make-live-info) ,u2 (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) (define-instruction effect (cas)
[(op (x ur) (y ur) (w funky12) (old ur) (new ur)) [(op (x ur) (y ur) (w imm-constant) (old ur) (new ur))
(lea->reg x y w (lea->reg x y w
(lambda (r) (lambda (r)
(let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])

24
racket/src/ChezScheme/s/arm64.ss
View File

@ -600,12 +600,20 @@
(with-output-language (L15d Effect) (with-output-language (L15d Effect)
(define add-offset (define add-offset
(lambda (r) (lambda (r)
(if (eqv? (nanopass-case (L15d Triv) w [(immediate ,imm) imm]) 0) (let ([i (nanopass-case (L15d Triv) w [(immediate ,imm) imm])])
(k r) (cond
(let ([u (make-tmp 'u)]) [(eqv? i 0) (k r)]
(seq [(unsigned12? i)
(let ([u (make-tmp 'u)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,w)) `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,w))
(k u)))))) (k u)))]
[else
(let ([u (make-tmp 'u)])
(seq
`(set! ,(make-live-info) ,u ,w)
`(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,u))
(k u)))]))))
(if (eq? y %zero) (if (eq? y %zero)
(add-offset x) (add-offset x)
(let ([u (make-tmp 'u)]) (let ([u (make-tmp 'u)])
@ -614,7 +622,7 @@
(add-offset u))))))) (add-offset u)))))))
;; NB: compiler implements init-lock! and unlock! as word store of zero ;; NB: compiler implements init-lock! and unlock! as word store of zero
(define-instruction pred (lock!) (define-instruction pred (lock!)
[(op (x ur) (y ur) (w unsigned12)) [(op (x ur) (y ur) (w imm-constant))
(let ([u (make-tmp 'u)] (let ([u (make-tmp 'u)]
[u2 (make-tmp 'u2)]) [u2 (make-tmp 'u2)])
(values (values
@ -627,7 +635,7 @@
`(asm ,null-info ,asm-lock ,r ,u ,u2))))) `(asm ,null-info ,asm-lock ,r ,u ,u2)))))
`(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))]) `(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))])
(define-instruction effect (locked-incr! locked-decr!) (define-instruction effect (locked-incr! locked-decr!)
[(op (x ur) (y ur) (w unsigned12)) [(op (x ur) (y ur) (w imm-constant))
(lea->reg x y w (lea->reg x y w
(lambda (r) (lambda (r)
(let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])
@ -636,7 +644,7 @@
`(set! ,(make-live-info) ,u2 (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) (define-instruction effect (cas)
[(op (x ur) (y ur) (w unsigned12) (old ur) (new ur)) [(op (x ur) (y ur) (w imm-constant) (old ur) (new ur))
(lea->reg x y w (lea->reg x y w
(lambda (r) (lambda (r)
(let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])

6
racket/src/ChezScheme/s/ppc32.ss
View File

@ -674,14 +674,14 @@
(k x u)))]))))) (k x u)))])))))
;; compiler implements init-lock! and unlock! as 32-bit store of zero ;; compiler implements init-lock! and unlock! as 32-bit store of zero
(define-instruction pred (lock!) (define-instruction pred (lock!)
[(op (x ur) (y ur) (w shifted-integer16 integer16)) [(op (x ur) (y ur) (w imm-constant))
(lea->reg x y w (lea->reg x y w
(lambda (base index) (lambda (base index)
(values (values
'() '()
`(asm ,info-cc-eq ,(asm-lock info-cc-eq) ,base ,index))))]) `(asm ,info-cc-eq ,(asm-lock info-cc-eq) ,base ,index))))])
(define-instruction effect (locked-incr! locked-decr!) (define-instruction effect (locked-incr! locked-decr!)
[(op (x ur) (y ur) (w shifted-integer16 integer16)) [(op (x ur) (y ur) (w imm-constant))
(lea->reg x y w (lea->reg x y w
(lambda (base index) (lambda (base index)
(let ([u (make-tmp 'u)]) (let ([u (make-tmp 'u)])
@ -689,7 +689,7 @@
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(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) (define-instruction effect (cas)
[(op (x ur) (y ur) (w shifted-integer16 integer16) (old ur) (new ur)) [(op (x ur) (y ur) (w imm-constant) (old ur) (new ur))
(lea->reg x y w (lea->reg x y w
(lambda (base index) (lambda (base index)
(let ([u (make-tmp 'u)]) (let ([u (make-tmp 'u)])

118
racket/src/ChezScheme/s/x86_64.ss
View File

@ -739,58 +739,86 @@
(define-instruction pred (condition-code) (define-instruction pred (condition-code)
[(op) (values '() `(asm ,info ,(asm-condition-code info)))]) [(op) (values '() `(asm ,info ,(asm-condition-code info)))])
(let* ([info-cc-eq (make-info-condition-code 'eq? #f #t)] (let ()
[asm-eq (asm-relop info-cc-eq)]) (define imm->imm32
(define-instruction pred (type-check?) (lambda (y w k)
[(op (x ur mem) (mask imm32 ur) (type imm32 ur)) (nanopass-case (L15d Triv) w
(let ([tmp (make-tmp 'u)]) [(immediate ,imm)
(values (if (real-imm32? imm)
(with-output-language (L15d Effect) (k y w)
(seq (let ([tmp (make-tmp 'u)]
[zero (with-output-language (L15d Triv)
`(immediate 0))])
(with-output-language (L15d Effect)
(seq
`(set! ,(make-live-info) ,tmp ,w)
`(set! ,(make-live-info) ,tmp (asm ,null-info ,asm-add ,tmp ,y))
(k tmp zero)))))])))
(let* ([info-cc-eq (make-info-condition-code 'eq? #f #t)]
[asm-eq (asm-relop info-cc-eq)])
(define-instruction pred (type-check?)
[(op (x ur mem) (mask imm32 ur) (type imm32 ur))
(let ([tmp (make-tmp 'u)])
(values
(with-output-language (L15d Effect)
(seq
`(set! ,(make-live-info) ,tmp ,x) `(set! ,(make-live-info) ,tmp ,x)
`(set! ,(make-live-info) ,tmp (asm ,null-info ,asm-logand ,tmp ,mask)))) `(set! ,(make-live-info) ,tmp (asm ,null-info ,asm-logand ,tmp ,mask))))
`(asm ,info-cc-eq ,asm-eq ,tmp ,type)))]) `(asm ,info-cc-eq ,asm-eq ,tmp ,type)))])
(define-instruction pred (logtest log!test) (define-instruction pred (logtest log!test)
[(op (x mem) (y ur imm32)) [(op (x mem) (y ur imm32))
(values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))] (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))]
[(op (x ur imm32) (y mem)) [(op (x ur imm32) (y mem))
(values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))]
[(op (x imm32) (y ur)) [(op (x imm32) (y ur))
(values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))]
[(op (x ur) (y ur imm32)) [(op (x ur) (y ur imm32))
(values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))]) (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))])
(define-instruction pred (lock!) (define-instruction pred (lock!)
[(op (x ur) (y ur) (w imm32)) [(op (x ur) (y ur) (w imm))
(let ([uts (make-precolored-unspillable 'uts %ts)]) (imm->imm32
(values y w
(nanopass-case (L15d Triv) w (lambda (y w)
[(immediate ,imm) (let ([uts (make-precolored-unspillable 'uts %ts)])
(with-output-language (L15d Effect) (values
(seq (nanopass-case (L15d Triv) w
`(set! ,(make-live-info) ,uts (immediate 1)) [(immediate ,imm)
`(set! ,(make-live-info) ,uts (with-output-language (L15d Effect)
(asm ,info ,asm-exchange ,uts (seq
(mref ,x ,y ,imm uptr)))))]) `(set! ,(make-live-info) ,uts (immediate 1))
`(asm ,info-cc-eq ,asm-eq ,uts (immediate 0))))])) `(set! ,(make-live-info) ,uts
(asm ,info ,asm-exchange ,uts
(mref ,x ,y ,imm uptr)))))])
`(asm ,info-cc-eq ,asm-eq ,uts (immediate 0))))))]))
(define-instruction effect (locked-incr!) (define-instruction effect (locked-incr!)
[(op (x ur) (y ur) (w imm32)) [(op (x ur) (y ur) (w imm))
`(asm ,info ,asm-locked-incr ,x ,y ,w)]) (imm->imm32
y w
(lambda (y w)
`(asm ,info ,asm-locked-incr ,x ,y ,w)))])
(define-instruction effect (locked-decr!) (define-instruction effect (locked-decr!)
[(op (x ur) (y ur) (w imm32)) [(op (x ur) (y ur) (w imm))
`(asm ,info ,asm-locked-decr ,x ,y ,w)]) (imm->imm32
y w
(lambda (y w)
`(asm ,info ,asm-locked-decr ,x ,y ,w)))])
(define-instruction effect (cas) (define-instruction effect (cas)
[(op (x ur) (y ur) (w imm32) (old ur) (new ur)) [(op (x ur) (y ur) (w imm) (old ur) (new ur))
(let ([urax (make-precolored-unspillable 'urax %rax)]) (imm->imm32
(with-output-language (L15d Effect) y w
(seq (lambda (y w)
`(set! ,(make-live-info) ,urax ,old) (let ([urax (make-precolored-unspillable 'urax %rax)])
;; NB: may modify %rax: (with-output-language (L15d Effect)
`(asm ,info ,asm-locked-cmpxchg ,x ,y ,w ,urax ,new))))]) (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) (define-instruction effect (pause)
[(op) `(asm ,info ,asm-pause)]) [(op) `(asm ,info ,asm-pause)])