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

cs: reduce allocation on foreign calls with 5-8 arguments

Browse Source 
Extend a fast path for up to 4 arguments to work on up to 8 arguments.
This commit is contained in:
Matthew Flatt 2020-11-04 15:22:41 -07:00
parent 18ff816358
commit e50f53e990
2 changed files with 60 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
racket/src/cs/rumble/foreign.ss
View File

@ -1664,6 +1664,7 @@
[(scheme-object struct union) #f]
[else #t]))
in-types))
(let ([arity-mask (bitwise-arithmetic-shift-left 1 (length in-types))])
(lambda (to-wrap)
(let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)]
[proc (and (not (cpointer-needs-lock? proc-p))
@ -1680,49 +1681,37 @@
(do-procedure-reduce-arity-mask
(cond
[proc
(case-lambda
[()
(c->s out-type (with-interrupts-disabled* (proc)))]
[(orig-a)
(let ([a (unwrap orig-a (car in-types))])
(c->s out-type (retain
orig-a
(with-interrupts-disabled* (proc (unpack a (car in-types)))))))]
[(orig-a orig-b)
(let ([a (unwrap orig-a (car in-types))]
[b (unwrap orig-b (cadr in-types))])
(c->s out-type (retain
orig-a orig-b
(with-interrupts-disabled*
(proc (unpack a (car in-types)) (unpack b (cadr in-types)))))))]
[(orig-a orig-b orig-c)
(let ([a (unwrap orig-a (car in-types))]
[b (unwrap orig-b (cadr in-types))]
[c (unwrap orig-c (caddr in-types))])
(c->s out-type (with-interrupts-disabled*
(let-syntax ([gen (lambda (stx)
(syntax-case stx ()
[(_ id ...)
(with-syntax ([(type ...) (generate-temporaries #'(id ...))]
[(orig ...) (generate-temporaries #'(id ...))])
#'(let*-values ([(type in-types) (values (car in-types) (cdr in-types))]
...)
(lambda (orig ...)
(let ([id (unwrap orig type)] ...)
(c->s out-type
(retain
orig-a orig-b orig-c
(proc (unpack a (car in-types))
(unpack b (cadr in-types))
(unpack c (caddr in-types)))))))]
[(orig-a orig-b orig-c orig-d)
(let ([a (unwrap orig-a (car in-types))]
[b (unwrap orig-b (cadr in-types))]
[c (unwrap orig-c (caddr in-types))]
[d (unwrap orig-d (cadddr in-types))])
(c->s out-type (retain
orig-a orig-b orig-c orig-d
orig ...
(with-interrupts-disabled*
(proc (unpack a (car in-types))
(unpack b (cadr in-types))
(unpack c (caddr in-types))
(unpack d (cadddr in-types)))))))]
[orig-args
(proc (unpack id type) ...))))))))]))])
(case arity-mask
[(1) (gen)]
[(2) (gen a)]
[(4) (gen a b)]
[(8) (gen a b c)]
[(16) (gen a b c d)]
[(32) (gen a b c d e)]
[(64) (gen a b c d e f)]
[(128) (gen a b c d e f g)]
[(256) (gen a b c d e f g h)]
[else
(lambda orig-args
(let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)])
(c->s out-type (with-interrupts-disabled*
(retain
orig-args
(#%apply proc (map (lambda (a t) (unpack a t)) args in-types))))))])]
(#%apply proc (map (lambda (a t) (unpack a t)) args in-types)))))))]))]
[else
(lambda orig-args
(let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)])
@ -1731,8 +1720,8 @@
orig-args
(#%apply (gen-proc (cpointer-address proc-p))
(map (lambda (a t) (unpack a t)) args in-types)))))))])
(fxsll 1 (length in-types))
(cpointer->name proc-p))))]
arity-mask
(cpointer->name proc-p)))))]
[else
(lambda (to-wrap)
(let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)]

3
racket/src/cs/schemified/io.scm
View File

@ -32624,7 +32624,8 @@
(lambda (s_0 up?_0)
(if (if (equal? (1/current-locale) "")
(not
(zero?
(fx=
0
(fxand
(|#%app|
rktio_convert_properties