summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/boot-9.scm2
-rw-r--r--module/ice-9/command-line.scm28
-rw-r--r--module/ice-9/poe.scm36
-rw-r--r--module/ice-9/psyntax.scm3
-rw-r--r--module/ice-9/r4rs.scm52
-rw-r--r--module/language/assembly.scm10
-rw-r--r--module/language/assembly/compile-bytecode.scm237
-rw-r--r--module/srfi/srfi-1.scm75
-rw-r--r--module/statprof.scm93
9 files changed, 338 insertions, 198 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 401d90476..294b91515 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3048,6 +3048,8 @@ module '(ice-9 q) '(make-q q-length))}."
(let* ((internal-name (if (pair? name) (car name) name))
(external-name (if (pair? name) (cdr name) name))
(var (module-ensure-local-variable! m internal-name)))
+ ;; FIXME: use a bit on variables instead of object
+ ;; properties.
(set-object-property! var 'replace #t)
(module-add! public-i external-name var)))
names)))
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index a34c9a67c..e94336a90 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -197,26 +197,28 @@ If FILE begins with `-' the -s switch is mandatory.
(args (cdr args)))
(cond
((not (string-prefix? "-" arg)) ; foo
- ;; If we specified the -ds option, do_script points to the
- ;; cdr of an expression like (load #f) we replace the car
- ;; (i.e., the #f) with the script name.
- (if (pair? do-script)
- (set-car! do-script arg))
+ ;; If we specified the -ds option, do-script is the cdr of
+ ;; an expression like (load #f). We replace the car (i.e.,
+ ;; the #f) with the script name.
(set! arg0 arg)
(set! interactive? #f)
- (finish args
- (cons `(load ,arg) out)))
+ (if (pair? do-script)
+ (begin
+ (set-car! do-script arg0)
+ (finish args out))
+ (finish args (cons `(load ,arg0) out))))
((string=? arg "-s") ; foo
(if (null? args)
(error "missing argument to `-s' switch"))
(set! arg0 (car args))
- (if (pair? do-script)
- (set-car! do-script arg0))
(set! interactive? #f)
- (finish (cdr args)
- (cons `(load ,arg0) out)))
-
+ (if (pair? do-script)
+ (begin
+ (set-car! do-script arg0)
+ (finish (cdr args) out))
+ (finish (cdr args) (cons `(load ,arg0) out))))
+
((string=? arg "-c") ; evaluate expr
(if (null? args)
(error "missing argument to `-c' switch"))
@@ -245,7 +247,7 @@ If FILE begins with `-' the -s switch is mandatory.
((string=? arg "-x") ; add to %load-extensions
(if (null? args)
- (error "missing argument to `-L' switch"))
+ (error "missing argument to `-x' switch"))
(set! user-extensions (cons (car args) user-extensions))
(parse (cdr args)
out))
diff --git a/module/ice-9/poe.scm b/module/ice-9/poe.scm
index e7b6e3a75..c19a760b2 100644
--- a/module/ice-9/poe.scm
+++ b/module/ice-9/poe.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1996, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1996, 2001, 2006, 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
@@ -74,17 +74,19 @@
(funcq-assoc arg-list (cdr alist)))))
+(define not-found (list 'not-found))
+
(define (pure-funcq base-func)
(lambda args
- (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
- (if cached
+ (let* ((key (cons base-func args))
+ (cached (hashx-ref funcq-hash funcq-assoc funcq-memo key not-found)))
+ (if (not (eq? cached not-found))
(begin
- (funcq-buffer (car cached))
- (cdr cached))
+ (funcq-buffer key)
+ cached)
- (let ((val (apply base-func args))
- (key (cons base-func args)))
+ (let ((val (apply base-func args)))
(funcq-buffer key)
(hashx-set! funcq-hash funcq-assoc funcq-memo key val)
val)))))
@@ -101,22 +103,14 @@
(define funcq-memo (make-hash-table size))
(lambda args
- (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
- (if cached
+ (let* ((key (cons base-func args))
+ (cached (hashx-ref funcq-hash funcq-assoc funcq-memo key not-found)))
+ (if (not (eq? cached not-found))
(begin
- (funcq-buffer (car cached))
- (cdr cached))
+ (funcq-buffer key)
+ cached)
- (let ((val (apply base-func args))
- (key (cons base-func args)))
+ (let ((val (apply base-func args)))
(funcq-buffer key)
(hashx-set! funcq-hash funcq-assoc funcq-memo key val)
val)))))
-
-
-
-
-
-
-
-
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 17acf3ff9..85ceb13c2 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -770,7 +770,8 @@
(lambda (id w)
(define-syntax first
(syntax-rules ()
- ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
+ ;; Rely on Guile's multiple-values truncation.
+ ((_ e) e)))
(define search
(lambda (sym subst marks)
(if (null? subst)
diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm
index 4d3febafa..86b6e9454 100644
--- a/module/ice-9/r4rs.scm
+++ b/module/ice-9/r4rs.scm
@@ -1,7 +1,7 @@
;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
-;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 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
@@ -140,14 +140,16 @@ already exist. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
-automatically and the value yielded by the procedure is returned.
+automatically and the values yielded by the procedure are returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
- (let* ((file (open-input-file str))
- (ans (proc file)))
- (close-input-port file)
- ans))
+ (let ((p (open-input-file str)))
+ (call-with-values
+ (lambda () (proc p))
+ (lambda vals
+ (close-input-port p)
+ (apply values vals)))))
(define (call-with-output-file str proc)
"PROC should be a procedure of one argument, and STR should be a
@@ -156,14 +158,16 @@ already exists. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
-automatically and the value yielded by the procedure is returned.
+automatically and the values yielded by the procedure are returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
- (let* ((file (open-output-file str))
- (ans (proc file)))
- (close-output-port file)
- ans))
+ (let ((p (open-output-file str)))
+ (call-with-values
+ (lambda () (proc p))
+ (lambda vals
+ (close-output-port p)
+ (apply values vals)))))
(define (with-input-from-port port thunk)
(let* ((swaports (lambda () (set! port (set-current-input-port port)))))
@@ -184,13 +188,11 @@ input, an input port connected to it is made
the default value returned by `current-input-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
-default is restored. Returns the value yielded by THUNK. If an
+default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
- (let* ((nport (open-input-file file))
- (ans (with-input-from-port nport thunk)))
- (close-port nport)
- ans))
+ (call-with-input-file file
+ (lambda (p) (with-input-from-port p thunk))))
(define (with-output-to-file file thunk)
"THUNK must be a procedure of no arguments, and FILE must be a
@@ -199,13 +201,11 @@ The file is opened for output, an output port connected to it is made
the default value returned by `current-output-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
-default is restored. Returns the value yielded by THUNK. If an
+default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
- (let* ((nport (open-output-file file))
- (ans (with-output-to-port nport thunk)))
- (close-port nport)
- ans))
+ (call-with-output-file file
+ (lambda (p) (with-output-to-port p thunk))))
(define (with-error-to-file file thunk)
"THUNK must be a procedure of no arguments, and FILE must be a
@@ -214,13 +214,11 @@ The file is opened for output, an output port connected to it is made
the default value returned by `current-error-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
-default is restored. Returns the value yielded by THUNK. If an
+default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
- (let* ((nport (open-output-file file))
- (ans (with-error-to-port nport thunk)))
- (close-port nport)
- ans))
+ (call-with-output-file file
+ (lambda (p) (with-error-to-port p thunk))))
(define (with-input-from-string string thunk)
"THUNK must be a procedure of no arguments.
@@ -228,7 +226,7 @@ The test of STRING is opened for
input, an input port connected to it is made,
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed.
-Returns the value yielded by THUNK. If an
+Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-input-string string
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index e119628da..ad8dead65 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 ae6476891..c31582991 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/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 8ddf2714b..68b62de56 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -1,6 +1,6 @@
;;; srfi-1.scm --- List Library
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 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
@@ -16,6 +16,11 @@
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;; Some parts from the reference implementation, which is
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use.
+
;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;; Date: 2001-06-06
@@ -747,15 +752,23 @@ and those making the associations."
(define* (alist-delete! key alist #:optional (k= equal?))
(alist-delete key alist k=)) ; XXX:optimize
+;;; Delete / assoc / member
+
+(define* (member x ls #:optional (= equal?))
+ (cond
+ ((eq? = eq?) (memq x ls))
+ ((eq? = eqv?) (memv x ls))
+ (else (find-tail (lambda (y) (= x y)) ls))))
+
;;; Set operations on lists
(define (lset<= = . rest)
(if (null? rest)
- #t
- (let lp ((f (car rest)) (r (cdr rest)))
- (or (null? r)
- (and (every (lambda (el) (member el (car r) =)) f)
- (lp (car r) (cdr r)))))))
+ #t
+ (let lp ((f (car rest)) (r (cdr rest)))
+ (or (null? r)
+ (and (every (lambda (el) (member el (car r) =)) f)
+ (lp (car r) (cdr r)))))))
(define (lset= = . rest)
(if (null? rest)
@@ -780,25 +793,41 @@ a common tail with LIST), but the order they're added is unspecified.
The given `=' procedure is used for comparing elements, called
as `(@var{=} listelem elem)', i.e., the second argument is one of the
given REST parameters."
- (let lp ((l rest) (acc list))
- (if (null? l)
- acc
- (if (member (car l) acc (lambda (x y) (= y x)))
- (lp (cdr l) acc)
- (lp (cdr l) (cons (car l) acc))))))
+ ;; If `=' is `eq?' or `eqv?', users won't be able to tell which arg is
+ ;; first, so we can pass the raw procedure through to `member',
+ ;; allowing `memq' / `memv' to be selected.
+ (define pred
+ (if (or (eq? = eq?) (eq? = eqv?))
+ =
+ (lambda (x y) (= y x))))
+
+ (let lp ((ans list) (rest rest))
+ (if (null? rest)
+ ans
+ (lp (if (member (car rest) ans pred)
+ ans
+ (cons (car rest) ans))
+ (cdr rest)))))
(define (lset-union = . rest)
- (let ((acc '()))
- (for-each (lambda (lst)
- (if (null? acc)
- (set! acc lst)
- (for-each (lambda (elem)
- (if (not (member elem acc
- (lambda (x y) (= y x))))
- (set! acc (cons elem acc))))
- lst)))
- rest)
- acc))
+ ;; Likewise, allow memq / memv to be used if possible.
+ (define pred
+ (if (or (eq? = eq?) (eq? = eqv?))
+ =
+ (lambda (x y) (= y x))))
+
+ (fold (lambda (lis ans) ; Compute ANS + LIS.
+ (cond ((null? lis) ans) ; Don't copy any lists
+ ((null? ans) lis) ; if we don't have to.
+ ((eq? lis ans) ans)
+ (else
+ (fold (lambda (elt ans)
+ (if (member elt ans pred)
+ ans
+ (cons elt ans)))
+ ans lis))))
+ '()
+ rest))
(define (lset-intersection = list1 . rest)
(let lp ((l list1) (acc '()))
diff --git a/module/statprof.scm b/module/statprof.scm
index da6f3f1fc..33246e5bd 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
+@var{loop} 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
+@code{statprof-fetch-call-tree} 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))))