~ chicken-core (chicken-5) 0a7f917519cb17803444f97693064151646fe64a
commit 0a7f917519cb17803444f97693064151646fe64a
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Tue Jun 20 16:22:57 2023 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Fri Jun 23 13:20:17 2023 +0200
Add initial support for having line numbers available in csi
- Ensure the line number database is initialized by csi on startup
- Set up the source-info-hook for the reader so that we update the db
- Update trace emitting code to query the line number db and store it
In order to make this work properly, the trace_info_struct has to be
modified such that it can hold the location in either a raw C string
or a "cooked" Scheme string, so that we can pass the location from
Scheme (from the line number database) into the C trace buffer.
We have to keep the raw location string for emitted C code - there we
probably don't want the overhead of creating Scheme literals for every
trace-point in the code.
While at it, rename the "raw" entry to "raw_location" to clarify what
it is. Maybe later we can rename the "cooked[12]" entries as well.
The profiler has to be updated as well to deal with the raw/cooked
location. In case there's a cooked (Scheme string) location, we
simple emit "<eval>", so all the evaluated code ends up in the same
profiling entry. Note that this behaviour is actually the same it was
before (as csi originally always emitted "<eval>" or "<syntax>" into
the trace buffer) - it just means that the profiler doesn't get to
benefit from the improved line number information, but it doesn't make
things worse.
diff --git a/chicken.h b/chicken.h
index 97a7e3bc..8503ccc1 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1304,8 +1304,9 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_tty_portp(p) C_mk_bool(isatty(fileno(C_port_file(p))))
-#define C_emit_eval_trace_info(x, y, z) C_emit_trace_info2(C_text("<eval>"), x, y, z)
-#define C_emit_syntax_trace_info(x, y, z) C_emit_trace_info2(C_text("<syntax>"), x, y, z)
+#define C_emit_trace_info(l, x, y, z) C_emit_trace_info2(NULL, l, x, y, z)
+#define C_emit_eval_trace_info(x, y, z) C_emit_trace_info2(C_text("<eval>"), C_SCHEME_FALSE, x, y, z)
+#define C_emit_syntax_trace_info(x, y, z) C_emit_trace_info2(C_text("<syntax>"), C_SCHEME_FALSE, x, y, z)
/* These expect C_VECTOR_TYPE to be 0: */
#define C_vector_to_structure(v) (C_block_header(v) |= C_STRUCTURE_TYPE, C_SCHEME_UNDEFINED)
@@ -1844,7 +1845,7 @@ C_fctexport int C_fcall C_in_heapp(C_word x) C_regparm;
C_fctexport int C_fcall C_in_fromspacep(C_word x) C_regparm;
C_fctexport int C_fcall C_in_scratchspacep(C_word x) C_regparm;
C_fctexport void C_fcall C_trace(C_char *name) C_regparm;
-C_fctexport C_word C_fcall C_emit_trace_info2(char *raw, C_word x, C_word y, C_word t) C_regparm;
+C_fctexport C_word C_fcall C_emit_trace_info2(char *raw, C_word l, C_word x, C_word y, C_word t) C_regparm;
C_fctexport C_word C_fcall C_u_i_string_hash(C_word str, C_word rnd) C_regparm;
C_fctexport C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd) C_regparm;
C_fctexport C_word C_halt(C_word msg);
diff --git a/csi.scm b/csi.scm
index b3db4521..26a956ea 100644
--- a/csi.scm
+++ b/csi.scm
@@ -73,6 +73,7 @@ EOF
;;; Parameters:
(define-constant init-file "csirc")
+(define-constant line-number-database-size 997) ; Copied from core.scm
(set! ##sys#repl-print-length-limit 2048)
(set! ##sys#features (cons #:csi ##sys#features))
@@ -1157,4 +1158,7 @@ EOF
(let ((r (optional rs)))
(exit (if (fixnum? r) r 0)))))))))))))
-(run))
+(set! ##sys#line-number-database (make-vector line-number-database-size '()))
+
+(fluid-let ((##sys#default-read-info-hook ##sys#read/source-info-hook))
+ (run)))
diff --git a/eval.scm b/eval.scm
index cad25de9..b5671e9a 100644
--- a/eval.scm
+++ b/eval.scm
@@ -112,7 +112,8 @@
(define (emit-trace-info tf info cntr e v)
(when tf
(##core#inline
- "C_emit_eval_trace_info"
+ "C_emit_trace_info"
+ (or (get-line-number info) "<eval>")
info
(##sys#make-structure 'frameinfo cntr e v)
(thread-id ##sys#current-thread) ) ) )
diff --git a/expand.scm b/expand.scm
index 0710a3a1..0567e8d5 100644
--- a/expand.scm
+++ b/expand.scm
@@ -718,7 +718,7 @@
;;; Hook for source information
-(define (##sys#read/source-info-hook class data val) ; Used here and in core.scm
+(define (##sys#read/source-info-hook class data val) ; Used here, in core.scm and in csi.scm
(when (and (eq? 'list-info class) (symbol? (car data)))
(hash-table-set!
##sys#line-number-database
diff --git a/library.scm b/library.scm
index c4129d29..94f304b8 100644
--- a/library.scm
+++ b/library.scm
@@ -4959,14 +4959,14 @@ EOF
;;; Access backtrace:
-(define-constant +trace-buffer-entry-slot-count+ 4)
+(define-constant +trace-buffer-entry-slot-count+ 5)
(set! chicken.base#get-call-chain
(let ((extract
(foreign-lambda* nonnull-c-string ((scheme-object x)) "C_return((C_char *)x);")))
(lambda (#!optional (start 0) (thread ##sys#current-thread))
(let* ((tbl (foreign-value "C_trace_buffer_size" int))
- ;; 4 slots: "raw" string, cooked1, cooked2, thread
+ ;; 5 slots: "raw" location (for compiled code), "cooked" location (for interpreted code), cooked1, cooked2, thread
(c +trace-buffer-entry-slot-count+)
(vec (##sys#make-vector (fx* c tbl) #f))
(r (##core#inline "C_fetch_trace" start vec))
@@ -4978,9 +4978,10 @@ EOF
(let ((t (##sys#slot vec (fx+ i 3)))) ; thread id
(if (or (not t) (not thread) (eq? t-id t))
(cons (vector
- (extract (##sys#slot vec i)) ; raw
- (##sys#slot vec (fx+ i 1)) ; cooked1
- (##sys#slot vec (fx+ i 2))) ; cooked2
+ (or (##sys#slot vec (fx+ i 1)) ; cooked_location
+ (extract (##sys#slot vec i))) ; raw_location
+ (##sys#slot vec (fx+ i 2)) ; cooked1
+ (##sys#slot vec (fx+ i 3))) ; cooked2
(loop (fx+ i c)))
(loop (fx+ i c))))))))))
diff --git a/runtime.c b/runtime.c
index 5ff08f3f..2a556e2d 100644
--- a/runtime.c
+++ b/runtime.c
@@ -281,8 +281,10 @@ typedef struct finalizer_node_struct
typedef struct trace_info_struct
{
- C_char *raw;
- C_word cooked1, cooked2, thread;
+ /* Either raw_location is set to a C string or NULL */
+ C_char *raw_location;
+ /* cooked_location is C_SCHEME_FALSE or a Scheme string (when raw_location is NULL) */
+ C_word cooked_location, cooked1, cooked2, thread;
} TRACE_INFO;
typedef struct hdump_bucket_struct
@@ -3725,6 +3727,7 @@ static C_regparm void C_fcall mark_live_objects(C_byte *tgt_space_start, C_byte
/* Mark trace-buffer: */
for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {
+ mark(&tinfo->cooked_location);
mark(&tinfo->cooked1);
mark(&tinfo->cooked2);
mark(&tinfo->thread);
@@ -4360,8 +4363,13 @@ static void take_profile_sample()
tb = trace_buffer_top - 1;
}
+ if (tb->raw_location != NULL) {
+ key = tb->raw_location;
+ } else {
+ key = "<eval>"; /* Location string is GCable, can't use it */
+ }
+
/* We could also just hash the pointer but that's a bit trickier */
- key = tb->raw;
bp = profile_table + hash_string(C_strlen(key), key, PROFILE_TABLE_SIZE, 0, 0);
b = *bp;
@@ -4419,7 +4427,8 @@ C_regparm void C_fcall C_trace(C_char *name)
trace_buffer_full = 1;
}
- trace_buffer_top->raw = name;
+ trace_buffer_top->raw_location = name;
+ trace_buffer_top->cooked_location = C_SCHEME_FALSE;
trace_buffer_top->cooked1 = C_SCHEME_FALSE;
trace_buffer_top->cooked2 = C_SCHEME_FALSE;
thread = C_block_item(current_thread_symbol, 0);
@@ -4428,7 +4437,7 @@ C_regparm void C_fcall C_trace(C_char *name)
}
-C_regparm C_word C_fcall C_emit_trace_info2(char *raw, C_word x, C_word y, C_word t)
+C_regparm C_word C_fcall C_emit_trace_info2(char *raw, C_word l, C_word x, C_word y, C_word t)
{
/* See above */
if(profiling && next_profile_bucket == NULL) {
@@ -4443,7 +4452,8 @@ C_regparm C_word C_fcall C_emit_trace_info2(char *raw, C_word x, C_word y, C_wor
trace_buffer_full = 1;
}
- trace_buffer_top->raw = raw;
+ trace_buffer_top->raw_location = raw;
+ trace_buffer_top->cooked_location = l;
trace_buffer_top->cooked1 = x;
trace_buffer_top->cooked2 = y;
trace_buffer_top->thread = t;
@@ -4485,7 +4495,13 @@ C_char *C_dump_trace(int start)
horror(C_text("out of memory - cannot reallocate trace-dump buffer"));
}
- C_strlcat(result, ptr->raw, result_len);
+ if (ptr->raw_location != NULL) {
+ C_strlcat(result, ptr->raw_location, result_len);
+ } else if (ptr->cooked_location != C_SCHEME_FALSE) {
+ C_strlcat(result, C_c_string(ptr->cooked_location), nmin(C_header_size(ptr->cooked_location), result_len));
+ } else {
+ C_strlcat(result, "<unknown>", result_len);
+ }
if(i > 0) C_strlcat(result, "\n", result_len);
else C_strlcat(result, " \t<--\n", result_len);
@@ -4517,6 +4533,8 @@ C_regparm void C_fcall C_clear_trace_buffer(void)
trace_buffer_full = 0;
for(i = 0; i < C_trace_buffer_size; ++i) {
+ trace_buffer[ i ].raw_location = NULL;
+ trace_buffer[ i ].cooked_location = C_SCHEME_FALSE;
trace_buffer[ i ].cooked1 = C_SCHEME_FALSE;
trace_buffer[ i ].cooked2 = C_SCHEME_FALSE;
trace_buffer[ i ].thread = C_SCHEME_FALSE;
@@ -4550,16 +4568,17 @@ C_word C_fetch_trace(C_word starti, C_word buffer)
ptr += start;
i -= start;
- if(C_header_size(buffer) < i * 4)
+ if(C_header_size(buffer) < i * 5)
panic(C_text("destination buffer too small for call-chain"));
for(;i--; ++ptr) {
if(ptr >= trace_buffer_limit) ptr = trace_buffer;
/* outside-pointer, will be ignored by GC */
- C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw);
+ C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw_location);
/* subject to GC */
+ C_mutate(&C_block_item(buffer, p++), ptr->cooked_location);
C_mutate(&C_block_item(buffer, p++), ptr->cooked1);
C_mutate(&C_block_item(buffer, p++), ptr->cooked2);
C_mutate(&C_block_item(buffer, p++), ptr->thread);
Trap