wingo pushed a commit to branch main
in repository guile.
commit c758c99b5e37408e48dc1b22c73d6ec35d9de866
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Wed Mar 13 13:11:14 2024 +0100
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 | 3 +-
module/language/tree-il/demux-lambda.scm | 124 +++++++++++++++++++++++++++++++
module/language/tree-il/optimize.scm | 4 +-
module/system/base/optimize.scm | 3 +-
4 files changed, 131 insertions(+), 3 deletions(-)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index a71946958..00f677e4f 100644
--- a/am/bootstrap.am
+++ b/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 \
diff --git a/module/language/tree-il/demux-lambda.scm
b/module/language/tree-il/demux-lambda.scm
new file mode 100644
index 000000000..661ce7962
--- /dev/null
+++ b/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))
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index b1d8b8294..11e0470be 100644
--- a/module/language/tree-il/optimize.scm
+++ b/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))
diff --git a/module/system/base/optimize.scm b/module/system/base/optimize.scm
index 8c36cca07..2152041c3 100644
--- a/module/system/base/optimize.scm
+++ b/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)
