[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-8-87-g06d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-8-87-g06dcb9d |
|
Date: |
Sat, 13 Mar 2010 20:02:59 +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=06dcb9dfb663169ce612bca241e5438c73bfa5c6
The branch, master has been updated
via 06dcb9dfb663169ce612bca241e5438c73bfa5c6 (commit)
via 01c0082fae4ce3b0c09f003a2141c38cfc062d74 (commit)
via 32ce4058db1adc319dabf6f93143cb367f7456fc (commit)
from 9f0745183605c4f2997b95c421637678ca5e5e2a (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 06dcb9dfb663169ce612bca241e5438c73bfa5c6
Author: Andy Wingo <address@hidden>
Date: Sat Mar 13 21:03:06 2010 +0100
narrowing stacks to prompts; backtrace shows frames from start-stack
* libguile/stacks.c (scm_sys_stacks): New global variable, moved here
from boot-9.scm.
(scm_init_stacks): Define scm_sys_stacks to %stacks.
(stack_depth): Remove narrowing by frame pointer.
(find_prompt): New helper.
(narrow_stack): Clean up a bit, and allow narrowing by prompt tag.
(scm_make_stack): Update docs, and use scm_stack_id to get the stack
id.
(scm_stack_id): The current stack id may be fetched as the cdar of
%stacks.
(stack_id_with_fp): Remove helper.
* module/ice-9/boot-9.scm (%start-stack): Fix indentation.
(%stacks): Remove definition, it's in stacks.c now.
(default-pre-unwind-handler): Narrow by another frame.
(save-stack): Remove special handling for certain stack ids, as it is
often possible that the function isn't on the stack -- in the
interpreter, or after a tail call. Better to narrow by prompt ids.
* module/system/vm/debug.scm (print-frames): Change to operate on a
vector of frames.
(run-debugger): Change to receive a vector of frames. The debugger
also has the full stack, so it can re-narrow (or widen) to get the
whole stack, if the user wants.
(stack->vector): New helper.
(debug-pre-unwind-handler): Narrow by more frames, and to the most
recent start-stack invocation. Adapt to run-debugger change.
commit 01c0082fae4ce3b0c09f003a2141c38cfc062d74
Author: Andy Wingo <address@hidden>
Date: Fri Mar 12 12:10:23 2010 +0100
remove repl-vm; repl evaluation does not cause recursive vm invocation
* module/system/repl/common.scm (<repl>): Remove "vm" field and repl-vm
accessor. I think the correct model is to just use the-vm. This change
was prompted by the need to have the REPL itself not cause a recursive
VM invocation, so that captured prompts at the REPL are rewindable.
(make-repl): Remove treatment of #:vm.
(repl-eval): Load a compiled expression as a simple thunk, avoiding a
recursive VM call.
* module/system/repl/command.scm (profile, trace): Remove repl-vm
treatment.
(backtrace, debugger, step): Remove, as they were not implemented.
commit 32ce4058db1adc319dabf6f93143cb367f7456fc
Author: Andy Wingo <address@hidden>
Date: Fri Mar 12 11:54:26 2010 +0100
prompt around REPL evaluations, and around `guile' program invocation
* module/ice-9/control.scm (%): Add a single-argument case, which
instates a default prompt with a default handler.
* libguile/script.c (scm_compile_shell_switches): Wrap user programs in
a default prompt.
* module/system/repl/common.scm (repl-eval): REPL expressions are user
programs too; wrap each one in a default prompt.
-----------------------------------------------------------------------
Summary of changes:
libguile/script.c | 9 ++-
libguile/stacks.c | 177 ++++++++++++++++++++++++---------------
module/ice-9/boot-9.scm | 40 ++++-----
module/ice-9/control.scm | 18 ++++
module/system/repl/command.scm | 27 ++-----
module/system/repl/common.scm | 25 +++---
module/system/vm/debug.scm | 179 +++++++++++++++++++++------------------
7 files changed, 270 insertions(+), 205 deletions(-)
diff --git a/libguile/script.c b/libguile/script.c
index 89ff7a0..2f24957 100644
--- a/libguile/script.c
+++ b/libguile/script.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
2005, 2006, 2007, 2008, 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
@@ -740,6 +740,13 @@ scm_compile_shell_switches (int argc, char **argv)
{
SCM val = scm_cons (sym_begin, tail);
+ /* Wrap the expression in a prompt. */
+ val = scm_list_2 (scm_list_3 (scm_sym_at,
+ scm_list_2 (scm_from_locale_symbol
("ice-9"),
+ scm_from_locale_symbol
("control")),
+ scm_from_locale_symbol ("%")),
+ val);
+
#if 0
scm_write (val, SCM_UNDEFINED);
scm_newline (SCM_UNDEFINED);
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 431d6b1..a7ebda0 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -24,6 +24,7 @@
#endif
#include "libguile/_scm.h"
+#include "libguile/control.h"
#include "libguile/eval.h"
#include "libguile/debug.h"
#include "libguile/continuations.h"
@@ -41,6 +42,8 @@
#include "libguile/private-options.h"
+static SCM scm_sys_stacks;
+
/* {Stacks}
*
@@ -59,17 +62,14 @@
-static SCM stack_id_with_fp (SCM frame, SCM **fp);
-
/* Count number of debug info frames on a stack, beginning with FRAME.
*/
static long
-stack_depth (SCM frame, SCM *fp)
+stack_depth (SCM frame)
{
long n = 0;
/* count frames, skipping boot frames */
- for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp;
- frame = scm_frame_previous (frame))
+ for (; scm_is_true (frame); frame = scm_frame_previous (frame))
++n;
return n;
}
@@ -95,6 +95,21 @@ stack_depth (SCM frame, SCM *fp)
* encountered.
*/
+static SCM
+find_prompt (SCM key)
+{
+ SCM winds;
+ for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds))
+ {
+ SCM elt = scm_car (winds);
+ if (SCM_PROMPT_P (elt) && SCM_PROMPT_TAG (elt) == key)
+ return elt;
+ }
+ scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
+ scm_list_1 (key));
+ return SCM_BOOL_F; /* not reached */
+}
+
static void
narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
@@ -105,25 +120,35 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long
outer, SCM outer_key)
frame = SCM_STACK_FRAME (stack);
/* Cut inner part. */
- if (scm_is_eq (inner_key, SCM_BOOL_T))
+ if (scm_is_true (scm_procedure_p (inner_key)))
{
- /* Cut specified number of frames. */
- for (; inner && len; --inner)
+ /* Cut until the given procedure is seen. */
+ for (; inner && len ; --inner)
{
+ SCM proc = scm_frame_procedure (frame);
len--;
frame = scm_frame_previous (frame);
+ if (scm_is_eq (proc, inner_key))
+ break;
}
}
+ else if (scm_is_symbol (inner_key))
+ {
+ /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
+ symbols. */
+ SCM prompt = find_prompt (inner_key);
+ for (; len; len--, frame = scm_frame_previous (frame))
+ if (SCM_PROMPT_REGISTERS (prompt)->fp
+ == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+ break;
+ }
else
{
- /* Cut until the given procedure is seen. */
- for (; inner && len ; --inner)
+ /* Cut specified number of frames. */
+ for (; inner && len; --inner)
{
- SCM proc = scm_frame_procedure (frame);
len--;
frame = scm_frame_previous (frame);
- if (scm_is_eq (proc, inner_key))
- break;
}
}
@@ -131,12 +156,39 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long
outer, SCM outer_key)
SCM_SET_STACK_FRAME (stack, frame);
/* Cut outer part. */
- for (; outer && len ; --outer)
+ if (scm_is_true (scm_procedure_p (outer_key)))
{
- frame = scm_stack_ref (stack, scm_from_long (len - 1));
- len--;
- if (scm_is_eq (scm_frame_procedure (frame), outer_key))
- break;
+ /* Cut until the given procedure is seen. */
+ for (; outer && len ; --outer)
+ {
+ frame = scm_stack_ref (stack, scm_from_long (len - 1));
+ len--;
+ if (scm_is_eq (scm_frame_procedure (frame), outer_key))
+ break;
+ }
+ }
+ else if (scm_is_symbol (outer_key))
+ {
+ /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
+ symbols. */
+ SCM prompt = find_prompt (outer_key);
+ while (len)
+ {
+ frame = scm_stack_ref (stack, scm_from_long (len - 1));
+ len--;
+ if (SCM_PROMPT_REGISTERS (prompt)->fp
+ == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
+ break;
+ }
+ }
+ else
+ {
+ /* Cut specified number of frames. */
+ for (; outer && len ; --outer)
+ {
+ frame = scm_stack_ref (stack, scm_from_long (len - 1));
+ len--;
+ }
}
SCM_SET_STACK_LENGTH (stack, len);
@@ -163,24 +215,33 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
"Create a new stack. If @var{obj} is @code{#t}, the current\n"
"evaluation stack is used for creating the stack frames,\n"
"otherwise the frames are taken from @var{obj} (which must be\n"
- "either a debug object or a continuation).\n\n"
+ "a continuation or a frame object).\n"
+ "\n"
"@var{args} should be a list containing any combination of\n"
- "integer, procedure and @code{#t} values.\n\n"
+ "integer, procedure, prompt tag and @code{#t} values.\n"
+ "\n"
"These values specify various ways of cutting away uninteresting\n"
"stack frames from the top and bottom of the stack that\n"
"@code{make-stack} returns. They come in pairs like this:\n"
"@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
- "@var{outer_cut_2} @dots{})}.\n\n"
- "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
- "procedure. @code{#t} means to cut away all frames up to but\n"
- "excluding the first user module frame. An integer means to cut\n"
- "away exactly that number of frames. A procedure means to cut\n"
- "away all frames up to but excluding the application frame whose\n"
- "procedure matches the specified one.\n\n"
- "Each @var{outer_cut_N} can be an integer or a procedure. An\n"
- "integer means to cut away that number of frames. A procedure\n"
- "means to cut away frames down to but excluding the application\n"
- "frame whose procedure matches the specified one.\n\n"
+ "@var{outer_cut_2} @dots{})}.\n"
+ "\n"
+ "Each @var{inner_cut_N} can be @code{#t}, an integer, a prompt\n"
+ "tag, or a procedure. @code{#t} means to cut away all frames up\n"
+ "to but excluding the first user module frame. An integer means\n"
+ "to cut away exactly that number of frames. A prompt tag means\n"
+ "to cut away all frames that are inside a prompt with the given\n"
+ "tag. A procedure means to cut away all frames up to but\n"
+ "excluding the application frame whose procedure matches the\n"
+ "specified one.\n"
+ "\n"
+ "Each @var{outer_cut_N} can be an integer, a prompt tag, or a\n"
+ "procedure. An integer means to cut away that number of frames.\n"
+ "A prompt tag means to cut away all frames that are outside a\n"
+ "prompt with the given tag. A procedure means to cut away\n"
+ "frames down to but excluding the application frame whose\n"
+ "procedure matches the specified one.\n"
+ "\n"
"If the @var{outer_cut_N} of the last pair is missing, it is\n"
"taken as 0.")
#define FUNC_NAME s_scm_make_stack
@@ -189,7 +250,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
int maxp;
SCM frame;
SCM stack;
- SCM id, *id_fp;
SCM inner_cut, outer_cut;
/* Extract a pointer to the innermost frame of whatever object
@@ -209,6 +269,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
else if (SCM_VM_FRAME_P (obj))
frame = obj;
else if (SCM_CONTINUATIONP (obj))
+ /* FIXME: Narrowing to prompt tags should narrow with respect to the
prompts
+ that were in place when the continuation was captured. */
frame = scm_i_continuation_to_frame (obj);
else
{
@@ -224,20 +286,16 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
if (scm_is_false (frame))
return SCM_BOOL_F;
- /* Get ID of the stack corresponding to the given frame. */
- id = stack_id_with_fp (frame, &id_fp);
-
/* Count number of frames. Also get stack id tag and check whether
there are more stackframes than we want to record
(SCM_BACKTRACE_MAXDEPTH). */
- id = SCM_BOOL_F;
maxp = 0;
- n = stack_depth (frame, id_fp);
+ n = stack_depth (frame);
/* Make the stack object. */
stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
SCM_SET_STACK_LENGTH (stack, n);
- SCM_SET_STACK_ID (stack, id);
+ SCM_SET_STACK_ID (stack, scm_stack_id (obj));
SCM_SET_STACK_FRAME (stack, frame);
/* Narrow the stack according to the arguments given to scm_make_stack. */
@@ -258,9 +316,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
narrow_stack (stack,
scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
- scm_is_integer (inner_cut) ? 0 : inner_cut,
+ scm_is_integer (inner_cut) ? SCM_BOOL_T : inner_cut,
scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
- scm_is_integer (outer_cut) ? 0 : outer_cut);
+ scm_is_integer (outer_cut) ? SCM_BOOL_T : outer_cut);
n = SCM_STACK_LENGTH (stack);
}
@@ -277,44 +335,26 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
"Return the identifier given to @var{stack} by @code{start-stack}.")
#define FUNC_NAME s_scm_stack_id
{
- SCM frame, *id_fp;
-
- if (scm_is_eq (stack, SCM_BOOL_T))
+ if (scm_is_eq (stack, SCM_BOOL_T)
+ /* FIXME: frame case assumes frame still live on the stack, and no
+ intervening start-stack. Hmm... */
+ || SCM_VM_FRAME_P (stack))
{
- struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
- frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
+ /* Fetch most recent start-stack tag. */
+ SCM stacks = scm_fluid_ref (scm_sys_stacks);
+ return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F;
}
- else if (SCM_VM_FRAME_P (stack))
- frame = stack;
else if (SCM_CONTINUATIONP (stack))
- frame = scm_i_continuation_to_frame (stack);
+ /* FIXME: implement me */
+ return SCM_BOOL_F;
else
{
SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
/* not reached */
}
-
- return stack_id_with_fp (frame, &id_fp);
}
#undef FUNC_NAME
-static SCM
-stack_id_with_fp (SCM frame, SCM **fp)
-{
- SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame);
-
- if (SCM_VM_CONT_P (holder))
- {
- *fp = NULL;
- return SCM_BOOL_F;
- }
- else
- {
- *fp = NULL;
- return SCM_BOOL_F;
- }
-}
-
SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
(SCM stack, SCM index),
"Return the @var{index}'th frame from @var{stack}.")
@@ -347,6 +387,9 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
void
scm_init_stacks ()
{
+ scm_sys_stacks = scm_make_fluid ();
+ scm_c_define ("%stacks", scm_sys_stacks);
+
scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
SCM_UNDEFINED);
scm_set_struct_vtable_name_x (scm_stack_type,
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 5c777f4..eca7163 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1030,7 +1030,7 @@ If there is no handler at all, Guile prints an error and
then exits."
;;; {The interpreter stack}
;;;
-(define %stacks (make-fluid))
+;; %stacks defined in stacks.c
(define (%start-stack tag thunk)
(let ((prompt-tag (make-prompt-tag "start-stack")))
(call-with-prompt
@@ -2742,7 +2742,8 @@ module '(ice-9 q) '(make-q q-length))}."
(define (set-repl-prompt! v) (set! scm-repl-prompt v))
(define (default-pre-unwind-handler key . args)
- (save-stack 1)
+ ;; Narrow by two more frames: this one, and the throw handler.
+ (save-stack 2)
(apply throw key args))
(begin-deprecated
@@ -2839,28 +2840,25 @@ module '(ice-9 q) '(make-q q-length))}."
;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
(define before-signal-stack (make-fluid))
+;; FIXME: stack-saved? is broken in the presence of threads.
(define stack-saved? #f)
(define (save-stack . narrowing)
- (or stack-saved?
- (cond ((not (memq 'debug (debug-options-interface)))
- (fluid-set! the-last-stack #f)
- (set! stack-saved? #t))
- (else
- (fluid-set!
- the-last-stack
- (case (stack-id #t)
- ((repl-stack)
- (apply make-stack #t save-stack primitive-eval #t 0
narrowing))
- ((load-stack)
- (apply make-stack #t save-stack 0 #t 0 narrowing))
- ((#t)
- (apply make-stack #t save-stack 0 1 narrowing))
- (else
- (let ((id (stack-id #t)))
- (and (procedure? id)
- (apply make-stack #t save-stack id #t 0 narrowing))))))
- (set! stack-saved? #t)))))
+ (if (not stack-saved?)
+ (begin
+ (let ((stacks (fluid-ref %stacks)))
+ (fluid-set! the-last-stack
+ ;; (make-stack obj inner outer inner outer ...)
+ ;;
+ ;; In this case, cut away the make-stack frame, the
+ ;; save-stack frame, and then narrow as specified by the
+ ;; user, delimited by the nearest start-stack invocation,
+ ;; if any.
+ (apply make-stack #t
+ 2
+ (if (pair? stacks) (cdar stacks) 0)
+ narrowing)))
+ (set! stack-saved? #t))))
(define before-error-hook (make-hook))
(define after-error-hook (make-hook))
diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm
index 98397a3..dbee61e 100644
--- a/module/ice-9/control.scm
+++ b/module/ice-9/control.scm
@@ -28,6 +28,10 @@
(define-syntax %
(syntax-rules ()
+ ((_ expr)
+ (call-with-prompt (default-prompt-tag)
+ (lambda () expr)
+ default-prompt-handler))
((_ expr handler)
(call-with-prompt (default-prompt-tag)
(lambda () expr)
@@ -36,3 +40,17 @@
(call-with-prompt tag
(lambda () expr)
handler))))
+
+;; Each prompt tag has a type -- an expected set of arguments, and an unwritten
+;; contract of what its handler will do on an abort. In the case of the default
+;; prompt tag, we could choose to return values, exit nonlocally, or punt to
the
+;; user.
+;;
+;; We choose the latter, by requiring that the user return one value, a
+;; procedure, to an abort to the prompt tag. That argument is then invoked with
+;; the continuation as an argument, within a reinstated default prompt. In this
+;; way the return value(s) from a default prompt are under the user's control.
+(define (default-prompt-handler k proc)
+ (% (default-prompt-tag)
+ (proc k)
+ default-prompt-handler))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index ae8568a..67feeb1 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -28,7 +28,6 @@
#:use-module (system vm program)
#:use-module (system vm vm)
#:autoload (system base language) (lookup-language language-reader)
- #:autoload (system vm debug) (vm-debugger vm-backtrace)
#:autoload (system vm trace) (vm-trace)
#:autoload (system vm profile) (vm-profile)
#:use-module (ice-9 format)
@@ -51,7 +50,7 @@
(compile (compile c) (compile-file cc)
(disassemble x) (disassemble-file xx))
(profile (time t) (profile pr))
- (debug (backtrace bt) (debugger db) (trace tr) (step st))
+ (debug (trace tr))
(system (gc) (statistics stat))))
(define (group-name g) (car g))
@@ -358,9 +357,9 @@ Time execution."
"profile FORM
Profile execution."
;; FIXME opts
- (let ((vm (repl-vm repl))
- (proc (make-program (repl-compile repl (repl-parse repl form)))))
- (apply statprof (lambda () (vm-apply vm proc '())) opts)))
+ (apply statprof
+ (make-program (repl-compile repl (repl-parse repl form)))
+ opts))
@@ -368,29 +367,15 @@ Profile execution."
;;; Debug commands
;;;
-(define-meta-command (backtrace repl)
- "backtrace
-Display backtrace."
- (vm-backtrace (repl-vm repl)))
-
-(define-meta-command (debugger repl)
- "debugger
-Start debugger."
- (vm-debugger (repl-vm repl)))
-
-(define-meta-command (trace repl form . opts)
+(define-meta-command (trace repl (form) . opts)
"trace FORM
Trace execution."
;; FIXME: doc options, or somehow deal with them better
(apply vm-trace
- (repl-vm repl)
+ (the-vm)
(make-program (repl-compile repl (repl-parse repl form)))
opts))
-(define-meta-command (step repl)
- "step FORM
-Step execution."
- (display "Not implemented yet\n"))
;;;
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 9570d1d..c760c89 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -1,6 +1,6 @@
;;; Repl common routines
-;; Copyright (C) 2001, 2008, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008, 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
@@ -22,8 +22,9 @@
#:use-module (system base syntax)
#:use-module (system base compile)
#:use-module (system base language)
- #:use-module (system vm vm)
- #:export (<repl> make-repl repl-vm repl-language repl-options
+ #:use-module (system vm program)
+ #:use-module (ice-9 control)
+ #:export (<repl> make-repl repl-language repl-options
repl-tm-stats repl-gc-stats
repl-welcome repl-prompt repl-read repl-compile repl-eval
repl-parse repl-print repl-option-ref repl-option-set!
@@ -34,7 +35,7 @@
;;; Repl type
;;;
-(define-record/keywords <repl> vm language options tm-stats gc-stats)
+(define-record/keywords <repl> language options tm-stats gc-stats)
(define repl-default-options
'((trace . #f)
@@ -42,8 +43,7 @@
(define %make-repl make-repl)
(define (make-repl lang)
- (%make-repl #:vm (the-vm)
- #:language (lookup-language lang)
+ (%make-repl #:language (lookup-language lang)
#:options repl-default-options
#:tm-stats (times)
#:gc-stats (gc-stats)))
@@ -76,12 +76,13 @@
(if parser (parser form) form)))
(define (repl-eval repl form)
- (let ((eval (language-evaluator (repl-language repl))))
- (if (and eval
- (or (null? (language-compilers (repl-language repl)))
- (assq-ref (repl-options repl) 'interp)))
- (eval form (current-module))
- (vm-load (repl-vm repl) (repl-compile repl form '())))))
+ (let* ((eval (language-evaluator (repl-language repl)))
+ (thunk (if (and eval
+ (or (null? (language-compilers (repl-language repl)))
+ (assq-ref (repl-options repl) 'interp)))
+ (lambda () (eval form (current-module)))
+ (make-program (repl-compile repl form '())))))
+ (% (thunk))))
(define (repl-print repl val)
(if (not (eq? val *unspecified*))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index b3686c3..4c99469 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -96,40 +96,34 @@
x))))
(frame-bindings frame))))))
-(define* (collect-frames frame #:key count)
- (cond
- ((not count)
- (let lp ((frame frame) (out '()))
- (if (not frame)
- out
- (lp (frame-previous frame) (cons frame out)))))
- ;; should also have a from-end option, either via negative count or
- ;; another kwarg
- ((>= count 0)
- (let lp ((frame frame) (out '()) (count count))
- (if (or (not frame) (zero? count))
- out
- (lp (frame-previous frame) (cons frame out) (1- count)))))))
-
-(define* (print-frames frames #:optional (port (current-output-port))
- #:key (start-index (1- (length frames))) (width 72)
- (full? #f))
- (let lp ((frames frames) (i start-index) (last-file ""))
- (if (pair? frames)
- (let* ((frame (car frames))
- (source (frame-source frame))
- (file (and source
- (or (source:file source)
- "current input")))
- (line (and=> source source:line)))
- (if (and file (not (equal? file last-file)))
- (format port "~&In ~a:~&" file))
- (format port "~:[~*~6_~;~5d:~]~3d ~v:@y~%" line line
- i width (frame-call-representation frame))
- (if full?
- (print-locals frame #:width width
- #:per-line-prefix " "))
- (lp (cdr frames) (1- i) (or file last-file))))))
+(define* (print-frames frames
+ #:optional (port (current-output-port))
+ #:key (width 72) (full? #f) (forward? #f) count)
+ (let* ((len (vector-length frames))
+ (lower-idx (if (or (not count) (positive? count))
+ 0
+ (max 0 (+ len count))))
+ (upper-idx (if (and count (negative? count))
+ (1- len)
+ (1- (if count (min count len) len))))
+ (inc (if forward? 1 -1)))
+ (let lp ((i (if forward? lower-idx upper-idx))
+ (last-file ""))
+ (if (<= lower-idx i upper-idx)
+ (let* ((frame (vector-ref frames i))
+ (source (frame-source frame))
+ (file (and source
+ (or (source:file source)
+ "current input")))
+ (line (and=> source source:line)))
+ (if (and file (not (equal? file last-file)))
+ (format port "~&In ~a:~&" file))
+ (format port "~:[~*~6_~;~5d:~]~3d ~v:@y~%" line line
+ i width (frame-call-representation frame))
+ (if full?
+ (print-locals frame #:width width
+ #:per-line-prefix " "))
+ (lp (+ i inc) (or file last-file)))))))
;;;
@@ -150,31 +144,22 @@
(set! (prop vm) debugger)
debugger)))))
-(define* (run-debugger frame #:optional (vm (the-vm)))
+(define* (run-debugger stack frames i #:optional (vm (the-vm)))
(let* ((db (vm-debugger vm))
(level (debugger-level db)))
(dynamic-wind
(lambda () (set! (debugger-level db) (1+ level)))
- (lambda () (debugger-repl db frame))
+ (lambda () (debugger-repl db stack frames i))
(lambda () (set! (debugger-level db) level)))))
-(define (debugger-repl db frame)
- (let ((top frame)
- (cur frame)
- (index 0)
+(define (debugger-repl db stack frames index)
+ (let ((top (vector-ref frames 0))
+ (cur (vector-ref frames index))
(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))
- idx
- (lp (1+ idx) (frame-previous walk)))))
(define (frame-at-index idx)
- (let lp ((idx idx) (walk top))
- (cond
- ((not walk) #f)
- ((zero? idx) walk)
- (else (lp (1- idx) (frame-previous walk))))))
+ (and (< idx (vector-length frames))
+ (vector-ref frames idx)))
(define (show-frame)
;; #2 0x009600e0 in do_std_select (args=0xbfffd9e0) at
threads.c:1668
;; 1668 select (select_args->nfds,
@@ -214,44 +199,51 @@
(define-command ((commands backtrace bt) #:optional count
#:key (width 72) full?)
- "Print a backtrace of all stack frames, or innermost COUNT frames."
- (print-frames (collect-frames top #:count count)
+ "Print a backtrace of all stack frames, or innermost COUNT frames.
+If COUNT is negative, the last COUNT frames will be shown."
+ (print-frames frames
+ #:count count
#:width width
#:full? full?))
(define-command ((commands up) #:optional (count 1))
"Select and print stack frames that called this one.
An argument says how many frames up to go"
- (if (or (not (integer? count)) (<= count 0))
- (format #t "Invalid argument to `up': expected a positive integer
for COUNT.~%")
- (let lp ((n count))
- (cond
- ((zero? n) (show-frame))
- ((frame-previous cur)
- => (lambda (new)
- (set! cur new)
- (set! index (1+ index))
- (lp (1- n))))
- ((= n count)
- (format #t "Already at outermost frame.\n"))
- (else
- (format #t "Reached outermost frame after walking ~a frames.\n"
- (- count n))
- (show-frame))))))
-
+ (cond
+ ((or (not (integer? count)) (<= count 0))
+ (format #t "Invalid argument to `up': expected a positive integer
for COUNT.~%"))
+ ((>= (+ count index) (vector-length frames))
+ (cond
+ ((= index (1- (vector-length frames)))
+ (format #t "Already at outermost frame.\n"))
+ (else
+ (set! index (1- (vector-length frames)))
+ (set! cur (vector-ref frames index))
+ (show-frame))))
+ (else
+ (set! index (+ count index))
+ (set! cur (vector-ref frames index))
+ (show-frame))))
+
(define-command ((commands down) #:optional (count 1))
"Select and print stack frames called by this one.
An argument says how many frames down to go"
(cond
((or (not (integer? count)) (<= count 0))
(format #t "Invalid argument to `down': expected a positive integer
for COUNT.~%"))
- ((= index 0)
- (format #t "Already at innermost frame.~%"))
+ ((< (- index count) 0)
+ (cond
+ ((zero? index)
+ (format #t "Already at innermost frame.\n"))
+ (else
+ (set! index 0)
+ (set! cur (vector-ref frames index))
+ (show-frame))))
(else
- (set! index (max (- index count) 0))
- (set! cur (frame-at-index index))
+ (set! index (- index count))
+ (set! cur (vector-ref frames index))
(show-frame))))
-
+
(define-command ((commands frame f) #:optional idx)
"Show the selected frame.
With an argument, select a frame by index, then show it."
@@ -377,15 +369,36 @@ With an argument, select a frame by index, then show it."
;; hm, trace via reassigning global vars. tricksy.
;; (state associated with vm ?)
+(define (stack->vector stack)
+ (let* ((len (stack-length stack))
+ (v (make-vector len)))
+ (if (positive? len)
+ (let lp ((i 0) (frame (stack-ref stack 0)))
+ (if (< i len)
+ (begin
+ (vector-set! v i frame)
+ (lp (1+ i) (frame-previous frame))))))
+ v))
+
(define (debug-pre-unwind-handler key . args)
- (let ((stack (make-stack #t 2)))
- (pmatch args
- ((,subr ,msg ,args . ,rest)
- (format #t "Throw to key `~a':\n" key)
- (display-error stack (current-output-port) subr msg args rest))
- (else
- (format #t "Throw to key `~a' with args `~s'." key args)))
- (format #t "Entering the debugger. Type `bt' for a backtrace or `c' to
continue.\n")
- (run-debugger (stack-ref stack 0)))
+ ;; Narrow the stack by three frames: make-stack, this one, and the throw
+ ;; handler.
+ (cond
+ ((make-stack #t 3) =>
+ (lambda (stack)
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (format #t "Throw to key `~a':\n" key)
+ (display-error stack (current-output-port) subr msg args rest))
+ (else
+ (format #t "Throw to key `~a' with args `~s'." key args)))
+ (format #t "Entering the debugger. Type `bt' for a backtrace or `c' to
continue.\n")
+ (run-debugger stack
+ (stack->vector
+ ;; by default, narrow to the most recent start-stack
+ (make-stack (stack-ref stack 0) 0
+ (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks)))))
+ 0))))
(save-stack debug-pre-unwind-handler)
(apply throw key args))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-8-87-g06dcb9d,
Andy Wingo <=