bug#61660: [feature request] optimization of case-lambda

[lloda <lloda@sarc.name>]

[-- Attachment #1: Type: text/plain, Size: 39 bytes --]


Patch attached, tests tbd. Thoughts?


[-- Attachment #2: 0001-peval-reduces-some-inlined-case-lambda-calls.patch --]
[-- Type: application/octet-stream, Size: 1952 bytes --]

From a1f605598a7a49b2971072c8db635b788e209e3a 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. Lambda cases
  with more than required args (either optional, keyword, or rest
  arguments) are ignored.
---
 module/language/tree-il/peval.scm | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 7945fd9b9..5c9799edb 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1668,6 +1668,21 @@ top-level bindings from ENV and return the resulting expression."
 
                   (log 'inline-end result exp)
                   result)))))
+           (($ <lambda> src-proc meta body)
+            ;; If there are multiple cases and one matches nargs, omit all the others.
+            (or (and (lambda-case-alternate body)
+                 (let ((nargs (length orig-args)))
+                   (let loop ((body body))
+                     (match body
+                       (#f #f)
+                       (($ <lambda-case> src-body req opt rest kw inits gensyms body alt)
+                        (if (and (not opt) (not rest) (not kw) (= nargs (length req)))
+                          (revisit-proc
+                           (make-lambda
+                            src-proc meta
+                            (make-lambda-case src-body req opt rest kw inits gensyms body #f)))
+                          (loop alt)))))))
+                (make-call src (for-call orig-proc) (map for-value orig-args))))
            (($ <let> _ _ _ vals _)
             ;; Attempt to inline `let' in the operator position.
             ;;
-- 
2.30.2