mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-04 08:40:21 +02:00
Code Activity

peval: logging

Browse source 
* module/language/tree-il/peval.scm: Define a quick and dirty
  infrastructure for logging.  Use it in peval.
This commit is contained in:
Andy Wingo 2011-10-07 15:49:36 +02:00
parent 1082cbba47
commit 41d43584f2
1 changed files with 52 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

56
module/language/tree-il/peval.scm
View file

@ -46,6 +46,31 @@
;; First, some helpers. ;; 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* ...) (define-syntax-rule (let/ec k e e* ...)
(let ((tag (make-prompt-tag))) (let ((tag (make-prompt-tag)))
(call-with-prompt (call-with-prompt
@ -578,7 +603,9 @@ top-level bindings from ENV and return the resulting expression."
(lp names syms vals (lp names syms vals
names* syms* vals* names* syms* vals*
(if (void? effect) (if (void? effect)
effects (begin
(log 'prune sym)
effects)
(cons effect effects))))))))) (cons effect effects)))))))))
(define (small-expression? x limit) (define (small-expression? x limit)
@ -614,6 +641,9 @@ top-level bindings from ENV and return the resulting expression."
(if counter (if counter
(record-effort! counter)) (record-effort! counter))
(log 'visit ctx (and=> counter effort-counter)
(unparse-tree-il exp))
(match exp (match exp
(($ <const>) (($ <const>)
(case ctx (case ctx
@ -627,6 +657,7 @@ top-level bindings from ENV and return the resulting expression."
(case ctx (case ctx
((effect) (make-void #f)) ((effect) (make-void #f))
(else (else
(log 'begin-copy gensym)
(let ((val (lookup gensym))) (let ((val (lookup gensym)))
(cond (cond
((or (not val) ((or (not val)
@ -634,6 +665,7 @@ top-level bindings from ENV and return the resulting expression."
(not (constant-expression? val))) (not (constant-expression? val)))
;; Don't copy-propagate through assigned variables, ;; Don't copy-propagate through assigned variables,
;; and don't reorder effects. ;; and don't reorder effects.
(log 'unbound-or-not-constant gensym val)
(record-residual-lexical-reference! gensym) (record-residual-lexical-reference! gensym)
exp) exp)
((lexical-ref? val) ((lexical-ref? val)
@ -643,6 +675,7 @@ top-level bindings from ENV and return the resulting expression."
(primitive-ref? val)) (primitive-ref? val))
;; Always propagate simple values that cannot lead to ;; Always propagate simple values that cannot lead to
;; code bloat. ;; code bloat.
(log 'copy-simple gensym val)
(for-tail val)) (for-tail val))
((= 1 (lexical-refcount gensym)) ((= 1 (lexical-refcount gensym))
;; Always propagate values referenced only once. ;; Always propagate values referenced only once.
@ -652,6 +685,7 @@ top-level bindings from ENV and return the resulting expression."
;; effectively clears out the residualized-lexical ;; effectively clears out the residualized-lexical
;; flags that may have been set when this value was ;; flags that may have been set when this value was
;; visited previously as an operand. ;; visited previously as an operand.
(log 'copy-single gensym val)
(case ctx (case ctx
((test) (for-test val)) ((test) (for-test val))
((operator) (record-source-expression! val (alpha-rename val))) ((operator) (record-source-expression! val (alpha-rename val)))
@ -663,16 +697,22 @@ top-level bindings from ENV and return the resulting expression."
;; if it's a lambda that's small enough. ;; if it's a lambda that's small enough.
(if (and (lambda? val) (if (and (lambda? val)
(small-expression? val operator-size-limit)) (small-expression? val operator-size-limit))
(record-source-expression! val (alpha-rename val))
(begin (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) (record-residual-lexical-reference! gensym)
exp))) exp)))
((eq? ctx 'operand) ((eq? ctx 'operand)
;; A pure expression in the operand position. Inline ;; A pure expression in the operand position. Inline
;; if it's small enough. ;; if it's small enough.
(if (small-expression? val operand-size-limit) (if (small-expression? val operand-size-limit)
(record-source-expression! val (alpha-rename val))
(begin (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) (record-residual-lexical-reference! gensym)
exp))) exp)))
(else (else
@ -681,8 +721,11 @@ top-level bindings from ENV and return the resulting expression."
;; fold because we don't know the operator. ;; fold because we don't know the operator.
(if (and (small-expression? val value-size-limit) (if (and (small-expression? val value-size-limit)
(not (tree-il-any lambda? val))) (not (tree-il-any lambda? val)))
(record-source-expression! val (alpha-rename val))
(begin (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) (record-residual-lexical-reference! gensym)
exp)))))))) exp))))))))
(($ <lexical-set> src name gensym exp) (($ <lexical-set> src name gensym exp)
@ -886,6 +929,7 @@ top-level bindings from ENV and return the resulting expression."
(let-values (((success? values) (let-values (((success? values)
(apply-primitive name (apply-primitive name
(map const-exp args)))) (map const-exp args))))
(log 'fold success? values exp)
(if success? (if success?
(case ctx (case ctx
((effect) (make-void #f)) ((effect) (make-void #f))
@ -922,6 +966,7 @@ top-level bindings from ENV and return the resulting expression."
;; A recursive call, or a lambda in the operator ;; A recursive call, or a lambda in the operator
;; position of the source expression. Process again in ;; position of the source expression. Process again in
;; tail context. ;; tail context.
(log 'inline-recurse key)
(loop (make-let src (append req (or opt '())) (loop (make-let src (append req (or opt '()))
gensyms gensyms
(append orig-args (append orig-args
@ -933,8 +978,10 @@ top-level bindings from ENV and return the resulting expression."
;; recursion of a recursive procedure, or a nested ;; recursion of a recursive procedure, or a nested
;; integration of a procedure that hasn't been seen ;; integration of a procedure that hasn't been seen
;; yet. ;; yet.
(log 'inline-begin exp)
(let/ec k (let/ec k
(define (abort) (define (abort)
(log 'inline-abort exp)
(k (make-application src (k (make-application src
(for-value orig-proc) (for-value orig-proc)
(map for-value orig-args)))) (map for-value orig-args))))
@ -970,6 +1017,7 @@ top-level bindings from ENV and return the resulting expression."
;; into the current counter. ;; into the current counter.
(transfer! new-counter counter)) (transfer! new-counter counter))
(log 'inline-end result exp)
result))))) result)))))
(_ (_
(make-application src proc (make-application src proc