[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-26-g89f9dd
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-26-g89f9dd7 |
|
Date: |
Thu, 05 May 2011 09:43:39 +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=89f9dd7065971d9d9047b42f044c06cc943f5efc
The branch, stable-2.0 has been updated
via 89f9dd7065971d9d9047b42f044c06cc943f5efc (commit)
via 81f529091b4741aea6060194d83d24c17460d652 (commit)
via 2d239a78d49a435ffe879c6e4a32a57d486b231b (commit)
via e640b44046dbb5516e691f1b4c6dd3a4cad3ac5b (commit)
from e6e286bb5895197a9433817fe3998a7c7c525386 (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 89f9dd7065971d9d9047b42f044c06cc943f5efc
Author: Andy Wingo <address@hidden>
Date: Thu May 5 11:22:42 2011 +0200
speed up compile-bytecode
* module/language/assembly/compile-bytecode.scm (compile-bytecode):
Rewrite to fill a bytevector directly, instead of using bytevector
ports. `write-bytecode' itself is still present and almost the same
as before; it's just that `write-byte' et al now inline the effect of
writing a byte to a binary port.
* test-suite/tests/asm-to-bytecode.test (comp-test): Refactor to use
public interfaces.
commit 81f529091b4741aea6060194d83d24c17460d652
Author: Andy Wingo <address@hidden>
Date: Thu May 5 10:09:48 2011 +0200
silly "optimization" in (language assembly)
* module/language/assembly.scm (byte-length): Silly, minor tweak: put
the fixed-length instruction case first. Seems to shave some 10% off
the time compiling psyntax.scm (when the whole rest of the system is
compiled, of course).
commit 2d239a78d49a435ffe879c6e4a32a57d486b231b
Author: Andy Wingo <address@hidden>
Date: Thu May 5 10:08:29 2011 +0200
add gcprof
* module/statprof.scm (gcprof): New variant of statprof; instead of
being driven by setitimer, this one is driven by the after-gc-hook.
commit e640b44046dbb5516e691f1b4c6dd3a4cad3ac5b
Author: Andy Wingo <address@hidden>
Date: Thu May 5 09:59:59 2011 +0200
minor statprof tweaks
* module/statprof.scm (statprof-reset): Make full-stacks? into an
optional arg instead of doing the rest arg dance.
(statprof-display): Format gc-time-taken appropriately.
-----------------------------------------------------------------------
Summary of changes:
module/language/assembly.scm | 10 +-
module/language/assembly/compile-bytecode.scm | 237 ++++++++++++++-----------
module/statprof.scm | 93 +++++++++-
test-suite/tests/asm-to-bytecode.test | 14 +-
4 files changed, 233 insertions(+), 121 deletions(-)
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index e119628..ad8dead 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -1,6 +1,6 @@
;;; Guile Virtual Machine Assembly
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -37,8 +37,8 @@
(define (byte-length assembly)
(pmatch assembly
- (,label (guard (not (pair? label)))
- 0)
+ ((,inst . _) (guard (>= (instruction-length inst) 0))
+ (+ 1 (instruction-length inst)))
((load-number ,str)
(+ 1 *len-len* (string-length str)))
((load-string ,str)
@@ -51,8 +51,8 @@
(+ 1 *len-len* (bytevector-length bv)))
((load-program ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
- ((,inst . _) (guard (>= (instruction-length inst) 0))
- (+ 1 (instruction-length inst)))
+ (,label (guard (not (pair? label)))
+ 0)
(else (error "unknown instruction" assembly))))
diff --git a/module/language/assembly/compile-bytecode.scm
b/module/language/assembly/compile-bytecode.scm
index ae64768..c315829 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Guile VM assembler
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -22,111 +22,144 @@
#:use-module (system base pmatch)
#:use-module (language assembly)
#:use-module (system vm instruction)
- #:use-module (srfi srfi-4)
#:use-module (rnrs bytevectors)
- #:use-module (ice-9 binary-ports)
#:use-module ((srfi srfi-1) #:select (fold))
- #:use-module ((srfi srfi-26) #:select (cut))
#:export (compile-bytecode))
-;; Gross.
-(define (port-position port)
- (seek port 0 SEEK_CUR))
-
(define (compile-bytecode assembly env . opts)
- (pmatch assembly
- ((load-program . _)
- (call-with-values open-bytevector-output-port
- (lambda (port get-bytevector)
- ;; Don't emit the `load-program' byte.
- (write-bytecode assembly port '() 0 #f)
- (values (get-bytevector) env env))))
- (else (error "bad assembly" assembly))))
+ (define-syntax define-inline1
+ (syntax-rules ()
+ ((_ (proc arg) body body* ...)
+ (define-syntax proc
+ (syntax-rules ()
+ ((_ (arg-expr (... ...)))
+ (let ((x (arg-expr (... ...))))
+ (proc x)))
+ ((_ arg)
+ (begin body body* ...)))))))
+
+ (define (fill-bytecode bv)
+ (let ((pos 0))
+ (define-inline1 (write-byte b)
+ (bytevector-u8-set! bv pos b)
+ (set! pos (1+ pos)))
+ (define u32-bv (make-bytevector 4))
+ (define-inline1 (write-int24-be x)
+ (bytevector-s32-set! u32-bv 0 x (endianness big))
+ (bytevector-u8-set! bv pos (bytevector-u8-ref u32-bv 1))
+ (bytevector-u8-set! bv (+ pos 1) (bytevector-u8-ref u32-bv 2))
+ (bytevector-u8-set! bv (+ pos 2) (bytevector-u8-ref u32-bv 3))
+ (set! pos (+ pos 3)))
+ (define-inline1 (write-uint32-be x)
+ (bytevector-u32-set! bv pos x (endianness big))
+ (set! pos (+ pos 4)))
+ (define-inline1 (write-uint32 x)
+ (bytevector-u32-native-set! bv pos x)
+ (set! pos (+ pos 4)))
+ (define-inline1 (write-loader-len len)
+ (bytevector-u8-set! bv pos (ash len -16))
+ (bytevector-u8-set! bv (+ pos 1) (logand (ash len -8) 255))
+ (bytevector-u8-set! bv (+ pos 2) (logand len 255))
+ (set! pos (+ pos 3)))
+ (define-inline1 (write-latin1-string s)
+ (let ((len (string-length s)))
+ (write-loader-len len)
+ (let lp ((i 0))
+ (if (< i len)
+ (begin
+ (bytevector-u8-set! bv (+ pos i)
+ (char->integer (string-ref s i)))
+ (lp (1+ i)))))
+ (set! pos (+ pos len))))
+ (define-inline1 (write-bytevector bv*)
+ (let ((len (bytevector-length bv*)))
+ (write-loader-len len)
+ (bytevector-copy! bv* 0 bv pos len)
+ (set! pos (+ pos len))))
+ (define-inline1 (write-wide-string s)
+ (write-bytevector (string->utf32 s (native-endianness))))
+ (define-inline1 (write-break label)
+ (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
+ (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
+ ((< offset (- (ash 1 23))) (error "jump too far backwards"
offset))
+ (else (write-int24-be offset)))))
-(define (write-bytecode asm port labels address emit-opcode?)
- ;; Write ASM's bytecode to PORT, a (binary) output port. If EMIT-OPCODE? is
- ;; false, don't emit bytecode for the first opcode encountered. Assume code
- ;; starts at ADDRESS (an integer). LABELS is assumed to be an alist mapping
- ;; labels to addresses.
- (define u32-bv (make-bytevector 4))
- (define write-byte (cut put-u8 port <>))
- (define get-addr
- (let ((start (port-position port)))
- (lambda ()
- (+ address (- (port-position port) start)))))
- (define (write-latin1-string s)
- (write-loader-len (string-length s))
- (string-for-each (lambda (c) (write-byte (char->integer c))) s))
- (define (write-int24-be x)
- (bytevector-s32-set! u32-bv 0 x (endianness big))
- (put-bytevector port u32-bv 1 3))
- (define (write-uint32-be x)
- (bytevector-u32-set! u32-bv 0 x (endianness big))
- (put-bytevector port u32-bv))
- (define (write-uint32 x)
- (bytevector-u32-native-set! u32-bv 0 x)
- (put-bytevector port u32-bv))
- (define (write-wide-string s)
- (write-loader-len (* 4 (string-length s)))
- (put-bytevector port (string->utf32 s (native-endianness))))
- (define (write-loader-len len)
- (write-byte (ash len -16))
- (write-byte (logand (ash len -8) 255))
- (write-byte (logand len 255)))
- (define (write-bytevector bv)
- (write-loader-len (bytevector-length bv))
- (put-bytevector port bv))
- (define (write-break label)
- (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
- (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
- ((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
- (else (write-int24-be offset)))))
+ (define (write-bytecode asm labels address emit-opcode?)
+ ;; Write ASM's bytecode to BV. If EMIT-OPCODE? is false, don't
+ ;; emit bytecode for the first opcode encountered. Assume code
+ ;; starts at ADDRESS (an integer). LABELS is assumed to be an
+ ;; alist mapping labels to addresses.
+ (define get-addr
+ (let ((start pos))
+ (lambda ()
+ (+ address (- pos start)))))
+ (define (write-break label)
+ (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
+ (cond ((>= offset (ash 1 23)) (error "jump too far forward"
offset))
+ ((< offset (- (ash 1 23))) (error "jump too far backwards"
offset))
+ (else (write-int24-be offset)))))
- (let ((inst (car asm))
- (args (cdr asm)))
- (let ((opcode (instruction->opcode inst))
- (len (instruction-length inst)))
- (if emit-opcode?
- (write-byte opcode))
- (pmatch asm
- ((load-program ,labels ,length ,meta . ,code)
- (write-uint32 length)
- (write-uint32 (if meta (1- (byte-length meta)) 0))
- (fold (lambda (asm address)
- (let ((start (port-position port)))
- (write-bytecode asm port labels address #t)
- (+ address (- (port-position port) start))))
- 0
- code)
- (if meta
- ;; Don't emit the `load-program' byte for metadata. Note that
- ;; META's bytecode meets the alignment requirements of
- ;; `scm_objcode', thanks to the alignment computed in `(language
- ;; assembly)'.
- (write-bytecode meta port '() 0 #f)))
- ((make-char32 ,x) (write-uint32-be x))
- ((load-number ,str) (write-latin1-string str))
- ((load-string ,str) (write-latin1-string str))
- ((load-wide-string ,str) (write-wide-string str))
- ((load-symbol ,str) (write-latin1-string str))
- ((load-array ,bv) (write-bytevector bv))
- ((br ,l) (write-break l))
- ((br-if ,l) (write-break l))
- ((br-if-not ,l) (write-break l))
- ((br-if-eq ,l) (write-break l))
- ((br-if-not-eq ,l) (write-break l))
- ((br-if-null ,l) (write-break l))
- ((br-if-not-null ,l) (write-break l))
- ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
- ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
- ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
- ((mv-call ,n ,l) (write-byte n) (write-break l))
- ((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
- (else
- (cond
- ((< (instruction-length inst) 0)
- (error "unhanded variable-length instruction" asm))
- ((not (= (length args) len))
- (error "bad number of args to instruction" asm len))
- (else
- (for-each write-byte args))))))))
+ (let ((inst (car asm))
+ (args (cdr asm)))
+ (let ((opcode (instruction->opcode inst))
+ (len (instruction-length inst)))
+ (if emit-opcode?
+ (write-byte opcode))
+ (pmatch asm
+ ((load-program ,labels ,length ,meta . ,code)
+ (write-uint32 length)
+ (write-uint32 (if meta (1- (byte-length meta)) 0))
+ (fold (lambda (asm address)
+ (let ((start pos))
+ (write-bytecode asm labels address #t)
+ (+ address (- pos start))))
+ 0
+ code)
+ (if meta
+ ;; Don't emit the `load-program' byte for metadata. Note
that
+ ;; META's bytecode meets the alignment requirements of
+ ;; `scm_objcode', thanks to the alignment computed in
`(language
+ ;; assembly)'.
+ (write-bytecode meta '() 0 #f)))
+ ((make-char32 ,x) (write-uint32-be x))
+ ((load-number ,str) (write-latin1-string str))
+ ((load-string ,str) (write-latin1-string str))
+ ((load-wide-string ,str) (write-wide-string str))
+ ((load-symbol ,str) (write-latin1-string str))
+ ((load-array ,bv) (write-bytevector bv))
+ ((br ,l) (write-break l))
+ ((br-if ,l) (write-break l))
+ ((br-if-not ,l) (write-break l))
+ ((br-if-eq ,l) (write-break l))
+ ((br-if-not-eq ,l) (write-break l))
+ ((br-if-null ,l) (write-break l))
+ ((br-if-not-null ,l) (write-break l))
+ ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
+ ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
+ ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo)
(write-break l))
+ ((mv-call ,n ,l) (write-byte n) (write-break l))
+ ((prompt ,escape-only? ,l) (write-byte escape-only?)
(write-break l))
+ (else
+ (cond
+ ((< len 0)
+ (error "unhanded variable-length instruction" asm))
+ ((not (= (length args) len))
+ (error "bad number of args to instruction" asm len))
+ (else
+ (for-each (lambda (x) (write-byte x)) args))))))))
+
+ ;; Don't emit the `load-program' byte.
+ (write-bytecode assembly '() 0 #f)
+ (if (= pos (bytevector-length bv))
+ (values bv env env)
+ (error "failed to fill bytevector" bv pos
+ (bytevector-length bv)))))
+
+ (pmatch assembly
+ ((load-program ,labels ,length ,meta . ,code)
+ (fill-bytecode (make-bytevector (+ 4 4 length
+ (if meta
+ (1- (byte-length meta))
+ 0)))))
+
+ (else (error "bad assembly" assembly))))
diff --git a/module/statprof.scm b/module/statprof.scm
index da6f3f1..33246e5 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -1,7 +1,7 @@
;;;; (statprof) -- a statistical profiler for Guile
;;;; -*-scheme-*-
;;;;
-;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
;;;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
;;;;
@@ -159,7 +159,9 @@
statprof-fetch-call-tree
statprof
- with-statprof))
+ with-statprof
+
+ gcprof))
;; This profiler tracks two numbers for every function called while
@@ -379,8 +381,8 @@ than @code{statprof-stop}, @code{#f} otherwise."
(accumulate-time (get-internal-run-time))
(set! last-start-time #f))))
-(define (statprof-reset sample-seconds sample-microseconds count-calls?
- . full-stacks?)
+(define* (statprof-reset sample-seconds sample-microseconds count-calls?
+ #:optional full-stacks?)
"Reset the statprof sampler interval to @var{sample-seconds} and
@var{sample-microseconds}. If @var{count-calls?} is true, arrange to
instrument procedure calls as well as collecting statistical profiling
@@ -397,7 +399,7 @@ Enables traps and debugging as necessary."
(set! sampling-frequency (cons sample-seconds sample-microseconds))
(set! remaining-prof-time #f)
(set! procedure-data (make-hash-table 131))
- (set! record-full-stacks? (and (pair? full-stacks?) (car full-stacks?)))
+ (set! record-full-stacks? full-stacks?)
(set! stacks '())
(sigaction SIGPROF profile-signal-handler)
#t)
@@ -531,7 +533,7 @@ optional @var{port} argument is passed, uses the current
output port."
(simple-format #t "Sample count: ~A\n" (statprof-sample-count))
(simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
(statprof-accumulated-time)
- (/ gc-time-taken internal-time-units-per-second))))))
+ (/ gc-time-taken 1.0 internal-time-units-per-second))))))
(define (statprof-display-anomolies)
"A sanity check that attempts to detect anomolies in statprof's
@@ -701,3 +703,82 @@ default: @code{#f}
#:count-calls? ,(kw-arg-ref #:count-calls? args #f)
#:full-stacks? ,(kw-arg-ref #:full-stacks? args #f)))
+(define* (gcprof thunk #:key (loop 1) (full-stacks? #f))
+ "Do an allocation profile of the execution of @var{thunk}.
+
+The stack will be sampled soon after every garbage collection, yielding
+an approximate idea of what is causing allocation in your program.
+
+Since GC does not occur very frequently, you may need to use the
address@hidden parameter, to cause @var{thunk} to be called @var{loop}
+times.
+
+If @var{full-stacks?} is true, at each sample, statprof will store away the
+whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
address@hidden to retrieve the last-stored stacks."
+
+ (define (reset)
+ (if (positive? profile-level)
+ (error "Can't reset profiler while profiler is running."))
+ (set! accumulated-time 0)
+ (set! last-start-time #f)
+ (set! sample-count 0)
+ (set! %count-calls? #f)
+ (set! procedure-data (make-hash-table 131))
+ (set! record-full-stacks? full-stacks?)
+ (set! stacks '()))
+
+ (define (gc-callback)
+ (cond
+ (inside-profiler?)
+ (else
+ (set! inside-profiler? #t)
+
+ ;; FIXME: should be able to set an outer frame for the stack cut
+ (let ((stop-time (get-internal-run-time))
+ ;; Cut down to gc-callback, and then one before (the
+ ;; after-gc async). See the note in profile-signal-handler
+ ;; also.
+ (stack (or (make-stack #t gc-callback 0 1)
+ (pk 'what! (make-stack #t)))))
+ (sample-stack-procs stack)
+ (accumulate-time stop-time)
+ (set! last-start-time (get-internal-run-time)))
+
+ (set! inside-profiler? #f))))
+
+ (define (start)
+ (set! profile-level (+ profile-level 1))
+ (if (= profile-level 1)
+ (begin
+ (set! remaining-prof-time #f)
+ (set! last-start-time (get-internal-run-time))
+ (set! gc-time-taken (cdr (assq 'gc-time-taken (gc-stats))))
+ (add-hook! after-gc-hook gc-callback)
+ (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
+ #t)))
+
+ (define (stop)
+ (set! profile-level (- profile-level 1))
+ (if (zero? profile-level)
+ (begin
+ (set! gc-time-taken
+ (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
+ (remove-hook! after-gc-hook gc-callback)
+ (accumulate-time (get-internal-run-time))
+ (set! last-start-time #f))))
+
+ (dynamic-wind
+ (lambda ()
+ (reset)
+ (start))
+ (lambda ()
+ (let lp ((i loop))
+ (if (not (zero? i))
+ (begin
+ (thunk)
+ (lp (1- i))))))
+ (lambda ()
+ (stop)
+ (statprof-display)
+ (set! procedure-data #f))))
diff --git a/test-suite/tests/asm-to-bytecode.test
b/test-suite/tests/asm-to-bytecode.test
index 0d8fecb..049e4b2 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -19,11 +19,9 @@
#:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib)
#:use-module (system vm instruction)
+ #:use-module (language assembly)
#:use-module (language assembly compile-bytecode))
-(define write-bytecode
- (@@ (language assembly compile-bytecode) write-bytecode))
-
(define (->u8-list sym val)
(let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
(uint32 4 ,bytevector-u32-native-set!))
@@ -54,11 +52,11 @@
(run-test `(length ,x) #t
(lambda ()
- (call-with-values open-bytevector-output-port
- (lambda (port get-bytevector)
- (write-bytecode x port '() 0 #t)
- (set! v (get-bytevector))
- (= (bytevector-length v) len)))))
+ (let* ((wrapped `(load-program () ,(byte-length x) #f ,x))
+ (bv (compile-bytecode wrapped '())))
+ (set! v (make-bytevector (- (bytevector-length bv) 8)))
+ (bytevector-copy! bv 8 v 0 (bytevector-length v))
+ (= (bytevector-length v) len))))
(run-test `(compile-equal? ,x ,y) #t
(lambda ()
(equal? v y)))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-26-g89f9dd7,
Andy Wingo <=