[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-146-ge3
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-146-ge30f5b7 |
|
Date: |
Mon, 11 Jan 2010 23:20:43 +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=e30f5b7d4032f79eb3ecdb0a11de37486221845c
The branch, master has been updated
via e30f5b7d4032f79eb3ecdb0a11de37486221845c (commit)
via e106eca674288661ca6a2b7352ed082cbcda1b12 (commit)
via f3a1fc5a9ec0cea5dcd6e505bf9a440ee3651891 (commit)
via 136b5494d13fdc4a7b3b59d4bd451beb2c075e25 (commit)
via 3b12702faf0fa42890e4c857aabda3e6d5eb5c83 (commit)
from dfe13aa2c82371dad3b455e79e295a21b50d4992 (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 e30f5b7d4032f79eb3ecdb0a11de37486221845c
Author: Andy Wingo <address@hidden>
Date: Tue Jan 12 00:21:16 2010 +0100
make-array bugfix
* libguile/vm-i-scheme.c (make-array): Fix terrible stack corruption
bug.
commit e106eca674288661ca6a2b7352ed082cbcda1b12
Author: Andy Wingo <address@hidden>
Date: Tue Jan 12 00:20:50 2010 +0100
inspector integration in debugger
* module/system/vm/debug.scm: Integrate with the inspector. Add a
"procedure" command.
commit f3a1fc5a9ec0cea5dcd6e505bf9a440ee3651891
Author: Andy Wingo <address@hidden>
Date: Tue Jan 12 00:20:10 2010 +0100
fix srfi-4 shared vector access from c
* libguile/srfi-4.c (DEFINE_SRFI_4_C_FUNCS): Fix
elements/writable_elements for shared vectors. Thanks to Daniel
Llorens del RÃo for the info.
commit 136b5494d13fdc4a7b3b59d4bd451beb2c075e25
Author: Andy Wingo <address@hidden>
Date: Tue Jan 12 00:19:18 2010 +0100
programs print as #<procedure ...>
* module/system/vm/program.scm (write-program): Print as #<procedure
...>. Fix stdin printing.
* doc/ref/vm.texi: Update a little bit.
commit 3b12702faf0fa42890e4c857aabda3e6d5eb5c83
Author: Andy Wingo <address@hidden>
Date: Tue Jan 12 00:18:24 2010 +0100
add a silly inspector
* module/Makefile.am:
* module/system/vm/inspect.scm: Add a very simple and stupid inspector.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/vm.texi | 65 ++++++++-------
libguile/srfi-4.c | 4 +-
libguile/vm-i-scheme.c | 3 +-
module/Makefile.am | 23 +++--
module/system/vm/debug.scm | 13 +++-
module/system/vm/inspect.scm | 190 ++++++++++++++++++++++++++++++++++++++++++
module/system/vm/program.scm | 5 +-
7 files changed, 257 insertions(+), 46 deletions(-)
create mode 100644 module/system/vm/inspect.scm
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index b64c2a6..ffcfbed 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -306,42 +306,45 @@ We can see how these concepts tie together by
disassembling the
@smallexample
scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b)))
scheme@@(guile-user)> ,x foo
-Disassembly of #<program foo (a)>:
+Disassembly of #<procedure foo (a)>:
- 0 (object-ref 1) ;; #<program b7e478b0 at <unknown port>:0:16
(b)>
- 2 (local-ref 0) ;; `a' (arg)
- 4 (vector 0 1) ;; 1 element
- 7 (make-closure)
- 8 (return)
+ 0 (assert-nargs-ee 0 1)
+ 3 (reserve-locals 0 1)
+ 6 (object-ref 1) ;; #<procedure 85bfec0 at <current
input>:0:16 (b)>
+ 8 (local-ref 0) ;; `a'
+ 10 (make-closure 0 1)
+ 13 (return)
----------------------------------------
-Disassembly of #<program b7e478b0 at <unknown port>:0:16 (b)>:
-
- 0 (toplevel-ref 1) ;; `foo'
- 2 (free-ref 0) ;; (closure variable)
- 4 (local-ref 0) ;; `b' (arg)
- 6 (list 0 3) ;; 3 elements at (unknown file):0:28
- 9 (return)
+Disassembly of #<procedure 85bfec0 at <current input>:0:16 (b)>:
+
+ 0 (assert-nargs-ee 0 1)
+ 3 (reserve-locals 0 1)
+ 6 (toplevel-ref 1) ;; `foo'
+ 8 (free-ref 0) ;; (closure variable)
+ 10 (local-ref 0) ;; `b'
+ 12 (list 0 3) ;; 3 elements at (unknown
file):0:28
+ 15 (return)
@end smallexample
-At @code{ip} 0, we load up the compiled lambda. @code{Ip} 2 and 4
-create the free variables vector, and @code{ip} 7 makes the
-closure---binding code (from the compiled lambda) with data (the
-free-variable vector). Finally we return the closure.
-
-The second stanza disassembles the compiled lambda. Toplevel variables
-are resolved relative to the module that was current when the
-procedure was created. This lookup occurs lazily, at the first time
-the variable is actually referenced, and the location of the lookup is
-cached so that future references are very cheap. @xref{Environment
-Control Instructions}, for more details.
-
-Then we see a reference to an external variable, corresponding to
address@hidden The disassembler doesn't have enough information to give a
-name to that variable, so it just marks it as being a ``closure
-variable''. Finally we see the reference to @code{b}, then the
address@hidden opcode, an inline implementation of the @code{list} scheme
-routine.
+First there's some prelude, where @code{foo} checks that it was called with
only
+1 argument. Then at @code{ip} 6, we load up the compiled lambda. @code{Ip} 8
+loads up `a', so that it can be captured into a closure by at @code{ip}
+10---binding code (from the compiled lambda) with data (the free-variable
+vector). Finally we return the closure.
+
+The second stanza disassembles the compiled lambda. After the prelude, we note
+that toplevel variables are resolved relative to the module that was current
+when the procedure was created. This lookup occurs lazily, at the first time
the
+variable is actually referenced, and the location of the lookup is cached so
+that future references are very cheap. @xref{Environment Control Instructions},
+for more details.
+
+Then we see a reference to a free variable, corresponding to @code{a}. The
+disassembler doesn't have enough information to give a name to that variable,
so
+it just marks it as being a ``closure variable''. Finally we see the reference
+to @code{b}, then the @code{list} opcode, an inline implementation of the
address@hidden scheme routine.
@node Instruction Set
@subsection Instruction Set
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index b807046..f9572d0 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -119,13 +119,13 @@
{ \
if (h->element_type != ETYPE (TAG)) \
scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
- return h->elements; \
+ return ((const ctype*) h->elements) + h->base; \
} \
ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \
{ \
if (h->element_type != ETYPE (TAG)) \
scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
- return h->writable_elements; \
+ return ((ctype*) h->writable_elements) + h->base; \
} \
const ctype *scm_##tag##vector_elements (SCM uvec, \
scm_t_array_handle *h, \
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index f5fc47d..02dbd5f 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -668,7 +668,8 @@ VM_DEFINE_INSTRUCTION (177, make_array, "make-array", 3,
-1, 1)
SYNC_REGISTER ();
ret = scm_from_contiguous_array (shape, sp - len + 1, len);
DROPN (len);
- RETURN (ret);
+ PUSH (ret);
+ NEXT;
}
/*
diff --git a/module/Makefile.am b/module/Makefile.am
index 54ceca9..b43cf2e 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright (C) 2009 Free Software Foundation, Inc.
+## Copyright (C) 2009, 2010 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -274,14 +274,19 @@ OOP_SOURCES = \
oop/goops/accessors.scm \
oop/goops/simple.scm
-SYSTEM_SOURCES = \
- system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \
- system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \
- system/vm/trace.scm system/vm/vm.scm \
- \
- system/xref.scm \
- \
- system/repl/repl.scm system/repl/common.scm \
+SYSTEM_SOURCES = \
+ system/vm/inspect.scm \
+ system/vm/debug.scm \
+ system/vm/frame.scm \
+ system/vm/instruction.scm \
+ system/vm/objcode.scm \
+ system/vm/profile.scm \
+ system/vm/program.scm \
+ system/vm/trace.scm \
+ system/vm/vm.scm \
+ system/xref.scm \
+ system/repl/repl.scm \
+ system/repl/common.scm \
system/repl/command.scm
LIB_SOURCES = \
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index ff4d000..b3686c3 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -26,6 +26,7 @@
#:use-module (ice-9 rdelim)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 format)
+ #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
#:use-module (system vm program)
#:export (run-debugger debug-pre-unwind-handler))
@@ -161,7 +162,8 @@
(let ((top frame)
(cur frame)
(index 0)
- (level (debugger-level db)))
+ (level (debugger-level db))
+ (last #f))
(define (frame-index frame)
(let lp ((idx 0) (walk top))
(if (= (frame-return-address frame) (frame-return-address walk))
@@ -203,6 +205,7 @@
(define (print* . vals)
(define (print x)
(run-hook before-print-hook x)
+ (set! last x)
(pretty-print x))
(if (and (pair? vals)
(not (and (null? (cdr vals))
@@ -266,6 +269,14 @@ With an argument, select a frame by index, then show it."
(format #t "No such frame.~%"))))
(else (show-frame))))
+ (define-command ((commands procedure proc))
+ "Print the procedure for the selected frame."
+ (print* (frame-procedure cur)))
+
+ (define-command ((commands inspect i))
+ "Launch the inspector on the last-printed object."
+ (%inspect last))
+
(define-command ((commands locals))
"Show locally-bound variables in the selected frame."
(print-locals cur))
diff --git a/module/system/vm/inspect.scm b/module/system/vm/inspect.scm
new file mode 100644
index 0000000..aebf50d
--- /dev/null
+++ b/module/system/vm/inspect.scm
@@ -0,0 +1,190 @@
+;;; Guile VM debugging facilities
+
+;;; Copyright (C) 2001, 2009, 2010 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
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Code:
+
+(define-module (system vm inspect)
+ #:use-module (system base pmatch)
+ #:use-module (system base syntax)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module ((language assembly disassemble)
+ #:select ((disassemble . %disassemble)))
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 format)
+ #:use-module (system vm program)
+ #:export (inspect))
+
+
+(define (reverse-hashq h)
+ (let ((ret (make-hash-table)))
+ (hash-for-each
+ (lambda (k v)
+ (hashq-set! ret v (cons k (hashq-ref ret v '()))))
+ h)
+ ret))
+
+(define (catch-bad-arguments thunk bad-args-thunk)
+ (catch 'wrong-number-of-args
+ (lambda ()
+ (catch 'keyword-argument-error
+ thunk
+ (lambda (k . args)
+ (bad-args-thunk))))
+ (lambda (k . args)
+ (bad-args-thunk))))
+
+(define (read-args prompt)
+ (define (read* reader)
+ (repl-reader prompt reader))
+ (define (next)
+ (read* read-char))
+ (define (cmd chr)
+ (cond
+ ((eof-object? chr) (list chr))
+ ((char=? chr #\newline) (cmd (next)))
+ ((char-whitespace? chr) (cmd (next)))
+ (else
+ (unread-char chr)
+ (let ((tok (read* read)))
+ (args (list tok) (next))))))
+ (define (args out chr)
+ (cond
+ ((eof-object? chr) (reverse out))
+ ((char=? chr #\newline) (reverse out))
+ ((char-whitespace? chr) (args out (next)))
+ (else
+ (unread-char chr)
+ (let ((tok (read* read)))
+ (args (cons tok out) (next))))))
+ (cmd (next)))
+
+
+;;;
+;;; Inspector
+;;;
+
+(define (inspect x)
+ (define-syntax define-command
+ (syntax-rules ()
+ ((_ ((mod cname alias ...) . args) body ...)
+ (define cname
+ (let ((c (lambda* args body ...)))
+ (set-procedure-property! c 'name 'cname)
+ (module-define! mod 'cname c)
+ (module-add! mod 'alias (module-local-variable mod 'cname))
+ ...
+ c)))))
+
+ (let ((commands (make-module)))
+ (define (prompt)
+ (format #f "address@hidden inspect> " x))
+
+ (define-command ((commands quit q continue cont c))
+ "Quit the inspector."
+ (throw 'quit))
+
+ (define-command ((commands print p))
+ "Print the current object using `pretty-print'."
+ (pretty-print x))
+
+ (define-command ((commands write w))
+ "Print the current object using `write'."
+ (write x))
+
+ (define-command ((commands display d))
+ "Print the current object using `display'."
+ (display x))
+
+ (define-command ((commands disassemble x))
+ "Disassemble the current object, which should be objcode or a procedure."
+ (catch #t
+ (lambda ()
+ (%disassemble x))
+ (lambda args
+ (format #t "Error disassembling object: ~a\n" args))))
+
+ (define-command ((commands help h ?) #:optional cmd)
+ "Show this help message."
+ (let ((rhash (reverse-hashq (module-obarray commands))))
+ (define (help-cmd cmd)
+ (let* ((v (module-local-variable commands cmd))
+ (p (variable-ref v))
+ (canonical-name (procedure-name p)))
+ ;; la la la
+ (format #t "~a~{ ~:@(~a~)~}~?~%~a~&~%"
+ canonical-name (program-lambda-list p)
+ "~#[~:;~40t(aliases: address@hidden, ~})~]"
+ (delq canonical-name (hashq-ref rhash v))
+ (procedure-documentation p))))
+ (cond
+ (cmd
+ (cond
+ ((and (symbol? cmd) (module-local-variable commands cmd))
+ (help-cmd cmd))
+ (else
+ (format #t "Invalid command ~s.~%" cmd)
+ (format #t "Try `help' for a list of commands~%"))))
+ (else
+ (let ((names (sort
+ (hash-map->list
+ (lambda (k v)
+ (procedure-name (variable-ref k)))
+ rhash)
+ (lambda (x y)
+ (string<? (symbol->string x)
+ (symbol->string y))))))
+ (format #t "Available commands:~%~%")
+ (for-each help-cmd names))))))
+
+ (define (handle cmd . args)
+ (cond
+ ((and (symbol? cmd)
+ (module-local-variable commands cmd))
+ => (lambda (var)
+ (let ((proc (variable-ref var)))
+ (catch-bad-arguments
+ (lambda ()
+ (apply (variable-ref var) args))
+ (lambda ()
+ (format (current-error-port)
+ "Invalid arguments to ~a. Try `help ~a'.~%"
+ (procedure-name proc) (procedure-name proc)))))))
+ ; ((and (integer? cmd) (exact? cmd))
+ ; (nth cmd))
+ ((eof-object? cmd)
+ (newline)
+ (throw 'quit))
+ (else
+ (format (current-error-port)
+ "~&Unknown command: ~a. Try `help'.~%" cmd)
+ *unspecified*)))
+
+ (catch 'quit
+ (lambda ()
+ (let loop ()
+ (apply
+ handle
+ (save-module-excursion
+ (lambda ()
+ (set-current-module commands)
+ (read-args prompt))))
+ (loop)))
+ (lambda (k . args)
+ (apply values args)))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index ccb9ebf..28d453a 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -192,13 +192,14 @@
. ,rest)))
(define (write-program prog port)
- (format port "#<program ~a~a>"
+ (format port "#<procedure ~a~a>"
(or (program-name prog)
(and=> (program-source prog 0)
(lambda (s)
(format #f "~a at ~a:~a:~a"
(number->string (object-address prog) 16)
- (or (source:file s) "<unknown port>")
+ (or (source:file s)
+ (if s "<current input>" "<unknown port>"))
(source:line s) (source:column s))))
(number->string (object-address prog) 16))
(let ((arities (program-arities prog)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-6-146-ge30f5b7,
Andy Wingo <=