From: Taylor R Campbell <campbell@mumble.net>
Date: Sat, 9 Feb 2019 16:14:15 +0000 (+0000)
Subject: Cache char set table.
X-Git-Tag: mit-scheme-pucked-10.1.10~6^2~13
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=79518c17ffb6d1297dee70e6b03dc30c0cf2f9fb;p=mit-scheme.git

Cache char set table.

This is a provisional kludge to make string searches by character set
in Edwin less obscenely expensive than they are at the moment, which
is killing IMAIL.

Formerly we just cached these in the char-set object itself.
---

diff --git a/src/edwin/string.scm b/src/edwin/string.scm
index 3eea2d925..ed719f017 100644
--- a/src/edwin/string.scm
+++ b/src/edwin/string.scm
@@ -1339,7 +1339,7 @@ USA.
 
 (define-integrable (%substring-find-next-char-in-set string start end char-set)
   ((ucode-primitive substring-find-next-char-in-set)
-   string start end (char-set-table char-set)))
+   string start end (cached-char-set-table char-set)))
 
 (define (string-find-previous-char-in-set string char-set)
   (guarantee-string string 'STRING-FIND-PREVIOUS-CHAR-IN-SET)
@@ -1354,7 +1354,28 @@ USA.
 
 (define (%substring-find-previous-char-in-set string start end char-set)
   ((ucode-primitive substring-find-previous-char-in-set)
-   string start end (char-set-table char-set)))
+   string start end (cached-char-set-table char-set)))
+
+;; Kludge!  These used to be cached in the record when the char-set was
+;; constructed; now they are not.
+
+(define char-set-table-lock
+  (make-thread-mutex))
+
+(define char-set-table-table
+  (make-weak-eq-hash-table))
+
+(define (cached-char-set-table char-set)
+  (or (begin (lock-thread-mutex char-set-table-lock)
+	(begin0 (hash-table-ref char-set-table-table char-set (lambda () #f))
+	  (unlock-thread-mutex char-set-table-lock)))
+      (let ((table (char-set-table char-set)))
+	(lock-thread-mutex char-set-table-lock)
+	;; If we raced with someone else, no problem -- if there's a
+	;; duplicate table then it'll be GC'd at the end.
+	(hash-table-set! char-set-table-table char-set table)
+	(unlock-thread-mutex char-set-table-lock)
+	table)))
 
 ;;;; String search