diff options
author | Andy Wingo <wingo@pobox.com> | 2023-11-27 14:25:23 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2023-11-27 14:30:41 +0100 |
commit | d7cf5bf373392a18e9a4de06f751eae3d66ce1af (patch) | |
tree | 38c642370ab6a94ff9cb6f47fa8237c396d066fa /module/language/tree-il | |
parent | 38e9bd7a2f9d84442bc26ec4b2d91f515aedfeb1 (diff) | |
download | guile-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.scm | 29 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 10 |
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)) |