Change names of set operations to indicate whether they use `eq?' or

`eqv?' to determine membership.  Eliminate multiple copies of various
such operations.

diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm
index 061fb0aec37e54b5eb41132c59ae28912d442190..1ec29f8e9af9139949b42f6216537ef7a99732a3 100644 (file)
--- a/v7/src/compiler/back/lapgn1.scm
+++ b/v7/src/compiler/back/lapgn1.scm
@@ -37,7 +37,7 @@
 
 ;;;; LAP Code Generation
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.18 1986/12/15 05:26:52 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.19 1986/12/18 06:10:31 cph Exp $
 
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
@@ -261,7 +261,7 @@
 
 (define (delete-machine-register! register)
   (set! *register-map* (delete-machine-register *register-map* register))
-  (set! *needed-registers* (set-delete *needed-registers* register)))
+  (set! *needed-registers* (eqv-set-delete *needed-registers* register)))
 
 (package (delete-pseudo-register! delete-dead-registers!)
   (define-export (delete-pseudo-register! register)
@@ -271,7 +271,7 @@
     (set! *dead-registers* '()))
   (define (delete-registers! map aliases)
     (set! *register-map* map)
-    (set! *needed-registers* (set-difference *needed-registers* aliases))))
+    (set! *needed-registers* (eqv-set-difference *needed-registers* aliases))))
 \f
 (define *next-constant*)
 (define *interned-constants*)

diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm
index 92741f670fe592113451428832826c2fbd4a5334..9e5583bf7cc5473437cc8ab8918d56bf7233b615 100644 (file)
--- a/v7/src/compiler/back/regmap.scm
+++ b/v7/src/compiler/back/regmap.scm
@@ -37,7 +37,7 @@
 
 ;;;; Register Allocator
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 1.85 1986/12/15 05:27:32 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 1.86 1986/12/18 06:10:51 cph Exp $
 
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
@@ -152,13 +152,13 @@ REGISTER-RENUMBERs are equal.
   (cons entry (map-entries map)))
 
 (define-integrable (map-entries:delete map entry)
-  (set-delete (map-entries map) entry))
+  (eq-set-delete (map-entries map) entry))
 
 (define-integrable (map-entries:delete* map entries)
-  (set-difference (map-entries map) entries))
+  (eq-set-difference (map-entries map) entries))
 
 (define-integrable (map-entries:replace map old new)
-  (set-substitute (map-entries map) old new))
+  (eq-set-substitute (map-entries map) old new))
 
 (define-integrable (map-registers:add map register)
   (sort-machine-registers (cons register (map-registers map))))
@@ -167,7 +167,7 @@ REGISTER-RENUMBERs are equal.
   (sort-machine-registers (append registers (map-registers map))))
 
 (define-integrable (map-registers:delete map register)
-  (set-delete (map-registers map) register))
+  (eqv-set-delete (map-registers map) register))
 \f
 ;;;; Map Entry
 
@@ -197,7 +197,7 @@ REGISTER-RENUMBERs are equal.
 (define (map-entry:delete-alias entry alias)
   (make-map-entry (map-entry-home entry)
                  (map-entry-saved-into-home? entry)
-                 (set-delete (map-entry-aliases entry) alias)))
+                 (eq-set-delete (map-entry-aliases entry) alias)))
 
 (define (map-entry=? entry entry*)
   (and (map-entry-home entry)
@@ -513,8 +513,8 @@ REGISTER-RENUMBERs are equal.
                (append! (register->register-transfer (car input-aliases)
                                                      (car output-aliases))
                         (loop (cdr output-aliases)))))
-         (loop (set-difference (map-entry-aliases (cdar entries))
-                               input-aliases)))))
+         (loop (eqv-set-difference (map-entry-aliases (cdar entries))
+                                   input-aliases)))))
   loop)
 \f
 (define (output-loop map entries)

diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm
index 7e534c43e2c08fe0258544cde80ee45d65718cbe..eb4499b9a738891103dc52e2a803d781fdbad526 100644 (file)
--- a/v7/src/compiler/base/utils.scm
+++ b/v7/src/compiler/base/utils.scm
@@ -37,7 +37,7 @@
 
 ;;;; Compiler Utilities
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.75 1986/12/17 08:02:18 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.76 1986/12/18 06:12:29 cph Exp $
 
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
@@ -227,29 +227,42 @@
 \f
 ;;;; Set Operations
 
-(define (set-adjoin element set)
+(define (eq-set-adjoin element set)
   (if (memq element set)
       set
       (cons element set)))
 
-(define (set-delete set item)
+(define (eqv-set-adjoin element set)
+  (if (memv element set)
+      set
+      (cons element set)))
+
+(define (eq-set-delete set item)
+  (define (loop set)
+    (cond ((null? set) '())
+         ((eq? (car set) item) (cdr set))
+         (else (cons (car set) (loop (cdr set))))))
+  (loop set))
+
+(define (eqv-set-delete set item)
   (define (loop set)
-    (cond ((null? set)
-          '())
-         ((eq? (car set) item)
-          (cdr set))
-         (else
-          (cons (car set) (loop (cdr set))))))
+    (cond ((null? set) '())
+         ((eqv? (car set) item) (cdr set))
+         (else (cons (car set) (loop (cdr set))))))
   (loop set))
 
-(define (set-substitute set old new)
+(define (eq-set-substitute set old new)
   (define (loop set)
-    (cond ((null? set)
-          (error "SET-SUBSTITUTE: Missing item" old))
-         ((eq? (car set) old)
-          (cons new (cdr set)))
-         (else
-          (cons (car set) (loop (cdr set))))))
+    (cond ((null? set) '())
+         ((eq? (car set) old) (cons new (cdr set)))
+         (else (cons (car set) (loop (cdr set))))))
+  (loop set))
+
+(define (eqv-set-substitute set old new)
+  (define (loop set)
+    (cond ((null? set) '())
+         ((eqv? (car set) old) (cons new (cdr set)))
+         (else (cons (car set) (loop (cdr set))))))
   (loop set))
 
 (define (set-search set procedure)
@@ -258,25 +271,45 @@
         (or (procedure (car items))
             (loop (cdr items)))))
   (loop set))
-
-(define set-union
-  (let ()
-    (define (loop x y)
-      (if (null? x)
-         y
-         (loop (cdr x)
-               (if (memq (car x) y)
-                   y
-                   (cons (car x) y)))))
-    (named-lambda (set-union x y)
-      (if (null? y)
-         x
-         (loop x y)))))
-
-(define (set-difference set1 set2)
-  (cond ((null? set1) '())
-       ((memq (car set1) set2) (set-difference (cdr set1) set2))
-       (else (cons (car set1) (set-difference (cdr set1) set2)))))
+\f
+;;; The dataflow analyzer assumes that
+;;; (eq? (list-tail (eq-set-union x y) n) y) for some n.
+
+(define (eq-set-union x y)
+  (if (null? y)
+      x
+      (let loop ((x x) (y y))
+       (if (null? x)
+           y
+           (loop (cdr x)
+                 (if (memq (car x) y)
+                     y
+                     (cons (car x) y)))))))
+
+(define (eqv-set-union x y)
+  (if (null? y)
+      x
+      (let loop ((x x) (y y))
+       (if (null? x)
+           y
+           (loop (cdr x)
+                 (if (memv (car x) y)
+                     y
+                     (cons (car x) y)))))))
+
+(define (eq-set-difference x y)
+  (define (loop x)
+    (cond ((null? x) '())
+         ((memq (car x) y) (loop (cdr x)))
+         (else (cons (car x) (loop (cdr x))))))
+  (loop x))
+
+(define (eqv-set-difference x y)
+  (define (loop x)
+    (cond ((null? x) '())
+         ((memv (car x) y) (loop (cdr x)))
+         (else (cons (car x) (loop (cdr x))))))
+  (loop x))
 \f
 ;;;; SCode Interface