add custodian-limit guard for expt

The `expt` function, unlike `arithmetic-shift`, did not include a
guard against allocation that should trigger a custodian-limit action.

Closes racket#4684

pkgs/base/info.rkt

@@ -14,7 +14,7 @@
 
 ;; In the Racket source repo, this version should change exactly when
 ;; "racket_version.h" changes:
-(define version "8.9.0.5")
+(define version "8.9.0.6")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-test-core/tests/racket/number.rktl

@@ -3,7 +3,7 @@
 
 (Section 'numbers)
 
-(require racket/extflonum racket/random racket/list)
+(require racket/fixnum racket/extflonum racket/random racket/list)
 
 (define has-single-flonum? (single-flonum-available?))
 (define has-exact-zero-inexact-complex? (not (eq? 'chez-scheme (system-type 'vm))))
@@ -643,6 +643,18 @@
 (test  5.540619075645279e+34 expt  -1.000000000000001 (expt 2 56))
 (test -5.5406190756452855e+34 expt -1.000000000000001 (add1 (expt 2 56)))
 
+(err/rt-test (eval '(expt 2 (expt 2 80))) exn:fail:out-of-memory?)
+(err/rt-test (eval '(expt 1+1i (expt 2 80))) exn:fail:out-of-memory?)
+(err/rt-test (eval '(expt 1/2 (expt 2 80))) exn:fail:out-of-memory?)
+(test 1 expt 1 (expt 2 80))
+(test 1 expt -1 (expt 2 80))
+(test -1 expt -1 (add1 (expt 2 80)))
+(test 1 expt -1 (sub1 (most-positive-fixnum)))
+(test -1 expt -1 (most-positive-fixnum))
+(test 0 expt 0 (expt 2 80))
+(test 0 expt 0 (add1 (expt 2 80)))
+(test 0.0 expt 0.5 (expt 2 80))
+
 (let ()
   (define nrs (list -inf.0 -2.0 -1.0 -0.5 -0.0 0.0 0.5 1.0 2.0 +inf.0))
   (define (neg-even nr) (- (- nr) 1))

racket/src/bc/src/bignum.c

@@ -858,31 +858,67 @@ static Scheme_Object *do_power(const Scheme_Object *a, uintptr_t b)
 
 Scheme_Object *do_big_power(const Scheme_Object *a, const Scheme_Object *b)
 {
-  /* This is really a fancy way of sleeping, because it's only used
-     when b is a bignum, which means that we have no chance of actually
-     reaching the result. But just in case... */
-  Scheme_Object *result, *v[2];
+  if (0) {
+    /* This is only used when b is a bignum, which means that we have
+       no chance of actually reaching the result. */
+    Scheme_Object *result, *v[2];
 
-  result = scheme_make_integer(1);
-  v[1] = scheme_make_integer(-1);
+    result = scheme_make_integer(1);
+    v[1] = scheme_make_integer(-1);
 
-  while (!scheme_is_zero(b)) {
-    if (SCHEME_TRUEP(scheme_odd_p(1, (Scheme_Object **)&b)))
-      result = scheme_bin_mult(a, result);
-    a = scheme_bin_mult(a, a);
+    while (!scheme_is_zero(b)) {
+      if (SCHEME_TRUEP(scheme_odd_p(1, (Scheme_Object **)&b)))
+        result = scheme_bin_mult(a, result);
+      a = scheme_bin_mult(a, a);
+
+      v[0] = (Scheme_Object *)b;
+      b = scheme_bitwise_shift(2, v);
+    }
 
-    v[0] = (Scheme_Object *)b;
-    b = scheme_bitwise_shift(2, v);
+    return result;
   }
 
-  return result;
+  scheme_raise_out_of_memory("expt", NULL);
+
+  return NULL;
 }
 
 
 Scheme_Object *scheme_generic_integer_power(const Scheme_Object *a, const Scheme_Object *b)
 {
   uintptr_t exponent;
 
+  /* assume that b > 0, but a might be 0, -1, or 1, and it might be
+     be a small value like that encoded as a bignum */
+
+  {
+    intptr_t v = 2;
+    if (SCHEME_INTP(a))
+      v = SCHEME_INT_VAL(a);
+    else if (SCHEME_BIGNUMP(a)) {
+      if (SCHEME_BIGLEN(a) == 0)
+        v = 0;
+      else if (SCHEME_BIGLEN(a) == 1) {
+        if (SCHEME_BIGDIG(a)[0] == 1) {
+          if (SCHEME_BIGPOS(a))
+            v = 1;
+          else
+            v = -1;
+        }
+      }
+    }
+    if ((v == 1) || (v == 0))
+      return scheme_make_integer(v);
+    else if (v == -1) {
+      if (SCHEME_INTP(b)) {
+        if (SCHEME_INT_VAL(b) & 0x1)
+          return scheme_make_integer(-1);
+      } else if (SCHEME_BIGDIG(b)[0] & 0x1)
+        return scheme_make_integer(-1);
+      return scheme_make_integer(1);
+    }
+  } 
+
   if (scheme_current_thread->constant_folding) {
     /* if we're trying to fold a constant, limit the work that we're willing to do at compile time */
     GC_CAN_IGNORE const char *too_big = "arguments too big to fold `expt'";

racket/src/bc/src/error.c

@@ -2745,9 +2745,10 @@ void scheme_raise_out_of_memory(const char *where, const char *msg, ...)
 
   scheme_raise_realm_exn(MZEXN_FAIL_OUT_OF_MEMORY,
                          name_len, scheme_primitive_realm, scheme_primitive_realm,
-                         "%s%sout of memory %t",
+                         "%s%sout of memory%s%t",
                          where ? where : "",
                          where ? ": " : "",
+                         (slen > 0) ? " " : "",
                          s, slen);
 }
 

racket/src/cs/chezpart.sls

@@ -52,6 +52,7 @@
                            bitwise-not
                            fllog flatan
                            fxquotient
+                           expt
                            make-flvector flvector-copy
                            vector->pseudo-random-generator
                            vector->pseudo-random-generator!)

racket/src/cs/rumble.sls

@@ -428,6 +428,7 @@
           real->double-flonum
           real->single-flonum
           arithmetic-shift
+          expt
           bitwise-ior
           bitwise-xor
           bitwise-and

racket/src/cs/rumble/foreign.ss

@@ -352,8 +352,8 @@
 (define-syntax-rule (checker who ?) (lambda (for-whom x) (if (? x) x (bad-ctype-value for-whom who x))))
 (define-syntax integer-checker
   (syntax-rules (signed unsigned)
-    [(_ who signed n int?) (checker who (lambda (x) (and (int? x) (<= (- (expt 2 (- n 1))) x  (- (expt 2 (- n 1)) 1)))))]
-    [(_ who unsigned n int?) (checker who (lambda (x) (and (int? x) (<= 0 x  (- (expt 2 n) 1)))))]))
+    [(_ who signed n int?) (checker who (lambda (x) (and (int? x) (<= (- (#%expt 2 (- n 1))) x  (- (#%expt 2 (- n 1)) 1)))))]
+    [(_ who unsigned n int?) (checker who (lambda (x) (and (int? x) (<= 0 x  (- (#%expt 2 n) 1)))))]))
 
 (define-ctype _bool 'boolean 'bool)
 (define-ctype _double 'double 'double (checker who flonum?))

racket/src/cs/rumble/memory.ss

@@ -230,7 +230,7 @@
       ;; Watch out for radiply growing memory use that isn't captured
       ;; fast enough by regularly scheduled event checking because it's
       ;; allocated in large chunks
-      (when (>= (bytes-allocated) trigger-major-gc-allocated)
+      (when (>= (bytes-allocated 0) trigger-major-gc-allocated)
         (set-timer 1)))))
 
 (define (set-incremental-collection-enabled! on?)

racket/src/cs/rumble/number.ss

@@ -69,6 +69,52 @@
       [else
        (#2%bitwise-arithmetic-shift x n)]))))
 
+;; similar to `arithmetic-shift`, we need to guard against
+;; large immediate allocations
+(define-syntax (expt stx)
+  (syntax-case stx ()
+    [(_ x-expr n-expr)
+     #'(let ([x x-expr]
+             [n n-expr])
+         (if (and (fixnum? n)
+                  (#3%fx< n 10000))
+             (#2%expt x n)
+             (general-expt x n)))]
+    [(_ expr ...) #'(general-expt expr ...)]
+    [_ #'general-expt]))
+
+(define general-expt
+  (|#%name|
+   expt
+   (lambda (x n)
+     (cond
+      [(not (number? x))
+       (#2%expt x n)]
+      [(and (fixnum? n)
+            (fxpositive? n)
+            (exact? x))
+       (unless (or (#3%fx< (fxabs n) 10000)
+                   (eqv? x 0)
+                   (eqv? x 1)
+                   (eqv? x -1))
+         (guard-large-allocation 'expt 'number n 1))
+       (#2%expt x n)]
+      [(and (bignum? n)
+            (positive? n)
+            (exact? x)
+            (not (or (eqv? x 0)
+                     (eqv? x 1)
+                     (eqv? x -1))))
+       (raise (|#%app|
+               exn:fail:out-of-memory
+               (error-message->adjusted-string
+                'expt primitive-realm
+                "out of memory"
+                primitive-realm)
+               (current-continuation-marks)))]
+      [else
+       (#2%expt x n)]))))
+
 (define-syntax-rule (define-bitwise op fxop)
   (...
    (define-syntax (op stx)

racket/src/cs/rumble/random.ss

@@ -289,8 +289,8 @@
 (define/who (random-seed k)
   (check who
          :test (and (exact-nonnegative-integer? k)
-                    (<= k (sub1 (expt 2 31))))
-         :contract "(integer-in 0 (sub1 (expt 2 31)))"
+                    (<= k (sub1 (#%expt 2 31))))
+         :contract "(integer-in 0 (sub1 (#%expt 2 31)))"
          k)
   (pseudo-random-generator-seed! (current-pseudo-random-generator) k))
 
@@ -329,7 +329,7 @@
 (define/who (random-seed k)
   (check who
          :test (and (exact-nonnegative-integer? k)
-                    (<= k (sub1 (expt 2 31))))
+                    (<= k (sub1 (#%expt 2 31))))
          :contract "(integer-in 0 (sub1 (expt 2 31)))"
          k)
   (pseudo-random-generator-seed! (current-pseudo-random-generator) k))

racket/src/version/racket_version.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 8
 #define MZSCHEME_VERSION_Y 9
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 5
+#define MZSCHEME_VERSION_W 6
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x