mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

peval: Enable inlining for functions with kwargs

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2024-03-13 20:19:59 +01:00
parent c758c99b5e
commit f95bf6921e
2 changed files with 273 additions and 167 deletions
Download patch file Download diff file Expand all files Collapse all files

426
module/language/tree-il/peval.scm
View file

@ -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))
(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)))))))
(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))))
(($ <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))

14
test-suite/tests/peval.test
View file

@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@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)