[Guile-commits] GNU Guile branch, wip-on-demand, updated. v2.0.2-161-gd9865d4

[Andy Wingo]

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=d9865d45e49219ca0694dbb25d4c72717ac318fc

The branch, wip-on-demand has been updated
       via  d9865d45e49219ca0694dbb25d4c72717ac318fc (commit)
       via  c2afb05ffc01f97ecbf8a950073cb149a1a64af4 (commit)
      from  5b110a87a91efe6f02f9a34407714415c0b1b2e8 (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 d9865d45e49219ca0694dbb25d4c72717ac318fc
Author: Andy Wingo <address@hidden>
Date:   Mon Oct 10 11:26:33 2011 +0200

    small refactor of "constructor" folding
    
    * module/language/tree-il/peval.scm (peval): Refactor folding of
      "constructors" (which still need renaming) to avoid visiting operands
      twice in some contexts.

commit c2afb05ffc01f97ecbf8a950073cb149a1a64af4
Author: Andy Wingo <address@hidden>
Date:   Mon Oct 10 10:55:55 2011 +0200

    revert `correctly charge inlining attempts to their call sites'
    
    Inlining attempts are processed within a counter, so there is no need to
    capture a counter there.  I don't think it's right to charge
    `let'/`letrec'/`fix' forms for inlining attempts of their operands;
    better to charge the forms doing the inlining, it seems.

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

Summary of changes:
 module/language/tree-il/peval.scm |  151 +++++++++++++++++--------------------
 1 files changed, 69 insertions(+), 82 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 8ce66ac..f3d0060 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -261,30 +261,29 @@
 ;; being visited multiple times, wasting effort.
 ;; 
 (define-record-type <operand>
-  (%make-operand var sym visit counter source visit-count residualize?
+  (%make-operand var sym visit 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!)
   (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 counter)
+(define* (make-operand var sym #:optional source visit)
   ;; Bound operands are considered copyable until we prove otherwise.
-  (%make-operand var sym visit counter source 0 #f (and source #t) #f))
+  (%make-operand var sym visit source 0 #f (and source #t) #f))
 
-(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-bound-operands vars syms sources visit)
+  (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
 
 (define (make-unbound-operands vars syms)
   (map make-operand vars syms))
 
-(define* (visit-operand op ctx #:optional effort-limit size-limit)
+(define* (visit-operand op counter 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 --
@@ -299,15 +298,14 @@
            (set-operand-visit-count! op (1+ (operand-visit-count op))))
          (lambda ()
            (and (operand-source op)
-                (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))))))
+                (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)))))))
 
@@ -598,12 +596,12 @@ top-level bindings from ENV and return the resulting 
expression."
              ((operand-residual-value op)
               (lp (cdr ops*) (cons op values) effects))
              ((referenced? op)
-              (set-operand-residual-value! op (visit-operand op 'value))
+              (set-operand-residual-value! op (visit-operand op counter 
'value))
               (lp (cdr ops*) (cons op values) effects))
              (else
               (lp (cdr ops*)
                   values
-                  (let ((effect (visit-operand op 'effect)))
+                  (let ((effect (visit-operand op counter 'effect)))
                     (if (void? effect)
                         effects
                         (acons op effect effects))))))))))))
@@ -677,7 +675,7 @@ top-level bindings from ENV and return the resulting 
expression."
            ;; 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)
+          ((visit-operand op counter ctx recursive-effort-limit 
operand-size-limit)
            =>
            ;; If we end up deciding to residualize this value instead of
            ;; copying it, save that residualized value.
@@ -749,8 +747,7 @@ top-level bindings from ENV and return the resulting 
expression."
               (new (fresh-gensyms vars))
               (ops (make-bound-operands vars new vals
                                         (lambda (exp counter ctx)
-                                          (loop exp env counter ctx))
-                                        counter))
+                                          (loop exp env counter ctx))))
               (env (fold extend-env env gensyms ops))
               (body (loop body env counter ctx)))
          (cond
@@ -781,7 +778,7 @@ 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 counter))
+                 (ops (make-bound-operands vars new vals visit))
                  (env* (fold extend-env env gensyms ops))
                  (body* (visit body counter ctx)))
          (if (and (const? body*)
@@ -796,7 +793,7 @@ 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 counter))
+                 (ops (make-bound-operands vars new vals visit))
                  (env* (fold extend-env env gensyms ops))
                  (body* (visit body counter ctx)))
          (if (const? body*)
@@ -884,67 +881,57 @@ top-level bindings from ENV and return the resulting 
expression."
        (let ((proc (visit orig-proc 'operator)))
          (match proc
            (($ <primitive-ref> _ (? constructor-primitive? name))
-            (case ctx
-              ((effect test)
-               (let ((res (if (eq? ctx 'effect)
-                              (make-void #f)
-                              (make-const #f #t))))
-                 (match (for-value exp)
-                   (($ <application> _ ($ <primitive-ref> _ 'cons) (x xs))
-                    (for-tail
-                     (make-sequence src (list x xs res))))
-                   (($ <application> _ ($ <primitive-ref> _ 'list) elts)
-                    (for-tail
-                     (make-sequence src (append elts (list res)))))
-                   (($ <application> _ ($ <primitive-ref> _ 'vector) elts)
-                    (for-tail
-                     (make-sequence src (append elts (list res)))))
-                   (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) 
())
-                    res)
-                   (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
-                       (($ <const> _ (? string?))))
-                    res)
-                   ((and exp ($ <application>))
-                    exp)
-                   (exp
-                    ;; It's possible that the for-value folded
-                    ;; e.g. `(car '(1 2))' to a constant.
-                    (for-tail exp)))))
-              (else
-               (match (cons name (map for-value orig-args))
-                 (('cons head tail)
-                  (match tail
-                    (($ <const> src ())
-                     (make-application src (make-primitive-ref #f 'list)
-                                       (list head)))
-                    (($ <application> src ($ <primitive-ref> _ 'list) elts)
-                     (make-application src (make-primitive-ref #f 'list)
-                                       (cons head elts)))
-                    (_ (make-application src proc
-                                         (list head tail)))))
+            (cond
+             ((and (memq ctx '(effect test))
+                   (match (cons name orig-args)
+                     ((or ('cons _ _)
+                          ('list . _)
+                          ('vector . _)
+                          ('make-prompt-tag)
+                          ('make-prompt-tag ($ <const> _ (? string?))))
+                      #t)
+                     (_ #f)))
+              ;; Some expressions can be folded without visiting the
+              ;; arguments for value.
+              (let ((res (if (eq? ctx 'effect)
+                             (make-void #f)
+                             (make-const #f #t))))
+                (for-tail (make-sequence src (append orig-args (list res))))))
+             (else
+              (match (cons name (map for-value orig-args))
+                (('cons head tail)
+                 (match tail
+                   (($ <const> src ())
+                    (make-application src (make-primitive-ref #f 'list)
+                                      (list head)))
+                   (($ <application> src ($ <primitive-ref> _ 'list) elts)
+                    (make-application src (make-primitive-ref #f 'list)
+                                      (cons head elts)))
+                   (_ (make-application src proc
+                                        (list head tail)))))
 
-                 ;; FIXME: these for-tail recursions could take
-                 ;; place outside an effort counter.
-                 (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head 
tail)))
-                  (for-tail (make-sequence src (list tail head))))
-                 (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head 
tail)))
-                  (for-tail (make-sequence src (list head tail))))
-                 (('car ($ <application> src ($ <primitive-ref> _ 'list) (head 
. tail)))
-                  (for-tail (make-sequence src (append tail (list head)))))
-                 (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head 
. tail)))
-                  (for-tail (make-sequence
-                             src
-                             (list head
-                                   (make-application
-                                    src (make-primitive-ref #f 'list) tail)))))
+                ;; FIXME: these for-tail recursions could take
+                ;; place outside an effort counter.
+                (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head 
tail)))
+                 (for-tail (make-sequence src (list tail head))))
+                (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head 
tail)))
+                 (for-tail (make-sequence src (list head tail))))
+                (('car ($ <application> src ($ <primitive-ref> _ 'list) (head 
. tail)))
+                 (for-tail (make-sequence src (append tail (list head)))))
+                (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head 
. tail)))
+                 (for-tail (make-sequence
+                            src
+                            (list head
+                                  (make-application
+                                   src (make-primitive-ref #f 'list) tail)))))
                   
-                 (('car ($ <const> src (head . tail)))
-                  (for-tail (make-const src head)))
-                 (('cdr ($ <const> src (head . tail)))
-                  (for-tail (make-const src tail)))
+                (('car ($ <const> src (head . tail)))
+                 (for-tail (make-const src head)))
+                (('cdr ($ <const> src (head . tail)))
+                 (for-tail (make-const src tail)))
 
-                 ((_ . args)
-                  (make-application src proc args))))))
+                ((_ . args)
+                 (make-application src proc args))))))
            (($ <primitive-ref> _ (? effect-free-primitive? name))
             (let ((args (map for-value orig-args)))
               (if (every const? args)   ; only simple constants
@@ -1092,7 +1079,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 'value 10 10))))
+                (singly-used-definition (visit-operand x counter 'value 10 
10))))
           (else x)))
        (match (singly-used-definition tag)
          (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)


hooks/post-receive
-- 
GNU Guile