mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

peval: more strict accounting

Browse source 
* module/language/tree-il/optimize.scm (transfer!, make-nested-counter):
  (make-recursive-counter, peval): Limit the algorithm's time to be
  strictly O(N) by transferring effort and size counters of recursive
  inlining attempts from containing counters.

* test-suite/tests/tree-il.test ("partial evaluation"): Update
  expectations for the ((lambda (x) (x x)) (lambda (x) (x x))) case, as
  the new accounting policy will cause the entire inlining attempt to
  abort.
This commit is contained in:
Andy Wingo 2011-09-27 00:21:16 +02:00
parent 05c9389e3f
commit 153ca1d239
2 changed files with 67 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

91
module/language/tree-il/optimize.scm
View file

@ -247,6 +247,19 @@ references to the new symbols."
counter counter
(find-counter data (counter-prev counter))))) (find-counter data (counter-prev counter)))))
(define* (transfer! from to #:optional
(effort (variable-ref (effort-counter from)))
(size (variable-ref (size-counter from))))
(define (transfer-counter! from-v to-v amount)
(let* ((from-balance (variable-ref from-v))
(to-balance (variable-ref to-v))
(amount (min amount from-balance)))
(variable-set! from-v (- from-balance amount))
(variable-set! to-v (+ to-balance amount))))
(transfer-counter! (effort-counter from) (effort-counter to) effort)
(transfer-counter! (size-counter from) (size-counter to) size))
(define (make-top-counter effort-limit size-limit continuation data) (define (make-top-counter effort-limit size-limit continuation data)
(%make-counter (make-variable effort-limit) (%make-counter (make-variable effort-limit)
(make-variable size-limit) (make-variable size-limit)
@ -256,20 +269,24 @@ references to the new symbols."
#f)) #f))
(define (make-nested-counter continuation data current) (define (make-nested-counter continuation data current)
(%make-counter (effort-counter current) (let ((c (%make-counter (make-variable 0)
(size-counter current) (make-variable 0)
continuation continuation
#f #f
data data
current)) current)))
(transfer! current c)
c))
(define (make-recursive-counter effort-limit size-limit orig current) (define (make-recursive-counter effort-limit size-limit orig current)
(%make-counter (make-variable effort-limit) (let ((c (%make-counter (make-variable 0)
(make-variable size-limit) (make-variable 0)
(counter-continuation orig) (counter-continuation orig)
#t #t
(counter-data orig) (counter-data orig)
current)) current)))
(transfer! current c effort-limit size-limit)
c))
(define* (peval exp #:optional (cenv (current-module)) (env vlist-null) (define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
#:key #:key
@ -837,29 +854,43 @@ it does not handle <fix> and <let-values>, it should be called before
;; integration of a procedure that hasn't been seen ;; integration of a procedure that hasn't been seen
;; yet. ;; yet.
(let/ec k (let/ec k
(let ((abort (lambda () (define (abort)
(k (make-application (k (make-application src
src (for-value orig-proc)
(for-value orig-proc) (map for-value orig-args))))
(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 (make-let src (append req (or opt '())) (loop (make-let src (append req (or opt '()))
gensyms gensyms
(append orig-args (append orig-args
(drop inits (- nargs nreq))) (drop inits (- nargs nreq)))
body) body)
env env new-counter ctx))
(cond
((find-counter key counter) (if counter
=> (lambda (prev) ;; The nested inlining attempt succeeded.
(make-recursive-counter recursive-effort-limit ;; Deposit the unspent effort and size back
operand-size-limit ;; into the current counter.
prev counter))) (transfer! new-counter counter))
(counter
(make-nested-counter abort key counter)) result)))))
(else
(make-top-counter effort-limit operand-size-limit
abort key)))
ctx)))))))
((or ($ <primitive-ref>) ((or ($ <primitive-ref>)
($ <lambda>) ($ <lambda>)
($ <toplevel-ref>) ($ <toplevel-ref>)

10
test-suite/tests/tree-il.test
View file

@ -793,12 +793,14 @@
(pass-if-peval (pass-if-peval
;; Infinite recursion ;; Infinite recursion
((lambda (x) (x x)) (lambda (x) (x x))) ((lambda (x) (x x)) (lambda (x) (x x)))
(let (x) (_) (apply (lambda _
((lambda _
(lambda-case (lambda-case
(((x) _ _ _ _ _) (((x) _ _ _ _ _)
(apply (lexical x _) (lexical x _)))))) (apply (lexical x _) (lexical x _)))))
(apply (lexical x _) (lexical x _)))) (lambda _
(lambda-case
(((x) _ _ _ _ _)
(apply (lexical x _) (lexical x _)))))))
(pass-if-peval (pass-if-peval
;; First order, aliased primitive. ;; First order, aliased primitive.