--- /dev/null
+#| -*-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))
+\f
+(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))))
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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)))
+\f
+(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)))))))
+\f
+;;;; 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)))))))))
+\f
+;;;; 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
projects / mit-scheme.git / commitdiff