From: Mark Friedman <edu/mit/csail/zurich/markf>
Date: Fri, 21 Apr 1989 18:54:53 +0000 (+0000)
Subject: Support for passing arguments in registers.
X-Git-Tag: 20090517-FFI~12144
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=88b7071419f0110e6ae89e1e1c18212aa05e933a;p=mit-scheme.git

Support for passing arguments in registers.
---

diff --git a/v7/src/compiler/fgopt/delint.scm b/v7/src/compiler/fgopt/delint.scm
new file mode 100644
index 000000000..50dc260e2
--- /dev/null
+++ b/v7/src/compiler/fgopt/delint.scm
@@ -0,0 +1,111 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/delint.scm,v 1.1 1989/04/21 18:54:53 markf 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. |#
+
+;;;; Delete intergrated parameters
+
+(define (delete-integrated-parameters blocks)
+  (for-each
+   (lambda (block)
+     (if (stack-block? block)
+	 (delete-integrated-parameters! block)))
+   blocks))
+
+(define (delete-integrated-parameters! block)
+  (let ((deletions '())
+	(procedure (block-procedure block)))
+    (if (procedure-interface-optimizible? procedure)
+	(begin
+	  (let ((delete-integrations
+		 (lambda (get-names set-names!)
+		   (with-values
+		       (lambda ()
+			 (find-integrated-variables (get-names procedure)))
+		     (lambda (not-integrated integrated)
+		       (if (not (null? integrated))
+			   (begin
+			     (set-names! procedure not-integrated)
+			     (set! deletions
+				   (eq-set-union deletions integrated)))))))))
+	    (delete-integrations (lambda (procedure)
+				   (cdr (procedure-required procedure)))
+				 (lambda (procedure required)
+				   (set-cdr! (procedure-required procedure)
+					     required)))
+	    (delete-integrations procedure-optional set-procedure-optional!))
+	  (let ((rest (procedure-rest procedure)))
+	    (if (and rest (lvalue-integrated? rest))
+		(begin (set! deletions (eq-set-adjoin deletions rest))
+		       (set-procedure-rest! procedure false))))))
+    (with-values
+	(lambda ()
+	  (find-integrated-bindings (procedure-names procedure)
+				    (procedure-values procedure)))
+      (lambda (names vals integrated)
+	(set-procedure-names! procedure names)
+	(set-procedure-values! procedure vals)
+	(set! deletions (eq-set-union deletions integrated))))
+    (if (not (null? deletions))
+	(set-block-bound-variables!
+	 block
+	 (eq-set-difference (block-bound-variables block) deletions)))))
+
+(define (find-integrated-bindings names vals)
+  (if (null? names)
+      (values '() '() '())
+      (with-values
+	  (lambda ()
+	    (find-integrated-bindings (cdr names) (cdr vals)))
+	(lambda (names* values* integrated)
+	  (if (lvalue-integrated? (car names))
+	      (values names* values* (cons (car names) integrated))
+	      (values (cons (car names) names*)
+		      (cons (car vals) values*)
+		      integrated))))))
+
+(define (find-integrated-variables variables)
+  (if (null? variables)
+      (values '() '())
+      (with-values
+	  (lambda ()
+	    (find-integrated-variables (cdr variables)))
+	(lambda (not-integrated integrated)
+	  (if (or (variable-register (car variables))
+		  (lvalue-integrated? (car variables)))
+	      (values not-integrated
+		      (cons (car variables) integrated))
+	      (values (cons (car variables) not-integrated)
+		      integrated))))))
+
+
+