Chez Scheme: fix offset constraints on backend cas and related

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

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".

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)])

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)])

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)])

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)])