mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-19 02:00:26 +02:00
Recognize append as a primcall and optimize it
* module/language/tree-il/primitives.scm (*primitive-constructors*): (append): Recognize append and reduce it to only the two-operand form. * module/language/tree-il/peval.scm (peval): Add optimizations to append.
This commit is contained in:
parent
38e9bd7a2f
commit
d7cf5bf373
3 changed files with 58 additions and 2 deletions
|
@ -1350,6 +1350,35 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(make-primcall src 'apply
|
||||
(cons (for-value proc) args))))))))
|
||||
|
||||
(($ <primcall> src 'append (x z))
|
||||
(let ((x (for-value x)))
|
||||
(match x
|
||||
((or ($ <const> _ ())
|
||||
($ <primcall> _ 'list ()))
|
||||
(for-value z))
|
||||
((or ($ <const> _ (_ . _))
|
||||
($ <primcall> _ 'cons)
|
||||
($ <primcall> _ 'list))
|
||||
(for-tail
|
||||
(let lp ((x x))
|
||||
(match x
|
||||
((or ($ <const> csrc ())
|
||||
($ <primcall> csrc 'list ()))
|
||||
;; Defer visiting z in value context to for-tail.
|
||||
z)
|
||||
(($ <const> csrc (x . y))
|
||||
(let ((x (make-const csrc x))
|
||||
(y (make-const csrc y)))
|
||||
(make-primcall src 'cons (list x (lp y)))))
|
||||
(($ <primcall> csrc 'cons (x y))
|
||||
(make-primcall src 'cons (list x (lp y))))
|
||||
(($ <primcall> csrc 'list (x . y))
|
||||
(let ((y (make-primcall csrc 'list y)))
|
||||
(make-primcall src 'cons (list x (lp y)))))
|
||||
(x (make-primcall src 'append (list x z)))))))
|
||||
(else
|
||||
(make-primcall src 'append (list x (for-value z)))))))
|
||||
|
||||
(($ <primcall> src (? constructor-primitive? name) args)
|
||||
(cond
|
||||
((and (memq ctx '(effect test))
|
||||
|
|
|
@ -69,7 +69,7 @@
|
|||
|
||||
integer->char char->integer number->string string->number
|
||||
|
||||
acons cons cons*
|
||||
acons cons cons* append
|
||||
|
||||
list vector
|
||||
|
||||
|
@ -147,7 +147,7 @@
|
|||
|
||||
(define *primitive-constructors*
|
||||
;; Primitives that return a fresh object.
|
||||
'(acons cons cons* list vector make-vector
|
||||
'(acons cons cons* append list vector make-vector
|
||||
make-struct/simple
|
||||
make-prompt-tag
|
||||
make-variable))
|
||||
|
@ -563,6 +563,12 @@
|
|||
(x y) (cons x y)
|
||||
(x y . rest) (cons x (cons* y . rest)))
|
||||
|
||||
(define-primitive-expander append
|
||||
() '()
|
||||
(x) (values x)
|
||||
(x y) (append x y)
|
||||
(x y . rest) (append x (append y . rest)))
|
||||
|
||||
(define-primitive-expander acons (x y z)
|
||||
(cons (cons x y) z))
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue