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

@@ -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))

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))
 

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)))))