From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 11 Oct 1993 23:31:45 +0000 (+0000)
Subject: Eliminate BTREE data structure, replacing it with RB-TREE
X-Git-Tag: 20090517-FFI~7778
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=58561259e0e6f36ef07d9158842e42bf29e39326;p=mit-scheme.git

Eliminate BTREE data structure, replacing it with RB-TREE
implementation that is built in to the runtime system.  This
replacement improves overall performance by a factor of three.
---

diff --git a/v7/src/cref/conpkg.scm b/v7/src/cref/conpkg.scm
index c1f32cdc3..561596c6a 100644
--- a/v7/src/cref/conpkg.scm
+++ b/v7/src/cref/conpkg.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/conpkg.scm,v 1.3 1991/11/04 20:33:57 cph Exp $
+$Id: conpkg.scm,v 1.4 1993/10/11 23:31:39 cph Exp $
 
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -83,10 +83,10 @@ MIT in each case. |#
 		    ,(package-reference (binding/package source))
 		    ',(binding/name source))))
 	      (binding/links binding)))
-       (btree-fringe (package/bindings package)))))
+       (package/sorted-bindings package))))
 
 (define (package/source-bindings package)
-  (list-transform-positive (btree-fringe (package/bindings package))
+  (list-transform-positive (package/sorted-bindings package)
     (lambda (binding)
       (eq? (binding/source-binding binding) binding))))
 
diff --git a/v7/src/cref/cref.pkg b/v7/src/cref/cref.pkg
index 2a6768d84..79fe17d8e 100644
--- a/v7/src/cref/cref.pkg
+++ b/v7/src/cref/cref.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.pkg,v 1.4 1991/03/01 20:19:34 cph Exp $
+$Id: cref.pkg,v 1.5 1993/10/11 23:31:40 cph Exp $
 
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -48,16 +48,6 @@ MIT in each case. |#
 	  cref/generate-cref-unusual
 	  cref/generate-trivial-constructor))
 
-(define-package (cross-reference balanced-binary-tree)
-  (files "btree")
-  (parent ())
-  (export (cross-reference)
-	  btree-delete!
-	  btree-fringe
-	  btree-insert!
-	  btree-lookup
-	  make-btree))
-
 (define-package (cross-reference analyze-file)
   (files "anfile")
   (parent (cross-reference))
diff --git a/v7/src/cref/cref.sf b/v7/src/cref/cref.sf
index 8237695b9..830dfc721 100644
--- a/v7/src/cref/cref.sf
+++ b/v7/src/cref/cref.sf
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.sf,v 1.5 1992/06/04 03:02:47 mhwu Exp $
+$Id: cref.sf,v 1.6 1993/10/11 23:31:40 cph Exp $
 
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -36,22 +36,15 @@ MIT in each case. |#
 (sf-conditionally "object")
 (sf-directory ".")
 
-;; Before runtime system is built this next thunk is the one
-;; used.
-(with-working-directory-pathname "../cref" ; this is rather useless
-  (lambda ()
-    (if (not (file-exists? "cref.bcon"))
-	(sf "triv.con" "cref.bcon"))
-    (if (not (file-exists? "cref.bldr"))
-	(sf "triv.ldr" "cref.bldr"))))
-
-;; After the runtime system is built, more elaborate work is done
-(with-working-directory-pathname "../cref" ; this is rather useless
-  (lambda ()
-    (if (file-exists? "../runtime/runtim.glob")
-	(begin
-	  (if (not (name->package '(CROSS-REFERENCE)))
-	      (load "make"))
-	  (cref/generate-constructors "cref")
-	  (sf "cref.con" "cref.bcon")
-	  (sf "cref.ldr" "cref.bldr")))))
\ No newline at end of file
+(if (not (file-exists? "cref.bcon"))
+    (sf "triv.con" "cref.bcon"))
+(if (not (file-exists? "cref.bldr"))
+    (sf "triv.ldr" "cref.bldr"))
+
+(if (file-exists? "../runtime/runtim.glob")
+    (begin
+      (if (not (name->package '(CROSS-REFERENCE)))
+	  (load "make"))
+      (cref/generate-constructors "cref")
+      (sf "cref.con" "cref.bcon")
+      (sf "cref.ldr" "cref.bldr")))
\ No newline at end of file
diff --git a/v7/src/cref/forpkg.scm b/v7/src/cref/forpkg.scm
index 7260af8a3..5398036d3 100644
--- a/v7/src/cref/forpkg.scm
+++ b/v7/src/cref/forpkg.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/forpkg.scm,v 1.7 1991/11/04 20:34:03 cph Exp $
+$Id: forpkg.scm,v 1.8 1993/10/11 23:31:41 cph Exp $
 
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -62,7 +62,7 @@ MIT in each case. |#
     (let ((free-references
 	   (append-map! (lambda (package)
 			  (list-transform-negative
-			      (btree-fringe (package/references package))
+			      (package/sorted-references package)
 			    reference/binding))
 			packages)))
       (if (not (null? free-references))
@@ -98,7 +98,7 @@ MIT in each case. |#
 	 (classify-bindings-by-package
 	  (lambda (binding)
 	    (binding/package (binding/source-binding binding)))
-	  (btree-fringe (package/bindings package)))))
+	  (package/sorted-bindings package))))
     (let ((class (assq package classes)))
       (if class
 	  (format-package/bindings port indentation width package (cdr class)))
@@ -157,7 +157,7 @@ MIT in each case. |#
 			    (set! unlinked (cons value-cell unlinked)))
 			   ((not (memq value-cell linked))
 			    (set! linked (cons value-cell linked))))))
-		 (btree-fringe (package/bindings package))))
+		 (package/sorted-bindings package)))
      packages)
     (values unlinked linked)))
 
diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm
index 93abb780d..85ce4f27b 100644
--- a/v7/src/cref/make.scm
+++ b/v7/src/cref/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.8 1991/11/04 20:34:10 cph Exp $
+$Id: make.scm,v 1.9 1993/10/11 23:31:42 cph Exp $
 
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -36,5 +36,6 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
+(load-option 'RB-TREE)
 (package/system-loader "cref" '() false)
-(add-system! (make-system "CREF" 1 8 '()))
\ No newline at end of file
+(add-system! (make-system "CREF" 1 9 '()))
\ No newline at end of file
diff --git a/v7/src/cref/object.scm b/v7/src/cref/object.scm
index d09c26c7b..3a11491ed 100644
--- a/v7/src/cref/object.scm
+++ b/v7/src/cref/object.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: object.scm,v 1.5 1992/12/03 03:13:59 cph Exp $
+$Id: object.scm,v 1.6 1993/10/11 23:31:42 cph Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -71,8 +71,8 @@ MIT in each case. |#
   (initialization false read-only true)
   parent
   (children '())
-  (bindings (make-btree) read-only true)
-  (references (make-btree) read-only true))
+  (bindings (make-rb-tree symbol=? symbol<?) read-only true)
+  (references (make-rb-tree symbol=? symbol<?) read-only true))
 
 (define (make-package name file-cases initialization parent)
   (let ((files
@@ -91,10 +91,14 @@ MIT in each case. |#
 (define-integrable (package/root? package)
   (null? (package/name package)))
 
-(define (package/find-binding package name)
-  (btree-lookup (package/bindings package) symbol<? binding/name name
-    identity-procedure
-    (lambda (name) name false)))
+(define-integrable (package/find-binding package name)
+  (rb-tree/lookup (package/bindings package) name #f))
+
+(define-integrable (package/sorted-bindings package)
+  (rb-tree/datum-list (package/bindings package)))
+
+(define-integrable (package/sorted-references package)
+  (rb-tree/datum-list (package/references package)))
 
 (define-integrable (file-case/type file-case)
   (car file-case))
@@ -179,9 +183,6 @@ MIT in each case. |#
   (expressions '())
   (binding false))
 
-(define-integrable (symbol<? x y)
-  (string<? (symbol->string x) (symbol->string y)))
-
 (define (symbol-list=? x y)
   (if (null? x)
       (null? y)
diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
index 3c67cdfa4..42cf0d533 100644
--- a/v7/src/cref/redpkg.scm
+++ b/v7/src/cref/redpkg.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/redpkg.scm,v 1.4 1991/11/04 20:34:18 cph Exp $
+$Id: redpkg.scm,v 1.5 1993/10/11 23:31:43 cph Exp $
 
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -171,7 +171,7 @@ MIT in each case. |#
 (define (resolve-references! pmodel)
   (for-each (lambda (package)
 	      (for-each resolve-reference!
-			(btree-fringe (package/references package))))
+			(package/sorted-references package)))
 	    (pmodel/packages pmodel)))
 
 (define (resolve-reference! reference)
@@ -377,33 +377,31 @@ MIT in each case. |#
      (cons expression (value-cell/expressions value-cell)))))
 
 (define (link! source-package source-name destination-package destination-name)
+  (if (package/find-binding destination-package destination-name)
+      (error "Attempt to reinsert binding" destination-name))
   (let ((source-binding (intern-binding! source-package source-name)))
-    (make-link source-binding
-	       (btree-insert! (package/bindings destination-package)
-			      symbol<?
-			      binding/name
-			      destination-name
-		 (lambda (destination-name)
-		   (make-binding destination-package
-				 destination-name
-				 (binding/value-cell source-binding)))
-		 (lambda (binding)
-		   binding
-		   (error "Attempt to reinsert binding" destination-name))
-		 identity-procedure))))
+    (let ((destination-binding
+	   (make-binding destination-package
+			 destination-name
+			 (binding/value-cell source-binding))))
+      (rb-tree/insert! (package/bindings destination-package)
+		       destination-name
+		       destination-binding)
+      (make-link source-binding destination-binding))))
 
 (define (intern-binding! package name)
-  (btree-insert! (package/bindings package) symbol<? binding/name name
-    (lambda (name)
-      (let ((value-cell (make-value-cell)))
-	(let ((binding (make-binding package name value-cell)))
-	  (set-value-cell/source-binding! value-cell binding)
-	  binding)))
-    identity-procedure
-    identity-procedure))
+  (or (package/find-binding package name)
+      (let ((binding
+	     (let ((value-cell (make-value-cell)))
+	       (let ((binding (make-binding package name value-cell)))
+		 (set-value-cell/source-binding! value-cell binding)
+		 binding))))
+	(rb-tree/insert! (package/bindings package) name binding)
+	binding)))
 
 (define (make-reference package name expression)
-  (let ((add-reference!
+  (let ((references (package/references package))
+	(add-reference!
 	 (lambda (reference)
 	   (set-reference/expressions!
 	    reference
@@ -411,13 +409,13 @@ MIT in each case. |#
 	   (set-expression/references!
 	    expression
 	    (cons reference (expression/references expression))))))
-    (btree-insert! (package/references package) symbol<? reference/name name
-      (lambda (name)
-	(%make-reference package name))
-      (lambda (reference)
-	(if (not (memq expression (reference/expressions reference)))
-	    (add-reference! reference))
-	reference)
-      (lambda (reference)
-	(add-reference! reference)
-	reference))))
\ No newline at end of file
+    (let ((reference (rb-tree/lookup references name #f)))
+      (if reference
+	  (begin
+	    (if (not (memq expression (reference/expressions reference)))
+		(add-reference! reference))
+	    reference)
+	  (let ((reference (%make-reference package name)))
+	    (rb-tree/insert! references name reference)
+	    (add-reference! reference)
+	    reference)))))
\ No newline at end of file
diff --git a/v7/src/cref/toplev.scm b/v7/src/cref/toplev.scm
index 7bc706f5e..88b618924 100644
--- a/v7/src/cref/toplev.scm
+++ b/v7/src/cref/toplev.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/toplev.scm,v 1.5 1991/11/04 20:34:26 cph Exp $
+$Id: toplev.scm,v 1.6 1993/10/11 23:31:44 cph Exp $
 
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -109,7 +109,6 @@ MIT in each case. |#
 (define (write-globals pathname pmodel)
   (fasdump (map binding/name
 		(list-transform-positive
-		    (btree-fringe
-		     (package/bindings (pmodel/root-package pmodel)))
+		    (package/sorted-bindings (pmodel/root-package pmodel))
 		  binding/source-binding))
 	   (pathname-new-type pathname "glob")))
\ No newline at end of file
diff --git a/v7/src/cref/triv.con b/v7/src/cref/triv.con
index 465c4cec9..297729a68 100644
--- a/v7/src/cref/triv.con
+++ b/v7/src/cref/triv.con
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/Attic/triv.con,v 1.3 1991/06/06 21:37:19 cph Exp $
+$Id: triv.con,v 1.4 1993/10/11 23:31:44 cph Exp $
 
-Copyright (c) 1989-91 Massachusetts Institute of Technology
+Copyright (c) 1989-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -54,24 +54,6 @@ MIT in each case. |#
   (environment-link-name destination source 'cref/generate-cref-unusual)
   (environment-link-name destination source 'cref/generate-trivial-constructor))
 
-(package/add-child!
- (find-package '(cross-reference))
- 'balanced-binary-tree
- (in-package (package/environment (find-package '(cross-reference)))
-   (let ((btree-delete!)
-	 (btree-fringe)
-	 (btree-insert!)
-	 (btree-lookup)
-	 (make-btree))
-     (the-environment))))
-(let ((source (package/environment (find-package '(cross-reference balanced-binary-tree))))
-      (destination (package/environment (find-package '(cross-reference)))))
-  (environment-link-name destination source 'btree-delete!)
-  (environment-link-name destination source 'btree-fringe)
-  (environment-link-name destination source 'btree-insert!)
-  (environment-link-name destination source 'btree-lookup)
-  (environment-link-name destination source 'make-btree))
-
 (package/add-child!
  (find-package '(cross-reference))
  'analyze-file
diff --git a/v7/src/cref/triv.ldr b/v7/src/cref/triv.ldr
index 3f8e7bf71..f5c200abe 100644
--- a/v7/src/cref/triv.ldr
+++ b/v7/src/cref/triv.ldr
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/Attic/triv.ldr,v 1.2 1993/08/28 23:30:13 gjr Exp $
+$Id: triv.ldr,v 1.3 1993/10/11 23:31:45 cph Exp $
 
-Copyright (c) 1989 Massachusetts Institute of Technology
+Copyright (c) 1989-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -35,16 +35,13 @@ MIT in each case. |#
 ;;;; "Trivial" loader needed to bootstrap cref.
 
 (declare (usual-integrations))
-
+
 (lambda (load alist)
   alist
   (let ((env (package/environment (find-package '(cross-reference)))))
     (load "mset" env)
     (load "object" env)
     (load "toplev" env))
-  (load "btree"
-	(package/environment
-	 (find-package '(cross-reference balanced-binary-tree))))
   (load "anfile"
 	(package/environment (find-package '(cross-reference analyze-file))))
   (load "conpkg"