From c0371902e9c5a360bb016d43308011c9ce1aa998 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 18 Dec 1986 06:12:29 +0000 Subject: [PATCH] Change names of set operations to indicate whether they use `eq?' or `eqv?' to determine membership. Eliminate multiple copies of various such operations. --- v7/src/compiler/back/lapgn1.scm | 6 +- v7/src/compiler/back/regmap.scm | 16 ++--- v7/src/compiler/base/utils.scm | 103 +++++++++++++++++++++----------- 3 files changed, 79 insertions(+), 46 deletions(-) diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index 061fb0aec..1ec29f8e9 100644 --- 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)))) (define *next-constant*) (define *interned-constants*) diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm index 92741f670..9e5583bf7 100644 --- 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)) ;;;; 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) (define (output-loop map entries) diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index 7e534c43e..eb4499b9a 100644 --- 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 @@ ;;;; 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))))) + +;;; 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)) ;;;; SCode Interface -- 2.25.1