don't fold ash in cp0 when the shift is too big

fix also bitwise-arithmetic-shift/-right/-left.

  primdata.ss, cp0.ss, 5_3.ms

original commit: 0b0777912b1aa80cff108dc1d34917bb80875e0b

mats/5_3.ms

@@ -3069,9 +3069,11 @@
    (= (ash 1 -32) 0)
    (= (ash 1 -33) 0)
    (= (ash 1 -96) 0)
-   (= (ash 987239487293874234 -1000) 0)
+   (= (ash 987239487293874234 -900) 0)
-   (= (ash -987239487293874234 -1000) -1)
+   (= (ash 987239487293874234 -1100) 0)
-   (let f ([i -1000])
+   (= (ash -987239487293874234 -900) -1)
+   (= (ash -987239487293874234 -1100) -1)
+   (let f ([i -2000])
      (or (fx= i 0)
          (and (negative? (ash -232342342340033477676766821733948948594358 i))
               (f (fx+ i 1)))))
@@ -3114,9 +3116,11 @@
    (= (bitwise-arithmetic-shift 1 -32) 0)
    (= (bitwise-arithmetic-shift 1 -33) 0)
    (= (bitwise-arithmetic-shift 1 -96) 0)
-   (= (bitwise-arithmetic-shift 987239487293874234 -1000) 0)
+   (= (bitwise-arithmetic-shift 987239487293874234 -900) 0)
-   (= (bitwise-arithmetic-shift -987239487293874234 -1000) -1)
+   (= (bitwise-arithmetic-shift 987239487293874234 -1100) 0)
-   (let f ([i -1000])
+   (= (bitwise-arithmetic-shift -987239487293874234 -900) -1)
+   (= (bitwise-arithmetic-shift -987239487293874234 -1100) -1)
+   (let f ([i -2000])
      (or (fx= i 0)
          (and (negative? (bitwise-arithmetic-shift -232342342340033477676766821733948948594358 i))
               (f (fx+ i 1)))))
@@ -3159,9 +3163,11 @@
    (= (bitwise-arithmetic-shift-right 1 32) 0)
    (= (bitwise-arithmetic-shift-right 1 33) 0)
    (= (bitwise-arithmetic-shift-right 1 96) 0)
-   (= (bitwise-arithmetic-shift-right 987239487293874234 1000) 0)
+   (= (bitwise-arithmetic-shift-right 987239487293874234 900) 0)
-   (= (bitwise-arithmetic-shift-right -987239487293874234 1000) -1)
+   (= (bitwise-arithmetic-shift-right 987239487293874234 1100) 0)
-   (let f ([i -1000])
+   (= (bitwise-arithmetic-shift-right -987239487293874234 900) -1)
+   (= (bitwise-arithmetic-shift-right -987239487293874234 1100) -1)
+   (let f ([i -2000])
      (or (fx= i 0)
          (and (negative? (bitwise-arithmetic-shift-right -232342342340033477676766821733948948594358 (- i)))
               (f (fx+ i 1)))))

s/cp0.ss

@@ -2408,10 +2408,33 @@
       (define-inline 3 (boolean=? symbol=? r6rs:char=? r6rs:char-ci=? r6rs:string=? r6rs:string-ci=?)
         [(arg1 arg2 . arg*) (handle-equality ctxt arg1 (cons arg2 arg*))])
 
-      (define-inline 3 (ash
+      (let ()
-                         bitwise-arithmetic-shift bitwise-arithmetic-shift-left
+        (define (try-fold-ash-op op ctxt x y)
-                         bitwise-arithmetic-shift-right)
+          (let ([xval (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! x))
-        [(x y) (handle-shift 3 ctxt x y)])
+                        [(quote ,d) (and (exact? d) (integer? d) d)]
+                        [else #f])]
+                [yval (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! y))
+                        [(quote ,d) (and (fixnum? d) (fx< -1000 d 1000) d)]
+                        [else #f])])
+            (and xval
+                 yval
+                 (let ([r (guard (c [#t #f]) (op xval yval))])
+                   (when r
+                     (residualize-seq '() (list x y) ctxt)
+                     `(quote ,r))))))
+        (define-syntax define-inline-ash-op
+          (syntax-rules ()
+            [(_ op)
+             (begin
+               (define-inline 2 op
+                 [(x y) (try-fold-ash-op op ctxt x y)])
+               (define-inline 3 op
+                 [(x y) (or (try-fold-ash-op op ctxt x y)
+                            (handle-shift 3 ctxt x y))]))]))
+        (define-inline-ash-op ash)
+        (define-inline-ash-op bitwise-arithmetic-shift)
+        (define-inline-ash-op bitwise-arithmetic-shift-left)
+        (define-inline-ash-op bitwise-arithmetic-shift-right))
 
       (define-inline 3 fxbit-field ; expose internal fx ops for partial optimization
         [(?n ?start ?end)

s/primdata.ss

@@ -28,9 +28,9 @@
   (bitwise-copy-bit [sig [(sint uint bit) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
   (bitwise-bit-field [sig [(sint sub-uint sub-uint) -> (uint)]] [flags arith-op mifoldable discard safeongoodargs])
   (bitwise-copy-bit-field [sig [(sint sub-uint sub-uint sint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
-  (bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs])
+  (bitwise-arithmetic-shift [sig [(sint sint) -> (sint)]] [flags arith-op discard cp02 cp03 safeongoodargs])
-  (bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs])
+  (bitwise-arithmetic-shift-left [sig [(sint uint) -> (sint)]] [flags arith-op discard cp02 cp03 safeongoodargs])
-  (bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op mifoldable discard cp03 safeongoodargs])
+  (bitwise-arithmetic-shift-right [sig [(sint uint) -> (sint)]] [flags arith-op discard cp02 cp03 safeongoodargs])
   (bitwise-rotate-bit-field [sig [(sint sub-uint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
   (bitwise-reverse-bit-field [sig [(sint sub-uint sub-uint) -> (sint)]] [flags arith-op mifoldable discard safeongoodargs])
 )
@@ -1136,7 +1136,7 @@
   (append! [sig [() -> (null)] [(list ... ptr) -> (ptr)]] [flags cp02])
   (apropos [sig [(sub-ptr) (sub-ptr environment) -> (void)]] [flags true])
   (apropos-list [sig [(sub-ptr) (sub-ptr environment) -> (list)]] [flags alloc])
-  (ash [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03])
+  (ash [sig [(sint sint) -> (sint)]] [flags arith-op discard cp02 cp03]) ; can take too long to fold
   (assertion-violationf [sig [(maybe-who string sub-ptr ...) -> (bottom)]] [flags abort-op]) ; 2nd arg is format string
   (asinh [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
   (atanh [sig [(number) -> (number)]] [flags arith-op mifoldable discard])