guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] GNU Guile branch, wip-on-demand, updated. v2.0.2-159-g5b


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, wip-on-demand, updated. v2.0.2-159-g5b110a8
Date: Sat, 08 Oct 2011 15:02:30 +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=5b110a87a91efe6f02f9a34407714415c0b1b2e8

The branch, wip-on-demand has been updated
       via  5b110a87a91efe6f02f9a34407714415c0b1b2e8 (commit)
       via  af12c438b7355fb5d74590fd7623f7129bc6e9c5 (commit)
       via  b3d7b4d0712d1f0a5b484e856e2712ee826ae53b (commit)
       via  99c2cb2989a34cebd2db3fef96a6e66810fef837 (commit)
       via  9c0acd7448adee2d644c7314786a4554986b50bf (commit)
       via  451d8ae33a4cb1e3db91669aaa0ada0b886fe79c (commit)
       via  0ddc24ee71e2023a110d8abb719c484da24ce864 (commit)
       via  158cc8ef19df2031c5e8b96470af9ca4a5f299fd (commit)
       via  737b732ab71f57dff1278581c9a3d7542f9b66ec (commit)
      from  f4e213df723f6dc31c8769a3e9eec9f942a5104c (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 5b110a87a91efe6f02f9a34407714415c0b1b2e8
Author: Andy Wingo <address@hidden>
Date:   Sat Oct 8 17:01:25 2011 +0200

    use pre-computed residual code in prune-bindings
    
    * module/language/tree-il/peval.scm (peval): When pruning bindings, use
      and take advantage of the already-computed residual code.

commit af12c438b7355fb5d74590fd7623f7129bc6e9c5
Author: Andy Wingo <address@hidden>
Date:   Sat Oct 8 16:49:42 2011 +0200

    remember residual values, where possible
    
    * module/language/tree-il/peval.scm (<operand>, peval): If we
      residualize a binding and we know what the value should be, record
      that binding.

commit b3d7b4d0712d1f0a5b484e856e2712ee826ae53b
Author: Andy Wingo <address@hidden>
Date:   Sat Oct 8 16:45:02 2011 +0200

    cache a copyable? flag on operands
    
    * module/language/tree-il/peval.scm (<operand>, make-operand, peval): If
      we visit an operand and it doesn't turn out to be constant, we will
      never be able to copy it.  Save ourselves future visits to the operand
      in that case.

commit 99c2cb2989a34cebd2db3fef96a6e66810fef837
Author: Andy Wingo <address@hidden>
Date:   Sat Oct 8 16:28:37 2011 +0200

    more copy propagation refactors

commit 9c0acd7448adee2d644c7314786a4554986b50bf
Author: Andy Wingo <address@hidden>
Date:   Sat Oct 8 16:15:46 2011 +0200

    correctly charge inlining attempts to their call sites
    
    * module/language/tree-il/peval.scm (<operand>): For bound variables,
      capture the counter when the operand is created.  This allows us to
      correctly charge inlining attempts to their call sites.
      (visit-operand): As such, no need to pass a counter here.
      (peval): Update.

commit 451d8ae33a4cb1e3db91669aaa0ada0b886fe79c
Author: Andy Wingo <address@hidden>
Date:   Sat Oct 8 16:00:33 2011 +0200

    refactor the record-residual-lexical-reference! facility
    
    * module/language/tree-il/peval.scm (<operand>, make-operand, peval):
      Instead of storing residualize flags in a hash table, store them in
      the operand directly.

commit 0ddc24ee71e2023a110d8abb719c484da24ce864
Author: Andy Wingo <address@hidden>
Date:   Sat Oct 8 15:28:31 2011 +0200

    fix operator extra fields

commit 158cc8ef19df2031c5e8b96470af9ca4a5f299fd
Author: Andy Wingo <address@hidden>
Date:   Sat Oct 8 15:22:05 2011 +0200

    refactor copy propagation in peval
    
    * module/language/tree-il/peval.scm (peval): Refactor copy propagation.

commit 737b732ab71f57dff1278581c9a3d7542f9b66ec
Author: Andy Wingo <address@hidden>
Date:   Sat Oct 8 14:44:33 2011 +0200

    fix letrec* ordering, divergence resulting from copy propagation
    
    * module/language/tree-il/peval.scm (visit-operand): If there is no
      counter in place, make one.  This prevents copy propagation from
      introducing new call sites that are not in a counter, which would be a
      divergence from O(N).
      (peval): Properly handle letrec* orderings.  Pass effort and size
      limits to visit-operand when we try to copy.

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

Summary of changes:
 module/language/tree-il/peval.scm |  269 ++++++++++++++++++++++---------------
 1 files changed, 159 insertions(+), 110 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index fb2ccef..8ce66ac 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -261,32 +261,53 @@
 ;; being visited multiple times, wasting effort.
 ;; 
 (define-record-type <operand>
-  (%make-operand var sym visit source visit-count
-                 value test effect operator call)
+  (%make-operand var sym visit counter source visit-count residualize?
+                 copyable? residual-value)
   operand?
   (var operand-var)
   (sym operand-sym)
   (visit %operand-visit)
+  (counter operand-counter)
   (source operand-source)
-  (visit-count operand-visit-count set-operand-visit-count!))
+  (visit-count operand-visit-count set-operand-visit-count!)
+  (residualize? operand-residualize? set-operand-residualize?!)
+  (copyable? operand-copyable? set-operand-copyable?!)
+  (residual-value operand-residual-value set-operand-residual-value!))
 
-(define* (make-operand var sym #:optional source visit)
-  (%make-operand var sym visit source 0 #f #f #f #f #f))
+(define* (make-operand var sym #:optional source visit counter)
+  ;; Bound operands are considered copyable until we prove otherwise.
+  (%make-operand var sym visit counter source 0 #f (and source #t) #f))
 
-(define (make-bound-operands vars syms sources visit)
-  (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
+(define (make-bound-operands vars syms sources visit counter)
+  (map (lambda (x y z) (make-operand x y z visit counter)) vars syms sources))
 
 (define (make-unbound-operands vars syms)
   (map make-operand vars syms))
 
-(define (visit-operand op counter ctx)
+(define* (visit-operand op ctx #:optional effort-limit size-limit)
+  ;; Peval is O(N) in call sites of the source program.  However,
+  ;; visiting an operand can introduce new call sites.  If we visit an
+  ;; operand outside a counter -- i.e., outside an inlining attempt --
+  ;; this can lead to divergence.  So, if we are visiting an operand to
+  ;; try to copy it, and there is no counter, make a new one.
+  ;;
+  ;; This will only happen at most as many times as there are lexical
+  ;; references in the source program.
   (and (zero? (operand-visit-count op))
        (dynamic-wind
          (lambda ()
            (set-operand-visit-count! op (1+ (operand-visit-count op))))
          (lambda ()
            (and (operand-source op)
-                ((%operand-visit op) (operand-source op) counter ctx)))
+                (let ((counter (operand-counter op)))
+                  (if (or counter (and (not effort-limit) (not size-limit)))
+                      ((%operand-visit op) (operand-source op) counter ctx)
+                      (let/ec k
+                        (define (abort) (k #f))
+                        ((%operand-visit op)
+                         (operand-source op) 
+                         (make-top-counter effort-limit size-limit abort op)
+                         ctx))))))
          (lambda ()
            (set-operand-visit-count! op (1- (operand-visit-count op)))))))
 
@@ -378,14 +399,11 @@ top-level bindings from ENV and return the resulting 
expression."
     (let ((x (vhash-assq new store)))
       (if x (cdr x) new)))
 
-  (define residual-lexical-references (make-hash-table))
-
-  (define (record-residual-lexical-reference! sym)
-    (hashq-set! residual-lexical-references sym #t))
-
-  (define (residualize-lexical op)
+  (define* (residualize-lexical op #:optional ctx val)
     (log 'residualize op)
-    (record-residual-lexical-reference! (operand-sym op))
+    (set-operand-residualize?! op #t)
+    (if (eq? ctx 'value)
+        (set-operand-residual-value! op val))
     (make-lexical-ref #f (var-name (operand-var op)) (operand-sym op)))
 
   (define (apply-primitive name args)
@@ -519,7 +537,7 @@ top-level bindings from ENV and return the resulting 
expression."
          (and (loop tag) (loop body) (loop handler)))
         (_ #f))))
 
-  (define (prune-bindings ops body counter ctx build-result)
+  (define (prune-bindings ops in-order? body counter ctx build-result)
     ;; This helper handles both `let' and `letrec'/`fix'.  In the latter
     ;; cases we need to make sure that if referenced binding A needs
     ;; as-yet-unreferenced binding B, that B is processed for value.
@@ -528,24 +546,37 @@ top-level bindings from ENV and return the resulting 
expression."
     ;;
     (define (referenced? op)
       ;; FIXME: comment me!
-      (or (eq? ctx 'operator)
-          (hashq-ref residual-lexical-references (operand-sym op))))
-
+      (or (eq? ctx 'operator) (operand-residualize? op)))
+    
+    ;; values := (op ...)
+    ;; effects := (op ...)
     (define (residualize values effects)
-      ;; Note, values and effects are reversed.  FIXME: letrec* ordering!
-      (let ((body (if (null? effects)
-                      body
-                      (make-sequence #f (reverse (cons body (map cdr 
effects)))))))
-        (if (null? values)
-            body
-            (let ((values (reverse values)))
-              (build-result (map (compose var-name operand-var car) values)
-                            (map (compose operand-sym car) values)
-                            (map cdr values)
-                            body)))))
+      ;; Note, values and effects are reversed.
+      (cond
+       (in-order?
+        (let ((values (filter operand-residual-value ops)))
+          (if (null? values)
+              body
+              (build-result (map (compose var-name operand-var) values)
+                            (map operand-sym values)
+                            (map operand-residual-value values)
+                            body))))
+       (else
+        (let ((body
+               (if (null? effects)
+                   body
+                   (let ((effect-vals (map operand-residual-value effects)))
+                     (make-sequence #f (reverse (cons body effect-vals)))))))
+          (if (null? values)
+              body
+              (let ((values (reverse values)))
+                (build-result (map (compose var-name operand-var) values)
+                              (map operand-sym values)
+                              (map operand-residual-value values)
+                              body)))))))
 
     ;; old := (bool ...)
-    ;; values := ((op . value) ...)
+    ;; values := (op ...)
     ;; effects := ((op . value) ...)
     (let prune ((old (map referenced? ops)) (values '()) (effects '()))
       (let lp ((ops* ops) (values values) (effects effects))
@@ -554,20 +585,25 @@ top-level bindings from ENV and return the resulting 
expression."
           (let ((new (map referenced? ops)))
             (if (not (equal? new old))
                 (prune new values '())
-                (residualize values effects))))
+                (residualize values
+                             (map (lambda (op val)
+                                    (set-operand-residual-value! op val)
+                                    op)
+                                  (map car effects) (map cdr effects))))))
          (else
           (let ((op (car ops*)))
             (cond
-             ((assq op values)
+             ((memq op values)
               (lp (cdr ops*) values effects))
+             ((operand-residual-value op)
+              (lp (cdr ops*) (cons op values) effects))
              ((referenced? op)
-              (lp (cdr ops*)
-                  (acons op (visit-operand op counter 'value) values)
-                  effects))
+              (set-operand-residual-value! op (visit-operand op 'value))
+              (lp (cdr ops*) (cons op values) effects))
              (else
               (lp (cdr ops*)
                   values
-                  (let ((effect (visit-operand op counter 'effect)))
+                  (let ((effect (visit-operand op 'effect)))
                     (if (void? effect)
                         effects
                         (acons op effect effects))))))))))))
@@ -623,69 +659,81 @@ top-level bindings from ENV and return the resulting 
expression."
          ((test) (make-const #f #t))
          (else exp)))
       (($ <lexical-ref> _ _ gensym)
-       (case ctx
-         ((effect) (make-void #f))
-         (else
-          (log 'begin-copy gensym)
-          (let* ((op (lookup gensym))
-                 (val (and ;; Don't copy-propagate lambdas if we are
-                           ;; residualizing a call.
-                           (not (and (eq? ctx 'call)
-                                     (lambda? (operand-source op))))
-                           ;; Don't bother visiting assigned lexicals;
-                           ;; they don't copy-propagate.
-                           (not (var-set? (operand-var op)))
-                           (visit-operand op counter ctx))))
-            (cond
-             ((or (not val) ; E.g. with formal parameters of a `lambda'.
-                  (not (constant-expression? val)))
-              ;; Don't propagate impure expressions.
-              (log 'unbound-or-not-constant gensym val)
-              (residualize-lexical op))
-             ((lexical-ref? val)
-              (for-tail val))
-             ((or (const? val)
-                  (void? val)
-                  (primitive-ref? val))
-              ;; Always propagate simple values that cannot lead to
-              ;; code bloat.
-              (log 'copy-simple gensym val)
-              val)
-             ((= 1 (var-refcount (operand-var op)))
-              ;; Always propagate values referenced only once.
-              ;; There is no need to rename the bindings, as they
-              ;; are only being moved, not copied.  However in
-              ;; operator context we do rename it, as that
-              ;; effectively clears out the residualized-lexical
-              ;; flags that may have been set when this value was
-              ;; visited previously as an operand.
-              (log 'copy-single gensym val)
-              val)
-             ;; FIXME: do demand-driven size accounting rather than
-             ;; these heuristics.
-             ((eq? ctx 'operator)
-              ;; A pure expression in the operator position.  Inline
-              ;; if it's a lambda that's small enough.
-              (if (and (lambda? val)
-                       (small-expression? val operator-size-limit))
-                  (begin
-                    (log 'copy-operator gensym val)
-                    val)
-                  (begin
-                    (log 'too-big-for-operator gensym val)
-                    (residualize-lexical op))))
-             (else
-              ;; A pure expression, processed for call or for value.
-              ;; Don't inline lambdas, because they will probably won't
-              ;; fold because we don't know the operator.
-              (if (and (small-expression? val value-size-limit)
-                       (not (tree-il-any lambda? val)))
-                  (begin
-                    (log 'copy-value gensym val)
-                    val)
-                  (begin
-                    (log 'too-big-or-has-lambda gensym val)
-                    (residualize-lexical op)))))))))
+       (log 'begin-copy gensym)
+       (let ((op (lookup gensym)))
+         (cond
+          ((eq? ctx 'effect)
+           (log 'lexical-for-effect gensym)
+           (make-void #f))
+          ((eq? ctx 'call)
+           ;; Don't propagate copies if we are residualizing a call.
+           (log 'residualize-lexical-call gensym op)
+           (residualize-lexical op))
+          ((var-set? (operand-var op))
+           ;; Assigned lexicals don't copy-propagate.
+           (log 'assigned-var gensym op)
+           (residualize-lexical op))
+          ((not (operand-copyable? op))
+           ;; We already know that this operand is not copyable.
+           (log 'not-copyable gensym op)
+           (residualize-lexical op))
+          ((visit-operand op ctx recursive-effort-limit operand-size-limit)
+           =>
+           ;; If we end up deciding to residualize this value instead of
+           ;; copying it, save that residualized value.
+           (lambda (val)
+             (cond
+              ((not (constant-expression? val))
+               (log 'not-constant gensym op)
+               ;; At this point, ctx is operator, test, or value.  A
+               ;; value that is non-constant in one context will be
+               ;; non-constant in the others, so it's safe to record
+               ;; that here, and avoid future visits.
+               (set-operand-copyable?! op #f)
+               (residualize-lexical op ctx val))
+              ((lexical-ref? val)
+               (for-tail val))
+              ((or (const? val)
+                   (void? val)
+                   (primitive-ref? val))
+               ;; Always propagate simple values that cannot lead to
+               ;; code bloat.
+               (log 'copy-simple gensym val)
+               val)
+              ((= 1 (var-refcount (operand-var op)))
+               ;; Always propagate values referenced only once.
+               (log 'copy-single gensym val)
+               val)
+              ;; FIXME: do demand-driven size accounting rather than
+              ;; these heuristics.
+              ((eq? ctx 'operator)
+               ;; A pure expression in the operator position.  Inline
+               ;; if it's a lambda that's small enough.
+               (if (and (lambda? val)
+                        (small-expression? val operator-size-limit))
+                   (begin
+                     (log 'copy-operator gensym val)
+                     val)
+                   (begin
+                     (log 'too-big-for-operator gensym val)
+                     (residualize-lexical op ctx val))))
+              (else
+               ;; A pure expression, processed for call or for value.
+               ;; Don't inline lambdas, because they will probably won't
+               ;; fold because we don't know the operator.
+               (if (and (small-expression? val value-size-limit)
+                        (not (tree-il-any lambda? val)))
+                   (begin
+                     (log 'copy-value gensym val)
+                     val)
+                   (begin
+                     (log 'too-big-or-has-lambda gensym val)
+                     (residualize-lexical op ctx val)))))))
+          (else
+           ;; Visit failed.  Either the operand isn't bound, as in
+           ;; lambda formal parameters, or the copy was aborted.
+           (log 'unbound-or-aborted gensym op)
+           (residualize-lexical op)))))
       (($ <lexical-set> src name gensym exp)
        (let ((op (lookup gensym)))
          (if (zero? (var-refcount (operand-var op)))
@@ -694,14 +742,15 @@ top-level bindings from ENV and return the resulting 
expression."
                    exp
                    (make-sequence src (list exp (make-void #f)))))
              (begin
-               (record-residual-lexical-reference! (operand-sym op))
+               (set-operand-residualize?! op #t)
                (make-lexical-set src name (operand-sym op) (for-value exp))))))
       (($ <let> src names gensyms vals body)
        (let* ((vars (map lookup-var gensyms))
               (new (fresh-gensyms vars))
               (ops (make-bound-operands vars new vals
                                         (lambda (exp counter ctx)
-                                          (loop exp env counter ctx))))
+                                          (loop exp env counter ctx))
+                                        counter))
               (env (fold extend-env env gensyms ops))
               (body (loop body env counter ctx)))
          (cond
@@ -720,7 +769,7 @@ top-level bindings from ENV and return the resulting 
expression."
           (else
            ;; Only include bindings for which lexical references
            ;; have been residualized.
-           (prune-bindings ops body counter ctx
+           (prune-bindings ops #f body counter ctx
                            (lambda (names gensyms vals body)
                              (if (null? names) (error "what!" names))
                              (make-let src names gensyms vals body)))))))
@@ -732,13 +781,13 @@ top-level bindings from ENV and return the resulting 
expression."
                           (loop exp env* counter ctx)))
                  (vars (map lookup-var gensyms))
                  (new (fresh-gensyms vars))
-                 (ops (make-bound-operands vars new vals visit))
+                 (ops (make-bound-operands vars new vals visit counter))
                  (env* (fold extend-env env gensyms ops))
                  (body* (visit body counter ctx)))
          (if (and (const? body*)
                   (every constant-expression? vals))
              body*
-             (prune-bindings ops body* counter ctx
+             (prune-bindings ops in-order? body* counter ctx
                              (lambda (names gensyms vals body)
                                (make-letrec src in-order?
                                             names gensyms vals body))))))
@@ -747,12 +796,12 @@ top-level bindings from ENV and return the resulting 
expression."
                           (loop exp env* counter ctx)))
                  (vars (map lookup-var gensyms))
                  (new (fresh-gensyms vars))
-                 (ops (make-bound-operands vars new vals visit))
+                 (ops (make-bound-operands vars new vals visit counter))
                  (env* (fold extend-env env gensyms ops))
                  (body* (visit body counter ctx)))
          (if (const? body*)
              body*
-             (prune-bindings ops body* counter ctx
+             (prune-bindings ops #f body* counter ctx
                              (lambda (names gensyms vals body)
                                (make-fix src names gensyms vals body))))))
       (($ <let-values> lv-src producer consumer)
@@ -1043,7 +1092,7 @@ top-level bindings from ENV and return the resulting 
expression."
                 (= (lexical-refcount (lexical-ref-gensym x)) 1)
                 (lookup (lexical-ref-gensym x)))
            => (lambda (x)
-                (singly-used-definition (visit-operand x counter 'value))))
+                (singly-used-definition (visit-operand x 'value 10 10))))
           (else x)))
        (match (singly-used-definition tag)
          (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
@@ -1067,4 +1116,4 @@ top-level bindings from ENV and return the resulting 
expression."
 ;; add test case: (letrec ((a a)) a)
 ;; add test case: /tmp/test.scm
 ;; add test case: /tmp/test2.scm
-;; 
+;; add test case: letrec* binding ordering


hooks/post-receive
-- 
GNU Guile



reply via email to

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