From 2a561f33708ec5c0b3e909c11361fd3b94ce567c Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Fri, 22 Jun 2007 21:45:25 +0000
Subject: [PATCH] Make the reader faster when reading #1= constructs when there
 are lots of them.  Use hash tables instead of an alists for holding and
 constructing the necessary objects.  This can vastly speed up the reader in
 some cases.  But unfortunately it slows down the reader when the circular
 structure is "small".

Some care has been taken not to make the reader slow when there are
now #= constructs.

This is based on a patch from Jared Davis.

reader.lisp:
o Add the new hash tables and initialize them appropriately.

sharpm.lisp:
o Update #= and ## macros to use the new hash tables.
---
 code/reader.lisp | 44 ++++++++++++++++++++++-----
 code/sharpm.lisp | 77 ++++++++++++++++++++++++++++++------------------
 2 files changed, 86 insertions(+), 35 deletions(-)

diff --git a/code/reader.lisp b/code/reader.lisp
index cab4a3446..3d925c754 100644
--- a/code/reader.lisp
+++ b/code/reader.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.61 2006/06/30 18:41:22 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.62 2007/06/22 21:45:25 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -563,12 +563,40 @@
 (defvar *ignore-extra-close-parentheses* t
   "If true, only warn when there is an extra close paren, otherwise error.")
 
-;; Alist for #=. Used to keep track of objects with labels assigned that have
-;; been completly read.  Entry is (integer-tag gensym-tag value).
-;;
-(defvar *sharp-equal-alist* ())
-
 (declaim (special *standard-input*))
+
+;;; The SHARP-EQUAL function introduces a label for an object, and the
+;;; SHARP-SHARP function allows us to refer to this label.  This is slightly
+;;; tricky because the object we are labelling can contain labels to itself in
+;;; order to create circular structures, e.g., #1=(cons 'hello #1#).
+;;;
+;;; The SHARP-EQUAL function is called when we are reading a stream and
+;;; encounter text of the form #<LABEL>=<OBJ>, where <LABEL> should be a number
+;;; and <OBJ> ought to be readable as an object.  Our first step is to use
+;;; gensym to create a new <TAG> for this label; we temporarily bind <LABEL> to
+;;; <TAG> and then read in <OBJ> using our <TAG> as a temporary binding for
+;;; <LABEL>.  Finally, we fix the <OBJ> by replacing any occurrences of <TAG>
+;;; with a pointer to <OBJ> itself, creating the circular structures.
+;;;
+;;; We now do this with a couple of data structures.
+;;;
+;;; 1.  *SHARP-EQUAL-FINAL-TABLE* is a hash table where "finished" associations
+;;;     are stored.  That is, it is a hash table from labels to objects, where
+;;;     the objects have already been patched and are tag-free.
+;;;
+;;; 2.  *SHARP-EQUAL-TEMP-TABLE* is a hash table where "unfinished"
+;;;     associations are stored.  That is, it is a hash table from labels to
+;;;     tags.
+;;;
+;;; 3.  *SHARP-EQUAL-REPL-TABLE* is a hash table that associates tags with
+;;;     their corrective pointers.  That is, this is the table we use to
+;;;     "patch" the objects.
+
+(defvar *sharp-equal-final-table*)
+(defvar *sharp-equal-temp-table*)
+(defvar *sharp-equal-repl-table*)
+
+
  
 ;;; READ-PRESERVING-WHITESPACE behaves just like read only it makes sure
 ;;; to leave terminating whitespace in the stream.
@@ -601,7 +629,9 @@
 					nil
 					(car result))))))))))
     (t
-     (let ((*sharp-equal-alist* nil))
+     (let ((*sharp-equal-final-table* nil)
+	   (*sharp-equal-temp-table* nil)
+	   (*sharp-equal-repl-table* nil))
        (read-preserving-whitespace-internal stream eof-errorp eof-value t)))))
 
 
diff --git a/code/sharpm.lisp b/code/sharpm.lisp
index f6098330b..2d37b87a7 100644
--- a/code/sharpm.lisp
+++ b/code/sharpm.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.26 2005/11/08 17:12:29 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.27 2007/06/22 21:45:25 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -243,11 +243,14 @@
 ;; substitutes in arrays and structures as well as lists.  The first arg is an
 ;; alist of the things to be replaced assoc'd with the things to replace them.
 ;;
-(defun circle-subst (old-new-alist tree)
+(defun circle-subst (repl-table tree)
   (cond ((not (typep tree '(or cons (array t) structure-object
 			    standard-object)))
-	 (let ((entry (find tree old-new-alist :key #'second)))
-	   (if entry (third entry) tree)))
+	 (multiple-value-bind (value presentp)
+	     (gethash tree repl-table)
+	   (if presentp
+	       value
+	       tree)))
 	((null (gethash tree *sharp-equal-circle-table*))
 	 (setf (gethash tree *sharp-equal-circle-table*) t)
 	 (cond ((typep tree '(or structure-object standard-object))
@@ -255,7 +258,7 @@
 		     (end (%instance-length tree)))
 		    ((= i end))
 		  (let* ((old (%instance-ref tree i))
-			 (new (circle-subst old-new-alist old)))
+			 (new (circle-subst repl-table old)))
 		    (unless (eq old new)
 		      (setf (%instance-ref tree i) new)))))
 	       ((arrayp tree)
@@ -264,12 +267,12 @@
 		  (do ((i start (1+ i)))
 		      ((>= i end))
 		    (let* ((old (aref data i))
-			   (new (circle-subst old-new-alist old)))
+			   (new (circle-subst repl-table old)))
 		      (unless (eq old new)
 			(setf (aref data i) new))))))
 	       (t
-		(let ((a (circle-subst old-new-alist (car tree)))
-		      (d (circle-subst old-new-alist (cdr tree))))
+		(let ((a (circle-subst repl-table (car tree)))
+		      (d (circle-subst repl-table (cdr tree))))
 		  (unless (eq a (car tree))
 		    (rplaca tree a))
 		  (unless (eq d (cdr tree))
@@ -277,6 +280,17 @@
 	 tree)
 	(t tree)))
 
+(defun maybe-create-tables ()
+  (unless *sharp-equal-final-table*
+    (setf *sharp-equal-final-table*
+	  (make-hash-table :size 40 :rehash-size 4000 :rehash-threshold 0.8 :test 'eql)))
+  (unless *sharp-equal-temp-table*
+    (setf *sharp-equal-temp-table*
+	  (make-hash-table :size 40 :rehash-size 4000 :rehash-threshold 0.8 :test 'eql)))
+  (unless *sharp-equal-repl-table*
+    (setf *sharp-equal-repl-table*
+	  (make-hash-table :size 40 :rehash-size 4000 :rehash-threshold 0.8 :test 'eq))))
+
 ;;; Sharp-equal works as follows.  When a label is assigned (ie when #= is
 ;;; called) we GENSYM a symbol is which is used as an unforgeable tag.
 ;;; *SHARP-SHARP-ALIST* maps the integer tag to this gensym.
@@ -291,25 +305,27 @@
 ;;; for each entry in the *SHARP-SHARP-ALIST, the current object is searched
 ;;; and any uses of the gensysm token are replaced with the actual value.
 ;;;
-(defvar *sharp-sharp-alist* ())
+
 ;;;
 (defun sharp-equal (stream ignore label)
   (declare (ignore ignore))
   (when *read-suppress* (return-from sharp-equal (values)))
   (unless label
     (%reader-error stream "Missing label for #=." label))
-  (when (or (assoc label *sharp-sharp-alist*)
-	    (assoc label *sharp-equal-alist*))
+  (maybe-create-tables)
+  (when (or (nth-value 1 (gethash label *sharp-equal-final-table*))
+	    (nth-value 1 (gethash label *sharp-equal-temp-table*)))
     (%reader-error stream "Multiply defined label: #~D=" label))
-  (let* ((tag (gensym))
-	 (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
-	 (obj (read stream t nil t)))
-    (when (eq obj tag)
-      (%reader-error stream "Have to tag something more than just #~D#."
-		     label))
-    (push (list label tag obj) *sharp-equal-alist*)
-    (let ((*sharp-equal-circle-table* (make-hash-table :test #'eq :size 20)))
-      (circle-subst *sharp-equal-alist* obj))))
+  (let* ((tag (gensym)))
+    (setf (gethash label *sharp-equal-temp-table*) tag)
+    (let ((obj (read stream t nil t)))
+      (when (eq obj tag)
+	(%reader-error stream "Have to tag something more than just #~D#."
+		       label))
+      (setf (gethash tag *sharp-equal-repl-table*) obj)
+      (let ((*sharp-equal-circle-table* (make-hash-table :test #'eq :size 20)))
+	(circle-subst *sharp-equal-repl-table* obj))
+      (setf (gethash label *sharp-equal-final-table*) obj))))
 ;;;
 (defun sharp-sharp (stream ignore label)
   (declare (ignore ignore))
@@ -317,14 +333,19 @@
   (unless label
     (%reader-error stream "Missing label for ##." label))
 
-  (let ((entry (assoc label *sharp-equal-alist*)))
-    (if entry
-	(third entry)
-	(let ((pair (assoc label *sharp-sharp-alist*)))
-	  (unless pair
-	    (%reader-error stream "Object is not labelled #~S#" label))
-	  (cdr pair)))))
-
+  (maybe-create-tables)
+  ;; Don't read ANSI "2.4.8.15 Sharpsign Equal-Sign" and worry that it requires
+  ;; you to implement forward references, because forward references are
+  ;; disallowed in "2.4.8.16 Sharpsign Sharpsign".
+  (multiple-value-bind (finalized-object successp)
+      (gethash label *sharp-equal-final-table*)
+    (if successp
+	finalized-object
+	(multiple-value-bind (temporary-tag successp)
+	    (gethash label *sharp-equal-temp-table*)
+	  (if successp
+	      temporary-tag
+	      (%reader-error stream "reference to undefined label #~D#" label))))))
 
 ;;;; #+/-
 
-- 
GitLab