wingo pushed a commit to branch main
in repository guile.
commit f95bf6921e13799abca6a0a13087609c42baba6b
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Wed Mar 13 20:19:59 2024 +0100
peval: Enable inlining for functions with kwargs
* module/language/tree-il/peval.scm (peval): Handle all lambda inlining
the same, and extend with support for multiple clauses and keyword
arguments.
* test-suite/tests/peval.test ("case-lambda"): Enable kwarg inlining.
---
module/language/tree-il/peval.scm | 428 +++++++++++++++++++++++---------------
test-suite/tests/peval.test | 14 +-
2 files changed, 274 insertions(+), 168 deletions(-)
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 1eb928f07..dd777d863 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1,6 +1,6 @@
;;; Tree-IL partial evaluator
-;; Copyright (C) 2011-2014,2017,2019-2023 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014,2017,2019-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
@@ -1554,7 +1554,83 @@ top-level bindings from ENV and return the resulting
expression."
(make-primcall src name args)))))
(($ <call> src orig-proc orig-args)
- ;; todo: augment the global env with specialized functions
+ (define (residualize-call)
+ (make-call src (for-call orig-proc) (map for-value orig-args)))
+
+ (define (singly-referenced-lambda? proc)
+ (match proc
+ (($ <lambda>) #t)
+ (($ <lexical-ref> _ _ sym)
+ (and (not (assigned-lexical? sym))
+ (= (lexical-refcount sym) 1)
+ (singly-referenced-lambda?
+ (operand-source (lookup sym)))))
+ (_ #f)))
+
+ (define (attempt-inlining proc names syms vals body)
+ (define inline-key (source-expression proc))
+ (define existing-counter (find-counter inline-key counter))
+ (define inlined-exp (make-let src names syms vals body))
+
+ (cond
+ ((and=> existing-counter counter-recursive?)
+ ;; A recursive call. Process again in tail context.
+
+ ;; Mark intervening counters as recursive, so we can
+ ;; handle a toplevel counter that recurses mutually with
+ ;; some other procedure. Otherwise, the next time we see
+ ;; the other procedure, the effort limit would be clamped
+ ;; to 100.
+ (let lp ((counter counter))
+ (unless (eq? counter existing-counter)
+ (set-counter-recursive?! counter #t)
+ (lp (counter-prev counter))))
+
+ (log 'inline-recurse inline-key)
+ (loop inlined-exp env counter ctx))
+ ((singly-referenced-lambda? orig-proc)
+ ;; A lambda in the operator position of the source
+ ;; expression. Process again in tail context.
+ (log 'inline-beta inline-key)
+ (loop inlined-exp env counter ctx))
+ (else
+ ;; An integration at the top-level, the first
+ ;; recursion of a recursive procedure, or a nested
+ ;; integration of a procedure that hasn't been seen
+ ;; yet.
+ (log 'inline-begin exp)
+ (let/ec k
+ (define (abort)
+ (log 'inline-abort exp)
+ (k (residualize-call)))
+ (define new-counter
+ (cond
+ ;; These first two cases will transfer effort from
+ ;; the current counter into the new counter.
+ (existing-counter
+ (make-recursive-counter recursive-effort-limit
+ operand-size-limit
+ existing-counter counter))
+ (counter
+ (make-nested-counter abort inline-key counter))
+ ;; This case opens a new account, effectively
+ ;; printing money. It should only do so once for
+ ;; each call site in the source program.
+ (else
+ (make-top-counter effort-limit operand-size-limit
+ abort inline-key))))
+ (define result
+ (loop inlined-exp env new-counter ctx))
+
+ (when counter
+ ;; The nested inlining attempt succeeded. Deposit the
+ ;; unspent effort and size back into the current
+ ;; counter.
+ (transfer! new-counter counter))
+
+ (log 'inline-end result exp)
+ result))))
+
(let revisit-proc ((proc (visit orig-proc 'operator)))
(match proc
(($ <primitive-ref> _ name)
@@ -1563,167 +1639,193 @@ top-level bindings from ENV and return the resulting
expression."
(augment-var-table-with-externally-introduced-lexicals
exp store))
(for-tail exp)))
- (($ <lambda> _ _
- ($ <lambda-case> _ req opt rest #f inits gensyms body #f))
- ;; Simple case: no keyword arguments.
- ;; todo: handle the more complex cases
- (let* ((nargs (length orig-args))
- (nreq (length req))
- (opt (or opt '()))
- (rest (if rest (list rest) '()))
- (nopt (length opt))
- (key (source-expression proc)))
- (define (singly-referenced-lambda? orig-proc)
- (match orig-proc
- (($ <lambda>) #t)
- (($ <lexical-ref> _ _ sym)
- (and (not (assigned-lexical? sym))
- (= (lexical-refcount sym) 1)
- (singly-referenced-lambda?
- (operand-source (lookup sym)))))
+
+ (($ <lambda> _ _ clause)
+ ;; A lambda. Attempt to find the matching clause, if
+ ;; possible.
+ (define (inline-clause req opt rest kw inits gensyms body
+ arity-mismatch)
+ (define (bind name sym val binds)
+ (cons (vector name sym val) binds))
+ (define (has-binding? binds sym)
+ (match binds
+ (() #f)
+ ((#(n s v) . binds)
+ (or (eq? s sym) (has-binding? binds sym)))))
+
+ ;; The basic idea is that we are going to transform an
+ ;; expression like ((lambda (param ...) body) arg ...)
+ ;; into (let ((param arg) ...) body). However, we have to
+ ;; consider order of effects and scope: the args are
+ ;; logically parallel, whereas initializer expressions for
+ ;; params that don't have arguments are evaluated in
+ ;; order, after the arguments. Therefore we have a set of
+ ;; parallel bindings, abbreviated pbinds, which proceed
+ ;; from the call site, and a set of serial bindings, the
+ ;; sbinds, which result from callee initializers. We
+ ;; collect these in reverse order as we parse arguments.
+ ;; The result is an outer let for the parallel bindings
+ ;; containing a let* of the serial bindings and then the
+ ;; body.
+
+ (define (process-req req syms args pbinds sbinds)
+ (match req
+ (() (process-opt (or opt '()) syms inits args pbinds sbinds))
+ ((name . req)
+ (match syms
+ ((sym . syms)
+ (match args
+ (() (arity-mismatch))
+ ((arg . args)
+ (process-req req syms args
+ (bind name sym arg pbinds)
+ sbinds))))))))
+
+ (define (keyword-arg? exp)
+ (match exp
+ (($ <const> _ (? keyword?)) #t)
+ (_ #f)))
+ (define (not-keyword-arg? exp)
+ (match exp
+ ((or ($ <const> _ (not (? keyword?)))
+ ($ <void>)
+ ($ <primitive-ref>)
+ ($ <lambda>))
+ #t)
(_ #f)))
- (define (inlined-call)
- (let ((req-vals (list-head orig-args nreq))
- (opt-vals (let lp ((args (drop orig-args nreq))
- (inits inits)
- (out '()))
- (match inits
- (() (reverse out))
- ((init . inits)
- (match args
- (()
- (lp '() inits (cons init out)))
- ((arg . args)
- (lp args inits (cons arg out))))))))
- (rest-vals (cond
- ((> nargs (+ nreq nopt))
- (list (make-primcall
- #f 'list
- (drop orig-args (+ nreq nopt)))))
- ((null? rest) '())
- (else (list (make-const #f '()))))))
- (if (>= nargs (+ nreq nopt))
- (make-let src
- (append req opt rest)
- gensyms
- (append req-vals opt-vals rest-vals)
- body)
- ;; The default initializers of optional arguments
- ;; may refer to earlier arguments, so in the general
- ;; case we must expand into a series of nested let
- ;; expressions.
- ;;
- ;; In the generated code, the outermost let
- ;; expression will bind all required arguments, as
- ;; well as the empty rest argument, if any. Each
- ;; optional argument will be bound within an inner
- ;; let.
- (make-let src
- (append req rest)
- (append (list-head gensyms nreq)
- (last-pair gensyms))
- (append req-vals rest-vals)
- (fold-right (lambda (var gensym val body)
- (make-let src
- (list var)
- (list gensym)
- (list val)
- body))
- body
- opt
- (list-head (drop gensyms nreq)
nopt)
- opt-vals)))))
+ (define (process-opt opt syms inits args pbinds sbinds)
+ (match opt
+ (() (process-rest syms inits args pbinds sbinds))
+ ((name . opt)
+ (match inits
+ ((init . inits)
+ (match syms
+ ((sym . syms)
+ (cond
+ (kw
+ (match args
+ ((or () ((? keyword-arg?) . _))
+ ;; Optargs and kwargs; stop optarg dispatch at
+ ;; first keyword.
+ (process-opt opt syms inits args pbinds
+ (bind name sym init sbinds)))
+ (((? not-keyword-arg? arg) . args)
+ ;; Arg is definitely not a keyword; it is an
+ ;; optarg.
+ (process-opt opt syms inits args
+ (bind name sym arg pbinds)
+ sbinds))
+ (_
+ ;; We can't tell whether the arg is a keyword
+ ;; or not! Annoying semantics, this.
+ (residualize-call))))
+ (else
+ ;; No kwargs.
+ (match args
+ (()
+ (process-opt opt syms inits args pbinds
+ (bind name sym init sbinds)))
+ ((arg . args)
+ (process-opt opt syms inits args
+ (bind name sym arg pbinds)
+ sbinds))))))))))))
+
+ (define (process-rest syms inits args pbinds sbinds)
+ (match rest
+ (#f
+ (match kw
+ ((#f . kw)
+ (process-kw kw syms inits args pbinds sbinds))
+ (#f
+ (unless (and (null? syms) (null? inits))
+ (error "internal error"))
+ (match args
+ (() (finish pbinds sbinds body))
+ (_ (arity-mismatch))))))
+ (rest
+ (match syms
+ ((sym . syms)
+ (let ((rest-val (make-primcall src 'list args)))
+ (unless (and (null? syms) (null? inits))
+ (error "internal error"))
+ (finish pbinds (bind rest sym rest-val sbinds)
+ body)))))))
+
+ (define (process-kw kw syms inits args pbinds sbinds)
+ ;; Require that the ordered list of the keywords'
+ ;; syms is the same as the remaining gensyms to bind.
+ ;; Psyntax emits tree-il with this property, and it
+ ;; is required by (and checked by) other parts of the
+ ;; compiler, e.g. tree-il-to-cps lowering.
+ (unless (equal? syms (match kw (((k name sym) ...) sym)))
+ (error "internal error: unexpected kwarg syms"))
+
+ (define (process-kw-args positional? args pbinds)
+ (match args
+ (()
+ (process-kw-inits kw inits pbinds sbinds))
+ ((($ <const> _ (? keyword? keyword)) arg . args)
+ (match (assq keyword kw)
+ ((keyword name sym)
+ ;; Because of side effects, we don't
+ ;; optimize passing the same keyword arg
+ ;; multiple times.
+ (if (has-binding? pbinds sym)
+ (residualize-call)
+ (process-kw-args #f args
+ (bind name sym arg pbinds))))
+ (#f (residualize-call))))
+ (((? not-keyword-arg?) . args)
+ (if positional?
+ (arity-mismatch)
+ (residualize-call)))
+ (_ (residualize-call))))
+
+ (define (process-kw-inits kw inits pbinds sbinds)
+ (match kw
+ (()
+ (unless (null? inits) (error "internal error"))
+ (finish pbinds sbinds body))
+ (((keyword name sym) . kw)
+ (match inits
+ ((init . inits)
+ (process-kw-inits kw inits pbinds
+ (if (has-binding? pbinds sym)
+ sbinds
+ (bind name sym init
sbinds))))))))
+
+ (process-kw-args #t args pbinds))
+
+ (define (finish pbinds sbinds body)
+ (match sbinds
+ (()
+ (match (reverse pbinds)
+ ((#(name sym val) ...)
+ (attempt-inlining proc name sym val body))))
+ ((#(name sym val) . sbinds)
+ (finish pbinds sbinds
+ (make-let src (list name) (list sym) (list val)
+ body)))))
+
+ ;; Limitations:
+ ;;
+ ;; - #:key or #:rest, but not both.
+ ;; - #:allow-other-keys unsupported.
(cond
- ((or (< nargs nreq) (and (null? rest) (> nargs (+ nreq nopt))))
- ;; An error, or effecting arguments.
- (make-call src (for-call orig-proc) (map for-value orig-args)))
- ((or (and=> (find-counter key counter) counter-recursive?)
- (singly-referenced-lambda? orig-proc))
- ;; A recursive call, or a lambda in the operator
- ;; position of the source expression. Process again in
- ;; tail context.
- ;;
- ;; In the recursive case, mark intervening counters as
- ;; recursive, so we can handle a toplevel counter that
- ;; recurses mutually with some other procedure.
- ;; Otherwise, the next time we see the other procedure,
- ;; the effort limit would be clamped to 100.
- ;;
- (let ((found (find-counter key counter)))
- (if (and found (counter-recursive? found))
- (let lp ((counter counter))
- (if (not (eq? counter found))
- (begin
- (set-counter-recursive?! counter #t)
- (lp (counter-prev counter)))))))
-
- (log 'inline-recurse key)
- (loop (inlined-call) env counter ctx))
+ ((and kw (or rest (match kw ((aok? . _) aok?))))
+ (residualize-call))
(else
- ;; An integration at the top-level, the first
- ;; recursion of a recursive procedure, or a nested
- ;; integration of a procedure that hasn't been seen
- ;; yet.
- (log 'inline-begin exp)
- (let/ec k
- (define (abort)
- (log 'inline-abort exp)
- (k (make-call src (for-call orig-proc)
- (map for-value orig-args))))
- (define new-counter
- (cond
- ;; These first two cases will transfer effort
- ;; from the current counter into the new
- ;; counter.
- ((find-counter key counter)
- => (lambda (prev)
- (make-recursive-counter recursive-effort-limit
- operand-size-limit
- prev counter)))
- (counter
- (make-nested-counter abort key counter))
- ;; This case opens a new account, effectively
- ;; printing money. It should only do so once
- ;; for each call site in the source program.
- (else
- (make-top-counter effort-limit operand-size-limit
- abort key))))
- (define result
- (loop (inlined-call) env new-counter ctx))
-
- (if counter
- ;; The nested inlining attempt succeeded.
- ;; Deposit the unspent effort and size back
- ;; into the current counter.
- (transfer! new-counter counter))
-
- (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
- orig-body
- (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))))
+ (process-req req gensyms orig-args '() '()))))
+
+ (let lp ((clause clause))
+ (match clause
+ ;; No clause matches.
+ (#f (residualize-call))
+ (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+ (inline-clause req opt rest kw inits gensyms body
+ (lambda () (lp alt)))))))
+
(($ <let> _ _ _ vals _)
;; Attempt to inline `let' in the operator position.
;;
@@ -1747,10 +1849,10 @@ top-level bindings from ENV and return the resulting
expression."
;; traverse through lambdas. In that case re-visit
;; the procedure.
(proc (revisit-proc proc)))
- (make-call src (for-call orig-proc)
- (map for-value orig-args))))
- (_
- (make-call src (for-call orig-proc) (map for-value orig-args))))))
+ (residualize-call)))
+
+ (_ (residualize-call)))))
+
(($ <lambda> src meta body)
(case ctx
((effect) (make-void #f))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index c96cfac21..756cccdf3 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wi...@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009-2014, 2017, 2020, 2022-2023 Free Software
Foundation, Inc.
+;;;; Copyright (C) 2009-2014, 2017, 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
@@ -1523,10 +1523,14 @@
(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))))
+ (pass-if-peval ((case-lambda* ((a b) 0) ((a #:key x) 1)) 0 #:x 1)
+ (const 1))
+ (pass-if-peval ((case-lambda* ((a b c) 0) ((a #:key x) 1)) 0 #:x 1)
+ (const 0))
+ (pass-if-peval ((case-lambda* ((a #:key x) 0) ((a b) 0)) 0 #:x 1)
+ (const 0))
+ (pass-if-peval ((case-lambda* ((a #:key x) 0) ((a b c) 1)) 0 1 2)
+ (const 1)))
(with-test-prefix "eqv?"
(pass-if-peval (eqv? x #f)
