~ chicken-core (chicken-5) ef5fbf34421b030c5098ae40a41ebc4c9bd17131
commit ef5fbf34421b030c5098ae40a41ebc4c9bd17131
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sun Jul 22 22:23:17 2018 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Nov 25 15:00:30 2018 +0100
Some small debugger data and wire protocol improvements
These changes are intended to simplify the use of the debugging protocol
by client applications by fixing a few oddities that would otherwise
need to be coded around on the client side.
Populate the "location" slot for call events. Previously, the debugging
stub would send Scheme filenames and line number information to clients
in the "location" slot for all except for 'call' events, which would
instead have the location as a prefix of the "value" slot. Move this
source information into the "location" slot so that all events sent to
the client use the fields in the same way in all cases.
Send missing values to the client as `#f' rather than as strings.
Previously, the debugging stub would send missing values to the client
as either an empty string or a string containing "#f" (a byproduct of
using `->string' during code generation), but it's easier to handle the
"real" #f token on the client side. So, introduce a `send_string_value'
procedure that sends C strings to the client as either a quoted string
or #f if the string is NULL or empty, rather than as strings in all
cases. Update call sites to indicate missing events and file locations
as NULL in C and #f on the wire. This requires bumping the predefined
integer value definitions by one, since event locations may now be NULL
if no Scheme or C source information is available. Rename `send_value'
to `send_scheme_value' for consistency with `send_string_value'. Update
feathers.tcl as necessary.
Emit C source info as a single string, rather than as a separate
filename and line number, to simplify its use in dbg-stub.c.
Use symbols for `##core#debug-event' node event types in core.scm.
Previously, these were strings in some places and symbols in others.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/c-backend.scm b/c-backend.scm
index babb2ac3..a624c815 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -962,7 +962,9 @@
(gen #t "{" (second info) ",0,")
(for-each
(lambda (x)
- (gen "C_text(\"" (backslashify (->string x)) "\"),"))
+ (if (not x)
+ (gen "NULL,")
+ (gen "C_text(\"" (backslashify (->string x)) "\"),")))
(cddr info))
(gen "},"))
(sort dbg-info-table (lambda (i1 i2) (< (car i1) (car i2)))))
diff --git a/chicken.h b/chicken.h
index 141ec2ee..ba676b4c 100644
--- a/chicken.h
+++ b/chicken.h
@@ -784,6 +784,9 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define CHICKEN_default_toplevel ((void *)C_default_5fstub_toplevel)
+#define C__STR1(x) #x
+#define C__STR2(x) C__STR1(x)
+
#define C_align4(n) (((n) + 3) & ~3)
#define C_align8(n) (((n) + 7) & ~7)
#define C_align16(n) (((n) + 15) & ~15)
@@ -826,10 +829,9 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
*/
# define C_VAL1(x) C__PREV_TMPST.n1
# define C_VAL2(x) C__PREV_TMPST.n2
-# define C__STR(x) #x
# define C__CHECK_panic(a,s,f,l) \
((a) ? (void)0 : \
- C_panic_hook(C_text("Low-level type assertion " s " failed at " f ":" C__STR(l))))
+ C_panic_hook(C_text("Low-level type assertion " s " failed at " f ":" C__STR1(l))))
# define C__CHECK_core(v,a,s,x) \
({ struct { \
typeof(v) n1; \
@@ -1643,16 +1645,16 @@ typedef struct C_DEBUG_INFO {
C_char *val;
} C_DEBUG_INFO;
-#define C_DEBUG_CALL 0
-#define C_DEBUG_GLOBAL_ASSIGN 1
-#define C_DEBUG_GC 2
-#define C_DEBUG_ENTRY 3
-#define C_DEBUG_SIGNAL 4
-#define C_DEBUG_CONNECT 5
-#define C_DEBUG_LISTEN 6
-#define C_DEBUG_INTERRUPTED 7
+#define C_DEBUG_CALL 1
+#define C_DEBUG_GLOBAL_ASSIGN 2
+#define C_DEBUG_GC 3
+#define C_DEBUG_ENTRY 4
+#define C_DEBUG_SIGNAL 5
+#define C_DEBUG_CONNECT 6
+#define C_DEBUG_LISTEN 7
+#define C_DEBUG_INTERRUPTED 8
-#define C_debugger(cell, c, av) (C_debugger_hook != NULL ? C_debugger_hook(cell, c, av, C_text(__FILE__), __LINE__) : C_SCHEME_UNDEFINED)
+#define C_debugger(cell, c, av) (C_debugger_hook != NULL ? C_debugger_hook(cell, c, av, C_text(__FILE__ ":" C__STR2(__LINE__))) : C_SCHEME_UNDEFINED)
/* Variables: */
@@ -1687,7 +1689,7 @@ C_varextern C_TLS void *C_restart_trampoline;
C_varextern C_TLS void (*C_pre_gc_hook)(int mode);
C_varextern C_TLS void (*C_post_gc_hook)(int mode, C_long ms);
C_varextern C_TLS void (*C_panic_hook)(C_char *msg);
-C_varextern C_TLS C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, char *cloc, int cln);
+C_varextern C_TLS C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, char *cloc);
C_varextern C_TLS int
C_abort_on_thread_exceptions,
diff --git a/core.scm b/core.scm
index 3ecdd817..2128b206 100644
--- a/core.scm
+++ b/core.scm
@@ -787,7 +787,7 @@
(walk
(if emit-debug-info
`(##core#begin
- (##core#debug-event "C_DEBUG_ENTRY" ',dest)
+ (##core#debug-event C_DEBUG_ENTRY ',dest)
,body0)
body0)
(append aliases e) #f #f dest ln #f))))
@@ -1121,7 +1121,7 @@
(when emit-debug-info
(set! val
`(let ((,var ,val))
- (##core#debug-event "C_DEBUG_GLOBAL_ASSIGN" ',var)
+ (##core#debug-event C_DEBUG_GLOBAL_ASSIGN ',var)
,var)))
;; We use `var0` instead of `var` because the {macro,current}-environment
;; are keyed by the raw and unqualified name
@@ -1144,7 +1144,7 @@
((##core#debug-event)
`(##core#debug-event
- ,(unquotify (cadr x))
+ ,(cadr x)
,ln ; this arg is added - from this phase on ##core#debug-event has an additional argument!
,@(map (lambda (arg)
(unquotify (walk arg e #f #f h ln tl?)))
@@ -2500,7 +2500,7 @@
(not (llist-match? llist (cdr subs))))
(quit-compiling
"~a: procedure `~a' called with wrong number of arguments"
- (source-info->line name)
+ (source-info->string name)
(if (pair? name) (cadr name) name)))
(register-direct-call! id)
(when custom (register-customizable! varname id))
@@ -2770,11 +2770,12 @@
(walk-var (first params) e e-count #f) )
((##core#direct_call)
- (let* ((name (second params))
- (name-str (source-info->string name))
+ (let* ((source-info (second params))
(demand (fourth params)))
- (if (and emit-debug-info name)
- (let ((info (list dbg-index 'C_DEBUG_CALL "" name-str)))
+ (if (and emit-debug-info source-info)
+ (let ((info (list dbg-index 'C_DEBUG_CALL
+ (source-info->line source-info)
+ (source-info->name source-info))))
(set! params (cons dbg-index params))
(set! debug-info (cons info debug-info))
(set! dbg-index (add1 dbg-index)))
@@ -2937,13 +2938,14 @@
((##core#call)
(let* ((len (length (cdr subs)))
(p2 (pair? (cdr params)))
- (name (and p2 (second params)))
- (name-str (source-info->string name)))
+ (source-info (and p2 (second params))))
(set! signatures (lset-adjoin/eq? signatures len))
(when (and (>= (length params) 3) (eq? here (third params)))
(set! looping (add1 looping)) )
- (if (and emit-debug-info name)
- (let ((info (list dbg-index 'C_DEBUG_CALL "" name-str)))
+ (if (and emit-debug-info source-info)
+ (let ((info (list dbg-index 'C_DEBUG_CALL
+ (source-info->line source-info)
+ (source-info->name source-info))))
(set! params (cons dbg-index params))
(set! debug-info (cons info debug-info))
(set! dbg-index (add1 dbg-index)))
diff --git a/dbg-stub.c b/dbg-stub.c
index 53d91cc1..e58a8af6 100644
--- a/dbg-stub.c
+++ b/dbg-stub.c
@@ -118,7 +118,7 @@ static volatile int interrupted = 0;
static int dbg_info_count = 0;
-static C_word debug_event_hook(C_DEBUG_INFO *cell, C_word c, C_word *av, C_char *cloc, int cln);
+static C_word debug_event_hook(C_DEBUG_INFO *cell, C_word c, C_word *av, C_char *cloc);
void
@@ -238,7 +238,7 @@ enable_debug_info(int n, int f)
C_DEBUG_INFO *dinfo;
for(dip = dbg_info_list; dip != NULL; dip = dip->next) {
- for(dinfo = dip->info; dinfo->loc != NULL; ++dinfo) {
+ for(dinfo = dip->info; dinfo->event; ++dinfo) {
if(i++ == n) {
dinfo->enabled = f;
return;
@@ -251,7 +251,7 @@ enable_debug_info(int n, int f)
static void
-send_string(char *str)
+send_string(C_char *str)
{
/* fprintf(stderr, "<SENT: %s>\n", str); */
C_fflush(stderr);
@@ -260,9 +260,18 @@ send_string(char *str)
terminate("write failed");
}
+static void
+send_string_value(C_char *str) {
+ if (str == 0 || *str == 0)
+ send_string(" #f");
+ else {
+ C_snprintf(rw_buffer, sizeof(rw_buffer), " \"%s\"", str);
+ send_string(rw_buffer);
+ }
+}
static void
-send_value(C_word x)
+send_scheme_value(C_word x)
{
if((x & C_FIXNUM_BIT) != 0)
C_snprintf(rw_buffer, sizeof(rw_buffer), " %ld", (long)C_unfix(x));
@@ -276,7 +285,7 @@ send_value(C_word x)
static void
-send_event(int event, C_char *loc, C_char *val, C_char *cloc, int cln)
+send_event(int event, C_char *loc, C_char *val, C_char *cloc)
{
int n;
int reply, mask;
@@ -288,9 +297,12 @@ send_event(int event, C_char *loc, C_char *val, C_char *cloc, int cln)
void **stats;
for(;;) {
- n = C_snprintf(rw_buffer, sizeof(rw_buffer), "(%d \"%s\" \"%s\" \"%s:%d\")\n",
- event, loc, val, cloc, cln);
+ C_snprintf(rw_buffer, sizeof(rw_buffer), "(%d", event);
send_string(rw_buffer);
+ send_string_value(loc);
+ send_string_value(val);
+ send_string_value(cloc);
+ send_string(")\n");
if(socket_read() < 0) terminate("read failed");
@@ -336,11 +348,13 @@ send_event(int event, C_char *loc, C_char *val, C_char *cloc, int cln)
str = C_strdup(str);
for(dip = unseen_dbg_info_list; dip != NULL; dip = dip->next) {
- for(dinfo = dip->info; dinfo->loc != NULL; ++dinfo) {
+ for(dinfo = dip->info; dinfo->event; ++dinfo) {
if(*str == '\0' || strstr(dinfo->val, str)) {
- C_snprintf(rw_buffer, sizeof(rw_buffer), "(* %d %d \"%s\" \"%s\")\n",
- dbg_info_count++, dinfo->event, dinfo->loc, dinfo->val);
+ C_snprintf(rw_buffer, sizeof(rw_buffer), "(* %d %d", dbg_info_count++, dinfo->event);
send_string(rw_buffer);
+ send_string_value(dinfo->loc);
+ send_string_value(dinfo->val);
+ send_string(")\n");
}
++n;
@@ -373,7 +387,7 @@ send_event(int event, C_char *loc, C_char *val, C_char *cloc, int cln)
send_string("(*");
for(n = 0; n < current_c; ++n)
- send_value(current_av[ n ]);
+ send_scheme_value(current_av[ n ]);
send_string(")\n");
break;
@@ -410,7 +424,7 @@ send_event(int event, C_char *loc, C_char *val, C_char *cloc, int cln)
send_string(rw_buffer);
for(mask = C_header_size(x); n < mask; ++n)
- send_value(C_block_item(x, n));
+ send_scheme_value(C_block_item(x, n));
send_string(")\n");
break;
@@ -426,7 +440,7 @@ send_event(int event, C_char *loc, C_char *val, C_char *cloc, int cln)
send_string("(* UNKNOWN)\n");
else {
send_string("(*");
- send_value(C_symbol_value(x));
+ send_scheme_value(C_symbol_value(x));
send_string(")\n");
}
@@ -542,7 +556,7 @@ connect_to_debugger()
return C_SCHEME_FALSE; /* failed to connect */
C_snprintf(info, sizeof(info), "%s:%d:%d", C_main_argv[ 0 ], getpid(), C_DEBUG_PROTOCOL_VERSION);
- send_event(C_DEBUG_CONNECT, info, "", "", 0);
+ send_event(C_DEBUG_CONNECT, info, NULL, NULL);
#ifndef _WIN32
C_signal(SIGUSR2, interrupt_signal_handler);
#endif
@@ -551,15 +565,14 @@ connect_to_debugger()
static C_word
-debug_event_hook(C_DEBUG_INFO *cell, C_word c, C_word *av, char *cloc, int cln)
+debug_event_hook(C_DEBUG_INFO *cell, C_word c, C_word *av, C_char *cloc)
{
if(socket_fd != 0) {
if(cell->enabled || interrupted || ((1 << cell->event) & event_mask) != 0 ) {
- /* fprintf(stderr, "event: %s:%d\n", cloc, cln); */
+ /* fprintf(stderr, "event: %s\n", cloc); */
current_c = c;
current_av = av;
- send_event(interrupted ? C_DEBUG_INTERRUPTED : cell->event, cell->loc,
- cell->val, cloc, cln);
+ send_event(interrupted ? C_DEBUG_INTERRUPTED : cell->event, cell->loc, cell->val, cloc);
interrupted = 0;
}
}
diff --git a/feathers.tcl b/feathers.tcl
index 0ad41c40..15aa3f0c 100755
--- a/feathers.tcl
+++ b/feathers.tcl
@@ -30,16 +30,15 @@ set version 0
set protocol_version 0
set debugger_port 9999
-set events(0) call
-set events(1) assign
-set events(2) gc
-set events(3) entry
-set events(4) signal
-set events(5) connect
-set events(6) listen
-set events(7) interrupted
-
-set reply(UNUSED) 0
+set events(1) call
+set events(2) assign
+set events(3) gc
+set events(4) entry
+set events(5) signal
+set events(6) connect
+set events(7) listen
+set events(8) interrupted
+
set reply(SETMASK) 1
set reply(TERMINATE) 2
set reply(CONTINUE) 3
@@ -82,8 +81,8 @@ set typecode(43) TAGGED_POINTER
set typecode(77) LAMBDA_INFO
set typecode(15) BUCKET
-set EXEC_EVENT_MASK 16; # signal
-set STEP_EVENT_MASK 27; # call, entry, assign, signal
+set EXEC_EVENT_MASK 32; # signal
+set STEP_EVENT_MASK 54; # call, entry, assign, signal
set membar_height 50
set value_cutoff_limit 200; # must be lower than limit in dbg-stub.c
@@ -784,8 +783,10 @@ proc ProcessInput {} {
proc ProcessLine {line} {
- if {[regexp {^\((\d+)\s+"([^"]*)"\s+"([^"]*)"\s+"([^"]*)"\)$} $line _ evt loc val \
- cloc]} {
+ if {[regexp {^\((\d+)\s+([^\s]*)\s+([^\s]*)\s+([^)]*)\)$} $line _ evt loc val cloc]} {
+ set val [ProcessString $val]
+ set loc [ProcessString $loc]
+ set cloc [ProcessString $cloc]
ProcessEvent $evt $loc $val $cloc
} elseif {[regexp {^\(\*\s*(.*)\)$} $line _ data]} {
ProcessData $data
@@ -1479,6 +1480,15 @@ proc InsertDebugInfo {index event args} {
return 0
}
+proc ProcessString {str} {
+ if {$str == "#f"} {
+ return ""
+ } elseif {[regexp {^"(.*)"$} $str _ strip]} {
+ return $strip
+ } else {
+ return $str
+ }
+}
proc FetchEventListReply {} {
global file_list reply_queue data_queue
@@ -1489,8 +1499,9 @@ proc FetchEventListReply {} {
proc EventInfoData {data} {
- if {[regexp {(\d+)\s+(\d+)\s+"([^"]*)"\s+"([^"]*)"$} $data _ index event \
- loc val]} {
+ if {[regexp {(\d+)\s+(\d+)\s+([^\s]*)\s+(.*)$} $data _ index event loc val]} {
+ set loc [ProcessString $loc]
+ set val [ProcessString $val]
InsertDebugInfo $index $event $loc $val
} else {
UpdateHeader "invalid event data: $data"
diff --git a/runtime.c b/runtime.c
index 518fb7cb..fe570f4d 100644
--- a/runtime.c
+++ b/runtime.c
@@ -342,7 +342,7 @@ C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);
C_TLS void (*C_panic_hook)(C_char *msg) = NULL;
C_TLS void (*C_pre_gc_hook)(int mode) = NULL;
C_TLS void (*C_post_gc_hook)(int mode, C_long ms) = NULL;
-C_TLS C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, C_char *cloc, int cln) = NULL;
+C_TLS C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, C_char *cloc) = NULL;
C_TLS int
C_gui_mode = 0,
diff --git a/support.scm b/support.scm
index 8d9baac2..bbb992c9 100644
--- a/support.scm
+++ b/support.scm
@@ -64,7 +64,8 @@
block-variable-literal-name make-random-name
clear-real-name-table! get-real-name set-real-name!
real-name real-name2 display-real-name-table
- source-info->string source-info->line call-info constant-form-eval
+ source-info->string source-info->line source-info->name
+ call-info constant-form-eval
dump-nodes read-info-hook read/source-info big-fixnum? small-bignum?
hide-variable export-variable variable-hidden? variable-visible?
mark-variable variable-mark intrinsic? predicate? foldable?
@@ -1467,12 +1468,13 @@
(let ((ln (car info))
(name (cadr info)))
(conc ln ":" (make-string (max 0 (- 4 (string-length ln))) #\space) " " name) )
- info))
+ (->string info)))
+
+(define (source-info->name info)
+ (if (list? info) (cadr info) (->string info)))
(define (source-info->line info)
- (if (list? info)
- (car info)
- (and info (->string info))))
+ (and (list? info) (car info)))
(define (call-info params var) ; Used only in optimizer.scm
(or (and-let* ((info (and (pair? (cdr params)) (second params))))
Trap