From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 30 Jan 2008 14:33:12 +0000 (+0000)
Subject: Optimize handling of #F events, so that they are added to the event
X-Git-Tag: 20090517-FFI~371
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3b90415d58206eba0b5713756422450814cd03de;p=mit-scheme.git

Optimize handling of #F events, so that they are added to the event
queue only when necessary.
---

diff --git a/v7/src/runtime/thread.scm b/v7/src/runtime/thread.scm
index f9ec2d9f1..18e0841d8 100644
--- a/v7/src/runtime/thread.scm
+++ b/v7/src/runtime/thread.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: thread.scm,v 1.46 2008/01/30 08:02:20 cph Exp $
+$Id: thread.scm,v 1.47 2008/01/30 14:33:12 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -764,7 +764,7 @@ USA.
   (let ((self first-running-thread))
     (if (eq? thread self)
 	(let ((block-events? (block-thread-events)))
-	  (ring/enqueue (thread/pending-events thread) event)
+	  (%add-pending-event thread event)
 	  (if (not block-events?)
 	      (unblock-thread-events)))
 	(without-interrupts
@@ -778,11 +778,25 @@ USA.
 	       (%maybe-toggle-thread-timer)))))))
 
 (define (%signal-thread-event thread event)
-  (ring/enqueue (thread/pending-events thread) event)
+  (%add-pending-event thread event)
   (if (and (not (thread/block-events? thread))
 	   (eq? 'WAITING (thread/execution-state thread)))
       (%thread-running thread)))
 
+(define (%add-pending-event thread event)
+  ;; PENDING-EVENTS has three states: (1) empty; (2) one #F event; or
+  ;; (3) any number of non-#F events.  This optimizes #F events away
+  ;; when they aren't needed.
+  (let ((ring (thread/pending-events thread)))
+    (let ((count (ring/count-max-2 ring)))
+      (if event
+	  (if (and (fix:= count 1)
+		   (not (ring/first-item ring)))
+	      (ring/set-first-item! ring event)
+	      (ring/enqueue ring event))
+	  (if (fix:= count 0)
+	      (ring/enqueue ring event))))))
+
 (define (handle-thread-events thread)
   (let loop ((any-events? #f))
     (let ((event (ring/dequeue (thread/pending-events thread) #t)))
@@ -1106,6 +1120,18 @@ USA.
 	      (set-link/next! prev next)
 	      (set-link/prev! next prev))
 	    (loop (link/next link))))))
+
+(define (ring/count-max-2 ring)
+  (let ((link (link/next ring)))
+    (cond ((eq? link ring) 0)
+	  ((eq? (link/next link) ring) 1)
+	  (else 2))))
+
+(define (ring/first-item ring)
+  (link/item (link/next ring)))
+
+(define (ring/set-first-item! ring item)
+  (set-link/item! (link/next ring) item))
 
 ;;;; Error Conditions