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

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

[lloda]

On 3.0.9


> ,optimize ((case-lambda (() 0)))
= 0

but 

> ,optimize ((case-lambda (() 0) ((a) 1)))
= ((case-lambda (() 0) ((a) 1)))


The problem with this is that when the output of a macro contains case-lambda, recursive application results in geometrical increase of code size. It seems that it should be possible to resolve the application on the spot; at last to reduce the case-lambda to a simple lambda when the arity is available (which now only happens when the case-lambda contains a single clause).

Thanks

  Daniel

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

[lloda]

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

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

[lloda]

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

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

[Ludovic Courtès]

Hi Daniel,

lloda <lloda@sarc.name> skribis:

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

[...]

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

Maybe s/FIXME/XXX/ since it’s at most a limitation, certainly not a bug.

It LGTM and Andy already approved it on IRC, so go ahead!

Ludo’.

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

[lloda]

> On 27 Feb 2023, at 11:11, Ludovic Courtès <ludo@gnu.org> wrote:
> 
> Hi Daniel,
> 
> lloda <lloda@sarc.name> skribis:
> 
>> 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.
> 
> [...]
> 
>> +++ 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)
> 
> Maybe s/FIXME/XXX/ since it’s at most a limitation, certainly not a bug.
> 
> It LGTM and Andy already approved it on IRC, so go ahead!
> 
> Ludo’.

Apologies for not seeing this earlier. Pushed to 3b47f87618047ebb8812788c64a44877a4f2e0dd. Thanks!

  - Daniel