[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] branch main updated: peval reduces some inlined case-lam
From: |
Daniel Llorens |
Subject: |
[Guile-commits] branch main updated: peval reduces some inlined case-lambda calls |
Date: |
Mon, 27 Feb 2023 05:56:31 -0500 |
This is an automated email from the git hooks/post-receive script.
lloda pushed a commit to branch main
in repository guile.
The following commit(s) were added to refs/heads/main by this push:
new 3b47f8761 peval reduces some inlined case-lambda calls
3b47f8761 is described below
commit 3b47f87618047ebb8812788c64a44877a4f2e0dd
Author: Daniel Llorens <lloda@sarc.name>
AuthorDate: Thu Feb 23 17:38:10 2023 +0100
peval reduces some inlined case-lambda calls
* module/language/tree-il/peval.scm (peval): Reduce multiple case lambda
in <call> trees according to the number of arguments. Do not try to
reduce case-lambda using keyword arguments.
* test-suite/tests/peval.test: Tests.
---
module/language/tree-il/peval.scm | 23 +++++++++++++
test-suite/tests/peval.test | 72 +++++++++++++++++++++++++++++++++++++++
2 files changed, 95 insertions(+)
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 7945fd9b9..7c05e9a2e 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1668,6 +1668,29 @@ top-level bindings from ENV and return the resulting
expression."
(log 'inline-end result exp)
result)))))
+ (($ <lambda> src-proc meta orig-body)
+ ;; If there are multiple cases and one matches nargs, omit all the
others.
+ (or (and
+ (lambda-case-alternate orig-body)
+ (let ((nargs (length orig-args)))
+ (let loop ((body orig-body))
+ (match body
+ (#f #f) ;; No matching case; an error.
+ (($ <lambda-case> src-case req opt rest kw inits
gensyms case-body alt)
+ (cond (kw
+ ;; FIXME: Not handling keyword cases.
+ #f)
+ ((let ((nreq (length req)))
+ (if rest
+ (<= nreq nargs)
+ (<= nreq nargs (+ nreq (if opt (length opt)
0)))))
+ ;; Keep only this case.
+ (revisit-proc
+ (make-lambda
+ src-proc meta
+ (make-lambda-case src-case req opt rest kw
inits gensyms case-body #f))))
+ (else (loop alt))))))))
+ (make-call src (for-call orig-proc) (map for-value
orig-args))))
(($ <let> _ _ _ vals _)
;; Attempt to inline `let' in the operator position.
;;
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index a2e4975d9..8a8f0124a 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1456,6 +1456,78 @@
;; <https://bugs.gnu.org/60522>.
(primcall make-vector)))
+(with-test-prefix "case-lambda"
+ ;; one case
+ (pass-if-peval
+ ((case-lambda (() 0)))
+ (const 0))
+
+ ;; middle
+ (pass-if-peval
+ ((case-lambda (() 0) ((a b) 1) ((a) 2)) 1 2)
+ (const 1))
+
+ ;; last
+ (pass-if-peval
+ ((case-lambda ((a b) 0) ((a) 1) (() 2)))
+ (const 2))
+
+ ;; first
+ (pass-if-peval
+ ((case-lambda ((a) 0) (() 1) ((a b) 2)) 1)
+ (const 0))
+
+ ;; rest arg
+ (pass-if-peval
+ ((case-lambda (args 0) ((a b) 1) ((a) 2)) 1 2)
+ (const 0))
+
+ ;; req before rest I
+ (pass-if-peval
+ ((case-lambda ((a b) 0) (args 1) ((a) 1)) 1 2)
+ (const 0))
+
+ ;; req before rest II
+ (pass-if-peval
+ ((case-lambda ((a) 0) (args 1) ((a b) 2)) 1 2)
+ (const 1))
+
+ ;; optional
+ (pass-if-peval
+ ((case-lambda* ((a #:optional x) 0) (args 1) ((a) 2)) 1 2)
+ (const 0))
+
+ ;; optional and rest, no match I
+ (pass-if-peval
+ ((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)))
+ (const 1))
+
+ ;; optional and rest, match I
+ (pass-if-peval
+ ((case-lambda* (() 0) ((a #:optional x . rest) 1) ((a) 2)) 1)
+ (const 1))
+
+ ;; optional and rest, match II
+ (pass-if-peval
+ ((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)) 1)
+ (const 0))
+
+ ;; optional and rest, match III
+ (pass-if-peval
+ ((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)) 1 2)
+ (const 0))
+
+ ;; optional and rest, match IV
+ (pass-if-peval
+ ((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)) 1 2 3)
+ (const 0))
+
+ ;; keyword cases survive
+ (pass-if (= 1 ((case-lambda* ((a b) 0) ((a #:key x) 1)) 0 #:x 1)))
+ (pass-if (= 0 ((case-lambda* ((a b c) 0) ((a #:key x) 1)) 0 #:x 1)))
+ (pass-if (= 0 ((case-lambda* ((a #:key x) 0) ((a b) 0)) 0 #:x 1)))
+ (pass-if (= 1 ((case-lambda* ((a #:key x) 0) ((a b c) 1)) 0 1 2))))
+
(with-test-prefix "eqv?"
(pass-if-peval (eqv? x #f)
(primcall eq? (toplevel x) (const #f)))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] branch main updated: peval reduces some inlined case-lambda calls,
Daniel Llorens <=