From 56fa12daf992d47a2ff2b326afa11708362674e0 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Sat, 28 Oct 2017 20:54:56 +0200
Subject: [PATCH] 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
---
 eval.scm    |    7 +++++--
 library.scm |   10 ++++++----
 runtime.c   |    7 ++++++-
 support.scm |    4 +++-
 4 files changed, 20 insertions(+), 8 deletions(-)

diff --git a/eval.scm b/eval.scm
index 0426e64..718ea80 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 a95bd19..867d944 100644
--- a/library.scm
+++ b/library.scm
@@ -4707,12 +4707,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
@@ -5454,7 +5455,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 bq unique)
 
 (define ##sys#primordial-thread
   (##sys#make-thread #f 'running 'primordial ##sys#default-thread-quantum))
diff --git a/runtime.c b/runtime.c
index 9423993..499fc92 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 517a1e5..550f9f2 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])
-- 
1.7.9.5