wingo pushed a commit to branch main
in repository guile.
commit d7cf5bf373392a18e9a4de06f751eae3d66ce1af
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Mon Nov 27 14:25:23 2023 +0100
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.
---
module/language/tree-il/peval.scm | 29 +++++++++++++++++++++++++++++
module/language/tree-il/primitives.scm | 10 ++++++++--
test-suite/tests/peval.test | 21 +++++++++++++++++++++
3 files changed, 58 insertions(+), 2 deletions(-)
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 937a797f0..1eb928f07 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -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))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 153c602b2..dd5592a41 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -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))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index bed2e2dc4..c96cfac21 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1588,5 +1588,26 @@
(pass-if-peval (begin (cons 1 (values)) #f)
(seq (primcall values (primcall values))
(const #f)))
+
(pass-if-peval (begin 1 (values) #f)
(const #f)))
+
+(with-test-prefix "append"
+ (pass-if-peval (append '() 42)
+ (const 42))
+
+ (pass-if-peval (append '(1 2) 42)
+ (primcall cons (const 1)
+ (primcall cons (const 2) (const 42))))
+
+ (pass-if-peval (append (list 1 2) 42)
+ (primcall cons (const 1)
+ (primcall cons (const 2) (const 42))))
+
+ (pass-if-peval (append (cons* 1 2 '()) 42)
+ (primcall cons (const 1)
+ (primcall cons (const 2) (const 42))))
+
+ (pass-if-peval (append (cons 1 2) 42)
+ (primcall cons (const 1)
+ (primcall append (const 2) (const 42)))))
