From 4140627ed80418fa1bdd7002d9e6cd117c4b87cc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 21 May 2021 08:26:07 -0600 Subject: [PATCH] Chez Scheme: fix offset constraints on backend `cas` and related --- racket/src/ChezScheme/mats/5_6.ms | 3 + .../mats/root-experr-compile-0-f-f-f | 3 + racket/src/ChezScheme/s/arm32.ss | 24 ++-- racket/src/ChezScheme/s/arm64.ss | 24 ++-- racket/src/ChezScheme/s/ppc32.ss | 6 +- racket/src/ChezScheme/s/x86_64.ss | 118 +++++++++++------- 6 files changed, 114 insertions(+), 64 deletions(-) diff --git a/racket/src/ChezScheme/mats/5_6.ms b/racket/src/ChezScheme/mats/5_6.ms index bd4afe218b..6b7f07dd56 100644 --- a/racket/src/ChezScheme/mats/5_6.ms +++ b/racket/src/ChezScheme/mats/5_6.ms @@ -1405,7 +1405,10 @@ (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 -2 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: (begin diff --git a/racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f b/racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f index 321e1b980e..c302b2d51c 100644 --- a/racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f +++ b/racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f @@ -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!: 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!: -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!: 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 -1". 5_6.mo:Expected error in mat stencil-vector: "stencil-vector: mask 0 does not match given number of items 1". diff --git a/racket/src/ChezScheme/s/arm32.ss b/racket/src/ChezScheme/s/arm32.ss index fc719ac739..29758bc9f2 100644 --- a/racket/src/ChezScheme/s/arm32.ss +++ b/racket/src/ChezScheme/s/arm32.ss @@ -748,12 +748,20 @@ (with-output-language (L15d Effect) (define add-offset (lambda (r) - (if (eqv? (nanopass-case (L15d Triv) w [(immediate ,imm) imm]) 0) - (k r) - (let ([u (make-tmp 'u)]) - (seq + (let ([i (nanopass-case (L15d Triv) w [(immediate ,imm) imm])]) + (cond + [(eqv? i 0) (k r)] + [(funky12 i) + (let ([u (make-tmp 'u)]) + (seq `(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) (add-offset x) (let ([u (make-tmp 'u)]) @@ -762,7 +770,7 @@ (add-offset u))))))) ; NB: compiler ipmlements init-lock! and unlock! as 32-bit store of zero (define-instruction pred (lock!) - [(op (x ur) (y ur) (w funky12)) + [(op (x ur) (y ur) (w imm-constant)) (let ([u (make-tmp 'u)] [u2 (make-tmp 'u2)]) (values @@ -775,7 +783,7 @@ `(asm ,null-info ,asm-lock ,r ,u ,u2))))) `(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))]) (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 (lambda (r) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) @@ -784,7 +792,7 @@ `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill)) `(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))]) (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 (lambda (r) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) diff --git a/racket/src/ChezScheme/s/arm64.ss b/racket/src/ChezScheme/s/arm64.ss index 2dae4637b6..c94c597bbc 100644 --- a/racket/src/ChezScheme/s/arm64.ss +++ b/racket/src/ChezScheme/s/arm64.ss @@ -600,12 +600,20 @@ (with-output-language (L15d Effect) (define add-offset (lambda (r) - (if (eqv? (nanopass-case (L15d Triv) w [(immediate ,imm) imm]) 0) - (k r) - (let ([u (make-tmp 'u)]) - (seq + (let ([i (nanopass-case (L15d Triv) w [(immediate ,imm) imm])]) + (cond + [(eqv? i 0) (k r)] + [(unsigned12? i) + (let ([u (make-tmp 'u)]) + (seq `(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) (add-offset x) (let ([u (make-tmp 'u)]) @@ -614,7 +622,7 @@ (add-offset u))))))) ;; NB: compiler implements init-lock! and unlock! as word store of zero (define-instruction pred (lock!) - [(op (x ur) (y ur) (w unsigned12)) + [(op (x ur) (y ur) (w imm-constant)) (let ([u (make-tmp 'u)] [u2 (make-tmp 'u2)]) (values @@ -627,7 +635,7 @@ `(asm ,null-info ,asm-lock ,r ,u ,u2))))) `(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))]) (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 (lambda (r) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) @@ -636,7 +644,7 @@ `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill)) `(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))]) (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 (lambda (r) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) diff --git a/racket/src/ChezScheme/s/ppc32.ss b/racket/src/ChezScheme/s/ppc32.ss index 82bf687983..c2a7f4336b 100644 --- a/racket/src/ChezScheme/s/ppc32.ss +++ b/racket/src/ChezScheme/s/ppc32.ss @@ -674,14 +674,14 @@ (k x u)))]))))) ;; compiler implements init-lock! and unlock! as 32-bit store of zero (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 (lambda (base index) (values '() `(asm ,info-cc-eq ,(asm-lock info-cc-eq) ,base ,index))))]) (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 (lambda (base index) (let ([u (make-tmp 'u)]) @@ -689,7 +689,7 @@ `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(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)) + [(op (x ur) (y ur) (w imm-constant) (old ur) (new ur)) (lea->reg x y w (lambda (base index) (let ([u (make-tmp 'u)]) diff --git a/racket/src/ChezScheme/s/x86_64.ss b/racket/src/ChezScheme/s/x86_64.ss index 06d10ee502..e069e6e0b8 100644 --- a/racket/src/ChezScheme/s/x86_64.ss +++ b/racket/src/ChezScheme/s/x86_64.ss @@ -739,58 +739,86 @@ (define-instruction pred (condition-code) [(op) (values '() `(asm ,info ,(asm-condition-code info)))]) - (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 + (let () + (define imm->imm32 + (lambda (y w k) + (nanopass-case (L15d Triv) w + [(immediate ,imm) + (if (real-imm32? imm) + (k y w) + (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 (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) - [(op (x mem) (y ur imm32)) - (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))] - [(op (x ur imm32) (y mem)) - (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] - [(op (x imm32) (y ur)) - (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] - [(op (x ur) (y ur imm32)) - (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))]) + (define-instruction pred (logtest log!test) + [(op (x mem) (y ur imm32)) + (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))] + [(op (x ur imm32) (y mem)) + (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] + [(op (x imm32) (y ur)) + (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] + [(op (x ur) (y ur imm32)) + (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))]) - (define-instruction pred (lock!) - [(op (x ur) (y ur) (w imm32)) - (let ([uts (make-precolored-unspillable 'uts %ts)]) - (values - (nanopass-case (L15d Triv) w - [(immediate ,imm) - (with-output-language (L15d Effect) - (seq - `(set! ,(make-live-info) ,uts (immediate 1)) - `(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 pred (lock!) + [(op (x ur) (y ur) (w imm)) + (imm->imm32 + y w + (lambda (y w) + (let ([uts (make-precolored-unspillable 'uts %ts)]) + (values + (nanopass-case (L15d Triv) w + [(immediate ,imm) + (with-output-language (L15d Effect) + (seq + `(set! ,(make-live-info) ,uts (immediate 1)) + `(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!) - [(op (x ur) (y ur) (w imm32)) - `(asm ,info ,asm-locked-incr ,x ,y ,w)]) + (define-instruction effect (locked-incr!) + [(op (x ur) (y ur) (w imm)) + (imm->imm32 + y w + (lambda (y w) + `(asm ,info ,asm-locked-incr ,x ,y ,w)))]) - (define-instruction effect (locked-decr!) - [(op (x ur) (y ur) (w imm32)) - `(asm ,info ,asm-locked-decr ,x ,y ,w)]) + (define-instruction effect (locked-decr!) + [(op (x ur) (y ur) (w imm)) + (imm->imm32 + y w + (lambda (y w) + `(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 (cas) + [(op (x ur) (y ur) (w imm) (old ur) (new ur)) + (imm->imm32 + y w + (lambda (y w) + (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)])