From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 26 Oct 1989 07:40:33 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~11740
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bd9fb2f3ed6da775d0989047184f5a321056f2a5;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/compiler/fgopt/reteqv.scm b/v7/src/compiler/fgopt/reteqv.scm
new file mode 100644
index 000000000..1d5d57f27
--- /dev/null
+++ b/v7/src/compiler/fgopt/reteqv.scm
@@ -0,0 +1,134 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reteqv.scm,v 1.1 1989/10/26 07:40:09 cph Rel $
+
+Copyright (c) 1989 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Return Equivalencing
+
+(declare (usual-integrations))
+
+(define (find-equivalent-returns! lvalues applications)
+  (for-each (lambda (application)
+	      (if (application/return? application)
+		  (set-return/equivalence-class! application '())))
+	    applications)
+  (for-each
+   (lambda (return-class)
+     (for-each
+      (lambda (return)
+	(set-return/equivalence-class! return return-class))
+      return-class))
+   (append-map
+    (lambda (source)
+      (list-transform-positive
+	  (node-equivalence-classes
+	   (gmap
+	    (eq-set-adjoin
+	     source
+	     (list-transform-positive (lvalue-forward-links source)
+	       lvalue/unique-source))
+	    lvalue-applications
+	    eq-set-union)
+	   return=?)
+	(lambda (class)
+	  (not (null? (cdr class))))))
+    (gmap (list-transform-positive lvalues continuation-variable?)
+      lvalue/unique-source
+      (lambda (source sources)
+	(if (and source (not (memq source sources)))
+	    (cons source sources)
+	    sources))))))
+
+(define (gmap items procedure adjoin)
+  (let loop ((items items))
+    (if (null? items)
+	'()
+	(adjoin (procedure (car items))
+		(loop (cdr items))))))
+
+(define (node-equivalence-classes nodes node=?)
+  (with-new-node-marks
+   (lambda ()
+     (let ((classes '()))
+       (for-each (lambda (node)
+		   (if (not (node-marked? node))
+		       (begin
+			 (node-mark! node)
+			 (let ((class
+				(list-search-positive classes
+				  (lambda (class)
+				    (node=? node (car class))))))
+			   (if class
+			       (set-cdr! class (cons node (cdr class)))
+			       (begin
+				 (set! classes (cons (list node) classes))
+				 unspecific))))))
+		 nodes)
+       classes))))
+
+(define (return=? x y)
+  (and (eq? (node/subgraph-color x) (node/subgraph-color y))
+       (let ((operator-x (rvalue-known-value (return/operator x)))
+	     (operator-y (rvalue-known-value (return/operator y)))
+	     (operand=?
+	      (lambda ()
+		(let ((operand-x (rvalue-known-value (return/operand x))))
+		  (and operand-x
+		       (eq? operand-x
+			    (rvalue-known-value (return/operand y))))))))
+	 (if operator-x
+	     (and (eq? operator-x operator-y)
+		  (or (eq? continuation-type/effect
+			   (continuation/type operator-x))
+		      (operand=?)))
+	     (and (not operator-y)
+		  (operand=?))))
+       (let ((x (application-context x))
+	     (y (application-context y)))
+	 (or (eq? x y)
+	     (let ((x (reference-context/block x))
+		   (y (reference-context/block y)))
+	       (let ((limit (block-popping-limit x)))
+		 (and (eq? limit (block-popping-limit y))
+		      (let ((dx (distance-to x limit))
+			    (dy (distance-to y limit)))
+			(and dx dy (= dx dy))))))))))
+
+(define (distance-to x limit)
+  (let loop ((x x))
+    (if (eq? x limit)
+	(block-frame-size x)
+	(let ((parent (block-parent x)))
+	  (and (eq? parent (block-stack-link x))
+	       (let ((rest (loop parent)))
+		 (and rest
+		      (+ rest (block-frame-size x)))))))))
\ No newline at end of file
diff --git a/v7/src/compiler/fgopt/varind.scm b/v7/src/compiler/fgopt/varind.scm
new file mode 100644
index 000000000..d0b2f3084
--- /dev/null
+++ b/v7/src/compiler/fgopt/varind.scm
@@ -0,0 +1,90 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/varind.scm,v 1.1 1989/10/26 07:40:21 cph Exp $
+
+Copyright (c) 1989 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Variable Indirections
+
+(declare (usual-integrations))
+
+(define (initialize-variable-indirections! lvalues)
+  (with-new-lvalue-marks
+   (lambda ()
+     (for-each (lambda (lvalue)
+		 (if (lvalue/variable? lvalue)		     (initialize-variable-indirection! lvalue)))
+	       lvalues))))
+
+(define (initialize-variable-indirection! variable)
+  (if (not (lvalue-marked? variable))
+      (begin
+	(lvalue-mark! variable)
+	(let ((block (variable-block variable)))
+	  (and (not (lvalue-known-value variable))
+	       (null? (variable-assignments variable))
+	       (not (lvalue/source? variable))
+	       (not (block-passed-out? block))
+	       (let ((indirection
+		      (let ((possibility
+			     (let ((links
+				    (lvalue-initial-backward-links variable)))
+			       (and (not (null? links))
+				    (null? (cdr links))
+				    (car links)))))
+			(and possibility
+			     (lvalue/variable? possibility)
+			     (null? (variable-assignments possibility))			     (let ((block* (variable-block possibility)))
+			       (and (not (block-passed-out? block*))
+				    (block-ancestor? block block*)))
+			     (begin
+			       (initialize-variable-indirection! possibility)
+			       (or (variable-indirection possibility)
+				   possibility))))))
+		 (if indirection
+		     (begin
+		       (set-variable-indirection! variable indirection)
+		       (let ((variables
+			      (block-variables-nontransitively-free block)))
+			 (if (not (memq indirection variables))
+			     (set-block-variables-nontransitively-free!
+			      block
+			      (cons indirection variables))))
+		       (let ((block* (variable-block indirection)))
+			 (let loop ((block block))
+			   (let ((variables (block-free-variables block)))
+			     (if (not (memq indirection variables))
+				 (begin
+				   (set-block-free-variables!
+				    block
+				    (cons indirection variables))
+				   (let ((parent (block-parent block)))
+				     (if (not (eq? parent block*))
+					 (loop parent))))))))))))))))
\ No newline at end of file
diff --git a/v7/src/compiler/rtlopt/rtlcsm.scm b/v7/src/compiler/rtlopt/rtlcsm.scm
new file mode 100644
index 000000000..43742a6f9
--- /dev/null
+++ b/v7/src/compiler/rtlopt/rtlcsm.scm
@@ -0,0 +1,319 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rtlcsm.scm,v 1.1 1989/10/26 07:40:33 cph Rel $
+
+Copyright (c) 1989 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Common Suffix Merging
+
+(declare (usual-integrations))
+
+(define (merge-common-suffixes! rgraphs)
+  (for-each merge-suffixes-of-rgraph! rgraphs))
+
+(define (merge-suffixes-of-rgraph! rgraph)
+  (let loop ()
+    (let ((suffix-classes (rgraph-matching-suffixes rgraph)))
+      (if (not (null? suffix-classes))
+	  (begin
+	    ;; Because many of the original bblocks can be discarded
+	    ;; by the merging process, processing of one suffix class
+	    ;; can make the information in the subsequent suffix
+	    ;; classes incorrect.  However, reanalysis will still
+	    ;; reproduce the remaining suffix classes.  So, process
+	    ;; one class and reanalyze before continuing.
+	    (merge-suffixes! rgraph (car suffix-classes))
+	    (loop))))))
+
+(define (merge-suffixes! rgraph suffixes)
+  (with-values
+      (lambda ()
+	(discriminate-items suffixes
+	  (lambda (suffix)
+	    (eq? (cdr suffix) (bblock-instructions (car suffix))))))
+    (lambda (total-suffixes partial-suffixes)
+      (if (not (null? total-suffixes))
+	  (let ((new-bblock (caar total-suffixes)))
+	    (for-each (lambda (suffix)
+			(replace-suffix-block! rgraph suffix new-bblock))
+		      (cdr total-suffixes))
+	    (replace-suffixes! rgraph new-bblock partial-suffixes))
+	  (let ((suffix (car partial-suffixes)))
+	    (split-suffix-block! rgraph suffix)
+	    (replace-suffixes! rgraph (car suffix) (cdr partial-suffixes)))))))
+
+(define (replace-suffixes! rgraph new-bblock partial-suffixes)
+  (for-each (lambda (suffix)
+	      (split-suffix-block! rgraph suffix)
+	      (replace-suffix-block! rgraph suffix new-bblock))
+	    partial-suffixes))
+
+(define (split-suffix-block! rgraph suffix)
+  (let ((old-bblock (car suffix))
+	(instructions (cdr suffix)))
+    (rinst-disconnect-previous! old-bblock instructions)
+    (let ((sblock (make-sblock (bblock-instructions old-bblock))))
+      (node-insert-snode! old-bblock sblock)
+      (add-rgraph-bblock! rgraph sblock))
+    (set-bblock-instructions! old-bblock instructions)))
+
+(define (replace-suffix-block! rgraph suffix new-bblock)
+  (let ((old-bblock (car suffix)))
+    (node-replace-on-right! old-bblock new-bblock)
+    (node-disconnect-on-left! old-bblock)
+    (delete-rgraph-bblock! rgraph old-bblock)))
+
+(define (rgraph-matching-suffixes rgraph)
+  (append-map (lambda (bblock-class)
+		(suffix-classes (initial-bblock-matches bblock-class)))
+	      (rgraph/bblock-classes rgraph)))
+
+(define (rgraph/bblock-classes rgraph)
+  (let ((sblock-classes (list false))
+	(pblock-classes (list false)))
+    (for-each (lambda (bblock)
+		(if (sblock? bblock)
+		    (add-sblock-to-classes! sblock-classes bblock)
+		    (add-pblock-to-classes! pblock-classes bblock)))
+	      (rgraph-bblocks rgraph))
+    (let ((singleton? (lambda (x) (null? (cdr x)))))
+      (append! (list-transform-negative (cdr sblock-classes) singleton?)
+	       (list-transform-negative (cdr pblock-classes) singleton?)))))
+
+(define (add-sblock-to-classes! classes sblock)
+  (let ((next (snode-next sblock)))
+    (let loop ((previous classes) (classes (cdr classes)))
+      (if (null? classes)
+	  (set-cdr! previous (list (list sblock)))
+	  (if (eq? next (snode-next (caar classes)))
+	      (set-car! classes (cons sblock (car classes)))
+	      (loop classes (cdr classes)))))))
+
+(define (add-pblock-to-classes! classes pblock)
+  (let ((consequent (pnode-consequent pblock))
+	(alternative (pnode-alternative pblock)))
+    (let loop ((previous classes) (classes (cdr classes)))
+      (if (null? classes)
+	  (set-cdr! previous (list (list pblock)))
+	  (if (let ((pblock* (caar classes)))
+		(and (eq? consequent (pnode-consequent pblock*))
+		     (eq? alternative (pnode-alternative pblock*))))
+	      (set-car! classes (cons pblock (car classes)))
+	      (loop classes (cdr classes)))))))
+
+(define (initial-bblock-matches bblocks)
+  (let loop ((bblocks bblocks))
+    (if (null? bblocks)
+	'()
+	(let ((entries (find-matching-bblocks (car bblocks) (cdr bblocks))))
+	  (if (null? entries)
+	      (loop (cdr bblocks))
+	      (append! entries (loop (cdr bblocks))))))))
+
+(define (suffix-classes entries)
+  (let ((classes '())
+	(class-member?
+	 (lambda (class suffix)
+	   (list-search-positive class
+	     (lambda (suffix*)
+	       (and (eq? (car suffix) (car suffix*))
+		    (eq? (cdr suffix) (cdr suffix*))))))))
+    (for-each (lambda (entry)
+		(let ((class
+		       (list-search-positive classes
+			 (lambda (class)
+			   (class-member? class (car entry))))))
+		  (if class
+		      (if (not (class-member? class (cdr entry)))
+			  (set-cdr! class (cons (cdr entry) (cdr class))))
+		      (let ((class
+			     (list-search-positive classes
+			       (lambda (class)
+				 (class-member? class (cdr entry))))))
+			(if class
+			    (set-cdr! class (cons (car entry) (cdr class)))
+			    (set! classes
+				  (cons (list (car entry) (cdr entry))
+					classes))))))
+		unspecific)
+	      entries)
+    (map cdr
+	 (sort (map (lambda (class) (cons (rinst-length (cdar class)) class))
+		    classes)
+	       (lambda (x y)
+		 (< (car x) (car y)))))))
+
+;;;; Basic Block Matching
+
+(define (find-matching-bblocks bblock bblocks)
+  (let loop ((bblocks bblocks))
+    (if (null? bblocks)
+	'()
+	(with-values (lambda () (matching-suffixes bblock (car bblocks)))
+	  (lambda (sx sy adjustments)
+	    (if (or (interesting-suffix? bblock sx)
+		    (interesting-suffix? (car bblocks) sy))
+		(begin
+		  (for-each (lambda (adjustment) (adjustment)) adjustments)
+		  (cons (cons (cons bblock sx) (cons (car bblocks) sy))
+			(loop (cdr bblocks))))
+		(loop (cdr bblocks))))))))
+
+(define (interesting-suffix? bblock rinst)
+  (and rinst
+       (or (rinst-next rinst)
+	   (eq? rinst (bblock-instructions bblock))
+	   (and (sblock? bblock)
+		(snode-next bblock))
+	   (let ((rtl (rinst-rtl rinst)))
+	     (let ((type (rtl:expression-type rtl)))
+	       (if (eq? type 'INVOCATION:PRIMITIVE)
+		   (let ((procedure (rtl:invocation:primitive-procedure rtl)))
+		     (and (not (eq? compiled-error-procedure procedure))
+			  (negative? (primitive-procedure-arity procedure))))
+		   (memq type
+			 '(INTERPRETER-CALL:ACCESS
+			   INTERPRETER-CALL:DEFINE
+			   INTERPRETER-CALL:LOOKUP
+			   INTERPRETER-CALL:SET!
+			   INTERPRETER-CALL:UNASSIGNED?
+			   INTERPRETER-CALL:UNBOUND
+			   INTERPRETER-CALL:CACHE-ASSIGNMENT
+			   INTERPRETER-CALL:CACHE-REFERENCE
+			   INTERPRETER-CALL:CACHE-UNASSIGNED?
+			   INVOCATION:COMPUTED-LEXPR
+			   INVOCATION:CACHE-REFERENCE
+			   INVOCATION:LOOKUP))))))))
+
+(define (matching-suffixes x y)
+  (let loop
+      ((rx (bblock-reversed-instructions x))
+       (ry (bblock-reversed-instructions y))
+       (wx false)
+       (wy false)
+       (e '())
+       (adjustments '()))
+    (if (or (null? rx) (null? ry))
+	(values wx wy adjustments)
+	(with-values
+	    (lambda ()
+	      (match-rtl (rinst-rtl (car rx)) (rinst-rtl (car ry)) e))
+	  (lambda (e adjustment)
+	    (if (eq? e 'FAILURE)
+		(values wx wy adjustments)
+		(let ((adjustments
+		       (if adjustment
+			   (cons adjustment adjustments)
+			   adjustments)))
+		  (if (for-all? e (lambda (b) (eqv? (car b) (cdr b))))
+		      (loop (cdr rx) (cdr ry)
+			    (car rx) (car ry)
+			    e adjustments)
+		      (loop (cdr rx) (cdr ry)
+			    wx wy
+			    e adjustments)))))))))
+
+;;;; RTL Instruction Matching
+
+(define (match-rtl x y e)
+  (cond ((not (eq? (rtl:expression-type x) (rtl:expression-type y)))
+	 (values 'FAILURE false))
+	((rtl:assign? x)
+	 (values
+	  (let ((ax (rtl:assign-address x)))
+	    (let ((e (match ax (rtl:assign-address y) e)))
+	      (if (eq? e 'FAILURE)
+		  'FAILURE
+		  (match (rtl:assign-expression x)
+			 (rtl:assign-expression y)
+			 (remove-from-environment!
+			  e
+			  (if (rtl:pseudo-register-expression? ax)
+			      (list (rtl:register-number ax))
+			      '()))))))
+	  false))
+	((and (rtl:invocation? x)
+	      (not (eqv? (rtl:invocation-continuation x)
+			 (rtl:invocation-continuation y))))
+	 (let ((x* (rtl:map-subexpressions x identity-procedure))
+	       (y* (rtl:map-subexpressions y identity-procedure)))
+	   (rtl:set-invocation-continuation! x* false)
+	   (rtl:set-invocation-continuation! y* false)
+	   (values (match x* y* e)
+		   (lambda ()
+		     (rtl:set-invocation-continuation! x false)
+		     (rtl:set-invocation-continuation! y false)))))
+	(else
+	 (values (match x y e) false))))
+
+(define (remove-from-environment! e keys)
+  (if (null? keys)
+      e
+      (remove-from-environment! (del-assv! (car keys) e) (cdr keys))))
+
+(define (match x y e)
+  (cond ((pair? x)
+	 (let ((type (car x)))
+	   (if (and (pair? y) (eq? type (car y)))
+	       (case type
+		 ((CONSTANT)
+		  (if (eqv? (cadr x) (cadr y))
+		      e
+		      'FAILURE))
+		 ((REGISTER)
+		  (let ((rx (cadr x))
+			(ry (cadr y)))
+		    (if (pseudo-register? rx)
+			(if (pseudo-register? ry)
+			    (let ((entry (assv rx e)))
+			      (cond ((not entry) (cons (cons rx ry) e))
+				    ((eqv? (cdr entry) ry) e)
+				    (else 'FAILURE)))
+			    'FAILURE)
+			(if (pseudo-register? ry)
+			    'FAILURE
+			    (if (eqv? rx ry)
+				e
+				'FAILURE)))))
+		 (else
+		  (let loop ((x (cdr x)) (y (cdr y)) (e e))
+		    (cond ((pair? x)
+			   (if (pair? y)
+			       (let ((e (match (car x) (car y) e)))
+				 (if (eq? e 'FAILURE)
+				     'FAILURE
+				     (loop (cdr x) (cdr y) e)))
+			       'FAILURE))
+			  ((eqv? x y) e)
+			  (else 'FAILURE)))))
+	       'FAILURE)))
+	((eqv? x y) e)
+	(else 'FAILURE)))
\ No newline at end of file