From: lloda <lloda@sarc.name>
To: 61660@debbugs.gnu.org
Subject: bug#61660: [feature request] optimization of case-lambda
Date: Fri, 24 Feb 2023 18:26:29 +0100 [thread overview]
Message-ID: <B06590B5-6C8F-4313-BF53-CDE684B652FA@sarc.name> (raw)
In-Reply-To: <CF5217BF-0AAD-476A-A5F2-B9AC040B0CBF@sarc.name>
[-- Attachment #1: Type: text/plain, Size: 59 bytes --]
Fixed patch handling rest & #:optional, with test cases.
[-- Attachment #2: 0001-peval-reduces-some-inlined-case-lambda-calls.patch --]
[-- Type: application/octet-stream, Size: 4757 bytes --]
From 61ed612fb36108e395bdee4b1bbb46b49ef017b3 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <lloda@sarc.name>
Date: Thu, 23 Feb 2023 17:38:10 +0100
Subject: [PATCH] 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)))
--
2.30.2
next prev parent reply other threads:[~2023-02-24 17:26 UTC|newest]
Thread overview: 6+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-01-20 19:16 bug#60971: build failure of v3.0.9rc1 on mac os 12.6 lloda
[not found] ` <handler.60971.B.167424218722695.ack@debbugs.gnu.org>
2023-02-23 19:00 ` bug#61660: [feature request] optimization of case-lambda lloda
2023-02-24 17:26 ` lloda [this message]
2023-02-27 10:11 ` Ludovic Courtès
2023-02-27 17:19 ` lloda
-- strict thread matches above, loose matches on Subject: below --
2023-02-20 17:56 lloda
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=B06590B5-6C8F-4313-BF53-CDE684B652FA@sarc.name \
--to=lloda@sarc.name \
--cc=61660@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).