From 848d2148b084e67ac6909cca4f1918271ee38207 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 18 Jan 2020 09:45:41 -0700
Subject: [PATCH] cs: cooperate with improved cross-library inlining

An improvement to Chez Scheme allows more function from the Rumble and
other built-in layers to be inlined into compiled Racket code, and a
new `$app/no-inline` primitive enables improved control over how slow
paths are integrated.
---
 pkgs/base/info.rkt                      |   2 +-
 racket/src/cs/README.txt                |  52 +++++++
 racket/src/cs/bootstrap/make-boot.rkt   |   2 +
 racket/src/cs/bootstrap/primdata.rkt    |   3 +-
 racket/src/cs/bootstrap/scheme-lang.rkt |  37 +++--
 racket/src/cs/compile-file.ss           |   2 +-
 racket/src/cs/rumble/begin0.ss          |   3 +-
 racket/src/cs/rumble/box.ss             | 102 +++++++-------
 racket/src/cs/rumble/impersonator.ss    |   6 +
 racket/src/cs/rumble/inline.ss          |   2 +-
 racket/src/cs/rumble/procedure.ss       |   5 +-
 racket/src/cs/rumble/vector.ss          | 179 ++++++++++++------------
 racket/src/racket/src/schvers.h         |   2 +-
 13 files changed, 240 insertions(+), 157 deletions(-)

diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt
index cca96f5449..d1bbdd1a86 100644
--- a/pkgs/base/info.rkt
+++ b/pkgs/base/info.rkt
@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.6.0.3")
+(define version "7.6.0.4")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))
diff --git a/racket/src/cs/README.txt b/racket/src/cs/README.txt
index 02f027b0cf..a540218a7b 100644
--- a/racket/src/cs/README.txt
+++ b/racket/src/cs/README.txt
@@ -539,3 +539,55 @@ configuration:
    Effectiveness: Avoids improvement to stack traces, but also avoids
    increases load time and memory use of Racket programs by as much as
    50%.
+
+Inlining Expectations
+---------------------
+
+Chez Scheme will inline small Rumble functions as long as the inlined
+function body refers only to primitives and other identifiers that are
+explicitly defined in the Rumble library body. The "explicily defined"
+part can be tricky, particularly since inling will consider the
+function body after other inlining is already applied. For example,
+given
+
+  (define (list? v)
+    (or (null? v)
+        (and (pair? v)
+             (slow-list? v))))
+
+  (define (slow-list? v)
+    (let loop ([v v] [depth 0])
+      ....))
+
+then `list?` probably will not be inlined, because the call to
+`slow-list?` within `list?` is likely to be inlined, so that `list?`
+ends up calling the `loop` function nested within `slow-list?` (and
+`loop` is not defined at the level of the library body).
+
+The `$app/no-inline` primitive is useful to prevent unproductive
+inlining, particularly to enable other, productive inlining. For
+example,
+
+  (define (list? v)
+    (or (null? v)
+        (and (pair? v)
+             (#%$app/no-inline slow-list? v))))
+
+is likely to make `list?` inlinable, since the reference to
+`slow-list?` is preserved.
+
+Chez Scheme will inline small Rumble functions independent of the
+amount of inlining that has already happened at the call site of the
+Rumble function. To prevent code explosion and endless inlining
+cycles, however, it will not perform further inlining of a Rumble
+function that is referenced by code introduced by inlining another
+Rumble function.
+
+Using a macro to force inlining can be ok, but that technique should
+be used sparingly. Note that a reference to a primitive in a macro
+will be compiled as a safe reference to the primitive, since the
+conversion of a primitive reference to unsafe or not based on
+`(optimize-level)` is an expansion-time operation. So, macros that are
+meant to expand to uses of unsafe operations should refer to the
+operations using `#3%`; beware that such a reference will stay unsafe,
+even if `UNSAFE_COMP` is disabled in the makefile.
diff --git a/racket/src/cs/bootstrap/make-boot.rkt b/racket/src/cs/bootstrap/make-boot.rkt
index ed09e24d50..d9b3153ccb 100644
--- a/racket/src/cs/bootstrap/make-boot.rkt
+++ b/racket/src/cs/bootstrap/make-boot.rkt
@@ -174,6 +174,8 @@
        [`(eval-when ,_ (define ,m . ,rhs))
         (when (define-for-syntax? m)
           (orig-eval `(begin-for-syntax (define ,m . ,rhs))))]
+       [`(define-flags . ,_)
+        (orig-eval e)]
        [_ (void)])))
 
   (set-current-expand-set-callback!
diff --git a/racket/src/cs/bootstrap/primdata.rkt b/racket/src/cs/bootstrap/primdata.rkt
index f1cc739854..5e10b11c65 100644
--- a/racket/src/cs/bootstrap/primdata.rkt
+++ b/racket/src/cs/bootstrap/primdata.rkt
@@ -75,8 +75,7 @@
                                                            sigs
                                                            (map sig->interface sigs)))]))])
            (loop))))))
-  (values flags->bits
-          (lambda () (list->vector (hash-keys priminfos)))
+  (values (lambda () (list->vector (hash-keys priminfos)))
           (lambda (sym) (hash-ref priminfos sym #f))))
 
 (define (sig->interface sig)
diff --git a/racket/src/cs/bootstrap/scheme-lang.rkt b/racket/src/cs/bootstrap/scheme-lang.rkt
index bc3d104720..e864f9b983 100644
--- a/racket/src/cs/bootstrap/scheme-lang.rkt
+++ b/racket/src/cs/bootstrap/scheme-lang.rkt
@@ -1,5 +1,6 @@
 #lang racket/base
-(require (for-syntax racket/base)
+(require (for-syntax racket/base
+                     racket/match)
          (prefix-in r: racket/include)
          racket/fixnum
          racket/vector
@@ -42,7 +43,7 @@
          letrec*
          putprop getprop remprop
          $sputprop $sgetprop $sremprop
-         prim-mask
+         define-flags
          $primitive
          $tc $tc-field $thread-tc
          enumerate
@@ -591,15 +592,33 @@
                                                            (lambda lhs (values . flat-lhs)))])]))])
        #'(let-values ([lhs rhs] ...) body ...))]))
 
-(define-values (prim-flags->bits primvec get-priminfo)
+(define-values (primvec get-priminfo)
   (get-primdata $sputprop scheme-dir))
 
-(define-syntax prim-mask
-  (syntax-rules (or)
-    [(_ (or flag ...))
-     (prim-flags->bits '(flag ...))]
-    [(_ flag)
-     (prim-flags->bits '(flag))]))
+(begin-for-syntax
+  (define (make-flags->bits specs)
+    (define bits
+      (for/fold ([bits #hasheq()]) ([spec (in-list specs)])
+        (define (get-val v)
+          (if (number? v) v (hash-ref bits v)))
+        (match spec
+          [`(,name (or ,vals ...))
+           (hash-set bits name (apply bitwise-ior (map get-val vals)))]
+          [`(,name ,val)
+           (hash-set bits name (get-val val))])))
+    (lambda (flags)
+      (apply bitwise-ior (for/list ([flag (in-list flags)])
+                           (hash-ref bits flag))))))
+
+(define-syntax (define-flags stx)
+  (syntax-case stx ()
+    [(_ name spec ...)
+     #'(define-syntax name
+         (let ([flags->bits (make-flags->bits '(spec ...))])
+           (lambda (stx)
+             (syntax-case stx (or)
+               [(_ . flags)
+                (flags->bits 'flags)]))))]))
 
 (define-syntax $primitive
   (syntax-rules ()
diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss
index dc8a6dab30..49626e6cd3 100644
--- a/racket/src/cs/compile-file.ss
+++ b/racket/src/cs/compile-file.ss
@@ -2,7 +2,7 @@
 ;; Check to make we're using a build of Chez Scheme
 ;; that has all the features we need.
 (define-values (need-maj need-min need-sub need-dev)
-  (values 9 5 3 12))
+  (values 9 5 3 13))
 
 (unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
   (error 'compile-file
diff --git a/racket/src/cs/rumble/begin0.ss b/racket/src/cs/rumble/begin0.ss
index caefc8ed2e..b139ad5db8 100644
--- a/racket/src/cs/rumble/begin0.ss
+++ b/racket/src/cs/rumble/begin0.ss
@@ -11,6 +11,5 @@
        (lambda (l apply?)
          expr ...
          (if apply?
-             (#%apply values l)
+             (#3%apply values l)
              l)))]))
-
diff --git a/racket/src/cs/rumble/box.ss b/racket/src/cs/rumble/box.ss
index ba6b8a4d4e..bd46b4bcc5 100644
--- a/racket/src/cs/rumble/box.ss
+++ b/racket/src/cs/rumble/box.ss
@@ -17,7 +17,7 @@
 (define (unbox b)
   (if (#%box? b)
       (#3%unbox b)
-      (impersonate-unbox b)))
+      (#%$app/no-inline impersonate-unbox b)))
 
 (define (unsafe-unbox b)
   ;; must handle impersonators
@@ -26,7 +26,10 @@
 (define/who (unbox* b)
   (if (#%box? b)
       (#3%unbox b)
-      (bad-box*-op who #f b)))
+      (#%$app/no-inline bad-unbox* b)))
+
+(define (bad-unbox* b)
+  (bad-box*-op 'unbox* #f b))
 
 (define (bad-box*-op who set? b)
   (raise-argument-error who
@@ -38,7 +41,7 @@
 (define (set-box! b v)
   (if (#%mutable-box? b)
       (#3%set-box! b v)
-      (impersonate-set-box! b v)))
+      (#%$app/no-inline impersonate-set-box! b v)))
 
 (define (unsafe-set-box! b v)
   ;; must handle impersonators
@@ -47,7 +50,10 @@
 (define/who (set-box*! b v)
   (if (#%mutable-box? b)
       (#3%set-box! b v)
-      (bad-box*-op who #t b)))
+      (#%$app/no-inline bad-set-box*! b)))
+
+(define (bad-set-box*! b)
+  (bad-box*-op 'set-box*! #t b))
 
 ;; in schemified:
 (define (unbox/check-undefined b name)
@@ -83,53 +89,51 @@
     (make-box-impersonator val b props ref set)))
 
 (define (impersonate-unbox orig)
-  (pariah
-   (if (and (impersonator? orig)
-            (#%box? (impersonator-val orig)))
-       (let loop ([o orig])
-         (cond
-          [(#%box? o) (#%unbox o)]
-          [(box-chaperone? o)
-           (let* ([val (loop (impersonator-next o))]
-                  [new-val (|#%app| (box-chaperone-ref o) o val)])
-             (unless (chaperone-of? new-val val)
-               (raise-arguments-error 'unbox
-                                      "chaperone produced a result that is not a chaperone of the original result"
-                                      "chaperone result" new-val
-                                      "original result" val))
-             new-val)]
-          [(box-impersonator? o)
-           (let ([val  (loop (impersonator-next o))])
-             ((box-impersonator-ref o) o val))]
-          [else (loop (impersonator-next o))]))
-       ;; Let primitive report the error:
-       (#2%unbox orig))))
+  (if (and (impersonator? orig)
+           (#%box? (impersonator-val orig)))
+      (let loop ([o orig])
+        (cond
+         [(#%box? o) (#%unbox o)]
+         [(box-chaperone? o)
+          (let* ([val (loop (impersonator-next o))]
+                 [new-val (|#%app| (box-chaperone-ref o) o val)])
+            (unless (chaperone-of? new-val val)
+              (raise-arguments-error 'unbox
+                                     "chaperone produced a result that is not a chaperone of the original result"
+                                     "chaperone result" new-val
+                                     "original result" val))
+            new-val)]
+         [(box-impersonator? o)
+          (let ([val  (loop (impersonator-next o))])
+            ((box-impersonator-ref o) o val))]
+         [else (loop (impersonator-next o))]))
+      ;; Let primitive report the error:
+      (#2%unbox orig)))
 
 (define (impersonate-set-box! orig val)
-  (pariah
-   (cond
-    [(not (and (impersonator? orig)
-               (mutable-box? (impersonator-val orig))))
-     ;; Let primitive report the error:
-     (#2%set-box! orig val)]
-    [else
-     (let loop ([o orig] [val val])
-       (cond
-        [(#%box? o) (#2%set-box! o val)]
-        [else
-         (let ([next (impersonator-next o)])
-           (cond
-            [(box-chaperone? o)
-             (let ([new-val (|#%app| (box-chaperone-set o) next val)])
-               (unless (chaperone-of? new-val val)
-                 (raise-arguments-error 'set-box!
-                                        "chaperone produced a result that is not a chaperone of the original result"
-                                        "chaperone result" new-val
-                                        "original result" val))
-               (loop next new-val))]
-            [(box-impersonator? o)
-             (loop next ((box-impersonator-set o) next val))]
-            [else (loop next val)]))]))])))
+  (cond
+   [(not (and (impersonator? orig)
+              (mutable-box? (impersonator-val orig))))
+    ;; Let primitive report the error:
+    (#2%set-box! orig val)]
+   [else
+    (let loop ([o orig] [val val])
+      (cond
+       [(#%box? o) (#2%set-box! o val)]
+       [else
+        (let ([next (impersonator-next o)])
+          (cond
+           [(box-chaperone? o)
+            (let ([new-val (|#%app| (box-chaperone-set o) next val)])
+              (unless (chaperone-of? new-val val)
+                (raise-arguments-error 'set-box!
+                                       "chaperone produced a result that is not a chaperone of the original result"
+                                       "chaperone result" new-val
+                                       "original result" val))
+              (loop next new-val))]
+           [(box-impersonator? o)
+            (loop next ((box-impersonator-set o) next val))]
+           [else (loop next val)]))]))]))
 
 (define (set-box-impersonator-hash!)
   (record-type-hash-procedure (record-type-descriptor box-chaperone)
diff --git a/racket/src/cs/rumble/impersonator.ss b/racket/src/cs/rumble/impersonator.ss
index 66562f78b9..60ceb551bf 100644
--- a/racket/src/cs/rumble/impersonator.ss
+++ b/racket/src/cs/rumble/impersonator.ss
@@ -23,6 +23,9 @@
    "received" e2))
 
 (define (impersonate-ref acc rtd pos orig record-name field-name)
+  (#%$app/no-inline do-impersonate-ref acc rtd pos orig record-name field-name))
+
+(define (do-impersonate-ref acc rtd pos orig record-name field-name)
   (impersonate-struct-or-property-ref acc rtd (cons rtd pos) orig record-name field-name))
 
 (define (impersonate-struct-or-property-ref acc rtd key orig record-name field-name)
@@ -71,6 +74,9 @@
                           orig)]))
 
 (define (impersonate-set! set rtd pos abs-pos orig a record-name field-name)
+  (#%$app/no-inline do-impersonate-set! set rtd pos abs-pos orig a record-name field-name))
+
+(define (do-impersonate-set! set rtd pos abs-pos orig a record-name field-name)
   (cond
    [(and (impersonator? orig)
          (record? (impersonator-val orig) rtd))
diff --git a/racket/src/cs/rumble/inline.ss b/racket/src/cs/rumble/inline.ss
index 7eaa656d28..4a4d2c821f 100644
--- a/racket/src/cs/rumble/inline.ss
+++ b/racket/src/cs/rumble/inline.ss
@@ -15,7 +15,7 @@
               #'(let ([arg tmp] ...)
                   (if guard
                       op
-                      (orig-id arg ...)))]
+                      (#3%$app/no-inline orig-id arg ...)))]
              [(_ . args)
               #'(orig-id . args)]
              [_ #'orig-id])))]))
diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss
index dcc0d19fa2..12213d0870 100644
--- a/racket/src/cs/rumble/procedure.ss
+++ b/racket/src/cs/rumble/procedure.ss
@@ -77,11 +77,10 @@
   (let ([tmp f])
     (if (#%procedure? tmp)
         tmp
-        (slow-extract-procedure tmp n-args))))
+        (#3%$app/no-inline slow-extract-procedure tmp n-args))))
 
 (define (slow-extract-procedure f n-args)
-  (pariah ; => don't inline enclosing procedure
-   (do-extract-procedure f f n-args #f not-a-procedure)))
+  (do-extract-procedure f f n-args #f not-a-procedure))
 
 ;; Returns a host-Scheme procedure, but first checks arity so that
 ;; checking and reporting use the right top-level function, and
diff --git a/racket/src/cs/rumble/vector.ss b/racket/src/cs/rumble/vector.ss
index 2a324b3252..88701135a4 100644
--- a/racket/src/cs/rumble/vector.ss
+++ b/racket/src/cs/rumble/vector.ss
@@ -142,7 +142,7 @@
 (define (vector-length vec)
   (if (#%vector? vec)
       (#3%vector-length vec)
-      (impersonate-vector-length vec)))
+      (#%$app/no-inline impersonate-vector-length vec)))
 
 (define (unsafe-vector-length vec)
   (vector-length vec))
@@ -150,41 +150,43 @@
 (define (vector*-length vec)
   (if (#%vector? vec)
       (#3%vector-length vec)
-      (bad-vector*-for-length vec)))
+      (#%$app/no-inline bad-vector*-for-length vec)))
 
 (define (bad-vector*-for-length vec)
   (raise-argument-error 'vector*-length "(and/c vector? (not impersonator?))" vec))
 
 (define (impersonate-vector-length vec)
-  (pariah
-   (if (and (impersonator? vec)
-            (#%vector? (impersonator-val vec)))
-       (cond
-        [(vector-unsafe-chaperone? vec)
-         (#%vector-length (vector-unsafe-chaperone-vec vec))]
-        [(vector-unsafe-impersonator? vec)
-         (#%vector-length (vector-unsafe-impersonator-vec vec))]
-        [else
-         (#%vector-length (impersonator-val vec))])
-       ;; Let primitive report the error:
-       (#2%vector-length vec))))
+  (if (and (impersonator? vec)
+           (#%vector? (impersonator-val vec)))
+      (cond
+       [(vector-unsafe-chaperone? vec)
+        (#%vector-length (vector-unsafe-chaperone-vec vec))]
+       [(vector-unsafe-impersonator? vec)
+        (#%vector-length (vector-unsafe-impersonator-vec vec))]
+       [else
+        (#%vector-length (impersonator-val vec))])
+      ;; Let primitive report the error:
+      (#2%vector-length vec)))
 
 ;; ----------------------------------------
 
 (define (vector-ref vec idx)
   (if (#%$vector-ref-check? vec idx)
       (#3%vector-ref vec idx)
-      (impersonate-vector-ref vec idx)))
+      (#%$app/no-inline impersonate-vector-ref vec idx)))
 
 (define (unsafe-vector-ref vec idx)
   (if (#%vector? vec)
       (#3%vector-ref vec idx)
-      (impersonate-vector-ref vec idx)))
+      (#%$app/no-inline impersonate-vector-ref vec idx)))
 
 (define/who (vector*-ref vec idx)
   (if (#%$vector-ref-check? vec idx)
       (#3%vector-ref vec idx)
-      (bad-vector*-op who #f vec idx)))
+      (#%$app/no-inline bad-vector*-ref vec idx)))
+
+(define (bad-vector*-ref vec idx)
+  (bad-vector*-op 'vector*-ref #f vec idx))
 
 (define (bad-vector*-op who set? vec idx)
   (cond
@@ -198,93 +200,94 @@
   (check-range who "vector" vec idx #f (fx- (#%vector-length vec) 1)))
 
 (define (impersonate-vector-ref orig idx)
-  (pariah
-   (if (and (impersonator? orig)
-            (#%vector? (impersonator-val orig)))
-       (let loop ([o orig])
-         (cond
-          [(#%vector? o) (#2%vector-ref o idx)]
-          [(vector-chaperone? o)
-           (let* ([o-next (impersonator-next o)]
-                  [val (loop o-next)]
-                  [new-val (if (vector*-chaperone? o)
-                               (|#%app| (vector-chaperone-ref o) orig o-next idx val)
-                               (|#%app| (vector-chaperone-ref o) o-next idx val))])
-             (unless (chaperone-of? new-val val)
-               (raise-arguments-error 'vector-ref
-                                      "chaperone produced a result that is not a chaperone of the original result"
-                                      "chaperone result" new-val
-                                      "original result" val))
-             new-val)]
-          [(vector-impersonator? o)
-           (let* ([o-next (impersonator-next o)]
-                  [val (loop o-next)])
-             (if (vector*-impersonator? o)
-                 (|#%app| (vector-impersonator-ref o) orig o-next idx val)
-                 (|#%app| (vector-impersonator-ref o) o-next idx val)))]
-          [(vector-unsafe-impersonator? o)
-           (vector-ref (vector-unsafe-impersonator-vec o)  idx)]
-          [(vector-unsafe-chaperone? o)
-           (vector-ref (vector-unsafe-chaperone-vec o)  idx)]
-          [else (loop (impersonator-next o))]))
-       ;; Let primitive report the error:
-       (#2%vector-ref orig idx))))
+  (if (and (impersonator? orig)
+           (#%vector? (impersonator-val orig)))
+      (let loop ([o orig])
+        (cond
+         [(#%vector? o) (#2%vector-ref o idx)]
+         [(vector-chaperone? o)
+          (let* ([o-next (impersonator-next o)]
+                 [val (loop o-next)]
+                 [new-val (if (vector*-chaperone? o)
+                              (|#%app| (vector-chaperone-ref o) orig o-next idx val)
+                              (|#%app| (vector-chaperone-ref o) o-next idx val))])
+            (unless (chaperone-of? new-val val)
+              (raise-arguments-error 'vector-ref
+                                     "chaperone produced a result that is not a chaperone of the original result"
+                                     "chaperone result" new-val
+                                     "original result" val))
+            new-val)]
+         [(vector-impersonator? o)
+          (let* ([o-next (impersonator-next o)]
+                 [val (loop o-next)])
+            (if (vector*-impersonator? o)
+                (|#%app| (vector-impersonator-ref o) orig o-next idx val)
+                (|#%app| (vector-impersonator-ref o) o-next idx val)))]
+         [(vector-unsafe-impersonator? o)
+          (vector-ref (vector-unsafe-impersonator-vec o)  idx)]
+         [(vector-unsafe-chaperone? o)
+          (vector-ref (vector-unsafe-chaperone-vec o)  idx)]
+         [else (loop (impersonator-next o))]))
+      ;; Let primitive report the error:
+      (#2%vector-ref orig idx)))
 
 ;; ----------------------------------------
 
 (define (vector-set! vec idx val)
   (if (#%$vector-set!-check? vec idx)
       (#3%vector-set! vec idx val)
-      (impersonate-vector-set! vec idx val)))
+      (#%$app/no-inline impersonate-vector-set! vec idx val)))
 
 (define (unsafe-vector-set! vec idx val)
   (if (#%vector? vec)
       (#3%vector-set! vec idx val)
-      (impersonate-vector-set! vec idx val)))
+      (#%$app/no-inline impersonate-vector-set! vec idx val)))
 
 (define/who (vector*-set! vec idx val)
   (if (#%$vector-set!-check? vec idx)
       (#3%vector-set! vec idx val)
-      (bad-vector*-op who #t vec idx)))
+      (#%$app/no-inline bad-vector*-set! vec idx val)))
+
+(define (bad-vector*-set! vec idx val)
+  (bad-vector*-op 'vector*-set! #t vec idx))
 
 (define (impersonate-vector-set! orig idx val)
-  (pariah
-   (cond
-    [(not (and (impersonator? orig)
-               (mutable-vector? (impersonator-val orig))))
-     ;; Let primitive report the error:
-     (#2%vector-set! orig idx val)]
-    [(or (not (exact-nonnegative-integer? idx))
-         (>= idx (vector-length (impersonator-val orig))))
-     ;; Let primitive report the index error:
-     (#2%vector-set! (impersonator-val orig) idx val)]
-    [else
-     (let loop ([o orig] [val val])
-       (cond
-        [(#%vector? o) (#2%vector-set! o idx val)]
-        [else
-         (let ([next (impersonator-next o)])
-           (cond
-            [(vector-chaperone? o)
-             (let ([new-val (if (vector*-chaperone? o)
-                                (|#%app| (vector-chaperone-set o) orig next idx val)
-                                (|#%app| (vector-chaperone-set o) next idx val))])
-               (unless (chaperone-of? new-val val)
-                 (raise-arguments-error 'vector-set!
-                                        "chaperone produced a result that is not a chaperone of the original result"
-                                        "chaperone result" new-val
-                                        "original result" val))
-               (loop next new-val))]
-            [(vector-impersonator? o)
-             (loop next
-                   (if (vector*-impersonator? o)
-                       (|#%app| (vector-impersonator-set o) orig next idx val)
-                       (|#%app| (vector-impersonator-set o) next idx val)))]
-            [(vector-unsafe-impersonator? o)
-             (#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)]
-            [(vector-unsafe-chaperone? o)
-             (#2%vector-set! (vector-unsafe-chaperone-vec o) idx val)]
-            [else (loop next val)]))]))])))
+  (cond
+   [(not (and (impersonator? orig)
+              (mutable-vector? (impersonator-val orig))))
+    ;; Let primitive report the error:
+    (#2%vector-set! orig idx val)]
+   [(or (not (exact-nonnegative-integer? idx))
+        (>= idx (vector-length (impersonator-val orig))))
+    ;; Let primitive report the index error:
+    (#2%vector-set! (impersonator-val orig) idx val)]
+   [else
+    (let loop ([o orig] [val val])
+      (cond
+       [(#%vector? o) (#2%vector-set! o idx val)]
+       [else
+        (let ([next (impersonator-next o)])
+          (cond
+           [(vector-chaperone? o)
+            (let ([new-val (if (vector*-chaperone? o)
+                               (|#%app| (vector-chaperone-set o) orig next idx val)
+                               (|#%app| (vector-chaperone-set o) next idx val))])
+              (unless (chaperone-of? new-val val)
+                (raise-arguments-error 'vector-set!
+                                       "chaperone produced a result that is not a chaperone of the original result"
+                                       "chaperone result" new-val
+                                       "original result" val))
+              (loop next new-val))]
+           [(vector-impersonator? o)
+            (loop next
+                  (if (vector*-impersonator? o)
+                      (|#%app| (vector-impersonator-set o) orig next idx val)
+                      (|#%app| (vector-impersonator-set o) next idx val)))]
+           [(vector-unsafe-impersonator? o)
+            (#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)]
+           [(vector-unsafe-chaperone? o)
+            (#2%vector-set! (vector-unsafe-chaperone-vec o) idx val)]
+           [else (loop next val)]))]))]))
 
 ;; ----------------------------------------
 
diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h
index 3edf6e909a..f7d3c60fa7 100644
--- a/racket/src/racket/src/schvers.h
+++ b/racket/src/racket/src/schvers.h
@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 6
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x