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

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

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