From 3e297e025e307006436cab30628486dd154aa2c9 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 15 Jan 2019 11:56:03 -0700
Subject: [PATCH] adjust `make-arity-wrapper` to enforce the supplied arity
 mask

original commit: a9ec7da3ea3b8edc665b060bcba675248119d260
---
 LOG                              |   8 +--
 c/externs.h                      |   1 +
 c/number.c                       |   9 +++
 c/prim.c                         |   1 +
 csug/objects.stex                |  70 ++++++++++---------
 mats/misc.ms                     | 100 +++++++++++++++++++--------
 release_notes/release_notes.stex |  25 ++++---
 s/cmacros.ss                     |   6 +-
 s/cpnanopass.ss                  | 112 +++++++++++++++++++++++--------
 s/interpret.ss                   |   6 +-
 s/library.ss                     |   3 +-
 s/patch.ss                       |   2 +-
 s/primdata.ss                    |  11 +--
 s/prims.ss                       |  33 +++++----
 s/print.ss                       |  11 ++-
 s/record.ss                      |   4 +-
 16 files changed, 272 insertions(+), 130 deletions(-)

diff --git a/LOG b/LOG
index 8b7cb6a769..fd7af78515 100644
--- a/LOG
+++ b/LOG
@@ -1031,10 +1031,10 @@
     prims.ss, primdata.ss, cp0.ss, cpnanopass.ss,
     cmacros.ss, mkheader.ss, gc.c, segment.c, types.h,
     4.ms, smgmt.stex, release_notes.stex
-- add make-arity-wrapper
-    cmacros.ss, cpnanopass.ss, interpret.ss, library.ss,
-    primdata.ss, prims.ss, gc.c, objects.stex, release_notes.stex
-    misc.ms, mats/patch*, mats/root*
+ - add make-wrapper-procedure, make-arity-wrapper-procedure, etc.
+     cmacros.ss, cpnanopass.ss, interpret.ss, library.ss, primdata.ss,
+     prims.ss, print.ss, gc.c, number.c, prim.c, externs.h,
+     objects.stex, release_notes.stex, misc.ms, mats/patch*, mats/root*
 - add object-backreferences and enable-object-backreferences as an aid
   to debugging memory leaks
      back.ss, cmacros.ss, inspect.ss, primdata.ss,
diff --git a/c/externs.h b/c/externs.h
index ddcd2e7e6a..5284a3ddf2 100644
--- a/c/externs.h
+++ b/c/externs.h
@@ -268,6 +268,7 @@ extern ptr S_logtest PROTO((ptr x, ptr y));
 extern ptr S_logor PROTO((ptr x, ptr y));
 extern ptr S_logxor PROTO((ptr x, ptr y));
 extern ptr S_lognot PROTO((ptr x));
+extern void S_bignum_mask_test PROTO((void));
 
 /* prim.c */
 extern ptr S_lookup_library_entry PROTO((iptr n, IBOOL errorp));
diff --git a/c/number.c b/c/number.c
index 97bee865bd..a7930eefff 100644
--- a/c/number.c
+++ b/c/number.c
@@ -1647,6 +1647,15 @@ ptr S_logbitp(k, x) ptr k, x; {
   }
 }
 
+/* %ac0 must hold a nonnegative fixnum.  %ts must hold a bignum.  Changes %ts */
+void S_bignum_mask_test(void) {
+  ptr tc = get_thread_context();
+  iptr n = (iptr)AC0(tc);
+  ptr x = TS(tc);
+
+  TS(tc) = big_logbitp(n, x, BIGLEN(x), BIGSIGN(x));
+}
+
 /* similar logic to big_logand */
 
 static ptr big_logbitp(n, x, xl, xs) ptr x; iptr n, xl; IBOOL xs; {
diff --git a/c/prim.c b/c/prim.c
index ff0e3c4f02..6d75cf0e0f 100644
--- a/c/prim.c
+++ b/c/prim.c
@@ -140,6 +140,7 @@ static void create_c_entry_vector() {
     install_c_entry(CENTRY_Scall_one_result, proc2ptr(S_call_one_result));
     install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results));
     install_c_entry(CENTRY_segment_info, proc2ptr(S_segment_info));
+    install_c_entry(CENTRY_bignum_mask_test, proc2ptr(S_bignum_mask_test));
 
     for (i = 0; i < c_entry_vector_size; i++) {
 #ifndef PTHREADS
diff --git a/csug/objects.stex b/csug/objects.stex
index b82f6b2dcf..2c2ba333f0 100644
--- a/csug/objects.stex
+++ b/csug/objects.stex
@@ -3820,6 +3820,7 @@ encoding of all bits set is \scheme{-1}.
 
 %----------------------------------------------------------------------------
 \entryheader
+\formdef{make-wrapper-procedure}{\categoryprocedure}{(make-wrapper-procedure \var{proc} \var{arity-mask} \var{data})}
 \formdef{make-arity-wrapper-procedure}{\categoryprocedure}{(make-arity-wrapper-procedure \var{proc} \var{arity-mask} \var{data})}
 \returns a procedure that behaves like \var{proc}, but with the given \var{arity-mask}
 \listlibraries
@@ -3831,90 +3832,99 @@ integer representing an arity mask in the sense of \scheme{procedure-arity-mask}
 
 The resulting procedure behaves the same as \var{proc}, except that
 \scheme{procedure-arity-mask} on the result procedure returns
-\var{arity-mask}. Although \var{arity-mask} determines the value
-reported by \scheme{procedure-arity-mask}, when the result procedure
-is called, its arguments are passed on to \var{proc} without checking
-whether the count is consistent with \var{arity-mask}.
+\var{arity-mask}. When the result of \scheme{make-arity-wrapper-procedure}
+is called, the given arguments are compared to the given arity mask, and an error is reported
+if the argument count does not match. The result of \scheme{make-wrapper-procedure},
+in contrast, does not enforce the given arity mask.
 
 The \var{data} argument can be any value, and it can be retrived from
-the result procedure with \scheme{arity-wrapper-procedure-data}.
+the result procedure with \scheme{wrapper-procedure-data}.
 
 \schemedisplay
-(define vector3 (make-arity-wrapper-procedure vector 8 #f))
+(define vector3 (make-wrapper-procedure vector 8 #f))
 (procedure-arity-mask vector) ; => -1
 (procedure-arity-mask vector3) ; => 8
 (vector3 1 2 3) ;=> #(1 2 3)
 (vector3 1 2) ;=> #(1 2)
+(define vector3/check (make-arity-wrapper-procedure vector 8 #f))
+(vector3/check 1 2 3) ;=>  #(1 2 3)
+(vector3/check 1 2) ;=> \var{exception}
 \endschemedisplay
 
 %----------------------------------------------------------------------------
 \entryheader
-\formdef{arity-wrapper-procedure?}{\categoryprocedure}{(arity-wrapper-procedure? \var{obj})}
-\returns \scheme{#t} if \var{obj} is an arity wrapper procedure, \scheme{#f} otherwise
+\formdef{wrapper-procedure?}{\categoryprocedure}{(wrapper-procedure? \var{obj})}
+\returns \scheme{#t} if \var{obj} is a wrapper procedure, \scheme{#f} otherwise
 \listlibraries
 \endentryheader
 
+\noindent
+Determines whether \var{obj} is a wrapper procedure produced by either
+\scheme{make-wrapper-procedure} or \scheme{make-arity-wrapper-procedure}.
+
 \schemedisplay
-(arity-wrapper-procedure? vector) ; => #f
-(define vector3 (make-arity-wrapper-procedure vector 8 #f))
-(arity-wrapper-procedure? vector3) ; => #t
+(wrapper-procedure? vector) ; => #f
+(define vector3 (make-wrapper-procedure vector 8 #f))
+(wrapper-procedure? vector3) ; => #t
 \endschemedisplay
 
 
 %----------------------------------------------------------------------------
 \entryheader
-\formdef{arity-wrapper-procedure-data}{\categoryprocedure}{(arity-wrapper-procedure-data \var{aw-proc})}
+\formdef{wrapper-procedure-data}{\categoryprocedure}{(wrapper-procedure-data \var{w-proc})}
 \returns the data store with the arity wrapper procedure \var{proc}
 \listlibraries
 \endentryheader
 
 \noindent
-\var{aw-proc} must be an arity wrapper procedure produced by
-\scheme{make-arity-wrapper-procedure}.
+\var{w-proc} must be a wrapper procedure produced by either
+\scheme{make-wrapper-procedure} or \scheme{make-arity-wrapper-procedure}.
 
 
 \schemedisplay
-(define vector3 (make-arity-wrapper-procedure vector 8 'my-data))
+(define vector3 (make-wrapper-procedure vector 8 'my-data))
 (arity-wrapper-procedure-data vector3) ; => 'my-data
 \endschemedisplay
 
 %----------------------------------------------------------------------------
 \entryheader
-\formdef{set-arity-wrapper-procedure-data!}{\categoryprocedure}{(set-arity-wrapper-procedure-data! \var{aw-proc} \var{data})}
+\formdef{set-wrapper-procedure-data!}{\categoryprocedure}{(set-wrapper-procedure-data! \var{w-proc} \var{data})}
 \returns unspecified
 \listlibraries
 \endentryheader
 
 \noindent
-\var{aw-proc} must be an arity wrapper procedure produced by
-\scheme{make-arity-wrapper-procedure}.
+\var{w-proc} must be a wrapper procedure produced by either
+\scheme{make-wrapper-procedure} or \scheme{make-arity-wrapper-procedure}.
 
-Changes the data stored in \var{aw-proc} to \var{data}.
+Changes the data stored in \var{w-proc} to \var{data}.
 
 \schemedisplay
-(define vector3 (make-arity-wrapper-procedure vector 8 'my-data))
-(arity-wrapper-procedure-data vector3) ; => 'my-data
-(set-arity-wrapper-procedure-data! vector3 'my-new-data)
-(arity-wrapper-procedure-data vector3) ; => 'my-new-data
+(define vector3 (make-wrapper-procedure vector 8 'my-data))
+(wrapper-procedure-data vector3) ; => 'my-data
+(set-wrapper-procedure-data! vector3 'my-new-data)
+(wrapper-procedure-data vector3) ; => 'my-new-data
 \endschemedisplay
 
 %----------------------------------------------------------------------------
 \entryheader
-\formdef{set-arity-wrapper-procedure!}{\categoryprocedure}{(set-arity-wrapper-procedure-data! \var{aw-proc} \var{proc})}
+\formdef{set-wrapper-procedure!}{\categoryprocedure}{(set-wrapper-procedure-data! \var{w-proc} \var{proc})}
 \returns unspecified
 \listlibraries
 \endentryheader
 
 \noindent
-\var{aw-proc} must be an arity wrapper procedure produced by
-\scheme{make-arity-wrapper-procedure}, and \var{proc} must be a procedure.
+\var{w-proc} must be a wrapper procedure produced by either
+\scheme{make-wrapper-procedure} or
+\scheme{make-arity-wrapper-procedure}, and \var{proc} must be
+a procedure.
 
-Changes \var{aw-proc} so that it behaves the same as \var{proc}, except that
-the result of \scheme{(procedure-arity-mask \var{aw-proc})} is unchanged.
+Changes \var{w-proc} so that it behaves the same as \var{proc}, except that
+the result is unchanged for \scheme{(procedure-arity-mask \var{w-proc})}.
 
 \schemedisplay
-(define vector3 (make-arity-wrapper-procedure vector 8 'my-data))
+(define vector3 (make-wrapper-procedure vector 8 'my-data))
 (vector3 1 2 3) ; => #(1 2 3)
-(set-arity-wrapper-procedure! vector3 list)
+(set-wrapper-procedure! vector3 list)
 (vector3 1 2 3) ; => (1 2 3)
 \endschemedisplay
diff --git a/mats/misc.ms b/mats/misc.ms
index 9228ff0203..0ccab2cd80 100644
--- a/mats/misc.ms
+++ b/mats/misc.ms
@@ -5155,7 +5155,15 @@
   (ok-name? (procedure-name should-be-named-i) "i")
   (ok-name? (procedure-name should-be-named-j) "j"))
 
-(mat arity-wrapper-procedure
+(mat wrapper-procedure
+  (error? (make-wrapper-procedure))
+  (error? (make-wrapper-procedure (lambda args args)))
+  (error? (make-wrapper-procedure (lambda args args) 1))
+  (error? (make-wrapper-procedure 1 1 #f))
+  (error? (make-wrapper-procedure 'not-a-procedure 1 #f))
+  (error? (make-wrapper-procedure (lambda args args) 'not-an-exact-integer #f))
+  (error? (make-wrapper-procedure (lambda args args) 1.0 #f))
+
   (error? (make-arity-wrapper-procedure))
   (error? (make-arity-wrapper-procedure (lambda args args)))
   (error? (make-arity-wrapper-procedure (lambda args args) 1))
@@ -5164,55 +5172,93 @@
   (error? (make-arity-wrapper-procedure (lambda args args) 'not-an-exact-integer #f))
   (error? (make-arity-wrapper-procedure (lambda args args) 1.0 #f))
 
-  (equal? ((make-arity-wrapper-procedure (lambda args args) 8 #f) 1 2 3)
+  (equal? ((make-wrapper-procedure (lambda args args) 8 #f) 1 2 3)
           '(1 2 3))
-  (equal? ((make-arity-wrapper-procedure (lambda args args) 1 #f) 1 2 3) ; arity not checked!
+  (equal? ((make-wrapper-procedure (lambda args args) 1 #f) 1 2 3) ; arity not checked!
+          '(1 2 3))
+  (equal? ((make-wrapper-procedure (lambda args args) (expt 2 100) #f) 1 2 3) ; arity not checked!
           '(1 2 3))
 
+  (equal? ((make-arity-wrapper-procedure (lambda args args) 8 #f) 1 2 3)
+          '(1 2 3))
+  (equal? ((make-arity-wrapper-procedure (lambda args args) (+ (expt 2 100) 8) #f) 1 2 3)
+          '(1 2 3))
+  (error? ((make-arity-wrapper-procedure (lambda args args) 1 #f) 1 2 3))
+  (error? ((make-arity-wrapper-procedure (lambda args args) (expt 2 100) #f) 1 2 3))
+
+  (equal? (procedure-arity-mask (make-wrapper-procedure (lambda args args) 1 #f))
+          1)
+  (equal? (procedure-arity-mask (make-wrapper-procedure (lambda args args) -12345 #f))
+          -12345)
+  (equal? (procedure-arity-mask (make-wrapper-procedure (lambda args args) (expt 2 100) #f))
+          (expt 2 100))
+          
   (equal? (procedure-arity-mask (make-arity-wrapper-procedure (lambda args args) 1 #f))
           1)
   (equal? (procedure-arity-mask (make-arity-wrapper-procedure (lambda args args) -12345 #f))
           -12345)
+  (equal? (procedure-arity-mask (make-arity-wrapper-procedure (lambda args args) (expt 2 100) #f))
+          (expt 2 100))
+          
+  (not (wrapper-procedure? 10))
+  (not (wrapper-procedure? (lambda args args)))
+  (not (wrapper-procedure? (interpret '(lambda args args))))
+  (wrapper-procedure? (make-wrapper-procedure (lambda args args) 1 #f))
+  (wrapper-procedure? (make-arity-wrapper-procedure (lambda args args) 1 #f))
 
-  (not (arity-wrapper-procedure? 10))
-  (not (arity-wrapper-procedure? (lambda args args)))
-  (not (arity-wrapper-procedure? (interpret '(lambda args args))))
-  (arity-wrapper-procedure? (make-arity-wrapper-procedure (lambda args args) 1 #f))
-
-  (error? (arity-wrapper-procedure-data 1))
-  (error? (arity-wrapper-procedure-data (lambda args args)))
-  (error? (arity-wrapper-procedure-data (interpret '(lambda args args))))
-  (equal? (arity-wrapper-procedure-data (make-arity-wrapper-procedure (lambda args args) 1 'data))
+  (error? (wrapper-procedure-data 1))
+  (error? (wrapper-procedure-data (lambda args args)))
+  (error? (wrapper-procedure-data (interpret '(lambda args args))))
+  (equal? (wrapper-procedure-data (make-wrapper-procedure (lambda args args) 1 'data))
+          'data)
+  (equal? (wrapper-procedure-data (make-arity-wrapper-procedure (lambda args args) 1 'data))
           'data)
 
-  (error? (set-arity-wrapper-procedure!))
-  (error? (set-arity-wrapper-procedure! (make-arity-wrapper-procedure (lambda args args) 1 #f)))
-  (error? (set-arity-wrapper-procedure! 1 void))
-  (error? (set-arity-wrapper-procedure! (lambda args args) void))
-  (error? (set-arity-wrapper-procedure! (interpret '(lambda args args)) void))
+  (error? (set-wrapper-procedure!))
+  (error? (set-wrapper-procedure! (make-arity-wrapper-procedure (lambda args args) 1 #f)))
+  (error? (set-wrapper-procedure! 1 void))
+  (error? (set-wrapper-procedure! (lambda args args) void))
+  (error? (set-wrapper-procedure! (interpret '(lambda args args)) void))
+  (let ([p (make-wrapper-procedure (lambda args args) 8 #f)])
+    (set-wrapper-procedure! p vector)
+    (equal? (p 1 2 3)
+            '#(1 2 3)))
   (let ([p (make-arity-wrapper-procedure (lambda args args) 8 #f)])
-    (set-arity-wrapper-procedure! p vector)
+    (set-wrapper-procedure! p vector)
     (equal? (p 1 2 3)
             '#(1 2 3)))
 
-  (error? (set-arity-wrapper-procedure-data!))
-  (error? (set-arity-wrapper-procedure-data! (make-arity-wrapper-procedure (lambda args args) 1 #f)))
-  (error? (set-arity-wrapper-procedure-data! 1 #t))
-  (error? (set-arity-wrapper-procedure-data! (lambda args args) #t))
-  (error? (set-arity-wrapper-procedure! (interpret '(lambda args args)) #t))
+  (error? (set-wrapper-procedure-data!))
+  (error? (set-wrapper-procedure-data! (make-arity-wrapper-procedure (lambda args args) 1 #f)))
+  (error? (set-wrapper-procedure-data! 1 #t))
+  (error? (set-wrapper-procedure-data! (lambda args args) #t))
+  (error? (set-wrapper-procedure-data! (interpret '(lambda args args)) #t))
+  (let ([p (make-wrapper-procedure (lambda args args) 8 'data)])
+    (set-wrapper-procedure-data! p 'other-data)
+    (equal? (wrapper-procedure-data p)
+            'other-data))
   (let ([p (make-arity-wrapper-procedure (lambda args args) 8 'data)])
-    (set-arity-wrapper-procedure-data! p 'other-data)
-    (equal? (arity-wrapper-procedure-data p)
+    (set-wrapper-procedure-data! p 'other-data)
+    (equal? (wrapper-procedure-data p)
             'other-data))
 
+  (let ([a (make-wrapper-procedure (lambda args args) 8 #f)])
+    (lock-object a)
+    (collect)
+    (let ([g (gensym)])
+      (set-wrapper-procedure-data! a g)
+      (collect)
+      (and
+       (equal? (wrapper-procedure-data a) g)
+       (begin (unlock-object a) #t))))
   (let ([a (make-arity-wrapper-procedure (lambda args args) 8 #f)])
     (lock-object a)
     (collect)
     (let ([g (gensym)])
-      (set-arity-wrapper-procedure-data! a g)
+      (set-wrapper-procedure-data! a g)
       (collect)
       (and
-       (equal? (arity-wrapper-procedure-data a) g)
+       (equal? (wrapper-procedure-data a) g)
        (begin (unlock-object a) #t))))
 
   )
diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex
index 3e2fba86ea..9f267d3678 100644
--- a/release_notes/release_notes.stex
+++ b/release_notes/release_notes.stex
@@ -81,18 +81,21 @@ of two vectors. An optional argument limits the size of the result vector,
 which enables a traversal of $N$ entries in $O(N)$ time when a hash table
 has more than $O(N)$ entries.
 
-\subsection{Procedure arity-mask adjustment and redirection (9.5.1)}
+\subsection{Procedure redirection with arity-mask adjustment (9.5.1)}
 
-The new procedure \scheme{make-arity-wrapper-procedure} creates a
-procedure that behaves like a given one, but with a different
-result for \scheme{procedure-arity-mask}. The new mask is intended to be a
-subset of the original procedure's arity mask, and the original procedure
-is intended to report its own error for argument counts that do not fit the
-specified mask, but neither behavior is checked.
-The wrapped procedure can be replaced imperatively, which is useful
-for triggering just-in-time conversions of a procedure's
-implementation while imposing a minimal overhead on calls to the
-procedure before or after conversion.
+The new procedures \scheme{make-wrapper-procedure} and \scheme{make-arity-wrapper-procedure},
+create a procedure that behaves like a given one, but with an
+associated data value and a potentially different result for
+\scheme{procedure-arity-mask}. If different, the new mask is intended to be a
+subset of the original procedure's arity mask, although that is not checked.
+The procedure returned by \scheme{make-arity-wrapper-procedure} checks the
+argument count against the given arity mask when call, while \scheme{make-wrapper-procedure}
+expects the original procedure is intended to
+report its own error for argument counts that do not fit the specified mask. The wrapped
+procedure (or its data value) can be replaced imperatively,
+which is useful for triggering just-in-time conversions of a procedure's implementation
+while imposing a minimal overhead on calls to the procedure before or after
+conversion.
 
 \subsection{Ordered guardians (9.5.1)}
 
diff --git a/s/cmacros.ss b/s/cmacros.ss
index 75038f58bc..acbd942d53 100644
--- a/s/cmacros.ss
+++ b/s/cmacros.ss
@@ -2656,7 +2656,8 @@
      (nuate #f 0 #f #t)
      (virtual-register #f 1 #t #t)
      (set-virtual-register! #f 1 #t #t)
-     ($arity-wrapper-apply #f 0 #f #f)
+     ($wrapper-apply #f 0 #f #f)
+     (wrapper-apply #f 0 #f #f)
      (arity-wrapper-apply #f 0 #f #f)
      ($shift-attachment #f 0 #f #f)
   ))
@@ -2705,5 +2706,6 @@
      Scall-one-result
      Scall-any-results
      segment-info
-  ))
+     bignum-mask-test
+     ))
 )
diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss
index 814a4b7541..576d9ef440 100644
--- a/s/cpnanopass.ss
+++ b/s/cpnanopass.ss
@@ -5587,7 +5587,7 @@
           (define hand-coded-closure?
             (lambda (name)
               (not (memq name '(nuate nonprocedure-code error-invoke invoke
-                                      arity-wrapper-apply $arity-wrapper-apply
+                                      $wrapper-apply wrapper-apply arity-wrapper-apply
                                       $shift-attachment)))))
           (define-inline 2 $hand-coded
             [(name)
@@ -5683,8 +5683,8 @@
           )
 
         (let ()
-          (define (make-wrapper-closure-alloc e-proc e-arity-mask e-data size libspec)
-            (bind #t ([c (%constant-alloc type-closure (fx* size (constant ptr-bytes)))])
+          (define (make-wrapper-closure-alloc e-proc e-arity-mask e-data libspec)
+            (bind #t ([c (%constant-alloc type-closure (fx* (if e-data 4 3) (constant ptr-bytes)))])
               (%seq
                 (set! ,(%mref ,c ,(constant closure-code-disp))
                       (literal ,(make-info-literal #f 'library libspec (constant code-data-disp))))
@@ -5695,14 +5695,18 @@
                        (set! ,(%mref ,c ,(fx+ (fx* (constant ptr-bytes) 2) (constant closure-data-disp))) ,e-data)
                        ,c)
                      c))))
+          (define-inline 3 $make-wrapper-procedure
+            [(e-proc e-arity-mask)
+             (bind #f (e-proc e-arity-mask)
+               (make-wrapper-closure-alloc e-proc e-arity-mask #f (lookup-libspec $wrapper-apply)))])
+          (define-inline 3 make-wrapper-procedure
+            [(e-proc e-arity-mask e-data)
+             (bind #f (e-proc e-arity-mask e-data)
+               (make-wrapper-closure-alloc e-proc e-arity-mask e-data (lookup-libspec wrapper-apply)))])
           (define-inline 3 make-arity-wrapper-procedure
             [(e-proc e-arity-mask e-data)
              (bind #f (e-proc e-arity-mask e-data)
-               (make-wrapper-closure-alloc e-proc e-arity-mask e-data 4 (lookup-libspec arity-wrapper-apply)))])
-          (define-inline 3 $make-arity-wrapper-procedure
-            [(e-proc e-arity-mask)
-             (bind #f (e-proc e-arity-mask)
-               (make-wrapper-closure-alloc e-proc e-arity-mask #f 3 (lookup-libspec $arity-wrapper-apply)))]))
+               (make-wrapper-closure-alloc e-proc e-arity-mask e-data (lookup-libspec arity-wrapper-apply)))]))
 
         (define-inline 3 $make-shift-attachment
           [(e-proc)
@@ -12708,30 +12712,80 @@
                           (out %ac0 %ac1 %cp %xp %yp %ts %td scheme-args extra-regs))))
                   (set! ,%ac0 ,(%constant svoid))
                   (jump ,%ref-ret (,%ac0))))]
-           [($arity-wrapper-apply arity-wrapper-apply)
+           [($wrapper-apply wrapper-apply arity-wrapper-apply)
             (let ([info (make-info (symbol->string sym) '())])
-              (info-lambda-fv*-set! info (if (eq? sym '$arity-wrapper-apply)
-                                             '(box arity-mask)
-                                             '(box arity-mask data)))
+              (define (add-check-arity cl-reg e)
+                (with-output-language (L13.5 Tail)
+                  (define (fail)
+                    `(goto ,(make-Ldoargerr)))
+                  (if (memq sym '(arity-wrapper-apply))
+                      (%seq
+                       (set! ,%ts ,(%mref ,cl-reg ,(fx+ (constant closure-data-disp) (constant ptr-bytes))))
+                       (if ,(%type-check mask-fixnum type-fixnum ,%ts)
+                           ;; Arity is a fixnum...
+                           (if ,(%inline u< ,%ac0 (immediate ,(constant fixnum-bits)))
+                               (seq
+                                (set! ,%ts ,(%inline sra ,%ts ,%ac0))
+                                (if ,(%inline logtest ,%ts (immediate ,(fix 1)))
+                                    ,e
+                                    ,(fail)))
+                               ;; Arg count is > fixnum width; allow if the fixnum
+                               ;; is negative
+                               (if ,(%inline u< ,%ts (immediate 0))
+                                   ,e
+                                   ,(fail)))
+                           ;; Arity is a bignum...
+                           ,(%seq
+                             ,(meta-cond
+                               [(real-register? '%cp)
+                                (save-scheme-state
+                                 (in %ac0 %cp %ts scheme-args)
+                                 (out %ac1 %xp %yp %td extra-regs))]
+                               [else
+                                (save-scheme-state
+                                 (in %ac0 %td %ts scheme-args)
+                                 (out %ac1 %xp %yp %cp extra-regs))])
+                             (inline ,(make-info-c-simple-call #f (lookup-c-entry bignum-mask-test))
+                                     ,%c-simple-call)
+                             ,(meta-cond
+                               [(real-register? '%cp)
+                                (restore-scheme-state
+                                 (in %ac0 %cp %ts scheme-args)
+                                 (out %ac1 %xp %yp %td extra-regs))]
+                               [else
+                                (restore-scheme-state
+                                 (in %ac0 %td %ts scheme-args)
+                                 (out %ac1 %xp %yp %cp extra-regs))])
+                             (if ,(%inline eq? ,%ts ,(%constant strue))
+                                 ,e
+                                 ,(fail)))))
+                      e)))
+              (info-lambda-fv*-set! info (if (memq sym '($wrapper-apply))
+                                             '(proc arity-mask)
+                                             '(proc arity-mask data)))
               (info-lambda-flags-set! info (fxior (constant code-flag-arity-in-closure)
-                                                  (if (eq? sym 'arity-wrapper-apply)
-                                                      (constant code-flag-mutable-closure)
-                                                      0)))
+                                                  (if (memq sym '($wrapper-apply))
+                                                      0
+                                                      (constant code-flag-mutable-closure))))
               `(lambda ,info 0 ()
-                ,(%seq
-                  ,(meta-cond
-                    [(real-register? '%cp)
-                     (%seq
-                       (set! ,%cp ,(%mref ,%cp ,(constant closure-data-disp)))
-                       (jump ,(%mref ,%cp ,(constant closure-code-disp))
-                             (,%ac0 ,%cp ,(reg-cons* %ret arg-registers) ...)))]
-                    [else
-                     (%seq
-                       (set! ,%td ,(ref-reg %cp))
-                       (set! ,%td ,(%mref ,%td ,(constant closure-data-disp)))
-                       (set! ,(ref-reg %cp) ,%td)
-                       (jump ,(%mref ,%td ,(constant closure-code-disp))
-                             (,%ac0 ,(reg-cons* %ret arg-registers) ...)))]))))]
+                ,(meta-cond
+                  [(real-register? '%cp)
+                   (add-check-arity
+                    %cp
+                    (%seq
+                      (set! ,%cp ,(%mref ,%cp ,(constant closure-data-disp)))
+                      (jump ,(%mref ,%cp ,(constant closure-code-disp))
+                            (,%ac0 ,%cp ,(reg-cons* %ret arg-registers) ...))))]
+                  [else
+                   (%seq
+                     (set! ,%td ,(ref-reg %cp))
+                     ,(add-check-arity
+                       %td
+                       (%seq
+                         (set! ,%td ,(%mref ,%td ,(constant closure-data-disp)))
+                         (set! ,(ref-reg %cp) ,%td)
+                         (jump ,(%mref ,%td ,(constant closure-code-disp))
+                               (,%ac0 ,(reg-cons* %ret arg-registers) ...)))))])))]
            [($shift-attachment)
             ;; Reify the continuation, but dropping the first `attachments` element,
             ;; which must be present, so that the attachment will be popped
diff --git a/s/interpret.ss b/s/interpret.ss
index 59aff4a6fb..924a94abf2 100644
--- a/s/interpret.ss
+++ b/s/interpret.ss
@@ -365,21 +365,21 @@
                  [(0)
                   (ip2-closure free
                     ($rt lambda ()
-                      ($make-arity-wrapper-procedure
+                      ($make-wrapper-procedure
                        (lambda args
                          ($rt body ([a0 0] [a1 0] [fp 0]) args (length args)))
                        arity-mask)))]
                  [(1)
                   (ip2-closure free
                     ($rt lambda ()
-                      ($make-arity-wrapper-procedure
+                      ($make-wrapper-procedure
                        (lambda (a0 . args)
                          ($rt body ([a1 0] [fp 0]) args (length args)))
                        arity-mask)))]
                  [(2)
                   (ip2-closure free
                     ($rt lambda ()
-                      ($make-arity-wrapper-procedure
+                      ($make-wrapper-procedure
                        (lambda (a0 a1 . args)
                          ($rt body ([fp 0]) args (length args)))
                        arity-mask)))]))))]
diff --git a/s/library.ss b/s/library.ss
index 4a69847c47..c7476b8c0f 100644
--- a/s/library.ss
+++ b/s/library.ss
@@ -128,8 +128,9 @@
 (define-hand-coded-library-entry values-error)
 (define-hand-coded-library-entry $shift-attachment)
 (define-hand-coded-library-entry bytevector=?)
+(define-hand-coded-library-entry $wrapper-apply)
+(define-hand-coded-library-entry wrapper-apply)
 (define-hand-coded-library-entry arity-wrapper-apply)
-(define-hand-coded-library-entry $arity-wrapper-apply)
 
 (define $instantiate-code-object ($hand-coded '$instantiate-code-object))
 
diff --git a/s/patch.ss b/s/patch.ss
index af30b4261b..74252da992 100644
--- a/s/patch.ss
+++ b/s/patch.ss
@@ -13,7 +13,7 @@
 ;;; See the License for the specific language governing permissions and
 ;;; limitations under the License.
 
-(define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t))))
+(define ($make-wrapper-procedure proc mask) proc)
 
 (printf "loading ~s cross compiler~%" (constant machine-type-name))
 
diff --git a/s/primdata.ss b/s/primdata.ss
index feb06949f5..6fd867564f 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -1129,8 +1129,6 @@
   (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])
-  (arity-wrapper-procedure? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
-  (arity-wrapper-procedure-data [sig [(ptr) -> (ptr)]] [flags discard])
   (ash [sig [(sint sint) -> (sint)]] [flags arith-op mifoldable discard cp03])
   (assertion-violationf [sig [(who string sub-ptr ...) -> (bottom)]] [flags abort-op]) ; 2nd arg is format string
   (asinh [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
@@ -1462,6 +1460,7 @@
   (make-thread-parameter [feature pthreads] [sig [(ptr) (ptr procedure) -> (ptr)]] [flags true cp02 cp03])
   (make-weak-eq-hashtable [sig [() (uint) -> (eq-hashtable)]] [flags alloc])
   (make-weak-eqv-hashtable [sig [() (uint) -> (hashtable)]] [flags alloc])
+  (make-wrapper-procedure [sig [(procedure sint ptr) -> (procedure)]] [flags pure true mifoldable discard])
   (mark-port-closed! [sig [(port) -> (void)]] [flags true])
   (maximum-memory-bytes [sig [() -> (uint)]] [flags alloc])
   (maybe-compile-file [sig [(pathname) (pathname pathname) -> (void)]] [flags true])
@@ -1575,8 +1574,6 @@
   (s8-list->bytevector [sig [(sub-list) -> (bytevector)]] [flags alloc])
   (sc-expand [sig [(ptr) (ptr environment) (ptr environment ptr) (ptr environment ptr ptr) (ptr environment ptr ptr maybe-string) -> (ptr)]] [flags])
   (scheme-environment [sig [() -> (environment)]] [flags unrestricted alloc])
-  (set-arity-wrapper-procedure! [sig [(ptr procedure) -> (void)]] [flags true])
-  (set-arity-wrapper-procedure-data! [sig [(ptr ptr) -> (void)]] [flags true])
   (set-binary-port-input-buffer! [sig [(binary-input-port bytevector) -> (void)]] [flags true])
   (set-binary-port-input-index! [sig [(binary-input-port sub-index) -> (void)]] [flags true])
   (set-binary-port-input-size! [sig [(binary-input-port sub-length) -> (void)]] [flags true])
@@ -1611,6 +1608,8 @@
   (set-timer [sig [(ufixnum) -> (ufixnum)]] [flags true])
   (set-top-level-value! [sig [(symbol ptr) (symbol ptr environment) -> (void)]] [flags true])
   (set-virtual-register! [sig [(sub-index ptr) -> (void)]] [flags true])
+  (set-wrapper-procedure! [sig [(ptr procedure) -> (void)]] [flags true])
+  (set-wrapper-procedure-data! [sig [(ptr ptr) -> (void)]] [flags true])
   (sinh [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
   (sleep [sig [(time) -> (void)]] [flags true])
   (sort [sig [(procedure list) -> (list)]] [flags true])
@@ -1726,6 +1725,8 @@
   (with-output-to-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags])    ; has options argument
   (with-output-to-string [sig [(procedure) -> (string)]] [flags])
   (with-source-path [sig [(who pathname procedure) -> (ptr ...)]] [flags])
+  (wrapper-procedure? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
+  (wrapper-procedure-data [sig [(ptr) -> (ptr)]] [flags discard])
 )
 
 (define-symbol-flags* ([libraries] [flags system proc]) ; system procedures
@@ -2121,8 +2122,8 @@
   ($make-textual-input-port #;[sig [(string port-handler string) (string port-handler string ptr) -> (textual-input-port)]] [flags alloc])
   ($make-textual-output-port #;[sig [(string port-handler string) (string port-handler string ptr) -> (textual-output-port)]] [flags alloc])
   ($make-tlc [flags alloc])
-  ($make-arity-wrapper-procedure [flags])
   ($make-vtable [flags])
+  ($make-wrapper-procedure [flags])
   ($map [flags])
   ($mark-invoked! [flags])
   ($maybe-compile-file [flags])
diff --git a/s/prims.ss b/s/prims.ss
index 92768c9eff..4f62498ee0 100644
--- a/s/prims.ss
+++ b/s/prims.ss
@@ -206,7 +206,11 @@
   (lambda (x)
     (unless (procedure? x)
       ($oops '$procedure-name "~s is not a procedure" x))
-    ($code-name ($closure-code x))))
+    (let name ([x x])
+      (let ([code ($closure-code x)])
+        (if ($code-arity-in-closure? code)
+            (name ($closure-ref x 0))
+            ($code-name code))))))
 
 (define-who procedure-arity-mask
   (lambda (x)
@@ -2323,12 +2327,17 @@
         (wctmb cp (string->utf16 str 'little))))))
 )
 
-;; like `make-arity-wrapper-procedure`, but for system use and immutable
-(define-who $make-arity-wrapper-procedure
+(define-who $make-wrapper-procedure
   (lambda (proc arity-mask)
     (unless (procedure? proc) ($oops who "~s is not a procedure" proc))
     (unless (or (fixnum? arity-mask) (bignum? arity-mask)) ($oops who "~s is not an arity mask" arity-mask))
-    (#3%$make-arity-wrapper-procedure proc arity-mask)))
+    (#3%$make-wrapper-procedure proc arity-mask)))
+
+(define-who make-wrapper-procedure
+  (lambda (proc arity-mask data)
+    (unless (procedure? proc) ($oops who "~s is not a procedure" proc))
+    (unless (or (fixnum? arity-mask) (bignum? arity-mask)) ($oops who "~s is not an arity mask" arity-mask))
+    (#3%make-wrapper-procedure proc arity-mask data)))
 
 (define-who make-arity-wrapper-procedure
   (lambda (proc arity-mask data)
@@ -2336,26 +2345,26 @@
     (unless (or (fixnum? arity-mask) (bignum? arity-mask)) ($oops who "~s is not an arity mask" arity-mask))
     (#3%make-arity-wrapper-procedure proc arity-mask data)))
 
-(define-who arity-wrapper-procedure?
+(define-who wrapper-procedure?
   (lambda (x)
     (and (procedure? x)
-         ;; A somewhat indirect test: mutable + arity in closure => arity wrapper
          (let ([c ($closure-code x)])
            (and ($code-arity-in-closure? c)
+                ;; Indirect way of distinguishing from `$make-wrapper-procedure` result:
                 ($code-mutable-closure? c))))))
 
-(define-who set-arity-wrapper-procedure!
+(define-who set-wrapper-procedure!
   (lambda (x proc)
-    (unless (arity-wrapper-procedure? x) ($oops who "~s is not an arity wrapper procedure" x))
+    (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x))
     (unless (procedure? proc)  ($oops who "~s is not a procedure" proc))
     ($closure-set! x 0 proc)))
 
-(define-who arity-wrapper-procedure-data
+(define-who wrapper-procedure-data
   (lambda (x)
-    (unless (arity-wrapper-procedure? x) ($oops who "~s is not an arity wrapper procedure" x))
+    (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x))
     ($closure-ref x 2)))
 
-(define-who set-arity-wrapper-procedure-data!
+(define-who set-wrapper-procedure-data!
   (lambda (x v)
-    (unless (arity-wrapper-procedure? x) ($oops who "~s is not an arity wrapper procedure" x))
+    (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x))
     ($closure-set! x 2 v)))
diff --git a/s/print.ss b/s/print.ss
index e56e855e1e..a703180024 100644
--- a/s/print.ss
+++ b/s/print.ss
@@ -717,9 +717,14 @@ floating point returns with (1 0 -1 ...).
 
   (define wrprocedure
     (lambda (x p)
-      (display-string "#<procedure" p)
-      (wrcodename ($closure-code x) p)
-      (write-char #\> p)))
+      (let ([code ($closure-code x)])
+        (cond
+         [($code-arity-in-closure? code) ; => wrapper procedure
+          (wrprocedure ($closure-ref x 0) p)]
+         [else
+          (display-string "#<procedure" p)
+          (wrcodename code p)
+          (write-char #\> p)]))))
 
   (define wrcode
     (lambda (x p)
diff --git a/s/record.ss b/s/record.ss
index c8866b4f85..c3019a6752 100644
--- a/s/record.ss
+++ b/s/record.ss
@@ -826,7 +826,7 @@
                     [(5) (nlambda 5)]
                     [(6) (nlambda 6)]
                     [else (rec constructor
-                            ($make-arity-wrapper-procedure
+                            ($make-wrapper-procedure
                              (lambda xr
                                (unless (fx= (length xr) nflds)
                                  ($oops #f "incorrect number of arguments to ~s" constructor))
@@ -925,7 +925,7 @@
                                   [else #f])]
                            [else #f])])
                      (rec constructor
-                       ($make-arity-wrapper-procedure
+                       ($make-wrapper-procedure
                         (lambda xr
                           (unless (fx= (length xr) nflds)
                             ($oops #f "incorrect number of arguments to ~s" constructor))