[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-148-g41d4358

[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=41d43584f2175e22e3380ae1553a3415dae711fc

The branch, stable-2.0 has been updated
       via  41d43584f2175e22e3380ae1553a3415dae711fc (commit)
       via  1082cbba47d3735a502c7cc631c5cc4a705b6a62 (commit)
      from  012492a7f1968bb996a98864da32591bffbf08a3 (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 41d43584f2175e22e3380ae1553a3415dae711fc
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 7 15:49:36 2011 +0200

    peval: logging
    
    * module/language/tree-il/peval.scm: Define a quick and dirty
      infrastructure for logging.  Use it in peval.

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

Summary of changes:
 module/language/tree-il/peval.scm |   59 +++++++++++++++++++++++++++++++++---
 1 files changed, 54 insertions(+), 5 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index aadba24..8246e47 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -46,6 +46,31 @@
 
 ;; First, some helpers.
 ;;
+;; For efficiency we define *logging* to inline to #f, so that the call
+;; to log* gets optimized out.  If you want to log, do:
+;;
+;;   (define %logging #f)
+;;   (define-syntax *logging* (identifier-syntax %logging)
+;;
+;; Then you can change %logging at runtime.
+;;
+(define-syntax *logging* (identifier-syntax #f))
+
+(define-syntax log
+  (syntax-rules (quote)
+    ((log 'event arg ...)
+     (if (and *logging*
+              (or (eq? *logging* #t)
+                  (memq 'event *logging*)))
+         (log* 'event arg ...)))))
+
+(define (log* event . args)
+  (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print))
+                        'pretty-print)))
+    (pp `(log ,event . ,args))
+    (newline)
+    (values)))
+
 (define-syntax-rule (let/ec k e e* ...)
   (let ((tag (make-prompt-tag)))
     (call-with-prompt
@@ -527,7 +552,8 @@ top-level bindings from ENV and return the resulting 
expression."
         (($ <const>) #t)
         (($ <lambda>) #t)
         (($ <lambda-case> _ req opt rest kw inits _ body alternate)
-         (and (every loop inits) (loop body) (loop alternate)))
+         (and (every loop inits) (loop body)
+              (or (not alternate) (loop alternate))))
         (($ <lexical-ref> _ _ gensym)
          (not (assigned-lexical? gensym)))
         (($ <primitive-ref>) #t)
@@ -577,7 +603,9 @@ top-level bindings from ENV and return the resulting 
expression."
               (lp names syms vals
                   names* syms* vals*
                   (if (void? effect)
-                      effects
+                      (begin
+                        (log 'prune sym)
+                        effects)
                       (cons effect effects)))))))))
   
   (define (small-expression? x limit)
@@ -613,6 +641,9 @@ top-level bindings from ENV and return the resulting 
expression."
     (if counter
         (record-effort! counter))
 
+    (log 'visit ctx (and=> counter effort-counter)
+         (unparse-tree-il exp))
+
     (match exp
       (($ <const>)
        (case ctx
@@ -626,6 +657,7 @@ top-level bindings from ENV and return the resulting 
expression."
        (case ctx
          ((effect) (make-void #f))
          (else
+          (log 'begin-copy gensym)
           (let ((val (lookup gensym)))
             (cond
              ((or (not val)
@@ -633,6 +665,7 @@ top-level bindings from ENV and return the resulting 
expression."
                   (not (constant-expression? val)))
               ;; Don't copy-propagate through assigned variables,
               ;; and don't reorder effects.
+              (log 'unbound-or-not-constant gensym val)
               (record-residual-lexical-reference! gensym)
               exp)
              ((lexical-ref? val)
@@ -642,6 +675,7 @@ top-level bindings from ENV and return the resulting 
expression."
                   (primitive-ref? val))
               ;; Always propagate simple values that cannot lead to
               ;; code bloat.
+              (log 'copy-simple gensym val)
               (for-tail val))
              ((= 1 (lexical-refcount gensym))
               ;; Always propagate values referenced only once.
@@ -651,6 +685,7 @@ top-level bindings from ENV and return the resulting 
expression."
               ;; 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)
               (case ctx
                 ((test) (for-test val))
                 ((operator) (record-source-expression! val (alpha-rename val)))
@@ -662,16 +697,22 @@ top-level bindings from ENV and return the resulting 
expression."
               ;; if it's a lambda that's small enough.
               (if (and (lambda? val)
                        (small-expression? val operator-size-limit))
-                  (record-source-expression! val (alpha-rename val))
                   (begin
+                    (log 'copy-operator gensym val)
+                    (record-source-expression! val (alpha-rename val)))
+                  (begin
+                    (log 'too-big-for-operator gensym val)
                     (record-residual-lexical-reference! gensym)
                     exp)))
              ((eq? ctx 'operand)
               ;; A pure expression in the operand position.  Inline
               ;; if it's small enough.
               (if (small-expression? val operand-size-limit)
-                  (record-source-expression! val (alpha-rename val))
                   (begin
+                    (log 'copy-operand gensym val)
+                    (record-source-expression! val (alpha-rename val)))
+                  (begin
+                    (log 'too-big-for-operand gensym val)
                     (record-residual-lexical-reference! gensym)
                     exp)))
              (else
@@ -680,8 +721,11 @@ top-level bindings from ENV and return the resulting 
expression."
               ;; fold because we don't know the operator.
               (if (and (small-expression? val value-size-limit)
                        (not (tree-il-any lambda? val)))
-                  (record-source-expression! val (alpha-rename val))
                   (begin
+                    (log 'copy-value gensym val)
+                    (record-source-expression! val (alpha-rename val)))
+                  (begin
+                    (log 'too-big-or-has-lambda gensym val)
                     (record-residual-lexical-reference! gensym)
                     exp))))))))
       (($ <lexical-set> src name gensym exp)
@@ -885,6 +929,7 @@ top-level bindings from ENV and return the resulting 
expression."
                   (let-values (((success? values)
                                 (apply-primitive name
                                                  (map const-exp args))))
+                    (log 'fold success? values exp)
                     (if success?
                         (case ctx
                           ((effect) (make-void #f))
@@ -921,6 +966,7 @@ top-level bindings from ENV and return the resulting 
expression."
                 ;; A recursive call, or a lambda in the operator
                 ;; position of the source expression.  Process again in
                 ;; tail context.
+                (log 'inline-recurse key)
                 (loop (make-let src (append req (or opt '()))
                                 gensyms
                                 (append orig-args
@@ -932,8 +978,10 @@ top-level bindings from ENV and return the resulting 
expression."
                 ;; 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-application src
                                          (for-value orig-proc)
                                          (map for-value orig-args))))
@@ -969,6 +1017,7 @@ top-level bindings from ENV and return the resulting 
expression."
                       ;; into the current counter.
                       (transfer! new-counter counter))
 
+                  (log 'inline-end result exp)
                   result)))))
            (_
             (make-application src proc


hooks/post-receive
-- 
GNU Guile