~ chicken-core (chicken-5) 00d8dcd2425a9eaa31f768fc5eac08555952e89c

commit 00d8dcd2425a9eaa31f768fc5eac08555952e89c
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Oct 28 20:54:56 2017 +0200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Fri Nov 3 20:07:47 2017 +0100

    Add identity slot to thread and use this for distinguishing threads when extracting call-chain.
    
    Otherwise we hold on to threads too long, see also #1356
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/NEWS b/NEWS
index e8cc5dc4..c849aede 100644
--- a/NEWS
+++ b/NEWS
@@ -16,6 +16,8 @@
     also accept multiple values via direct invocation after being
     captured through `call/cc`, not just via `values` (#1390)
   - Removed the deprecated C_locative_ref and C_mutate2 C functions.
+  - The trace buffer no longer holds on to thread objects, allowing them to
+    be garbage collected sooner (#1356, thanks to Kristian Lein-Mathisen)
 
 - Compiler
   - Fixed an off by one allocation problem in generated C code for (list ...).
diff --git a/eval.scm b/eval.scm
index 0426e644..718ea80d 100644
--- a/eval.scm
+++ b/eval.scm
@@ -83,6 +83,9 @@
 (define compile-to-closure
   (let ((reverse reverse))
     (lambda (exp env se #!optional cntr evalenv static tl?)
+      (define-syntax thread-id
+        (syntax-rules ()
+          ((_ t) (##sys#slot t 14))))
 
       (define (find-id id se)		; ignores macro bindings
 	(cond ((null? se) #f)
@@ -114,7 +117,7 @@
 	   "C_emit_eval_trace_info" 
 	   info
 	   (##sys#make-structure 'frameinfo cntr e v)
-	   ##sys#current-thread) ) )
+	   (thread-id ##sys#current-thread) ) ) )
       
       (define (emit-syntax-trace-info tf info cntr) 
 	(when tf
@@ -122,7 +125,7 @@
 	   "C_emit_syntax_trace_info"
 	   info
 	   cntr
-	   ##sys#current-thread) ) )
+           (thread-id ##sys#current-thread) ) ) )
 	
       (define (decorate p ll h cntr)
 	(eval-decorator p ll h cntr))
diff --git a/library.scm b/library.scm
index c17236a6..bedd7d23 100644
--- a/library.scm
+++ b/library.scm
@@ -4702,12 +4702,13 @@ EOF
 	     (c +trace-buffer-entry-slot-count+)
 	     (vec (##sys#make-vector (fx* c tbl) #f))
 	     (r (##core#inline "C_fetch_trace" start vec))
-	     (n (if (fixnum? r) r (fx* c tbl))))
+	     (n (if (fixnum? r) r (fx* c tbl)))
+             (t-id (and thread (##sys#slot thread 14))))
 	(let loop ((i 0))
 	  (if (fx>= i n)
 	      '()
-	      (let ((t (##sys#slot vec (fx+ i 3)))) ; thread
-		(if (or (not t) (not thread) (eq? thread t))
+	      (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
@@ -5449,7 +5450,8 @@ EOF
    (##core#undefined)			; #10 specific
    #f					; #11 block object (type depends on blocking type)
    '()					; #12 recipients
-   #f) )				; #13 unblocked by timeout?
+   #f					; #13 unblocked by timeout?
+   (cons #f #f)))            		; #14 ID (just needs to be unique)
 
 (define ##sys#primordial-thread
   (##sys#make-thread #f 'running 'primordial ##sys#default-thread-quantum))
diff --git a/runtime.c b/runtime.c
index 9423993a..499fc922 100644
--- a/runtime.c
+++ b/runtime.c
@@ -259,6 +259,8 @@ static C_TLS int timezone;
 # define SIGBUS                      0
 #endif
 
+#define C_thread_id(x)   C_block_item((x), 14)
+
 
 /* Type definitions: */
 
@@ -4408,6 +4410,8 @@ done:
 
 C_regparm void C_fcall C_trace(C_char *name)
 {
+  C_word thread;
+
   if(show_trace) {
     C_fputs(name, C_stderr);
     C_fputc('\n', C_stderr);
@@ -4432,7 +4436,8 @@ C_regparm void C_fcall C_trace(C_char *name)
   trace_buffer_top->raw = name;
   trace_buffer_top->cooked1 = C_SCHEME_FALSE;
   trace_buffer_top->cooked2 = C_SCHEME_FALSE;
-  trace_buffer_top->thread = C_block_item(current_thread_symbol, 0);
+  thread = C_block_item(current_thread_symbol, 0);
+  trace_buffer_top->thread = C_thread_id(thread);
   ++trace_buffer_top;
 }
 
diff --git a/support.scm b/support.scm
index 517a1e57..905f7ae8 100644
--- a/support.scm
+++ b/support.scm
@@ -194,7 +194,9 @@
 
 ;; Move to C-platform?
 (define (emit-syntax-trace-info info cntr) 
-  (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) )
+  (define (thread-id t) (##sys#slot t 14))
+  (##core#inline "C_emit_syntax_trace_info" info cntr
+                 (thread-id ##sys#current-thread)))
 
 (define (map-llist proc llist)
   (let loop ([llist llist])