From ab06e8b06a0fd8479917a37cb1fa35449f72ef59 Mon Sep 17 00:00:00 2001
From: felix <felix@call-with-current-continuation.org>
Date: Fri, 27 Oct 2017 18:02:51 +0200
Subject: [PATCH] Store thread names in the trasce buffer, not threads.
This avoids keeping threads too long, but may fail when extracting the
backtrace of a specific thread from the thread-buffer (see also #1356)
---
eval.scm | 7 +++++--
library.scm | 7 ++++---
runtime.c | 7 ++++++-
support.scm | 4 +++-
4 files changed, 18 insertions(+), 7 deletions(-)
diff --git a/eval.scm b/eval.scm
index 0426e64..1a2f68e 100644
a
|
b
|
|
83 | 83 | (define compile-to-closure |
84 | 84 | (let ((reverse reverse)) |
85 | 85 | (lambda (exp env se #!optional cntr evalenv static tl?) |
| 86 | (define-syntax thread-name |
| 87 | (syntax-rules () |
| 88 | ((_ t) (##sys#slot t 6)))) |
86 | 89 | |
87 | 90 | (define (find-id id se) ; ignores macro bindings |
88 | 91 | (cond ((null? se) #f) |
… |
… |
|
114 | 117 | "C_emit_eval_trace_info" |
115 | 118 | info |
116 | 119 | (##sys#make-structure 'frameinfo cntr e v) |
117 | | ##sys#current-thread) ) ) |
| 120 | (thread-name ##sys#current-thread) ) ) ) |
118 | 121 | |
119 | 122 | (define (emit-syntax-trace-info tf info cntr) |
120 | 123 | (when tf |
… |
… |
|
122 | 125 | "C_emit_syntax_trace_info" |
123 | 126 | info |
124 | 127 | cntr |
125 | | ##sys#current-thread) ) ) |
| 128 | (thread-name ##sys#current-thread) ) ) ) |
126 | 129 | |
127 | 130 | (define (decorate p ll h cntr) |
128 | 131 | (eval-decorator p ll h cntr)) |
diff --git a/library.scm b/library.scm
index d7c9387..9126c33 100644
a
|
b
|
EOF |
4707 | 4707 | (c +trace-buffer-entry-slot-count+) |
4708 | 4708 | (vec (##sys#make-vector (fx* c tbl) #f)) |
4709 | 4709 | (r (##core#inline "C_fetch_trace" start vec)) |
4710 | | (n (if (fixnum? r) r (fx* c tbl)))) |
| 4710 | (n (if (fixnum? r) r (fx* c tbl))) |
| 4711 | (tname (and thread (##sys#slot thread 6)))) |
4711 | 4712 | (let loop ((i 0)) |
4712 | 4713 | (if (fx>= i n) |
4713 | 4714 | '() |
4714 | | (let ((t (##sys#slot vec (fx+ i 3)))) ; thread |
4715 | | (if (or (not t) (not thread) (eq? thread t)) |
| 4715 | (let ((t (##sys#slot vec (fx+ i 3)))) ; thread name |
| 4716 | (if (or (not t) (not thread) (eq? tname t)) |
4716 | 4717 | (cons (vector |
4717 | 4718 | (extract (##sys#slot vec i)) ; raw |
4718 | 4719 | (##sys#slot vec (fx+ i 1)) ; cooked1 |
diff --git a/runtime.c b/runtime.c
index 9423993..3faa7de 100644
a
|
b
|
static C_TLS int timezone; |
259 | 259 | # define SIGBUS 0 |
260 | 260 | #endif |
261 | 261 | |
| 262 | #define C_thread_name(x) C_block_item((x), 6) |
| 263 | |
262 | 264 | |
263 | 265 | /* Type definitions: */ |
264 | 266 | |
… |
… |
done: |
4408 | 4410 | |
4409 | 4411 | C_regparm void C_fcall C_trace(C_char *name) |
4410 | 4412 | { |
| 4413 | C_word thread; |
| 4414 | |
4411 | 4415 | if(show_trace) { |
4412 | 4416 | C_fputs(name, C_stderr); |
4413 | 4417 | C_fputc('\n', C_stderr); |
… |
… |
C_regparm void C_fcall C_trace(C_char *name) |
4432 | 4436 | trace_buffer_top->raw = name; |
4433 | 4437 | trace_buffer_top->cooked1 = C_SCHEME_FALSE; |
4434 | 4438 | trace_buffer_top->cooked2 = C_SCHEME_FALSE; |
4435 | | trace_buffer_top->thread = C_block_item(current_thread_symbol, 0); |
| 4439 | thread = C_block_item(current_thread_symbol, 0); |
| 4440 | trace_buffer_top->thread = C_thread_name(thread); |
4436 | 4441 | ++trace_buffer_top; |
4437 | 4442 | } |
4438 | 4443 | |
diff --git a/support.scm b/support.scm
index 9d00b37..f29258c 100644
a
|
b
|
|
193 | 193 | |
194 | 194 | ;; Move to C-platform? |
195 | 195 | (define (emit-syntax-trace-info info cntr) |
196 | | (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) ) |
| 196 | (define (thread-name t) (##sys#slot t 6)) |
| 197 | (##core#inline "C_emit_syntax_trace_info" info cntr |
| 198 | (thread-name ##sys#current-thread))) |
197 | 199 | |
198 | 200 | (define (map-llist proc llist) |
199 | 201 | (let loop ([llist llist]) |