summaryrefslogtreecommitdiff
path: root/module/language/tree-il
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-11-27 14:25:23 +0100
committerAndy Wingo <wingo@pobox.com>2023-11-27 14:30:41 +0100
commitd7cf5bf373392a18e9a4de06f751eae3d66ce1af (patch)
tree38c642370ab6a94ff9cb6f47fa8237c396d066fa /module/language/tree-il
parent38e9bd7a2f9d84442bc26ec4b2d91f515aedfeb1 (diff)
downloadguile-d7cf5bf373392a18e9a4de06f751eae3d66ce1af.tar.gz
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.
Diffstat (limited to 'module/language/tree-il')
-rw-r--r--module/language/tree-il/peval.scm29
-rw-r--r--module/language/tree-il/primitives.scm10
2 files changed, 37 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))