* call-with-values where the second argument is a single-value
procedure is now direct-call-optimized.
This commit is contained in:
parent
8139a91a61
commit
126b7aa8fa
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -487,6 +487,16 @@
|
|||
(record-case info
|
||||
[(case-info L args proper) proper])]))]
|
||||
[else #f]))
|
||||
(define (single-value-consumer? x)
|
||||
(record-case x
|
||||
[(clambda L cases F)
|
||||
(and (fx= (length cases) 1)
|
||||
(record-case (car cases)
|
||||
[(clambda-case info body)
|
||||
(record-case info
|
||||
[(case-info L args proper)
|
||||
(and proper (fx= (length args) 1))])]))]
|
||||
[else #f]))
|
||||
(define (valid-mv-producer? x)
|
||||
(record-case x
|
||||
[(funcall) #t]
|
||||
|
@ -507,6 +517,8 @@
|
|||
(let ([producer (inline (car rand*) '())]
|
||||
[consumer (cadr rand*)])
|
||||
(cond
|
||||
[(single-value-consumer? consumer)
|
||||
(inline consumer (list producer))]
|
||||
[(and (valid-mv-consumer? consumer)
|
||||
(valid-mv-producer? producer))
|
||||
(make-mvcall producer consumer)]
|
||||
|
|
|
@ -1597,8 +1597,11 @@ reference-implementation:
|
|||
(revcons (reverse ls ls ls '())
|
||||
(append ($car ls*) ($cdr ls*)))])))
|
||||
(primitive-set! 'append
|
||||
(lambda (ls . ls*)
|
||||
(append ls ls*))))
|
||||
(case-lambda
|
||||
[() '()]
|
||||
[(ls) ls]
|
||||
[(ls . ls*)
|
||||
(append ls ls*)])))
|
||||
|
||||
|
||||
(primitive-set! 'list->vector
|
||||
|
|
|
@ -26,6 +26,7 @@
|
|||
syntax quasisyntax unsyntax unsyntax-splicing datum
|
||||
let let* let-values cond case define-record or and when unless do
|
||||
include parameterize trace untrace trace-lambda trace-define
|
||||
rec
|
||||
time))
|
||||
|
||||
|
||||
|
|
|
@ -4676,3 +4676,10 @@
|
|||
[(_ expr)
|
||||
#'(time-it (lambda () expr) 'expr)])))
|
||||
|
||||
(define-syntax rec
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ name proc) (identifier? #'name)
|
||||
#'(letrec ([name proc])
|
||||
name)])))
|
||||
|
||||
|
|
Loading…
Reference in New Issue