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))))) (($ 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 + (($ ) #t) + (($ _ _ 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 (($ _ 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))) - (($ _ _ - ($ _ 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 - (($ ) #t) - (($ _ _ sym) - (and (not (assigned-lexical? sym)) - (= (lexical-refcount sym) 1) - (singly-referenced-lambda? - (operand-source (lookup sym))))) + + (($ _ _ 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 + (($ _ (? keyword?)) #t) + (_ #f))) + (define (not-keyword-arg? exp) + (match exp + ((or ($ _ (not (? keyword?))) + ($ ) + ($ ) + ($ )) + #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)) + ((($ _ (? 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)) + (($ 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))))) - (($ 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. - (($ 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)))) (($ _ _ _ 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))))) + (($ 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 --- 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)