suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust make-arity-wrapper to enforce the supplied arity mask

Browse Source 
original commit: a9ec7da3ea3b8edc665b060bcba675248119d260
This commit is contained in:
Matthew Flatt 2019-01-15 11:56:03 -07:00
parent dd5384be5e
commit 3e297e025e
16 changed files with 272 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
LOG
View File

@ -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,

1
c/externs.h
View File

@ -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));

9
c/number.c
View File

@ -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; {

1
c/prim.c
View File

@ -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

70
csug/objects.stex
View File

@ -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

100
mats/misc.ms
View File

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

25
release_notes/release_notes.stex
View File

@ -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)}

6
s/cmacros.ss
View File

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

112
s/cpnanopass.ss
View File

@ -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

6
s/interpret.ss
View File

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

3
s/library.ss
View File

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

2
s/patch.ss
View File

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

11
s/primdata.ss
View File

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

33
s/prims.ss
View File

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

11
s/print.ss
View File

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

4
s/record.ss
View File

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