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] [(scheme-object struct union) #f]
[else #t])) [else #t]))
in-types)) in-types))
(let ([arity-mask (bitwise-arithmetic-shift-left 1 (length in-types))])
(lambda (to-wrap) (lambda (to-wrap)
(let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)] (let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)]
[proc (and (not (cpointer-needs-lock? proc-p)) [proc (and (not (cpointer-needs-lock? proc-p))
@ -1680,49 +1681,37 @@
(do-procedure-reduce-arity-mask (do-procedure-reduce-arity-mask
(cond (cond
[proc [proc
(case-lambda (let-syntax ([gen (lambda (stx)
[() (syntax-case stx ()
(c->s out-type (with-interrupts-disabled* (proc)))] [(_ id ...)
[(orig-a) (with-syntax ([(type ...) (generate-temporaries #'(id ...))]
(let ([a (unwrap orig-a (car in-types))]) [(orig ...) (generate-temporaries #'(id ...))])
(c->s out-type (retain #'(let*-values ([(type in-types) (values (car in-types) (cdr in-types))]
orig-a ...)
(with-interrupts-disabled* (proc (unpack a (car in-types)))))))] (lambda (orig ...)
[(orig-a orig-b) (let ([id (unwrap orig type)] ...)
(let ([a (unwrap orig-a (car in-types))] (c->s out-type
[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*
(retain (retain
orig-a orig-b orig-c orig ...
(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
(with-interrupts-disabled* (with-interrupts-disabled*
(proc (unpack a (car in-types)) (proc (unpack id type) ...))))))))]))])
(unpack b (cadr in-types)) (case arity-mask
(unpack c (caddr in-types)) [(1) (gen)]
(unpack d (cadddr in-types)))))))] [(2) (gen a)]
[orig-args [(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)]) (let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)])
(c->s out-type (with-interrupts-disabled* (c->s out-type (with-interrupts-disabled*
(retain (retain
orig-args 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 [else
(lambda orig-args (lambda orig-args
(let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)]) (let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)])
@ -1731,8 +1720,8 @@
orig-args orig-args
(#%apply (gen-proc (cpointer-address proc-p)) (#%apply (gen-proc (cpointer-address proc-p))
(map (lambda (a t) (unpack a t)) args in-types)))))))]) (map (lambda (a t) (unpack a t)) args in-types)))))))])
(fxsll 1 (length in-types)) arity-mask
(cpointer->name proc-p))))] (cpointer->name proc-p)))))]
[else [else
(lambda (to-wrap) (lambda (to-wrap)
(let* ([proc-p (unwrap-cpointer 'ffi-call 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) (lambda (s_0 up?_0)
(if (if (equal? (1/current-locale) "") (if (if (equal? (1/current-locale) "")
(not (not
(zero? (fx=
0
(fxand (fxand
(|#%app| (|#%app|
rktio_convert_properties rktio_convert_properties