From: Chris Hanson Date: Thu, 19 Mar 1987 00:49:12 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~13667 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b8216b058e1b8727d7113ace434e667ad50c8217;p=mit-scheme.git Initial revision --- diff --git a/v7/src/compiler/base/object.scm b/v7/src/compiler/base/object.scm new file mode 100644 index 000000000..bfdd98611 --- /dev/null +++ b/v7/src/compiler/base/object.scm @@ -0,0 +1,130 @@ +#| -*-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)) + +(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))) + +(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 diff --git a/v7/src/compiler/base/sets.scm b/v7/src/compiler/base/sets.scm new file mode 100644 index 000000000..2d3340ff5 --- /dev/null +++ b/v7/src/compiler/base/sets.scm @@ -0,0 +1,121 @@ +#| -*-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)) + +(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)) + +;;; 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 diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm new file mode 100644 index 000000000..6c6e81af2 --- /dev/null +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -0,0 +1,110 @@ +#| -*-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)) + +(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)) + +(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 diff --git a/v7/src/compiler/rtlbase/rtlcfg.scm b/v7/src/compiler/rtlbase/rtlcfg.scm new file mode 100644 index 000000000..26cbbc334 --- /dev/null +++ b/v7/src/compiler/rtlbase/rtlcfg.scm @@ -0,0 +1,82 @@ +#| -*-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)) + +;;; 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 diff --git a/v7/src/compiler/rtlbase/rtlreg.scm b/v7/src/compiler/rtlbase/rtlreg.scm new file mode 100644 index 000000000..c5f701b7e --- /dev/null +++ b/v7/src/compiler/rtlbase/rtlreg.scm @@ -0,0 +1,66 @@ +#| -*-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)) + +(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 diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm new file mode 100644 index 000000000..4f9f9785a --- /dev/null +++ b/v7/src/compiler/rtlbase/rtlty1.scm @@ -0,0 +1,173 @@ +#| -*-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)) + +(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) + +;;;; 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)) + +;;; 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 diff --git a/v7/src/compiler/rtlopt/rcseep.scm b/v7/src/compiler/rtlopt/rcseep.scm new file mode 100644 index 000000000..4642e74b6 --- /dev/null +++ b/v7/src/compiler/rtlopt/rcseep.scm @@ -0,0 +1,104 @@ +#| -*-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)) + +(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)) + +(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 diff --git a/v7/src/compiler/rtlopt/rcseht.scm b/v7/src/compiler/rtlopt/rcseht.scm new file mode 100644 index 000000000..570313df9 --- /dev/null +++ b/v7/src/compiler/rtlopt/rcseht.scm @@ -0,0 +1,173 @@ +#| -*-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)) + +(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)) + +(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)) + +(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))))))) + +(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 diff --git a/v7/src/compiler/rtlopt/rcserq.scm b/v7/src/compiler/rtlopt/rcserq.scm new file mode 100644 index 000000000..84d960f3f --- /dev/null +++ b/v7/src/compiler/rtlopt/rcserq.scm @@ -0,0 +1,67 @@ +#| -*-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)) + +(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 diff --git a/v7/src/compiler/rtlopt/rcsesr.scm b/v7/src/compiler/rtlopt/rcsesr.scm new file mode 100644 index 000000000..0871bb7e6 --- /dev/null +++ b/v7/src/compiler/rtlopt/rcsesr.scm @@ -0,0 +1,84 @@ +#| -*-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)) + +(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