From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 26 Apr 1989 05:11:29 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~12108
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0e7d6929b67ef62cd6e82b79450ac0bfcd63a164;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/compiler/base/constr.scm b/v7/src/compiler/base/constr.scm
new file mode 100644
index 000000000..348285321
--- /dev/null
+++ b/v7/src/compiler/base/constr.scm
@@ -0,0 +1,273 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/constr.scm,v 1.1 1989/04/26 05:11:06 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. |#
+
+;;; Procedures for managing a set of ordering constraints
+
+(define-structure (constraint
+		   (conc-name constraint/)
+		   (constructor
+		    &make-constraint (element)))
+  (element false read-only true)
+  (graph-head false)
+  (afters '())
+  (generation)
+  (closed? true))
+
+(define-structure (constraint-graph
+		   (conc-name constraint-graph/)
+		   (constructor make-constraint-graph ()))
+  (entry-nodes '())
+  (closed? true))
+
+(define (make-constraint element #!optional graph-head afters)
+  (let ((constraint (&make-constraint element)))
+    (if (and (not (default-object? graph-head))
+	     (constraint-graph? graph-head))
+	(begin
+	  (set-constraint/graph-head! constraint graph-head)
+	  (set-constraint-graph/entry-nodes!
+	   graph-head
+	   (cons constraint (constraint-graph/entry-nodes graph-head)))))
+    (if (not (default-object? afters))
+	(for-each
+	 (lambda (after) (constraint-add! constraint after))
+	 afters))
+    constraint))
+
+(define (find-constraint element graph-head)
+
+  (define (loop children)
+    (if (pair? children)
+	(or (search (car children))
+	    (loop (cdr children)))
+	false))
+
+  (define (search constraint)
+    (if (eqv? element (constraint/element constraint))
+	constraint
+	(loop (constraint/afters constraint))))
+  
+  (loop (constraint-graph/entry-nodes graph-head)))
+
+(define (find-or-make-constraint element graph-head
+				 #!optional afters)
+  (or (find-constraint element graph-head)
+      (if (default-object? afters)
+	  (make-constraint element graph-head)
+	  (make-constraint element graph-head afters))))
+          
+
+(define (constraint-add! before after)
+  (if (eq? (constraint/element before) (constraint/element after))
+      (error "A node cannot be constrained to come after itself" after))
+  (set-constraint/afters! before (cons after (constraint/afters before)))
+  (let ((c-graph (constraint/graph-head after)))
+    (if c-graph
+	(set-constraint-graph/entry-nodes! 
+	 c-graph
+	 (delq! after (constraint-graph/entry-nodes c-graph)))))
+  (set-constraint/closed?! before false)
+  (if (constraint/graph-head before)
+      (set-constraint-graph/closed?!
+       (constraint/graph-head before)
+       false)))
+
+(define (add-constraint-element! before-element after-element
+				 graph-head)
+  (find-or-make-constraint
+   before-element
+   graph-head
+   (list after-element)))
+
+(define (add-constraint-set! befores afters graph-head)
+  (let ((after-constraints
+	 (map (lambda (after)
+		(find-or-make-constraint after graph-head))
+	      afters)))
+    (for-each
+     (lambda (before)
+       (find-or-make-constraint before graph-head after-constraints))
+     befores)))
+
+(define (close-constraint-graph! c-graph)
+  (with-new-constraint-marks
+   (lambda ()
+     (for-each close-constraint-node!
+	       (constraint-graph/entry-nodes c-graph))))
+  (set-constraint-graph/closed?! c-graph true))
+
+(define (close-constraint-node! node)
+  (with-new-constraint-marks
+   (lambda ()
+     (&close-constraint-node! node))))
+
+(define (&close-constraint-node! node)
+  (transitively-close-dag!
+   node
+   constraint/afters
+   (lambda (before afters)
+     (set-constraint/afters!
+      before
+      (append
+       (constraint/afters before)
+       (if (memq node afters)
+	   (error
+	    "Illegal cycle in constraint graph involving node:"
+	    node)
+	   afters))))
+   constraint-marked?
+   (lambda (node)
+     (constraint-mark! node)
+     (set-constraint/closed?! node true))))
+
+(define (transitively-close-dag! node select update! marked? mark!)
+  (let transitively-close*! ((node node))
+    (let ((elements (select node)))
+      (if (or (null? elements) (marked? node))
+	  elements
+	  (begin
+	    (mark! node)
+	    (update! node (safe-mapcan transitively-close*! elements))
+	    (select node))))))
+
+(define-integrable (safe-mapcan procedure list)
+  (mapcan (lambda (item) (list-copy (procedure item))) list))
+
+(define (order-per-constraints elements constraint-graph)
+  (order-per-constraints/extracted
+   elements
+   constraint-graph
+   identity-procedure))
+
+(define (order-per-constraints/extracted things
+					 constraint-graph
+					 element-extractor)
+;;; This orders a set of things according to the constraints where the
+;;; things are not elements of the constraint-graph nodes but elements
+;;; can be extracted from the things by element-extractor
+  (let loop ((linearized-constraints
+	      (reverse-postorder
+	       (constraint-graph/entry-nodes constraint-graph)
+	       constraint/afters
+	       with-new-constraint-marks
+	       constraint-mark!
+	       constraint-marked?))
+	     (things things)
+	     (result '()))
+    (if (and (pair? linearized-constraints)
+	     (pair? things))
+	(let ((match (list-search-positive
+			 things
+		       (lambda (thing)
+			 (eqv?
+			  (constraint/element
+			   (car linearized-constraints))
+			  (element-extractor thing))))))
+	  (loop (cdr linearized-constraints)
+		(delv match things)
+		(if (and match
+			 (not (memv match result)))
+		    (cons match result)
+		    result)))
+	(reverse! result))))
+
+(define (legal-ordering-per-constraints? element-ordering constraint-graph)
+  (let loop ((ordering element-ordering)
+	     (nodes (constraint-graph/entry-nodes constraint-graph)))
+
+    (define (depth-first-search? node)
+      (if (or (null? node) (constraint-marked? node))
+	  false
+	  (begin
+	    (constraint-mark! node)
+	    (if (eq? (constraint/element node) (car ordering))
+		(loop (cdr ordering) (constraint/afters node))
+		(multiple-search? (constraint/afters node))))))
+
+    (define (multiple-search? nodes)
+      (if (null? nodes)
+	  false
+	  (or (depth-first-search? (car nodes))
+	      (multiple-search? (cdr nodes)))))
+
+    (if (null? ordering)
+	true
+	(with-new-constraint-marks
+	 (lambda ()
+	   (multiple-search? nodes))))))
+
+(define (reverse-postorder entry-nodes get-children
+			   with-new-node-marks node-mark!
+			   node-marked?)
+
+  (define result)
+  
+  (define (loop node)
+    (node-mark! node)
+    (for-each next (get-children node))
+    (set! result (cons node result)))
+
+  (define (next node)
+    (and node
+	 (not (node-marked? node))
+	 (loop node)))
+    
+  (define (doit node)
+    (set! result '())
+    (loop node)
+    (reverse! result))
+
+  (with-new-node-marks
+   (lambda ()
+     (mapcan doit entry-nodes))))
+
+(define *constraint-generation*)
+
+(define (with-new-constraint-marks thunk)
+  (fluid-let ((*constraint-generation* (make-constraint-generation)))
+    (thunk)))
+
+(define make-constraint-generation
+  (let ((constraint-generation 0))
+    (named-lambda (make-constraint/generation)
+      (let ((value constraint-generation))
+	(set! constraint-generation (1+ constraint-generation))
+	value))))
+
+(define (constraint-marked? constraint)
+  (eq? (constraint/generation constraint) *constraint-generation*))
+
+(define (constraint-mark! constraint)
+  (set-constraint/generation! constraint *constraint-generation*))
+
diff --git a/v7/src/compiler/rtlopt/rinvex.scm b/v7/src/compiler/rtlopt/rinvex.scm
new file mode 100644
index 000000000..cc84edfe9
--- /dev/null
+++ b/v7/src/compiler/rtlopt/rinvex.scm
@@ -0,0 +1,299 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.1 1989/04/26 05:11:29 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 Invertible Expression Elimination
+
+(declare (usual-integrations))
+
+(define *initial-queue*)
+(define *branch-queue*)
+(define *register-values*)
+
+(define (invertible-expression-elimination rgraphs)
+  (with-new-node-marks (lambda () (for-each walk-rgraph rgraphs))))
+
+(define (walk-rgraph rgraph)
+  (fluid-let ((*current-rgraph* rgraph)
+	      (*initial-queue* (make-queue))
+	      (*branch-queue* '())
+	      (*register-values*
+	       (make-vector (rgraph-n-registers rgraph) false)))
+    (for-each (lambda (edge)
+		(enqueue!/unsafe *initial-queue* (edge-right-node edge)))
+	      (rgraph-initial-edges rgraph))
+    (continue-walk)))
+
+(define (continue-walk)
+  (cond ((not (null? *branch-queue*))
+	 (let ((entry (car *branch-queue*)))
+	   (set! *branch-queue* (cdr *branch-queue*))
+	   (set! *register-values* (car entry))
+	   (walk-bblock (cdr entry))))
+	((not (queue-empty? *initial-queue*))
+	 (vector-fill! *register-values* false)
+	 (walk-bblock (dequeue!/unsafe *initial-queue*)))))
+
+(define (walk-bblock bblock)
+  (let loop ((rinst (bblock-instructions bblock)))
+    (let ((rtl (rinst-rtl rinst)))
+      ((lookup-method (rtl:expression-type rtl)) rtl))
+    (if (rinst-next rinst)
+	(loop (rinst-next rinst))))
+  (node-mark! bblock)
+  (if (sblock? bblock)
+      (let ((next (snode-next bblock)))
+	(if (walk-next? next)
+	    (walk-next next)
+	    (continue-walk)))
+      (let ((consequent (pnode-consequent bblock))
+	    (alternative (pnode-alternative bblock)))
+	(if (walk-next? consequent)
+	    (if (walk-next? alternative)
+		(if (node-previous>1? consequent)
+		    (begin
+		      (enqueue!/unsafe *initial-queue* consequent)
+		      (walk-next alternative))
+		    (begin
+		      (if (node-previous>1? alternative)
+			  (enqueue!/unsafe *initial-queue* alternative)
+			  (set! *branch-queue*
+				(cons (cons (vector-copy *register-values*)
+					    alternative)
+				      *branch-queue*)))
+		      (walk-bblock consequent)))
+		(walk-next consequent))
+	    (if (walk-next? alternative)
+		(walk-next alternative)
+		(continue-walk))))))
+
+(define-integrable (walk-next? bblock)
+  (and bblock (not (node-marked? bblock))))
+
+(define-integrable (walk-next bblock)
+  (if (node-previous>1? bblock) (vector-fill! *register-values* false))
+  (walk-bblock bblock))
+
+(define-integrable (register-value register)
+  (vector-ref *register-values* register))
+
+(define-integrable (set-register-value! register value)
+  (vector-set! *register-values* register value)
+  unspecific)
+
+(define (expression-update! get-expression set-expression! object)
+  (set-expression!
+   object
+   (let loop ((expression (get-expression object)))
+     (if (rtl:register? expression)
+	 expression
+	 (optimize-expression (rtl:map-subexpressions expression loop))))))
+
+(define (optimize-expression expression)
+  (let ((type (rtl:expression-type expression))
+	(fold-unary
+	 (lambda (type)
+	   (let ((subexpression
+		  (canonicalize-subexpression (cadr expression))))
+	     (if (eq? type (rtl:expression-type subexpression))
+		 (cadr subexpression)
+		 expression)))))
+    (let loop ((unary-inversions unary-inversions))
+      (cond ((null? unary-inversions)
+	     expression)
+	    ((eq? type (caar unary-inversions))
+	     (fold-unary (cdar unary-inversions)))
+	    ((eq? type (cdar unary-inversions))
+	     (fold-unary (caar unary-inversions)))
+	    (else
+	     (loop (cdr unary-inversions)))))))
+
+(define unary-inversions
+  '((OBJECT->FIXNUM . FIXNUM->OBJECT)
+    (OBJECT->UNSIGNED-FIXNUM . FIXNUM->OBJECT)
+    (ADDRESS->FIXNUM . FIXNUM->ADDRESS)))
+
+(define (canonicalize-subexpression expression)
+  (or (and (rtl:pseudo-register-expression? expression)
+	   (register-value (rtl:register-number expression)))
+      expression))
+
+(define (define-method type method)
+  (let ((entry (assq type methods)))
+    (if entry
+	(set-cdr! entry method)
+	(set! methods (cons (cons type method) methods))))
+  type)
+
+(define (lookup-method type)
+  (if (eq? type 'ASSIGN)
+      walk/assign
+      (let ((entry (assq type methods)))
+	(if (not entry)
+	    (error "Missing method" type))
+	(cdr entry))))
+
+(define methods
+  '())
+
+(define (walk/assign statement)
+  (expression-update! rtl:assign-expression
+		      rtl:set-assign-expression!
+		      statement)
+  (let ((address (rtl:assign-address statement)))
+    (if (rtl:pseudo-register-expression? address)
+	(set-register-value! (rtl:register-number address)
+			     (rtl:assign-expression statement)))))
+
+(define-method 'INVOCATION:SPECIAL-PRIMITIVE
+  (lambda (statement)
+    statement
+    (for-each-pseudo-register
+     (lambda (register)
+       (set-register-value! register false)))))
+
+(for-each (lambda (type)
+	    (define-method type (lambda (statement) statement unspecific)))
+	  '(CLOSURE-HEADER
+	    CONTINUATION-ENTRY
+	    CONTINUATION-HEADER
+	    IC-PROCEDURE-HEADER
+	    INVOCATION:APPLY
+	    INVOCATION:COMPUTED-JUMP
+	    INVOCATION:COMPUTED-LEXPR
+	    INVOCATION:JUMP
+	    INVOCATION:LEXPR
+	    INVOCATION:PRIMITIVE
+	    INVOCATION:UUO-LINK
+	    OPEN-PROCEDURE-HEADER
+	    OVERFLOW-TEST
+	    POP-RETURN
+	    PROCEDURE-HEADER))
+
+(define (define-one-arg-method type get set)
+  (define-method type
+    (lambda (statement)
+      (expression-update! get set statement))))
+
+(define-one-arg-method 'FIXNUM-PRED-1-ARG
+  rtl:fixnum-pred-1-arg-operand
+  rtl:set-fixnum-pred-1-arg-operand!)
+
+(define-one-arg-method 'TRUE-TEST
+  rtl:true-test-expression
+  rtl:set-true-test-expression!)
+
+(define-one-arg-method 'TYPE-TEST
+  rtl:type-test-expression
+  rtl:set-type-test-expression!)
+
+(define-one-arg-method 'UNASSIGNED-TEST
+  rtl:type-test-expression
+  rtl:set-unassigned-test-expression!)
+
+(define-one-arg-method 'INVOCATION:CACHE-REFERENCE
+  rtl:invocation:cache-reference-name
+  rtl:set-invocation:cache-reference-name!)
+
+(define-one-arg-method 'INVOCATION:LOOKUP
+  rtl:invocation:lookup-environment
+  rtl:set-invocation:lookup-environment!)
+
+(define-one-arg-method 'INVOCATION-PREFIX:MOVE-FRAME-UP
+  rtl:invocation-prefix:move-frame-up-locative
+  rtl:set-invocation-prefix:move-frame-up-locative!)
+
+(define-one-arg-method 'INTERPRETER-CALL:ACCESS
+  rtl:interpreter-call:access-environment
+  rtl:set-interpreter-call:access-environment!)
+
+(define-one-arg-method 'INTERPRETER-CALL:CACHE-REFERENCE
+  rtl:interpreter-call:cache-reference-name
+  rtl:set-interpreter-call:cache-reference-name!)
+
+(define-one-arg-method 'INTERPRETER-CALL:CACHE-UNASSIGNED?
+  rtl:interpreter-call:cache-unassigned?-name
+  rtl:set-interpreter-call:cache-unassigned?-name!)
+
+(define-one-arg-method 'INTERPRETER-CALL:LOOKUP
+  rtl:interpreter-call:lookup-environment
+  rtl:set-interpreter-call:lookup-environment!)
+
+(define-one-arg-method 'INTERPRETER-CALL:UNASSIGNED?
+  rtl:interpreter-call:unassigned?-environment
+  rtl:set-interpreter-call:unassigned?-environment!)
+
+(define-one-arg-method 'INTERPRETER-CALL:UNBOUND?
+  rtl:interpreter-call:unbound?-environment
+  rtl:set-interpreter-call:unbound?-environment!)
+
+(define (define-two-arg-method type get-1 set-1 get-2 set-2)
+  (define-method type
+    (lambda (statement)
+      (expression-update! get-1 set-1 statement)
+      (expression-update! get-2 set-2 statement))))
+
+(define-two-arg-method 'EQ-TEST
+  rtl:eq-test-expression-1
+  rtl:set-eq-test-expression-1!
+  rtl:eq-test-expression-2
+  rtl:set-eq-test-expression-2!)
+
+(define-two-arg-method 'FIXNUM-PRED-2-ARGS
+  rtl:fixnum-pred-2-args-operand-1
+  rtl:set-fixnum-pred-2-args-operand-1!
+  rtl:fixnum-pred-2-args-operand-2
+  rtl:set-fixnum-pred-2-args-operand-2!)
+(define-two-arg-method 'INVOCATION-PREFIX:DYNAMIC-LINK
+  rtl:invocation-prefix:dynamic-link-locative
+  rtl:set-invocation-prefix:dynamic-link-locative!
+  rtl:invocation-prefix:dynamic-link-register
+  rtl:set-invocation-prefix:dynamic-link-register!)
+
+(define-two-arg-method 'INTERPRETER-CALL:CACHE-ASSIGNMENT
+  rtl:interpreter-call:cache-assignment-name
+  rtl:set-interpreter-call:cache-assignment-name!
+  rtl:interpreter-call:cache-assignment-value
+  rtl:set-interpreter-call:cache-assignment-value!)
+
+(define-two-arg-method 'INTERPRETER-CALL:DEFINE
+  rtl:interpreter-call:define-environment
+  rtl:set-interpreter-call:define-environment!
+  rtl:interpreter-call:define-value
+  rtl:set-interpreter-call:define-value!)
+
+(define-two-arg-method 'INTERPRETER-CALL:SET!
+  rtl:interpreter-call:set!-environment
+  rtl:set-interpreter-call:set!-environment!
+  rtl:interpreter-call:set!-value
+  rtl:set-interpreter-call:set!-value!)
\ No newline at end of file