--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 1.1 1987/03/19 00:44:29 cph Exp $
+
+Copyright (c) 1987 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. |#
+
+;;;; Support for tagged objects
+
+(declare (usual-integrations))
+\f
+(define (make-vector-tag parent name)
+ (let ((tag (cons '() (or parent vector-tag:object))))
+ (vector-tag-put! tag ':TYPE-NAME name)
+ ((access add-unparser-special-object! unparser-package)
+ tag tagged-vector-unparser)
+ tag))
+
+(define *tagged-vector-unparser-show-hash*
+ true)
+
+(define (tagged-vector-unparser object)
+ (unparse-with-brackets
+ (lambda ()
+ (write-string "LIAR ")
+ (if *tagged-vector-unparser-show-hash*
+ (begin (fluid-let ((*unparser-radix* 10))
+ (write (hash object)))
+ (write-string " ")))
+ (fluid-let ((*unparser-radix* 16))
+ ((vector-method object ':UNPARSE) object)))))
+
+(define (vector-tag-put! tag key value)
+ (let ((entry (assq key (car tag))))
+ (if entry
+ (set-cdr! entry value)
+ (set-car! tag (cons (cons key value) (car tag))))))
+
+(define (vector-tag-get tag key)
+ (define (loop tag)
+ (and (pair? tag)
+ (or (assq key (car tag))
+ (loop (cdr tag)))))
+ (let ((value
+ (or (assq key (car tag))
+ (loop (cdr tag)))))
+ (and value (cdr value))))
+
+(define vector-tag:object
+ (list '()))
+
+(vector-tag-put! vector-tag:object ':TYPE-NAME 'OBJECT)
+
+(define-integrable (vector-tag vector)
+ (vector-ref vector 0))
+
+(define (define-vector-method tag name method)
+ (vector-tag-put! tag name method)
+ name)
+
+(define (vector-tag-method tag name)
+ (or (vector-tag-get tag name)
+ (error "Unbound method" tag name)))
+\f
+(define-integrable (vector-tag-parent-method tag name)
+ (vector-tag-method (cdr tag) name))
+
+(define-integrable (vector-method vector name)
+ (vector-tag-method (vector-tag vector) name))
+
+(define (define-unparser tag unparser)
+ (define-vector-method tag ':UNPARSE unparser))
+
+(define-integrable make-tagged-vector
+ vector)
+
+(define ((tagged-vector-predicate tag) object)
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (eq? tag (vector-tag object))))
+
+(define (tagged-vector-subclass-predicate tag)
+ (define (loop tag*)
+ (or (eq? tag tag*)
+ (and (pair? tag*)
+ (loop (cdr tag*)))))
+ (lambda (object)
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (loop (vector-tag object)))))
+
+(define tagged-vector?
+ (tagged-vector-subclass-predicate vector-tag:object))
+
+(define-unparser vector-tag:object
+ (lambda (object)
+ (write (vector-method object ':TYPE-NAME))))
+
+(define (->tagged-vector object)
+ (or (and (tagged-vector? object) object)
+ (and (integer? object)
+ (let ((object (unhash object)))
+ (and (tagged-vector? object) object)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/sets.scm,v 1.1 1987/03/19 00:44:43 cph Exp $
+
+Copyright (c) 1987 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. |#
+
+;;;; Simple Set Abstraction
+
+(declare (usual-integrations))
+\f
+(define (eq-set-adjoin element set)
+ (if (memq element set)
+ set
+ (cons element set)))
+
+(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) '())
+ ((eqv? (car set) item) (cdr set))
+ (else (cons (car set) (loop (cdr set))))))
+ (loop set))
+
+(define (eq-set-substitute set old new)
+ (define (loop 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)
+ (define (loop items)
+ (and (not (null? items))
+ (or (procedure (car items))
+ (loop (cdr items)))))
+ (loop set))
+\f
+;;; 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))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.1 1987/03/19 00:44:26 cph Exp $
+
+Copyright (c) 1987 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. |#
+
+;;;; Compiler File Dependencies
+
+(declare (usual-integrations))
+\f
+(define (file-dependency/integration/chain filenames)
+ (if (not (null? (cdr filenames)))
+ (begin (file-dependency/integration/make (car filenames) (cdr filenames))
+ (file-dependency/integration/chain (cdr filenames)))))
+
+(define (file-dependency/integration/join filenames dependency)
+ (for-each (lambda (filename)
+ (file-dependency/integration/make filename dependency))
+ filenames))
+
+(define (file-dependency/integration/make filename dependency)
+#|
+ (sf/add-file-declarations! filename `((INTEGRATE-EXTERNAL ,@dependency)))
+|#
+ 'DONE)
+
+(define (filename/append directory . names)
+ (map (lambda (name)
+ (string-append directory "/" name))
+ names))
+
+(define (file-dependency/syntax/join filenames dependency)
+ (for-each (lambda (filename)
+ (sf/set-file-syntax-table! filename dependency))
+ filenames))
+\f
+(define filenames/dependency-chain/base
+ (filename/append "base"
+ "object" "cfg" "ctypes" "dtypes" "bblock" "dfg" "rtltyp"
+ "rtlreg" "rtlcfg" "rtl" "emodel" "rtypes"))
+
+(define filenames/dependency-chain/rcse
+ (filename/append "front-end" "rcseht" "rcserq" "rcsesr" "rcseep" "rcse"))
+
+(define filenames/dependency-group/base
+ (append (filename/append "base" "linear")
+ (filename/append "alpha" "dflow" "graphc")
+ (filename/append "front-end"
+ "ralloc" "rcsesa" "rgcomb" "rlife" "rtlgen")
+ (filename/append "back-end" "lapgen")))
+
+(file-dependency/integration/chain
+ (reverse
+ (append filenames/dependency-chain/base
+ filenames/dependency-chain/rcse)))
+
+(file-dependency/integration/join filenames/dependency-group/base
+ filenames/dependency-chain/base)
+
+(file-dependency/syntax/join
+ (append (filename/append "base"
+ "bblock" "cfg" "ctypes" "dfg" "dtypes" "emodel"
+ "linear" "object" "queue" "rtl" "rtlcfg" "rtlreg"
+ "rtltyp" "rtypes" "sets" "toplev" "utils")
+ (filename/append "alpha" "dflow" "graphc")
+ (filename/append "front-end"
+ "ralloc" "rcse" "rcseep" "rcseht" "rcserq" "rcsesa"
+ "rcsesr" "rgcomb" "rlife" "rtlgen")
+ (filename/append "back-end"
+ "asmmac" "block" "lapgen" "laptop" "regmap" "symtab")
+ (filename/append "machines/bobcat" "insmac" "machin"))
+ compiler-syntax-table)
+
+(file-dependency/syntax/join
+ (append (filename/append "machines/bobcat" "lapgen")
+ (filename/append "machines/spectrum" "lapgen"))
+ lap-generator-syntax-table)
+
+(file-dependency/syntax/join
+ (append (filename/append "machines/bobcat" "instr1" "instr2" "instr3")
+ (filename/append "machines/spectrum" "instrs"))
+ assembler-syntax-table)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 1.1 1987/03/19 00:44:34 cph Exp $
+
+Copyright (c) 1987 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 CFG Nodes
+
+(declare (usual-integrations))
+\f
+;;; Hack to make RNODE-RTL, etc, work on both types of node.
+
+(define-snode rtl-snode)
+(define-pnode rtl-pnode)
+(define-vector-slots rnode 7 rtl dead-registers logical-link register-map lap)
+(define-vector-slots rtl-pnode 12 consequent-lap-generator
+ alternative-lap-generator)
+
+(define-integrable (statement->snode statement)
+ (make-pnode rtl-snode-tag statement '() false false false))
+
+(define-integrable (statement->scfg statement)
+ (snode->scfg (statement->snode statement)))
+
+(define-integrable (predicate->pnode predicate)
+ (make-pnode rtl-pnode-tag predicate '() false false false false false))
+
+(define-integrable (predicate->pcfg predicate)
+ (pnode->pcfg (predicate->pnode predicate)))
+
+(define-integrable (rnode-dead-register? rnode register)
+ (memv register (rnode-dead-registers rnode)))
+
+(let ((rnode-describe
+ (lambda (rnode)
+ `((RNODE-RTL ,(rnode-rtl rnode))
+ (RNODE-DEAD-REGISTERS ,(rnode-dead-registers rnode))
+ (RNODE-LOGICAL-LINK ,(rnode-logical-link rnode))
+ (RNODE-REGISTER-MAP ,(rnode-register-map rnode))
+ (RNODE-LAP ,(rnode-lap rnode))))))
+
+ (define-vector-method rtl-snode-tag ':DESCRIBE
+ (lambda (snode)
+ (append! ((vector-tag-method snode-tag ':DESCRIBE) snode)
+ (rnode-describe snode))))
+
+ (define-vector-method rtl-pnode-tag ':DESCRIBE
+ (lambda (pnode)
+ (append! ((vector-tag-method pnode-tag ':DESCRIBE) pnode)
+ (rnode-describe pnode)
+ `((RTL-PNODE-CONSEQUENT-LAP-GENERATOR
+ ,(rtl-pnode-consequent-lap-generator pnode))
+ (RTL-PNODE-ALTERNATIVE-LAP-GENERATOR
+ ,(rtl-pnode-alternative-lap-generator pnode)))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlreg.scm,v 1.1 1987/03/19 00:44:37 cph Exp $
+
+Copyright (c) 1987 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 Registers
+
+(declare (usual-integrations))
+\f
+(define machine-register-map
+ (make-vector number-of-machine-registers))
+
+(let loop ((n 0))
+ (if (< n number-of-machine-registers)
+ (begin (vector-set! machine-register-map n (%make-register n))
+ (loop (1+ n)))))
+
+(define-integrable (rtl:make-machine-register n)
+ (vector-ref machine-register-map n))
+
+(define *next-pseudo-number*)
+(define *temporary->register-map*)
+
+(define (rtl:make-pseudo-register)
+ (let ((n *next-pseudo-number*))
+ (set! *next-pseudo-number* (1+ *next-pseudo-number*))
+ (%make-register n)))
+
+(define (temporary->register temporary)
+ (let ((entry (assq temporary *temporary->register-map*)))
+ (if entry
+ (cdr entry)
+ (let ((register (rtl:make-pseudo-register)))
+ (set! *temporary->register-map*
+ (cons (cons temporary register)
+ *temporary->register-map*))
+ register))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.1 1987/03/19 00:44:40 cph Exp $
+
+Copyright (c) 1987 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. |#
+
+;;;; Register Transfer Language Type Definitions
+
+(declare (usual-integrations))
+\f
+(define-rtl-expression register % number)
+(define-rtl-expression object->address rtl: register)
+(define-rtl-expression object->datum rtl: register)
+(define-rtl-expression object->type rtl: register)
+(define-rtl-expression offset rtl: register number)
+(define-rtl-expression pre-increment rtl: register number)
+(define-rtl-expression post-increment rtl: register number)
+
+(define-rtl-expression cons-pointer rtl: type datum)
+(define-rtl-expression constant rtl: value)
+(define-rtl-expression entry:continuation rtl: continuation)
+(define-rtl-expression entry:procedure rtl: procedure)
+(define-rtl-expression offset-address rtl: register number)
+(define-rtl-expression unassigned rtl:)
+
+(define-rtl-predicate eq-test % expression-1 expression-2)
+(define-rtl-predicate true-test % expression)
+(define-rtl-predicate type-test % expression type)
+(define-rtl-predicate unassigned-test % expression)
+
+(define-rtl-statement assign % address expression)
+(define-rtl-statement continuation-heap-check rtl: continuation)
+(define-rtl-statement procedure-heap-check rtl: procedure)
+(define-rtl-statement return rtl:)
+(define-rtl-statement setup-closure-lexpr rtl: procedure)
+(define-rtl-statement setup-stack-lexpr rtl: procedure)
+
+(define-rtl-statement interpreter-call:access % environment name)
+(define-rtl-statement interpreter-call:define % environment name value)
+(define-rtl-statement interpreter-call:enclose rtl: size)
+(define-rtl-statement interpreter-call:lookup % environment name)
+(define-rtl-statement interpreter-call:set! % environment name value)
+(define-rtl-statement interpreter-call:unassigned? % environment name)
+(define-rtl-statement interpreter-call:unbound? % environment name)
+
+(define-rtl-statement invocation:apply rtl: pushed prefix continuation)
+(define-rtl-statement invocation:jump % pushed prefix continuation procedure)
+(define-rtl-statement invocation:lexpr rtl: pushed prefix continuation
+ procedure)
+(define-rtl-statement invocation:lookup % pushed prefix continuation
+ environment name)
+(define-rtl-statement invocation:primitive rtl: pushed prefix continuation
+ procedure)
+
+(define-rtl-statement message-sender:value rtl: size)
+(define-rtl-statement message-receiver:closure rtl: size)
+(define-rtl-statement message-receiver:stack rtl: size)
+(define-rtl-statement message-receiver:subproblem rtl: continuation)
+
+(define-integrable rtl:expression-type first)
+(define-integrable rtl:address-register second)
+(define-integrable rtl:address-number third)
+(define-integrable rtl:invocation-pushed second)
+(define-integrable rtl:invocation-prefix third)
+(define-integrable rtl:invocation-continuation fourth)
+(define-integrable rtl:test-expression second)
+\f
+;;;; Locatives
+
+;;; Locatives are used as an intermediate form by the code generator
+;;; to build expressions. Later, when the expressions are inserted
+;;; into statements, any locatives they contain are eliminated by
+;;; "simplifying" them into sequential instructions using pseudo
+;;; registers.
+
+(define-integrable register:environment
+ 'ENVIRONMENT)
+
+(define-integrable register:stack-pointer
+ 'STACK-POINTER)
+
+(define-integrable register:value
+ 'VALUE)
+
+(define-integrable (rtl:interpreter-call-result:access)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:ACCESS))
+
+(define-integrable (rtl:interpreter-call-result:enclose)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:ENCLOSE))
+
+(define-integrable (rtl:interpreter-call-result:lookup)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:LOOKUP))
+
+(define-integrable (rtl:interpreter-call-result:unassigned?)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNASSIGNED?))
+
+(define-integrable (rtl:interpreter-call-result:unbound?)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNBOUND?))
+
+(define (rtl:locative-offset locative offset)
+ (cond ((zero? offset) locative)
+ ((and (pair? locative) (eq? (car locative) 'OFFSET))
+ `(OFFSET ,(cadr locative) ,(+ (caddr locative) offset)))
+ (else `(OFFSET ,locative ,offset))))
+
+;;; Expressions that are used in the intermediate form.
+
+(define-integrable (rtl:make-fetch locative)
+ `(FETCH ,locative))
+
+(define-integrable (rtl:make-address locative)
+ `(ADDRESS ,locative))
+
+(define-integrable (rtl:make-cell-cons expression)
+ `(CELL-CONS ,expression))
+
+(define-integrable (rtl:make-typed-cons:pair type car cdr)
+ `(TYPED-CONS:PAIR ,type ,car ,cdr))
+\f
+;;; Linearizer Support
+
+(define-integrable (rtl:make-jump-statement label)
+ `(JUMP ,label))
+
+(define-integrable (rtl:make-jumpc-statement predicate label)
+ `(JUMPC ,predicate ,label))
+
+(define-integrable (rtl:make-label-statement label)
+ `(LABEL ,label))
+
+(define-integrable (rtl:negate-predicate expression)
+ `(NOT ,expression))
+
+;;; Stack
+
+(define-integrable (stack-locative-offset locative offset)
+ (rtl:locative-offset locative (stack->memory-offset offset)))
+
+(define-integrable (stack-push-address)
+ (rtl:make-pre-increment (interpreter-stack-pointer)
+ (stack->memory-offset -1)))
+
+(define-integrable (stack-pop-address)
+ (rtl:make-post-increment (interpreter-stack-pointer)
+(define-rtl-statement message-receiver:subproblem % continuation)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 1.1 1987/03/19 00:49:01 cph Exp $
+
+Copyright (c) 1987 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 Subexpression Elimination: Expression Predicates
+;;; Based on the GNU C Compiler
+
+(declare (usual-integrations))
+\f
+(define (expression-equivalent? x y validate?)
+ ;; If VALIDATE? is true, assume that Y comes from the hash table and
+ ;; should have its register references validated.
+ (define (loop x y)
+ (let ((type (rtl:expression-type x)))
+ (and (eq? type (rtl:expression-type y))
+ (case type
+ ((REGISTER)
+ (register-equivalent? x y))
+ ((OFFSET)
+ (let ((rx (rtl:offset-register x)))
+ (and (register-equivalent? rx (rtl:offset-register y))
+ (if (interpreter-stack-pointer? rx)
+ (eq? (stack-reference-quantity x)
+ (stack-reference-quantity y))
+ (= (rtl:offset-number x)
+ (rtl:offset-number y))))))
+ (else
+ (rtl:match-subexpressions x y loop))))))
+
+ (define (register-equivalent? x y)
+ (let ((x (rtl:register-number x))
+ (y (rtl:register-number y)))
+ (and (eq? (register-quantity x) (register-quantity y))
+ (or (not validate?)
+ (= (register-in-table y) (register-tick y))))))
+
+ (loop x y))
+
+(define (expression-refers-to? x y)
+ ;; True iff any subexpression of X matches Y.
+ (define (loop x)
+ (or (eq? x y)
+ (if (eq? (rtl:expression-type x) (rtl:expression-type y))
+ (expression-equivalent? x y false)
+ (rtl:any-subexpression? x loop))))
+ (loop x))
+\f
+(define (expression-address-varies? expression)
+ (if (memq (rtl:expression-type expression)
+ '(OFFSET PRE-INCREMENT POST-INCREMENT))
+ (register-expression-varies? (rtl:address-register expression))
+ (rtl:any-subexpression? expression expression-address-varies?)))
+
+(define (expression-varies? expression)
+ ;; This procedure should not be called on a register expression.
+ (let ((type (rtl:expression-type expression)))
+ (or (memq type '(OFFSET PRE-INCREMENT POST-INCREMENT))
+ (if (eq? type 'REGISTER)
+ (register-expression-varies? expression)
+ (rtl:any-subexpression? expression expression-varies?)))))
+
+(define (register-expression-varies? expression)
+ (not (= regnum:regs-pointer (rtl:register-number expression))))
+
+(define (stack-push/pop? expression)
+ (and (pre/post-increment? expression)
+ (interpreter-stack-pointer? (rtl:address-register expression))))
+
+(define (heap-allocate? expression)
+ (and (pre/post-increment? expression)
+ (interpreter-free-pointer? (rtl:address-register expression))))
+
+(define-integrable (pre/post-increment? expression)
+ (loop x))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 1.1 1987/03/19 00:49:04 cph Exp $
+
+Copyright (c) 1987 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 Subexpression Elimination: Hash Table Abstraction
+;;; Based on the GNU C Compiler
+
+(declare (usual-integrations))
+\f
+(define n-buckets 31)
+
+(define (make-hash-table)
+ (make-vector n-buckets false))
+
+(define *hash-table*)
+
+(define-integrable (hash-table-ref hash)
+ (vector-ref *hash-table* hash))
+
+(define-integrable (hash-table-set! hash element)
+ (vector-set! *hash-table* hash element))
+
+(define element-tag (make-vector-tag false 'ELEMENT))
+(define element? (tagged-vector-predicate element-tag))
+
+(define-vector-slots element 1
+ expression cost in-memory?
+ next-hash previous-hash
+ next-value previous-value first-value)
+
+(define (make-element expression)
+ (vector element-tag expression false false false false false false false))
+\f
+(define (hash-table-lookup hash expression)
+ (define (loop element)
+ (and element
+ (if (let ((expression* (element-expression element)))
+ (or (eq? expression expression*)
+ (expression-equivalent? expression expression* true)))
+ element
+ (loop (element-next-hash element)))))
+ (loop (hash-table-ref hash)))
+
+(define (hash-table-insert! hash expression class)
+ (let ((element (make-element expression))
+ (cost (rtl:expression-cost expression)))
+ (set-element-cost! element cost)
+ (let ((next (hash-table-ref hash)))
+ (set-element-next-hash! element next)
+ (if next (set-element-previous-hash! next element)))
+ (hash-table-set! hash element)
+ (cond ((not class)
+ (set-element-first-value! element element))
+ ((< cost (element-cost class))
+ (set-element-next-value! element class)
+ (set-element-previous-value! class element)
+ (let loop ((x element))
+ (if x
+ (begin (set-element-first-value! x element)
+ (loop (element-next-value x))))))
+ (else
+ (set-element-first-value! element class)
+ (let loop ((previous class)
+ (next (element-next-value class)))
+ (cond ((not next)
+ (set-element-next-value! element false)
+ (set-element-next-value! previous element)
+ (set-element-previous-value! element previous))
+ ((<= cost (element-cost next))
+ (set-element-next-value! element next)
+ (set-element-previous-value! next element)
+ (set-element-next-value! previous element)
+ (set-element-previous-value! element previous))
+ (else
+ (loop next (element-next-value next)))))))
+ element))
+\f
+(define (hash-table-delete! hash element)
+ (if element
+ (begin
+ ;; **** Mark this element as removed. [ref crock-1]
+ (set-element-first-value! element false)
+ (let ((next (element-next-value element))
+ (previous (element-previous-value element)))
+ (if next (set-element-previous-value! next previous))
+ (if previous
+ (set-element-next-value! previous next)
+ (let loop ((element next))
+ (if element
+ (begin (set-element-first-value! element next)
+ (loop (element-next-value element)))))))
+ (let ((next (element-next-hash element))
+ (previous (element-previous-hash element)))
+ (if next (set-element-previous-hash! next previous))
+ (if previous
+ (set-element-next-hash! previous next)
+ (hash-table-set! hash next))))))
+
+(define (hash-table-delete-class! predicate)
+ (let table-loop ((i 0))
+ (if (< i n-buckets)
+ (let bucket-loop ((element (hash-table-ref i)))
+ (if element
+ (begin (if (predicate element)
+ (hash-table-delete! i element))
+ (bucket-loop (element-next-hash element)))
+ (table-loop (1+ i)))))))
+\f
+(package (hash-table-copy)
+
+(define *elements*)
+
+(define-export (hash-table-copy table)
+ (fluid-let ((*elements* '()))
+ (vector-map table element-copy)))
+
+(define (element-copy element)
+ (and element
+ (let ((entry (assq element *elements*)))
+ (if entry
+ (cdr entry)
+ (let ((new (make-element (element-expression element))))
+ (set! *elements* (cons (cons element new) *elements*))
+ (set-element-cost! new (element-cost element))
+ (set-element-in-memory?! new (element-in-memory? element))
+ (set-element-next-hash!
+ new
+ (element-copy (element-next-hash element)))
+ (set-element-previous-hash!
+ new
+ (element-copy (element-previous-hash element)))
+ (set-element-next-value!
+ new
+ (element-copy (element-next-value element)))
+ (set-element-previous-value!
+ new
+ (element-copy (element-previous-value element)))
+ (set-element-first-value!
+ new
+ (element-copy (element-first-value element)))
+ new)))))
+
+ (list->vector elements*))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 1.1 1987/03/19 00:49:07 cph Exp $
+
+Copyright (c) 1987 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 Subexpression Elimination: Register/Quantity Abstractions
+;;; Based on the GNU C Compiler
+
+(declare (usual-integrations))
+\f
+(define quantity-tag (make-vector-tag false 'QUANTITY))
+(define quantity? (tagged-vector-predicate quantity-tag))
+(define-vector-slots quantity 1 number first-register last-register)
+
+(define *next-quantity-number*)
+
+(define (generate-quantity-number)
+ (let ((n *next-quantity-number*))
+ (set! *next-quantity-number* (1+ *next-quantity-number*))
+ n))
+
+(define (make-quantity number first-register last-register)
+ (vector quantity-tag number first-register last-register))
+
+(define (new-quantity register)
+ (make-quantity (generate-quantity-number) register register))
+
+(define (quantity-copy quantity)
+ (make-quantity (quantity-number quantity)
+ (quantity-first-register quantity)
+ (quantity-last-register quantity)))
+
+(define-register-references quantity)
+(define-register-references next-equivalent)
+(define-register-references previous-equivalent)
+(define-register-references expression)
+(define-register-references tick)
+(define-register-references in-table)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcsesr.scm,v 1.1 1987/03/19 00:49:12 cph Exp $
+
+Copyright (c) 1987 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 Subexpression Elimination: Stack References
+;;; Based on the GNU C Compiler
+
+(declare (usual-integrations))
+\f
+(define *stack-offset*)
+(define *stack-reference-quantities*)
+
+(define (stack-reference? expression)
+ (and (eq? (rtl:expression-type expression) 'OFFSET)
+ (interpreter-stack-pointer? (rtl:address-register expression))))
+
+(define (stack-reference-quantity expression)
+ (let ((n (+ *stack-offset* (rtl:offset-number expression))))
+ (let ((entry (ass= n *stack-reference-quantities*)))
+ (if entry
+ (cdr entry)
+ (let ((quantity (new-quantity false)))
+ (set! *stack-reference-quantities*
+ (cons (cons n quantity)
+ *stack-reference-quantities*))
+ quantity)))))
+
+(define-integrable (stack-pointer-adjust! offset)
+ (set! *stack-offset* (+ (stack->memory-offset offset) *stack-offset*))
+ (stack-pointer-invalidate!))
+
+(define-integrable (stack-pointer-invalidate!)
+ (register-expression-invalidate! (interpreter-stack-pointer)))
+
+(define-integrable (stack-invalidate!)
+ (set! *stack-reference-quantities* '()))
+
+(define (stack-region-invalidate! start end)
+ (let ((end (+ *stack-offset* end)))
+ (define (loop i quantities)
+ (if (< i end)
+ (loop (1+ i)
+ (del-ass=! i quantities))
+ (set! *stack-reference-quantities* quantities)))
+ (loop (+ *stack-offset* start) *stack-reference-quantities*)))
+
+(define (stack-reference-invalidate! expression)
+ (expression-invalidate! expression)
+ (set! *stack-reference-quantities*
+ (del-ass=! (+ *stack-offset* (rtl:offset-number expression))
+ *stack-reference-quantities*)))
+
+(define ass= (association-procedure = car))
+(define del-ass=! (delete-association-procedure list-deletor! = car))
\ No newline at end of file
projects / mit-scheme.git / commitdiff