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

speed up keyword expansion

Browse Source 
Expansion of a procedure with keywords is quadratic due to generating
a nested sequence of `let`s, but speed it up by roughly a constant
factor by using a dintinct symbol for each nested layer.

Related to #3070
This commit is contained in:
Matthew Flatt 2020-03-12 05:42:29 -06:00
parent f98d0a5cc1
commit 9ef2124a38
1 changed files with 36 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
racket/collects/racket/private/kw.rkt
View File

@ -906,31 +906,35 @@
;; to the actual value (if present); if the keyword isn't ;; to the actual value (if present); if the keyword isn't
;; available, then the corresponding `req' is applied, which ;; available, then the corresponding `req' is applied, which
;; should signal an error if the keyword is required. ;; should signal an error if the keyword is required.
(define-syntax let-kws (define-syntax (let-kws stx)
(syntax-rules () (syntax-case stx ()
[(_ kws kw-args () . body) [(_ kws kw-args () . body)
(begin . body)] #'(begin . body)]
[(_ kws kw-args ([kw arg arg? #f not-supplied-val]) . body) [(_ kws kw-args ([kw arg arg? #f not-supplied-val]) . body)
;; last optional argument doesn't need to check as much or take as many cdrs ;; last optional argument doesn't need to check as much or take as many cdrs
(let ([arg? (pair? kws)]) #'(let ([arg? (pair? kws)])
(let ([arg (if arg? (car kw-args) not-supplied-val)]) (let ([arg (if arg? (car kw-args) not-supplied-val)])
. body))] . body))]
[(_ kws kw-args ([kw arg arg? #f not-supplied-val] . rest) . body) [(_ kws kw-args ([kw arg arg? #f not-supplied-val] . rest) . body)
(let ([arg? (and (pair? kws) (with-syntax ([next-kws (gensym 'kws)]
(eq? 'kw (car kws)))]) [next-kw-args (gensym 'kw-args)])
(let ([arg (if arg? (car kw-args) not-supplied-val)] #'(let ([arg? (and (pair? kws)
[kws (if arg? (cdr kws) kws)] (eq? 'kw (car kws)))])
[kw-args (if arg? (cdr kw-args) kw-args)]) (let ([arg (if arg? (car kw-args) not-supplied-val)]
(let-kws kws kw-args rest . body)))] [next-kws (if arg? (cdr kws) kws)]
[next-kw-args (if arg? (cdr kw-args) kw-args)])
(let-kws next-kws next-kw-args rest . body))))]
[(_ kws kw-args ([kw arg arg? #t _]) . body) [(_ kws kw-args ([kw arg arg? #t _]) . body)
;; last required argument doesn't need to take cdrs ;; last required argument doesn't need to take cdrs
(let ([arg (car kw-args)]) #'(let ([arg (car kw-args)])
. body)] . body)]
[(_ kws kw-args ([kw arg arg? #t _] . rest) . body) [(_ kws kw-args ([kw arg arg? #t _] . rest) . body)
(let ([arg (car kw-args)] (with-syntax ([next-kws (gensym 'kws)]
[kws (cdr kws)] [next-kw-args (gensym 'kw-args)])
[kw-args (cdr kw-args)]) #'(let ([arg (car kw-args)]
(let-kws kws kw-args rest . body))])) [next-kws (cdr kws)]
[next-kw-args (cdr kw-args)])
(let-kws next-kws next-kw-args rest . body)))]))
;; Used for `req' when the keyword argument is optional: ;; Used for `req' when the keyword argument is optional:
(define-syntax missing-ok (define-syntax missing-ok
@ -1068,13 +1072,15 @@
(syntax-case stx (quote) (syntax-case stx (quote)
[(_ l1-expr '()) #'(null? l1-expr)] [(_ l1-expr '()) #'(null? l1-expr)]
[(_ '() l2-expr) #'#t] [(_ '() l2-expr) #'#t]
[(_ l1-expr '(kw . kws)) #'(let ([l1 l1-expr]) [(_ l1-expr '(kw . kws))
(let ([l1 (if (null? l1) (with-syntax ([l1 (gensym 'l1)])
l1 #'(let ([l1 l1-expr])
(if (eq? (car l1) 'kw) (let ([l1 (if (null? l1)
(cdr l1) l1
l1))]) (if (eq? (car l1) 'kw)
(subset?/static l1 'kws)))] (cdr l1)
l1))])
(subset?/static l1 'kws))))]
[(_ l1-expr l2-expr) #'(subset? l1-expr l2-expr)])) [(_ l1-expr l2-expr) #'(subset? l1-expr l2-expr)]))
(define-syntax (subsets?/static stx) (define-syntax (subsets?/static stx)
@ -1095,10 +1101,11 @@
(syntax-case stx (quote) (syntax-case stx (quote)
[(_ '() l2-expr) #'(null? l2-expr)] [(_ '() l2-expr) #'(null? l2-expr)]
[(_ '(kw . kw-rest) l2-expr) [(_ '(kw . kw-rest) l2-expr)
#'(let ([l2 l2-expr]) (with-syntax ([l2 (gensym 'l2)])
(and (pair? l2) #'(let ([l2 l2-expr])
(eq? (car l2) 'kw) (and (pair? l2)
(equal?/static 'kw-rest (cdr l2))))])) (eq? (car l2) 'kw)
(equal?/static 'kw-rest (cdr l2)))))]))
;; ---------------------------------------- ;; ----------------------------------------
;; `define' with keyword arguments ;; `define' with keyword arguments