From 1ed75d8531d83129e39f31a38823b7f58f3c7882 Mon Sep 17 00:00:00 2001 From: mainzelm Date: Thu, 8 Nov 2001 10:24:41 +0000 Subject: [PATCH] Let thread-uid->thread invoke the GC if it encounters multiple threads with the same uid. --- scheme/rts/thread.scm | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/scheme/rts/thread.scm b/scheme/rts/thread.scm index 2bb5ec7..338aa0a 100644 --- a/scheme/rts/thread.scm +++ b/scheme/rts/thread.scm @@ -108,14 +108,31 @@ ; by rts/channel-port.scm to when forcibly unlocking one of the REPL's ports. (define (thread-uid->thread uid) + (let ((matching-threads (threads-with-uid uid))) + (cond ((null? matching-threads) #f) + ((null? (cdr matching-threads)) + (car matching-threads)) + (else (set! matching-threads #f) + ((structure-ref primitives collect)) + (let ((new-matching-threads (threads-with-uid uid))) + (cond ((null? new-matching-threads) #f) + ((null? (cdr new-matching-threads)) + (car new-matching-threads)) + (else (debug-message "duplicate thread uid" + new-matching-threads) + (car new-matching-threads)))))))) + +(define (threads-with-uid uid) (let ((threads (all-threads))) (let loop ((i 0)) (cond ((= i (vector-length threads)) - #f) + '()) ((= uid (thread-uid (vector-ref threads i))) - (vector-ref threads i)) - (else - (loop (+ i 1))))))) + (cons (vector-ref threads i) (loop (+ i 1)))) + (else + (loop (+ i 1))))))) + + (define (all-threads) ((structure-ref primitives find-all-records) :thread))