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

cs: speed up calls to applicable structs

Browse Source
This commit is contained in:
Matthew Flatt 2018-08-24 20:22:01 -06:00
parent aa75a2fd32
commit f95723e70e
1 changed files with 37 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
racket/src/cs/rumble/procedure.ss
View File

@ -67,45 +67,54 @@
(define (extract-procedure f n-args) (define (extract-procedure f n-args)
(cond (cond
[(chez:procedure? f) f] [(#%procedure? f) f]
[else (or (try-extract-procedure/check-arity f n-args) [else (slow-extract-procedure f n-args)]))
(not-a-procedure f))]))
;; returns #f or a host-Scheme procedure, and checks arity so that (define (slow-extract-procedure f n-args)
;; checking and reporting use the right top-level function (pariah ; => don't inline enclosing procedure
(define (try-extract-procedure/check-arity f n-args) (do-extract-procedure f f n-args #f)))
(let ([v (try-extract-procedure f)])
(cond
[(not v) #f]
[(procedure-arity-includes? f n-args) v]
[else (wrong-arity-wrapper f)])))
(define (try-extract-procedure f) ;; Returns a host-Scheme procedure, but first checks arity so that
;; checking and reporting use the right top-level function, and
;; the returned procedure may just report a not-a-procedure error
(define (do-extract-procedure f orig-f n-args success-k)
(cond (cond
[(chez:procedure? f) f] [(#%procedure? f)
(if (chez:procedure-arity-includes? f n-args)
(if success-k
(success-k f)
f)
(wrong-arity-wrapper orig-f))]
[(record? f) [(record? f)
(let ([v (struct-property-ref prop:procedure (record-rtd f) none)]) (let ([v (struct-property-ref prop:procedure (record-rtd f) none)])
(cond (cond
[(eq? v none) #f] [(eq? v none) (not-a-procedure orig-f)]
[(fixnum? v) [(fixnum? v)
(try-extract-procedure (unsafe-struct-ref f v))] (do-extract-procedure (unsafe-struct-ref f v) orig-f n-args success-k)]
[(eq? v 'unsafe) [(eq? v 'unsafe)
(try-extract-procedure (do-extract-procedure
(if (chaperone? f) (if (chaperone? f)
(unsafe-procedure-chaperone-replace-proc f) (unsafe-procedure-chaperone-replace-proc f)
(unsafe-procedure-impersonator-replace-proc f)))] (unsafe-procedure-impersonator-replace-proc f))
orig-f
n-args
success-k)]
[else [else
(let ([v (try-extract-procedure v)]) (do-extract-procedure
(cond v
[(not v) (case-lambda)] orig-f
[else (fx+ n-args 1)
(case-lambda (lambda (v)
[() (v f)] (cond
[(a) (v f a)] [(not v) (case-lambda)]
[(a b) (v f a b)] [else
[(a b c) (v f a b c)] (case-lambda
[args (chez:apply v f args)])]))]))] [() (v f)]
[else #f])) [(a) (v f a)]
[(a b) (v f a b)]
[(a b c) (v f a b c)]
[args (chez:apply v f args)])])))]))]
[else (not-a-procedure orig-f)]))
(define (extract-procedure-name f) (define (extract-procedure-name f)
(cond (cond