New optimization: demux-lambda

Can help reduce case-lambda* / lambda* at Tree-IL optimization-time.

* module/language/tree-il/demux-lambda.scm: New file.
* am/bootstrap.am (SOURCES): Add new file.
* module/language/tree-il/optimize.scm (make-optimizer):
* module/system/base/optimize.scm (available-optimizations): Enable
demux-lambda at level 2.

am/bootstrap.am

@@ -1,4 +1,4 @@
-##  	Copyright (C) 2009-2023 Free Software Foundation, Inc.
+##  	Copyright (C) 2009-2024 Free Software Foundation, Inc.
 ##
 ##   This file is part of GNU Guile.
 ##
@@ -73,6 +73,7 @@ SOURCES =					\
   language/tree-il/compile-cps.scm		\
   language/tree-il/cps-primitives.scm		\
   language/tree-il/debug.scm			\
+  language/tree-il/demux-lambda.scm		\
   language/tree-il/effects.scm			\
   language/tree-il/eta-expand.scm		\
   language/tree-il/fix-letrec.scm		\

module/language/tree-il/demux-lambda.scm

@@ -0,0 +1,124 @@
+;;; Expand case-lambda and lambda* into simple dispatchers
+;;; Copyright (C) 2024 Free Software Foundation, Inc.
+;;;
+;;; This library is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; We can partition lambdas into simple and complex.  A simple lambda
+;;; has just one clause and no optional, rest, or keyword arguments.
+;;; Any other lambda is complex.  This pass aims to facilitate reduction
+;;; of complex lambdas to simple lambdas.  It does so by eta-expanding
+;;; lexically-bound complex lambdas into simple dispatchers that
+;;; tail-call simple lambda body procedures.  This will allow peval to
+;;; elide the complex lambdas in many cases.
+;;;
+;;; Code:
+
+(define-module (language tree-il demux-lambda)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (language tree-il)
+  #:export (demux-lambda))
+
+(define (make-binding name sym val) (vector name sym val))
+
+(define (demux-clause func-name clause)
+  (match clause
+    (#f (values '() clause))
+    (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+     (call-with-values (lambda () (demux-clause func-name alternate))
+       (lambda (bindings alternate)
+         (define simple-req
+           (append req (or opt '()) (if rest (list rest) '())
+                   (match kw
+                     ((aok? (kw name sym) ...) name)
+                     (#f '()))))
+         (define simple-clause
+           (make-lambda-case src simple-req '() #f #f '() gensyms body #f))
+         (define simple-func (make-lambda src '() simple-clause))
+         (define simple-sym (gensym "demuxed"))
+         (define simple-binding
+           (make-binding func-name simple-sym simple-func))
+
+         (define renamed-syms
+           (map (lambda (_) (gensym "demux")) gensyms))
+         (define rename-sym
+           (let ((renamed (map cons gensyms renamed-syms)))
+             (lambda (sym) (or (assq-ref renamed sym) sym))))
+         (define renamed-kw
+           (match kw
+             ((aok? (kw name sym) ...)
+              (cons aok? (map list kw name (map rename-sym sym))))
+             (#f #f)))
+         (define renamed-inits
+           (map (lambda (init)
+                  (post-order
+                   (lambda (exp)
+                     (match exp
+                       (($ <lexical-ref> src name sym)
+                        (make-lexical-ref src name (rename-sym sym)))
+                       (($ <lexical-set> src name sym exp)
+                        (make-lexical-set src name (rename-sym sym) exp))
+                       (_ exp)))
+                   init))
+                inits))
+         (define dispatch-call
+           (make-call src (make-lexical-ref src func-name simple-sym)
+                      (map (lambda (name sym)
+                             (make-lexical-ref src name sym))
+                           simple-req renamed-syms)))
+         (define dispatch-clause
+           (make-lambda-case src req opt rest renamed-kw renamed-inits
+                             renamed-syms dispatch-call alternate))
+
+         (values (cons simple-binding bindings)
+                 dispatch-clause))))))
+
+(define (demux-lambda exp)
+  (define (complex-lambda? val)
+    (match val
+      (($ <lambda> src meta
+          ($ <lambda-case> src req opt rest kw inits gensyms body alternate))
+       (or (pair? opt) rest (pair? kw) alternate))
+      (_ #f)))
+
+  (define (demux-binding name gensym val)
+    (if (complex-lambda? val)
+        (match val
+          (($ <lambda> src meta clause)
+           (call-with-values (lambda () (demux-clause name clause))
+             (lambda (extra-bindings clause)
+               (let ((val (make-lambda src meta clause)))
+                 (append extra-bindings
+                         (list (make-binding name gensym val))))))))
+        (list (make-binding name gensym val))))
+
+  (define (demux-lexically-bound-complex-lambdas exp)
+    (match exp
+       (($ <letrec> src in-order? names gensyms vals body)
+        (match (append-map demux-binding names gensyms vals)
+          ((#(name gensym val) ...)
+           (make-letrec src in-order? name gensym val body))))
+
+       (($ <let> src names gensyms vals body)
+        (if (or-map lambda? vals)
+            (demux-lexically-bound-complex-lambdas
+             (make-letrec src #f names gensyms vals body))
+            exp))
+
+       (_ exp)))
+
+  (post-order demux-lexically-bound-complex-lambdas exp))

module/language/tree-il/optimize.scm

@@ -1,6 +1,6 @@
 ;;; Tree-il optimizer
 
-;; Copyright (C) 2009, 2010-2015, 2018-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010-2015, 2018-2021, 2024 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -45,6 +45,7 @@
         (letrectify (lookup #:letrectify? letrectify))
         (seal?      (assq-ref opts #:seal-private-bindings?))
         (xinline?   (assq-ref opts #:cross-module-inlining?))
+        (demux      (lookup #:demux-lambda? demux-lambda))
         (peval      (lookup #:partial-eval? peval))
         (eta-expand (lookup #:eta-expand? eta-expand))
         (inlinables (lookup #:inlinable-exports? inlinable-exports)))
@@ -56,6 +57,7 @@
       (run-pass! (resolve exp env))
       (run-pass! (expand exp))
       (run-pass! (letrectify exp #:seal-private-bindings? seal?))
+      (run-pass! (demux exp))
       (run-pass! (fix-letrec exp))
       (run-pass! (peval exp env #:cross-module-inlining? xinline?))
       (run-pass! (eta-expand exp))

module/system/base/optimize.scm

@@ -1,6 +1,6 @@
 ;;; Optimization flags
 
-;; Copyright (C) 2018, 2020-2022 Free Software Foundation, Inc.
+;; Copyright (C) 2018,2020-2022,2024 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -32,6 +32,7 @@
        (#:resolve-primitives? 1)
        (#:expand-primitives? 1)
        (#:letrectify? 2)
+       (#:demux-lambda? 2)
        (#:seal-private-bindings? 3)
        (#:partial-eval? 1)
        (#:eta-expand? 2)