guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-124-g153ca


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-124-g153ca1d
Date: Mon, 26 Sep 2011 22:22:45 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=153ca1d2391115f1428837b9465bce89c76691de

The branch, stable-2.0 has been updated
       via  153ca1d2391115f1428837b9465bce89c76691de (commit)
      from  05c9389e3f869f3158d97289f50a52dc2b3caa26 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 153ca1d2391115f1428837b9465bce89c76691de
Author: Andy Wingo <address@hidden>
Date:   Tue Sep 27 00:21:16 2011 +0200

    peval: more strict accounting
    
    * 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.

-----------------------------------------------------------------------

Summary of changes:
 module/language/tree-il/optimize.scm |   91 +++++++++++++++++++++++-----------
 test-suite/tests/tree-il.test        |   10 ++--
 2 files changed, 67 insertions(+), 34 deletions(-)

diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 8c5ae94..d097331 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -247,6 +247,19 @@ references to the new symbols."
            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)
   (%make-counter (make-variable effort-limit)
                  (make-variable size-limit)
@@ -256,20 +269,24 @@ references to the new symbols."
                  #f))
 
 (define (make-nested-counter continuation data current)
-  (%make-counter (effort-counter current)
-                 (size-counter current)
-                 continuation
-                 #f
-                 data
-                 current))
+  (let ((c (%make-counter (make-variable 0)
+                          (make-variable 0)
+                          continuation
+                          #f
+                          data
+                          current)))
+    (transfer! current c)
+    c))
 
 (define (make-recursive-counter effort-limit size-limit orig current)
-  (%make-counter (make-variable effort-limit)
-                 (make-variable size-limit)
-                 (counter-continuation orig)
-                 #t
-                 (counter-data orig)
-                 current))
+  (let ((c (%make-counter (make-variable 0)
+                          (make-variable 0)
+                          (counter-continuation orig)
+                          #t
+                          (counter-data orig)
+                          current)))
+    (transfer! current c effort-limit size-limit)
+    c))
 
 (define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
                 #: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
                     ;; yet.
                     (let/ec k
-                      (let ((abort (lambda ()
-                                     (k (make-application
-                                         src
-                                         (for-value orig-proc)
-                                         (map for-value orig-args))))))
+                      (define (abort)
+                        (k (make-application src
+                                             (for-value 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 (make-let src (append req (or opt '()))
                                         gensyms
                                         (append orig-args
                                                 (drop inits (- nargs nreq)))
                                         body)
-                          env
-                          (cond
-                           ((find-counter key counter)
-                            => (lambda (prev)
-                                 (make-recursive-counter recursive-effort-limit
-                                                         operand-size-limit
-                                                         prev counter)))
-                           (counter
-                            (make-nested-counter abort key counter))
-                           (else
-                            (make-top-counter effort-limit operand-size-limit
-                                              abort key)))
-                          ctx)))))))
+                          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))
+
+                      result)))))
                ((or ($ <primitive-ref>)
                     ($ <lambda>)
                     ($ <toplevel-ref>)
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 4c5b6d6..290a483 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -793,12 +793,14 @@
   (pass-if-peval
    ;; Infinite recursion
    ((lambda (x) (x x)) (lambda (x) (x x)))
-   (let (x) (_)
-        ((lambda _
+   (apply (lambda _
            (lambda-case
             (((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
     ;; First order, aliased primitive.


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]