From: Chris Hanson Date: Tue, 14 Jun 1988 08:48:58 +0000 (+0000) Subject: First checkin for runtime system version 14. X-Git-Tag: 20090517-FFI~12724 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=631b5e3db5e6dcb21d347ea7ed41e47926594620;p=mit-scheme.git First checkin for runtime system version 14. --- diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm index a912ebf56..0c56140be 100644 --- a/v7/src/compiler/base/blocks.scm +++ b/v7/src/compiler/base/blocks.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.2 1987/12/30 06:57:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.3 1988/06/14 08:31:26 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -100,12 +100,14 @@ from the continuation, and then "glued" into place afterwards. block)) (define-vector-tag-unparser block-tag - (lambda (block) - (write-string "BLOCK") - (let ((procedure (block-procedure block))) - (if (and procedure (rvalue/procedure? procedure)) - (begin (write-string " ") - (write (procedure-label procedure))))))) + (lambda (state block) + ((standard-unparser + "BLOCK" (and (let ((procedure (block-procedure block))) + (and procedure (rvalue/procedure? procedure))) + (lambda (state block) + (unparse-object state + (procedure-label (block-procedure block)))))) + state block))) (define-integrable (rvalue/block? rvalue) (eq? (tagged-vector/tag rvalue) block-tag)) diff --git a/v7/src/compiler/base/contin.scm b/v7/src/compiler/base/contin.scm index 97c582649..48fb75faf 100644 --- a/v7/src/compiler/base/contin.scm +++ b/v7/src/compiler/base/contin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.2 1987/12/30 06:58:17 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.3 1988/06/14 08:31:35 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -40,6 +40,7 @@ MIT in each case. |# ;;; something other than PROCEDURE. (define (make-continuation block continuation type) + continuation (let ((block (make-block block 'CONTINUATION))) (let ((required (list (make-value-variable block)))) (set-block-bound-variables! block required) diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index 5ddf1987a..6bbb04be2 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.2 1987/12/30 06:58:24 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.3 1988/06/14 08:31:42 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -62,16 +62,18 @@ MIT in each case. |# (make-scfg application '()))) (define-vector-tag-unparser application-tag - (lambda (application) - (let ((type (application-type application))) - (cond ((eq? type 'COMBINATION) - (write-string "COMBINATION")) - ((eq? type 'RETURN) - (write-string "RETURN ") - (write (return/operand application))) - (else - (write-string "APPLICATION ") - (write type)))))) + (lambda (state application) + ((case (application-type application) + ((COMBINATION) + (standard-unparser "COMBINATION")) + ((RETURN) + (standard-unparser "RETURN" + (lambda (state return) + (unparse-object state (return/operand return))))) + (else + (standard-unparser "APPLICATION" (lambda (state application) + (unparse-object state (application-type application)))))) + state application))) (define-snode parallel application-node diff --git a/v7/src/compiler/base/debug.scm b/v7/src/compiler/base/debug.scm index 2bb467939..1656ce8f7 100644 --- a/v7/src/compiler/base/debug.scm +++ b/v7/src/compiler/base/debug.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.5 1988/06/03 14:50:41 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.6 1988/06/14 08:31:51 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -93,7 +93,7 @@ MIT in each case. |# (pathname-new-type input-path "brtl"))))) (let ((output-path (let ((default (pathname-new-type input-path "rtl"))) - (if (unassigned? output-path) + (if (default-object? output-path) default (merge-pathnames (->pathname output-path) default))))) (write-instructions @@ -117,9 +117,7 @@ MIT in each case. |# (lambda () (with-output-to-file (pathname-new-type (->pathname filename) "rtl") (lambda () - (for-each show-rtl-instruction - ((access linearize-rtl rtl-generator-package) - *rtl-graphs*))))))) + (for-each show-rtl-instruction (linearize-rtl *rtl-graphs*))))))) (define (show-rtl rtl) (pp-instructions @@ -140,7 +138,7 @@ MIT in each case. |# (define (pp-instructions thunk) (fluid-let ((*show-instruction* pp) - ((access *pp-primitives-by-name* scheme-pretty-printer) false) + (*pp-primitives-by-name* false) (*unparser-radix* 16)) (thunk))) @@ -153,12 +151,10 @@ MIT in each case. |# (newline)) (*show-instruction* rtl)) -(package (show-fg show-fg-node) - (define *procedure-queue*) (define *procedures*) -(define-export (show-fg) +(define (show-fg) (fluid-let ((*procedure-queue* (make-queue)) (*procedures* '())) (write-string "\n---------- Expression ----------") @@ -166,7 +162,7 @@ MIT in each case. |# (with-new-node-marks (lambda () (fg/print-entry-node (expression-entry-node *root-expression*)) - (queue-map! *procedure-queue* + (queue-map!/unsafe *procedure-queue* (lambda (procedure) (if (procedure-continuation? procedure) (write-string "\n\n---------- Continuation ----------") @@ -176,7 +172,7 @@ MIT in each case. |# (write-string "\n\n---------- Blocks ----------") (fg/print-blocks (expression-block *root-expression*)))) -(define-export (show-fg-node node) +(define (show-fg-node node) (fluid-let ((*procedure-queue* false)) (with-new-node-marks (lambda () @@ -240,7 +236,7 @@ MIT in each case. |# (not (memq rvalue *procedures*))) (begin (set! *procedures* (cons rvalue *procedures*)) - (enqueue! *procedure-queue* rvalue)))))) + (enqueue!/unsafe *procedure-queue* rvalue)))))) (define (fg/print-subproblem subproblem) (fg/print-object subproblem) @@ -248,7 +244,4 @@ MIT in each case. |# (fg/print-rvalue (subproblem-continuation subproblem))) (let ((prefix (subproblem-prefix subproblem))) (if (not (cfg-null? prefix)) - (fg/print-node (cfg-entry-node prefix))))) - -;;; end SHOW-FG -) \ No newline at end of file + (fg/print-node (cfg-entry-node prefix))))) \ No newline at end of file diff --git a/v7/src/compiler/base/enumer.scm b/v7/src/compiler/base/enumer.scm index 96cb0032f..624239d4e 100644 --- a/v7/src/compiler/base/enumer.scm +++ b/v7/src/compiler/base/enumer.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/enumer.scm,v 4.1 1987/12/04 20:03:52 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/enumer.scm,v 4.2 1988/06/14 08:32:00 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -46,9 +46,8 @@ MIT in each case. |# (define-structure (enumerand (conc-name enumerand/) (print-procedure - (standard-unparser 'ENUMERAND - (lambda (enumerand) - (write (enumerand/name enumerand)))))) + (standard-unparser "ENUMERAND" (lambda (state enumerand) + (unparse-object state (enumerand/name enumerand)))))) (enumeration false read-only true) (name false read-only true) (index false read-only true)) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index b911f7bd8..cedc1be30 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.5 1988/04/15 02:09:04 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.6 1988/06/14 08:32:14 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -92,9 +92,8 @@ MIT in each case. |# (variable-normal-offset variable))) (define-vector-tag-unparser variable-tag - (lambda (variable) - (write-string "VARIABLE ") - (write (variable-name variable)))) + (standard-unparser "VARIABLE" (lambda (state variable) + (unparse-object state (variable-name variable))))) (define-integrable (lvalue/variable? lvalue) (eq? (tagged-vector/tag lvalue) variable-tag)) diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index a89c77982..5e414f017 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.4 1987/12/31 10:43:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.5 1988/06/14 08:32:22 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,8 +36,38 @@ MIT in each case. |# (declare (usual-integrations)) +(define (initialize-package!) + (for-each (lambda (entry) + (syntax-table-define compiler-syntax-table (car entry) + (cadr entry))) + `((CFG-NODE-CASE ,transform/cfg-node-case) + (DEFINE-ENUMERATION ,transform/define-enumeration) + (DEFINE-EXPORT ,transform/define-export) + (DEFINE-LVALUE ,transform/define-lvalue) + (DEFINE-PNODE ,transform/define-pnode) + (DEFINE-ROOT-TYPE ,transform/define-root-type) + (DEFINE-RTL-EXPRESSION ,transform/define-rtl-expression) + (DEFINE-RTL-PREDICATE ,transform/define-rtl-predicate) + (DEFINE-RTL-STATEMENT ,transform/define-rtl-statement) + (DEFINE-RULE ,transform/define-rule) + (DEFINE-RVALUE ,transform/define-rvalue) + (DEFINE-SNODE ,transform/define-snode) + (DEFINE-VECTOR-SLOTS ,transform/define-vector-slots) + (DESCRIPTOR-LIST ,transform/descriptor-list) + (ENUMERATION-CASE ,transform/enumeration-case) + (INST ,transform/inst) + (INST-EA ,transform/inst-ea) + (LAP ,transform/lap) + (MAKE-LVALUE ,transform/make-lvalue) + (MAKE-PNODE ,transform/make-pnode) + (MAKE-RVALUE ,transform/make-rvalue) + (MAKE-SNODE ,transform/make-snode) + (PACKAGE ,transform/package))) + (syntax-table-define lap-generator-syntax-table 'DEFINE-RULE + transform/define-rule)) + (define compiler-syntax-table - (make-syntax-table system-global-syntax-table)) + (make-syntax-table syntax-table/system-internal)) (define lap-generator-syntax-table (make-syntax-table compiler-syntax-table)) @@ -48,100 +78,38 @@ MIT in each case. |# (define early-syntax-table (make-syntax-table compiler-syntax-table)) -(syntax-table-define compiler-syntax-table 'PACKAGE - (in-package system-global-environment - (declare (usual-integrations)) - (lambda (expression) - (apply (lambda (names . body) - (make-sequence - `(,@(map (lambda (name) - (make-definition name (make-unassigned-object))) - names) - ,(make-combination - (let ((block (syntax* body))) - (if (open-block? block) - (open-block-components block - (lambda (names* declarations body) - (make-lambda lambda-tag:let '() '() false - (list-transform-negative names* - (lambda (name) - (memq name names))) - declarations - body))) - (make-lambda lambda-tag:let '() '() false '() - '() block))) - '())))) - (cdr expression))))) - -(let () - -(define (parse-define-syntax pattern body if-variable if-lambda) - (cond ((pair? pattern) - (let loop ((pattern pattern) (body body)) - (cond ((pair? (car pattern)) - (loop (car pattern) `((LAMBDA ,(cdr pattern) ,@body)))) - ((symbol? (car pattern)) - (if-lambda pattern body)) - (else - (error "Illegal name" (car pattern)))))) - ((symbol? pattern) - (if-variable pattern body)) - (else - (error "Illegal name" pattern)))) - -(define lambda-list->bound-names - (letrec ((lambda-list->bound-names - (lambda (lambda-list) - (cond ((null? lambda-list) - '()) - ((pair? lambda-list) - (if (eq? (car lambda-list) - (access lambda-optional-tag lambda-package)) - (if (pair? (cdr lambda-list)) - (accumulate (cdr lambda-list)) - (error "Missing optional variable" lambda-list)) - (accumulate lambda-list))) - ((symbol? lambda-list) - (list lambda-list)) - (else - (error "Illegal rest variable" lambda-list))))) - (accumulate - (lambda (lambda-list) - (cons (let ((parameter (car lambda-list))) - (if (pair? parameter) (car parameter) parameter)) - (lambda-list->bound-names (cdr lambda-list)))))) - lambda-list->bound-names)) - -(syntax-table-define compiler-syntax-table 'DEFINE-EXPORT +(define (transform/package names . body) + (make-syntax-closure + (make-sequence + `(,@(map (lambda (name) + (make-definition name (make-unassigned-reference-trap))) + names) + ,(make-combination + (let ((block (syntax* body))) + (if (open-block? block) + (open-block-components block + (lambda (names* declarations body) + (make-lambda lambda-tag:let '() '() false + (list-transform-negative names* + (lambda (name) + (memq name names))) + declarations + body))) + (make-lambda lambda-tag:let '() '() false '() + '() block))) + '()))))) + +(define transform/define-export (macro (pattern . body) (parse-define-syntax pattern body (lambda (name body) + name `(SET! ,pattern ,@body)) (lambda (pattern body) `(SET! ,(car pattern) (NAMED-LAMBDA ,pattern ,@body)))))) - -(syntax-table-define compiler-syntax-table 'DEFINE-INTEGRABLE - (macro (pattern . body) - (if compiler:enable-integration-declarations? - (parse-define-syntax pattern body - (lambda (name body) - `(BEGIN (DECLARE (INTEGRATE ,pattern)) - (DEFINE ,pattern ,@body))) - (lambda (pattern body) - `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern))) - (DEFINE ,pattern - ,@(if (list? (cdr pattern)) - `((DECLARE - (INTEGRATE - ,@(lambda-list->bound-names (cdr pattern))))) - '()) - ,@body)))) - `(DEFINE ,pattern ,@body)))) - -) -(syntax-table-define compiler-syntax-table 'DEFINE-VECTOR-SLOTS +(define transform/define-vector-slots (macro (class index . slots) (define (loop slots n) (if (null? slots) @@ -163,7 +131,7 @@ MIT in each case. |# '*THE-NON-PRINTING-OBJECT* `(BEGIN ,@(loop slots index))))) -(syntax-table-define compiler-syntax-table 'DEFINE-ROOT-TYPE +(define transform/define-root-type (macro (type . slots) (let ((tag-name (symbol-append type '-TAG))) `(BEGIN (DEFINE ,tag-name @@ -176,7 +144,7 @@ MIT in each case. |# (LAMBDA (,type) (DESCRIPTOR-LIST ,type ,@slots))))))) -(syntax-table-define compiler-syntax-table 'DESCRIPTOR-LIST +(define transform/descriptor-list (macro (type . slots) (let ((ref-name (lambda (slot) (symbol-append type '- slot)))) `(LIST ,@(map (lambda (slot) @@ -191,8 +159,7 @@ MIT in each case. |# ((define-type-definition (macro (name reserved enumeration) (let ((parent (symbol-append name '-TAG))) - `(SYNTAX-TABLE-DEFINE COMPILER-SYNTAX-TABLE - ',(symbol-append 'DEFINE- name) + `(DEFINE ,(symbol-append 'TRANSFORM/DEFINE- name) (macro (type . slots) (let ((tag-name (symbol-append type '-TAG))) `(BEGIN (DEFINE ,tag-name @@ -213,22 +180,22 @@ MIT in each case. |# ;;; Kludge to make these compile efficiently. -(syntax-table-define compiler-syntax-table 'MAKE-SNODE +(define transform/make-snode (macro (tag . extra) `((ACCESS VECTOR ,system-global-environment) ,tag FALSE '() '() FALSE ,@extra))) -(syntax-table-define compiler-syntax-table 'MAKE-PNODE +(define transform/make-pnode (macro (tag . extra) `((ACCESS VECTOR ,system-global-environment) ,tag FALSE '() '() FALSE FALSE ,@extra))) -(syntax-table-define compiler-syntax-table 'MAKE-RVALUE +(define transform/make-rvalue (macro (tag . extra) `((ACCESS VECTOR ,system-global-environment) ,tag FALSE ,@extra))) -(syntax-table-define compiler-syntax-table 'MAKE-LVALUE +(define transform/make-lvalue (macro (tag . extra) (let ((result (generate-uninterned-symbol))) `(let ((,result @@ -238,6 +205,9 @@ MIT in each case. |# (SET! *LVALUES* (CONS ,result *LVALUES*)) ,result)))) +(define transform/define-rtl-expression) +(define transform/define-rtl-statement) +(define transform/define-rtl-predicate) (let ((rtl-common (lambda (type prefix components wrap-constructor) `(BEGIN @@ -261,29 +231,21 @@ MIT in each case. |# ,@(loop (cdr components) (* ref-index 2) (* set-index 2)))))))))) - (syntax-table-define compiler-syntax-table 'DEFINE-RTL-EXPRESSION - (macro (type prefix . components) - (rtl-common type prefix components identity-procedure))) - - (syntax-table-define compiler-syntax-table 'DEFINE-RTL-STATEMENT - (macro (type prefix . components) - (rtl-common type prefix components - (lambda (expression) `(STATEMENT->SRTL ,expression))))) - - (syntax-table-define compiler-syntax-table 'DEFINE-RTL-PREDICATE - (macro (type prefix . components) - (rtl-common type prefix components - (lambda (expression) `(PREDICATE->PRTL ,expression)))))) - -(syntax-table-define compiler-syntax-table 'UCODE-TYPE - (macro (name) - (microcode-type name))) + (set! transform/define-rtl-expression + (macro (type prefix . components) + (rtl-common type prefix components identity-procedure))) + + (set! transform/define-rtl-statement + (macro (type prefix . components) + (rtl-common type prefix components + (lambda (expression) `(STATEMENT->SRTL ,expression))))) -(syntax-table-define compiler-syntax-table 'UCODE-PRIMITIVE - (macro (name) - (make-primitive-procedure name))) + (set! transform/define-rtl-predicate + (macro (type prefix . components) + (rtl-common type prefix components + (lambda (expression) `(PREDICATE->PRTL ,expression)))))) -(syntax-table-define lap-generator-syntax-table 'DEFINE-RULE +(define transform/define-rule (macro (type pattern . body) (parse-rule pattern body (lambda (pattern variables qualifier actions) @@ -301,7 +263,7 @@ MIT in each case. |# ;; syntax-instruction actually returns a bit-level instruction sequence. ;; Kept separate for clarity and because it does not have to be like that. -(syntax-table-define compiler-syntax-table 'LAP +(define transform/lap (macro some-instructions (define (handle current remaining) (let ((processed @@ -319,18 +281,18 @@ MIT in each case. |# `EMPTY-INSTRUCTION-SEQUENCE (handle (car some-instructions) (cdr some-instructions))))) -(syntax-table-define compiler-syntax-table 'INST +(define transform/inst (macro (the-instruction) `(LAP:SYNTAX-INSTRUCTION ,(list 'QUASIQUOTE the-instruction)))) ;; This is a NOP for now. -(syntax-table-define compiler-syntax-table 'INST-EA +(define transform/inst-ea (macro (ea) (list 'QUASIQUOTE ea))) -(syntax-table-define compiler-syntax-table 'DEFINE-ENUMERATION +(define transform/define-enumeration (macro (name elements) (let ((enumeration (symbol-append name 'S))) `(BEGIN (DEFINE ,enumeration @@ -366,16 +328,17 @@ MIT in each case. |# ,body) body))))) -(syntax-table-define compiler-syntax-table 'ENUMERATION-CASE +(define transform/enumeration-case (macro (name expression . clauses) (macros/case-macro expression clauses (lambda (expression element) `(EQ? ,expression ,(symbol-append name '/ element))) (lambda (expression) + expression '())))) -(syntax-table-define compiler-syntax-table 'CFG-NODE-CASE +(define transform/cfg-node-case (macro (expression . clauses) (macros/case-macro expression clauses diff --git a/v7/src/compiler/base/object.scm b/v7/src/compiler/base/object.scm index 19e85e810..db03758b7 100644 --- a/v7/src/compiler/base/object.scm +++ b/v7/src/compiler/base/object.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.1 1987/12/04 20:04:24 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.2 1988/06/14 08:32:36 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -49,8 +49,8 @@ MIT in each case. |# (let ((root-tag (%make-vector-tag false 'OBJECT false))) (set-vector-tag-%unparser! root-tag - (lambda (object) - (write (vector-tag-name (tagged-vector/tag object))))) + (lambda (state object) + (unparse-object state (vector-tag-name (tagged-vector/tag object))))) (named-lambda (make-vector-tag parent name enumeration) (let ((tag (%make-vector-tag (or parent root-tag) @@ -58,9 +58,7 @@ MIT in each case. |# (and enumeration (enumeration/name->index enumeration name))))) - ((access add-unparser-special-object! unparser-package) - tag - tagged-vector/unparse) + (unparser/set-tagged-vector-method! tag tagged-vector/unparse) tag)))) (define (define-vector-tag-unparser tag unparser) @@ -114,12 +112,12 @@ MIT in each case. |# (define (tagged-vector? object) (and (vector? object) (not (zero? (vector-length object))) - (let ((tag (tagged-vector/tag object))) - (or (vector-tag? tag) - (type-object? tag))))) + (vector-tag? (tagged-vector/tag object)))) (define (->tagged-vector object) - (let ((object (if (integer? object) (unhash object) object))) (and (tagged-vector? object) object))) + (let ((object (if (integer? object) (unhash object) object))) (and (or (tagged-vector? object) + (named-structure? object)) + object))) (define (tagged-vector/predicate tag) (lambda (object) @@ -137,12 +135,12 @@ MIT in each case. |# (loop (vector-tag-parent tag*)))))))) (define (tagged-vector/description object) - (if (tagged-vector? object) - (let ((tag (tagged-vector/tag object))) - (cond ((vector-tag? tag) (vector-tag-description tag)) - ((type-object? tag) (type-object-description tag)) - (else (error "Unknown vector tag" tag)))) - (error "Not a tagged vector" object))) + (cond ((named-structure? object) + (named-structure/description object)) + ((tagged-vector? object) + (vector-tag-description (tagged-vector/tag object))) + (else + (error "Not a tagged vector" object)))) (define (type-object-description type-object) (2d-get type-object type-object-description)) @@ -151,29 +149,10 @@ MIT in each case. |# (2d-put! type-object type-object-description description)) (define (standard-unparser name unparser) - (lambda (object) - (unparse-with-brackets - (lambda () - (standard-unparser/prefix object) - (write name) - (if unparser - (begin (write-string " ") - (unparser object))))))) - -(define (tagged-vector/unparse vector) - (unparse-with-brackets - (lambda () - (standard-unparser/prefix vector) - (fluid-let ((*unparser-radix* 16)) - ((tagged-vector/unparser vector) vector))))) - -(define (standard-unparser/prefix object) - (if *tagged-vector-unparse-prefix-string* - (begin (write-string *tagged-vector-unparse-prefix-string*) - (write-string " "))) - (if *tagged-vector-unparse-show-hash* - (begin (write-string (number->string (hash object) 10)) - (write-string " ")))) - -(define *tagged-vector-unparse-prefix-string* "LIAR") -(define *tagged-vector-unparse-show-hash* true) \ No newline at end of file + (let ((name (string-append "LIAR " name))) (if unparser + (unparser/standard-method name unparser) + (unparser/standard-method name)))) + +(define (tagged-vector/unparse state vector) + (fluid-let ((*unparser-radix* 16)) + ((tagged-vector/unparser vector) state vector))) \ No newline at end of file diff --git a/v7/src/compiler/base/pmerly.scm b/v7/src/compiler/base/pmerly.scm index a51635818..3870b04dc 100644 --- a/v7/src/compiler/base/pmerly.scm +++ b/v7/src/compiler/base/pmerly.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmerly.scm,v 1.6 1987/08/25 02:18:38 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmerly.scm,v 1.7 1988/06/14 08:32:44 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -35,24 +35,13 @@ MIT in each case. |# ;;;; Very Simple Pattern Matcher: Early rule compilation and lookup (declare (usual-integrations)) - -;;; Exports - -(define early-parse-rule) -(define early-pattern-lookup) -(define early-make-rule) -(define make-database-transformer) -(define make-symbol-transformer) -(define make-bit-mask-transformer) - -(let () ;;;; Database construction -(define-export (early-make-rule pattern variables body) +(define (early-make-rule pattern variables body) (list pattern variables body)) -(define-export (early-parse-rule pattern receiver) +(define (early-parse-rule pattern receiver) (extract-variables pattern receiver)) (define (extract-variables pattern receiver) @@ -96,10 +85,10 @@ MIT in each case. |# ;;;; Early rule processing and code compilation -(define-export (early-pattern-lookup - rules instance #!optional transformers unparsed receiver limit) - (if (unassigned? limit) (set! limit *rule-limit*)) - (if (or (unassigned? receiver) (null? receiver)) +(define (early-pattern-lookup rules instance #!optional transformers unparsed + receiver limit) + (if (default-object? limit) (set! limit *rule-limit*)) + (if (or (default-object? receiver) (null? receiver)) (set! receiver (lambda (result code) (cond ((false? result) @@ -117,13 +106,13 @@ MIT in each case. |# (scode/make-block bindings '() program) false))) (fluid-let ((*rule-limit* limit) - (*transformers* (if (unassigned? transformers) + (*transformers* (if (default-object? transformers) '() transformers))) (try-rules rules expression (scode/make-error-combination "early-pattern-lookup: No pattern matches" - (if (or (unassigned? unparsed) (null? unparsed)) + (if (or (default-object? unparsed) (null? unparsed)) (scode/make-constant instance) unparsed)) list)))))) @@ -168,7 +157,8 @@ MIT in each case. |# ((eq? result 'MAYBE) (let ((var (make-variable-name 'TRY-NEXT-RULE-))) (loop (cdr rules) - (scode/make-combination (scode/make-variable var) '()) + (scode/make-combination (scode/make-variable var) + '()) (cons (cons var code) bindings) (1+ nrules)))) @@ -181,8 +171,9 @@ MIT in each case. |# (receiver 'MAYBE (scode/make-letrec (map (lambda (pair) - (scode/make-binding (car pair) - (scode/make-thunk (cdr pair)))) + (scode/make-binding + (car pair) + (scode/make-thunk (cdr pair)))) bindings) null-form))))) (loop rules null-form '() 0)) @@ -248,10 +239,11 @@ MIT in each case. |# (build-comparison (cdr evaluation) (cdar evaluation) (lambda (new-test new-bindings) - (process-evaluations (cdr evaluations) - (scode/merge-tests new-test test) - (append new-bindings bindings) - receiver)))))) + (process-evaluations + (cdr evaluations) + (scode/merge-tests new-test test) + (append new-bindings bindings) + receiver)))))) ;;;; Early variable processing @@ -387,8 +379,10 @@ MIT in each case. |# (merge-path path expression)) (append car-bindings cdr-bindings)))))))))))))) - (walk pattern '() expression (lambda (pure? test bindings) - (receiver test bindings)))) + (walk pattern '() expression + (lambda (pure? test bindings) + pure? + (receiver test bindings)))) ;;; car/cdr decomposition @@ -399,8 +393,10 @@ MIT in each case. |# (scode/merge-tests car-test cdr-test)) (combination-components car-test (lambda (car-operator car-operands) + car-operator (combination-components cdr-test (lambda (cdr-operator cdr-operands) + cdr-operator (scode/make-absolute-combination 'EQUAL? (list (scode/make-constant @@ -452,7 +448,8 @@ MIT in each case. |# (cond ((null? info) (receiver step expression)) ((null? (cadr info)) - (receiver step (scode/make-absolute-combination path (list expression)))) + (receiver step + (scode/make-absolute-combination path (list expression)))) (else (receiver (if (eq? step 'CAR) (caadr info) (cdadr info)) expression))))) @@ -488,7 +485,7 @@ MIT in each case. |# ;;;; Database transformers -(define-export (make-database-transformer database) +(define (make-database-transformer database) (lambda (texp name rename exp receiver) (let ((null-form (scode/make-constant (generate-uninterned-symbol 'NOT-FOUND-)))) @@ -522,16 +519,17 @@ MIT in each case. |# (scode/let-components code (lambda (names values decls body) - (and (not (null? names)) - (let ((place (assq 'INTEGRATE decls))) - (and (not (null? place)) - (let ((integrated (cdr place))) - (let loop ((left names)) - (cond ((null? left) - (can-integrate? body)) - ((memq (car left) integrated) - (loop (cdr left))) - (else false))))))))))) + values + (and (not (null? names)) + (let ((place (assq 'INTEGRATE decls))) + (and (not (null? place)) + (let ((integrated (cdr place))) + (let loop ((left names)) + (cond ((null? left) + (can-integrate? body)) + ((memq (car left) integrated) + (loop (cdr left))) + (else false))))))))))) (define-integrable (make-simple-transformer-test name tag) (scode/make-absolute-combination 'NOT @@ -553,8 +551,9 @@ MIT in each case. |# ;;;; Symbol transformers -(define-export (make-symbol-transformer alist) +(define (make-symbol-transformer alist) (lambda (texp name rename exp receiver) + texp (cond ((null? alist) (receiver false false)) ((symbol? exp) @@ -594,7 +593,7 @@ MIT in each case. |# ;;;; Accumulation transformers -(define-export (make-bit-mask-transformer size alist) +(define (make-bit-mask-transformer size alist) (lambda (texp name rename exp receiver) (cond ((null? alist) (transformer-fail receiver)) @@ -639,10 +638,12 @@ MIT in each case. |# (scode/combination-components obj (lambda (operator operands) + operands (and (scode/lambda? operator) (scode/lambda-components operator (lambda (name . ignore) + ignore (eq? name lambda-tag:let)))))))) (define (scode/make-let names values declarations body) @@ -661,6 +662,7 @@ MIT in each case. |# (lambda (operator values) (scode/lambda-components operator (lambda (tag names opt rest aux decls body) + tag opt rest aux (receiver names values decls body)))))) ;;;; Scode utilities (continued) @@ -679,7 +681,7 @@ MIT in each case. |# (scode/make-let (map scode/binding-variable bindings) (make-list (length bindings) - (scode/make-unassigned-object)) + (make-unassigned-reference-trap)) '() (scode/make-sequence (map* body @@ -724,7 +726,4 @@ MIT in each case. |# (cons evaluation-tag name)) (define-integrable (evaluation-expression exp) - (cdr exp)) - -;; End of early rule parsing package -) \ No newline at end of file + (cdr exp)) \ No newline at end of file diff --git a/v7/src/compiler/base/pmlook.scm b/v7/src/compiler/base/pmlook.scm index 770e3e001..6cb981f20 100644 --- a/v7/src/compiler/base/pmlook.scm +++ b/v7/src/compiler/base/pmlook.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmlook.scm,v 1.5 1987/07/08 21:53:09 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmlook.scm,v 1.6 1988/06/14 08:32:58 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,74 +36,55 @@ MIT in each case. |# (declare (usual-integrations)) -(define pattern-lookup) -(define pattern-variables) -(define make-pattern-variable) -(define pattern-variable?) -(define pattern-variable-name) - -(let ((pattern-variable-tag (make-named-tag "Pattern Variable"))) +(define pattern-variable-tag + (make-named-tag "Pattern Variable")) ;;; PATTERN-LOOKUP returns either false or a pair whose car is the ;;; item matched and whose cdr is the list of variable values. Use ;;; PATTERN-VARIABLES to get a list of names that is in the same order ;;; as the list of values. -(set! pattern-lookup - (named-lambda (pattern-lookup entries instance) - (define (lookup-loop entries values) - (define (match pattern instance) - (if (pair? pattern) - (if (eq? (car pattern) pattern-variable-tag) - (let ((entry (memq (cdr pattern) values))) - (if entry - (eqv? (cdr entry) instance) - (begin (set! values (cons instance values)) - true))) - (and (pair? instance) - (match (car pattern) (car instance)) - (match (cdr pattern) (cdr instance)))) - (eqv? pattern instance))) - (and (not (null? entries)) - (or (and (match (caar entries) instance) - (pattern-lookup/bind (cdar entries) values)) - (lookup-loop (cdr entries) '())))) - (lookup-loop entries '()))) - -(define (pattern-lookup/bind binder values) +(define (pattern-lookup entries instance) + (define (lookup-loop entries values) + (define (match pattern instance) + (if (pair? pattern) + (if (eq? (car pattern) pattern-variable-tag) + (let ((entry (memq (cdr pattern) values))) + (if entry + (eqv? (cdr entry) instance) + (begin (set! values (cons instance values)) + true))) + (and (pair? instance) + (match (car pattern) (car instance)) + (match (cdr pattern) (cdr instance)))) + (eqv? pattern instance))) + (and (not (null? entries)) + (or (and (match (caar entries) instance) + (pattern-lookup/bind (cdar entries) values)) + (lookup-loop (cdr entries) '())))) + (lookup-loop entries '())) + +(define-integrable (pattern-lookup/bind binder values) (apply binder values)) -(set! pattern-variables - (named-lambda (pattern-variables pattern) - (let ((variables '())) - (define (loop pattern) - (if (pair? pattern) - (if (eq? (car pattern) pattern-variable-tag) - (if (not (memq (cdr pattern) variables)) - (set! variables (cons (cdr pattern) variables))) - (begin (loop (car pattern)) - (loop (cdr pattern)))))) - (loop pattern) - variables))) - -(set! make-pattern-variable - (named-lambda (make-pattern-variable name) - (cons pattern-variable-tag name))) - -(set! pattern-variable? - (named-lambda (pattern-variable? obj) - (and (pair? obj) (eq? (car obj) pattern-variable-tag)))) - -(set! pattern-variable-name - (named-lambda (pattern-variable-name var) - (cdr var))) - -) - -;;; ALL-TRUE? is used to determine if splicing variables with -;;; qualifiers satisfy the qualification. - -(define (all-true? values) - (or (null? values) - (and (car values) - (all-true? (cdr values))))) \ No newline at end of file +(define (pattern-variables pattern) + (let ((variables '())) + (define (loop pattern) + (if (pair? pattern) + (if (eq? (car pattern) pattern-variable-tag) + (if (not (memq (cdr pattern) variables)) + (set! variables (cons (cdr pattern) variables))) + (begin (loop (car pattern)) + (loop (cdr pattern)))))) + (loop pattern) + variables)) + +(define-integrable (make-pattern-variable name) + (cons pattern-variable-tag name)) + +(define (pattern-variable? object) + (and (pair? object) + (eq? (car object) pattern-variable-tag))) + +(define-integrable (pattern-variable-name var) + (cdr var)) \ No newline at end of file diff --git a/v7/src/compiler/base/pmpars.scm b/v7/src/compiler/base/pmpars.scm index 134a1697a..5fa1af913 100644 --- a/v7/src/compiler/base/pmpars.scm +++ b/v7/src/compiler/base/pmpars.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmpars.scm,v 1.2 1987/07/08 21:53:25 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmpars.scm,v 1.3 1988/06/14 08:33:06 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -51,24 +51,18 @@ MIT in each case. |# ;;; arguments, will return either false, indicating that the ;;; qualifications failed, or the result of the body. -(define rule-result-expression) -(define parse-rule) - -(let () - -(set! parse-rule - (named-lambda (parse-rule pattern body receiver) - (extract-variables - pattern - (lambda (pattern variables) - (extract-qualifier - body - (lambda (qualifiers actions) - (let ((names (pattern-variables pattern))) - (receiver pattern - (reorder-variables variables names) - qualifiers - actions)))))))) +(define (parse-rule pattern body receiver) + (extract-variables + pattern + (lambda (pattern variables) + (extract-qualifier + body + (lambda (qualifiers actions) + (let ((names (pattern-variables pattern))) + (receiver pattern + (reorder-variables variables names) + qualifiers + actions))))))) (define (extract-variables pattern receiver) (if (pair? pattern) @@ -100,7 +94,7 @@ MIT in each case. |# (cons (car x) (merge-variables-lists (cdr x) y))))))) - + (define (extract-qualifier body receiver) (if (and (pair? (car body)) (eq? (caar body) 'QUALIFIER)) @@ -110,57 +104,52 @@ MIT in each case. |# (define (reorder-variables variables names) (map (lambda (name) (assq name variables)) names)) - -(set! rule-result-expression - (named-lambda (rule-result-expression variables qualifiers body) - (let ((body `(lambda () ,body))) - (process-transformations variables - (lambda (outer-vars inner-vars xforms xqualifiers) - (if (null? inner-vars) - `(lambda ,outer-vars - ,(if (null? qualifiers) - body - `(and ,@qualifiers ,body))) - `(lambda ,outer-vars - (let ,(map list inner-vars xforms) - (and ,@xqualifiers - ,@qualifiers - ,body))))))))) + +(define (rule-result-expression variables qualifiers body) + (let ((body `(lambda () ,body))) + (process-transformations variables + (lambda (outer-vars inner-vars xforms xqualifiers) + (if (null? inner-vars) + `(lambda ,outer-vars + ,(if (null? qualifiers) + body + `(and ,@qualifiers ,body))) + `(lambda ,outer-vars + (let ,(map list inner-vars xforms) + (and ,@xqualifiers + ,@qualifiers + ,body)))))))) (define (process-transformations variables receiver) (if (null? variables) (receiver '() '() '() '()) - (process-transformations - (cdr variables) - (lambda (outer inner xform qual) - (let ((name (caar variables)) - (variable (cdar variables))) - (cond ((null? variable) - (receiver (cons name outer) - inner - xform - qual)) - ((not (null? (cdr variable))) - (error "process-trasformations: Multiple qualifiers" - (car variables))) - (else - (let ((var (car variable))) - (define (handle-xform rename) - (if (eq? (car var) '?) - (receiver (cons rename outer) - (cons name inner) - (cons `(,(cadr var) ,rename) - xform) - (cons name qual)) - (receiver (cons rename outer) - (cons name inner) - (cons `(MAP ,(cadr var) ,rename) - xform) - (cons `(ALL-TRUE? ,name) qual)))) - (handle-xform - (if (null? (cddr var)) - name - (caddr var))))))))))) - -;; End of PARSE-RULE environment. -) \ No newline at end of file + (process-transformations (cdr variables) + (lambda (outer inner xform qual) + (let ((name (caar variables)) + (variable (cdar variables))) + (cond ((null? variable) + (receiver (cons name outer) + inner + xform + qual)) + ((not (null? (cdr variable))) + (error "process-trasformations: Multiple qualifiers" + (car variables))) + (else + (let ((var (car variable))) + (define (handle-xform rename) + (if (eq? (car var) '?) + (receiver (cons rename outer) + (cons name inner) + (cons `(,(cadr var) ,rename) + xform) + (cons name qual)) + (receiver (cons rename outer) + (cons name inner) + (cons `(MAP ,(cadr var) ,rename) + xform) + (cons `(APPLY BOOLEAN/AND ,name) qual)))) + (handle-xform + (if (null? (cddr var)) + name + (caddr var))))))))))) \ No newline at end of file diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index 160c14ebc..4a7501517 100644 --- a/v7/src/compiler/base/proced.scm +++ b/v7/src/compiler/base/proced.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.4 1988/04/15 02:09:17 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.5 1988/06/14 08:33:14 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -76,18 +76,19 @@ MIT in each case. |# procedure)) (define-vector-tag-unparser procedure-tag - (lambda (procedure) - (let ((type - (enumeration/index->name continuation-types - (procedure-type procedure)))) - (if (eq? type 'PROCEDURE) - (begin - (write-string "PROCEDURE ") - (write (procedure-label procedure))) - (begin - (write (procedure-label procedure)) - (write-string " ") - (write type)))))) + (lambda (state procedure) + ((let ((type + (enumeration/index->name continuation-types + (procedure-type procedure)))) + (if (eq? type 'PROCEDURE) + (standard-unparser "PROCEDURE" + (lambda (state procedure) + (unparse-object state (procedure-label procedure)))) + (standard-unparser (symbol->string (procedure-label procedure)) + (lambda (state procedure) + procedure + (unparse-object state type))))) + state procedure))) (define-integrable (rvalue/procedure? rvalue) (eq? (tagged-vector/tag rvalue) procedure-tag)) diff --git a/v7/src/compiler/base/rvalue.scm b/v7/src/compiler/base/rvalue.scm index 16a51010e..a9ccd2e44 100644 --- a/v7/src/compiler/base/rvalue.scm +++ b/v7/src/compiler/base/rvalue.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 4.2 1987/12/31 10:01:50 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 4.3 1988/06/14 08:33:23 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -103,9 +103,9 @@ MIT in each case. |# constant)))) (define-vector-tag-unparser constant-tag - (lambda (constant) - (write-string "CONSTANT ") - (write (constant-value constant)))) + (standard-unparser "CONSTANT" + (lambda (state constant) + (unparse-object state (constant-value constant))))) (define-integrable (rvalue/constant? rvalue) (eq? (tagged-vector/tag rvalue) constant-tag)) @@ -121,9 +121,9 @@ MIT in each case. |# (make-rvalue reference-tag block lvalue safe?)) (define-vector-tag-unparser reference-tag - (lambda (reference) - (write-string "REFERENCE ") - (write (variable-name (reference-lvalue reference))))) + (standard-unparser "REFERENCE" + (lambda (state reference) + (unparse-object state (variable-name (reference-lvalue reference)))))) (define-integrable (rvalue/reference? rvalue) (eq? (tagged-vector/tag rvalue) reference-tag)) @@ -157,9 +157,8 @@ MIT in each case. |# (make-rvalue unassigned-test-tag block lvalue)) (define-vector-tag-unparser unassigned-test-tag - (lambda (unassigned-test) - (write-string "UNASSIGNED-TEST ") - (write (unassigned-test-lvalue unassigned-test)))) + (standard-unparser "UNASSIGNED-TEST" (lambda (state unassigned-test) + (unparse-object state (unassigned-test-lvalue unassigned-test))))) (define-integrable (rvalue/unassigned-test? rvalue) (eq? (tagged-vector/tag rvalue) unassigned-test-tag)) diff --git a/v7/src/compiler/base/scode.scm b/v7/src/compiler/base/scode.scm index 92f3a0714..022437a25 100644 --- a/v7/src/compiler/base/scode.scm +++ b/v7/src/compiler/base/scode.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.3 1988/04/15 02:09:29 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.4 1988/06/14 08:33:30 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -60,7 +60,7 @@ MIT in each case. |# make-delay delay? delay-components delay-expression make-disjunction disjunction? disjunction-components - conditional-predicate conditional-alternative + disjunction-predicate disjunction-alternative make-in-package in-package? in-package-components in-package-environment in-package-expression make-lambda lambda? lambda-components @@ -70,9 +70,7 @@ MIT in each case. |# make-sequence sequence-actions sequence-components symbol? make-the-environment the-environment? - make-unassigned-object unassigned-object? make-unassigned? unassigned?? unassigned?-name - make-unbound? unbound?? unbound?-name make-variable variable? variable-components variable-name )) @@ -98,46 +96,61 @@ MIT in each case. |# ;;;; Absolute variables and combinations -(define (scode/make-absolute-reference variable-name) +(define-integrable (scode/make-absolute-reference variable-name) (scode/make-access '() variable-name)) (define (scode/absolute-reference? object) (and (scode/access? object) (null? (scode/access-environment object)))) -(define (scode/absolute-reference-name reference) +(define-integrable (scode/absolute-reference-name reference) (scode/access-name reference)) -(define (scode/make-absolute-combination name operands) +(define-integrable (scode/make-absolute-combination name operands) (scode/make-combination (scode/make-absolute-reference name) operands)) (define (scode/absolute-combination? object) (and (scode/combination? object) (scode/absolute-reference? (scode/combination-operator object)))) +(define-integrable (scode/absolute-combination-name combination) + (scode/absolute-reference-name (scode/combination-operator combination))) + +(define-integrable (scode/absolute-combination-operands combination) + (scode/combination-operands combination)) + (define (scode/absolute-combination-components combination receiver) - (scode/combination-components combination - (lambda (operator operands) - (receiver (scode/absolute-reference-name operator) operands)))) + (receiver (scode/absolute-combination-name combination) + (scode/absolute-combination-operands combination))) -(define scode/error-combination? - (type-object-predicate error-combination-type)) +(define (scode/error-combination? object) + (or (and (scode/combination? object) + (eq? (scode/combination-operator object) error-procedure)) + (and (scode/absolute-combination? object) + (eq? (scode/absolute-combination-name object) 'ERROR-PROCEDURE)))) (define (scode/error-combination-components combination receiver) (scode/combination-components combination (lambda (operator operands) - (receiver (car operands) - (let ((irritant (cadr operands))) - (cond ((scode/access? irritant) '()) - ((scode/absolute-combination? irritant) - (scode/absolute-combination-components irritant - (lambda (name operands) - (if (eq? name 'LIST) - operands - (list irritant))))) - (else (list irritant)))))))) + operator + (receiver + (car operands) + (let loop ((irritants (cadr operands))) + (cond ((null? irritants) '()) + ((and (scode/absolute-combination? irritants) + (eq? (scode/absolute-combination-name irritants) 'LIST)) + (scode/absolute-combination-operands irritants)) + ((and (scode/combination? irritants) + (eq? (scode/combination-operator irritants) cons)) + (let ((operands (scode/combination-operands irritants))) + (cons (car operands) + (loop (cadr operands))))) + (else + (error "Illegal irritants" (cadr operands))))))))) (define (scode/make-error-combination message operand) (scode/make-absolute-combination 'ERROR-PROCEDURE - (list message operand (scode/make-the-environment)))) \ No newline at end of file + (list message + (scode/make-combination cons (list operand '())) + (scode/make-the-environment)))) \ No newline at end of file diff --git a/v7/src/compiler/base/subprb.scm b/v7/src/compiler/base/subprb.scm index 4f53b71c7..107cb149e 100644 --- a/v7/src/compiler/base/subprb.scm +++ b/v7/src/compiler/base/subprb.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/subprb.scm,v 4.2 1987/12/30 06:59:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/subprb.scm,v 4.3 1988/06/14 08:33:38 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -106,11 +106,11 @@ known that the continuation need not be used. (constructor virtual-continuation/%make (block parent type)) (conc-name virtual-continuation/) (print-procedure - (standard-unparser 'VIRTUAL-CONTINUATION - (lambda (continuation) + (standard-unparser "VIRTUAL-CONTINUATION" (lambda (state continuation) (let ((type (virtual-continuation/type continuation))) (if type - (write + (unparse-object + state (enumeration/index->name continuation-types type)))))))) block diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm index 4cea2d842..cdc932e19 100644 --- a/v7/src/compiler/base/switch.scm +++ b/v7/src/compiler/base/switch.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.4 1988/04/15 02:09:42 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.5 1988/06/14 08:33:44 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index efea8a100..48ee66ba7 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.6 1988/04/15 02:09:53 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.7 1988/06/14 08:33:51 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -143,9 +143,7 @@ MIT in each case. |# (compiler:reset!) (let* ((topl (thunk)) (value - ((access generate-top-level-object - debugging-information-package) - topl *recursive-compilation-results*))) + (generate-top-level-object topl *recursive-compilation-results*))) (if (not compiler:preserve-data-structures?) (compiler:reset!)) (compiler-time-report "Total compilation time" @@ -160,13 +158,13 @@ MIT in each case. |# (lambda (source-file) (let ((scode-file (merge-pathnames - (make-pathname false false false "bin" false) + (make-pathname false false false false "bin" false) (->pathname source-file)))) ;; Maybe this should be done only if scode-file ;; does not exist or is older than source-file. (sf source-file scode-file) (newline) - (if (unassigned? output) + (if (default-object? output) (compile-bin-file scode-file) (compile-bin-file scode-file output)))))) (if (pair? input) @@ -175,8 +173,8 @@ MIT in each case. |# (define (compile-bin-file input-string #!optional output-string) (compiler-pathnames input-string - (and (not (unassigned? output-string)) output-string) - (make-pathname false false false "bin" 'NEWEST) + (and (not (default-object? output-string)) output-string) + (make-pathname false false false false "bin" 'NEWEST) (lambda (input-pathname output-pathname) (compile-scode (compiler-fasload input-pathname) (and compiler:generate-rtl-files? @@ -190,25 +188,19 @@ MIT in each case. |# (define compiler:abort-continuation) (define (compiler:batch-compile input #!optional output) - (fluid-let ((compiler:batch-mode? true) - ((access *error-hook* error-system) - (lambda (env mesg irr subst?) - (if compiler:abort-handled? - (begin - (newline) - (newline) - (display "*** Error: ") - (display mesg) - (display " ***") - (newline) - (display "Irritant: ") - (write irr) - (compiler:abort false)) - ((access standard-error-hook error-system) - env mesg irr subst?))))) - (if (unassigned? output) - (compile-bin-file input) - (compile-bin-file input output)))) + (fluid-let ((compiler:batch-mode? true)) + (bind-condition-handler '() compiler:batch-error-handler + (lambda () + (if (default-object? output) + (compile-bin-file input) + (compile-bin-file input output)))))) + +(define (compiler:batch-error-handler condition) + (and (condition/error? condition) + (begin (apply warn + (condition/message condition) + (condition/irritants condition)) + (compiler:abort false)))) (define (compiler:abort value) (if compiler:abort-handled? @@ -308,9 +300,9 @@ MIT in each case. |# info-output-pathname wrapper) - (if (unassigned? rtl-output-pathname) + (if (default-object? rtl-output-pathname) (set! rtl-output-pathname false)) - (if (unassigned? info-output-pathname) + (if (default-object? info-output-pathname) (set! info-output-pathname false)) (fluid-let ((*info-output-pathname* @@ -323,7 +315,7 @@ MIT in each case. |# (not (eq? rtl-output-pathname true))) rtl-output-pathname *rtl-output-pathname*))) - ((if (unassigned? wrapper) + ((if (default-object? wrapper) in-compiler wrapper) (lambda () @@ -404,9 +396,7 @@ MIT in each case. |# (define (phase/canonicalize-scode) (compiler-subphase "Canonicalizing Scode" (lambda () - (set! *scode* - ((access canonicalize/top-level fg-generator-package) - (last-reference *input-scode*)))))) + (set! *scode* (canonicalize/top-level (last-reference *input-scode*)))))) (define (phase/translate-scode) (compiler-subphase "Translating Scode into Flow Graph" @@ -420,9 +410,7 @@ MIT in each case. |# (set! *applications* '()) (set! *parallels* '()) (set! *assignments* '()) - (set! *root-expression* - ((access construct-graph fg-generator-package) - (last-reference *scode*))) + (set! *root-expression* (construct-graph (last-reference *scode*))) (set! *root-block* (expression-block *root-expression*)) (if (or (null? *expressions*) (not (null? (cdr *expressions*)))) @@ -449,88 +437,67 @@ MIT in each case. |# (define (phase/simulate-application) (compiler-subphase "Simulating Applications" (lambda () - ((access simulate-application fg-optimizer-package) - *lvalues* - *applications*)))) + (simulate-application *lvalues* *applications*)))) (define (phase/outer-analysis) (compiler-subphase "Outer Analysis" (lambda () - ((access outer-analysis fg-optimizer-package) - *root-expression* - *procedures* - *applications*)))) + (outer-analysis *root-expression* *procedures* *applications*)))) (define (phase/fold-constants) (compiler-subphase "Constant Folding" (lambda () - ((access fold-constants fg-optimizer-package) - *lvalues* - *applications*)))) + (fold-constants *lvalues* *applications*)))) (define (phase/open-coding-analysis) (compiler-subphase "Open Coding Analysis" (lambda () - ((access open-coding-analysis rtl-generator-package) - *applications*)))) + (open-coding-analysis *applications*)))) (define (phase/operator-analysis) (compiler-subphase "Operator Analysis" (lambda () - ((access operator-analysis fg-optimizer-package) - *procedures* - *applications*)))) + (operator-analysis *procedures* *applications*)))) (define (phase/identify-closure-limits) (compiler-subphase "Identifying Closure Limits" (lambda () - ((access identify-closure-limits! fg-optimizer-package) - *procedures* - *applications* - *assignments*)))) + (identify-closure-limits! *procedures* *applications* *assignments*)))) (define (phase/setup-block-types) (compiler-subphase "Setting Up Block Types" (lambda () - ((access setup-block-types! fg-optimizer-package) - *root-block*)))) + (setup-block-types! *root-block*)))) (define (phase/continuation-analysis) (compiler-subphase "Continuation Analysis" (lambda () - ((access continuation-analysis fg-optimizer-package) - *blocks*)))) + (continuation-analysis *blocks*)))) (define (phase/simplicity-analysis) (compiler-subphase "Simplicity Analysis" (lambda () - ((access simplicity-analysis fg-optimizer-package) - *parallels*)))) + (simplicity-analysis *parallels*)))) (define (phase/subproblem-ordering) (compiler-subphase "Ordering Subproblems" (lambda () - ((access subproblem-ordering fg-optimizer-package) - *parallels*)))) + (subproblem-ordering *parallels*)))) (define (phase/connectivity-analysis) (compiler-subphase "Connectivity Analysis" (lambda () - ((access connectivity-analysis fg-optimizer-package) - *root-expression* - *procedures*)))) + (connectivity-analysis *root-expression* *procedures*)))) (define (phase/design-environment-frames) (compiler-subphase "Designing Environment Frames" (lambda () - ((access design-environment-frames! fg-optimizer-package) - *blocks*)))) + (design-environment-frames! *blocks*)))) (define (phase/compute-node-offsets) (compiler-subphase "Computing Node Offsets" (lambda () - ((access compute-node-offsets fg-optimizer-package) - *root-expression*)))) + (compute-node-offsets *root-expression*)))) (define (phase/fg-optimization-cleanup) (compiler-subphase "Cleaning Up After Flow Graph Optimization" @@ -553,8 +520,7 @@ MIT in each case. |# (set! *rtl-graphs* '()) (set! *ic-procedure-headers* '()) (initialize-machine-register-map!) - ((access generate/top-level rtl-generator-package) - (last-reference *root-expression*)) + (generate/top-level (last-reference *root-expression*)) (set! label->object (make/label->object *rtl-expression* *rtl-procedures* @@ -592,37 +558,37 @@ MIT in each case. |# (define (phase/common-subexpression-elimination) (compiler-subphase "Eliminating Common Subexpressions" (lambda () - ((access common-subexpression-elimination rtl-cse-package) - *rtl-graphs*)))) + (common-subexpression-elimination *rtl-graphs*)))) (define (phase/lifetime-analysis) (compiler-subphase "Lifetime Analysis" (lambda () - ((access lifetime-analysis rtl-optimizer-package) *rtl-graphs*)))) + (lifetime-analysis *rtl-graphs*)))) (define (phase/code-compression) (compiler-subphase "Code Compression" (lambda () - ((access code-compression rtl-optimizer-package) *rtl-graphs*)))) + (code-compression *rtl-graphs*)))) (define (phase/rtl-file-output pathname) (compiler-phase "RTL File Output" (lambda () - (let ((lin ((access linearize-rtl rtl-generator-package) *rtl-graphs*))) + (let ((rtl (linearize-rtl *rtl-graphs*))) (if (eq? pathname true) ;; recursive compilation (set! *recursive-compilation-rtl-blocks* - (cons (cons *recursive-compilation-number* lin) + (cons (cons *recursive-compilation-number* rtl) *recursive-compilation-rtl-blocks*)) (fasdump (if (null? *recursive-compilation-rtl-blocks*) - lin + rtl (list->vector - (cons (cons 0 lin) *recursive-compilation-rtl-blocks*))) + (cons (cons 0 rtl) + *recursive-compilation-rtl-blocks*))) pathname)))))) (define (phase/register-allocation) (compiler-subphase "Allocating Registers" (lambda () - ((access register-allocation rtl-optimizer-package) *rtl-graphs*)))) + (register-allocation *rtl-graphs*)))) (define (phase/rtl-optimization-cleanup) (if (not compiler:preserve-data-structures?) @@ -639,7 +605,7 @@ MIT in each case. |# (compiler-phase "Generating BITs" (lambda () (set! compiler:external-labels '()) - ((access generate-bits lap-syntax-package) + (generate-bits *rtl-graphs* (lambda (block-label prefix) (set! compiler:block-label block-label) @@ -657,23 +623,17 @@ MIT in each case. |# (lambda () (set! compiler:bits (append-instruction-sequences! - (lap:make-entry-point compiler:entry-label - compiler:block-label) - ((access linearize-bits lap-syntax-package) - (last-reference *rtl-graphs*))))))) + (lap:make-entry-point compiler:entry-label compiler:block-label) + (linearize-bits (last-reference *rtl-graphs*))))))) (define (phase/assemble) (compiler-phase "Assembling" (lambda () (if compiler:preserve-data-structures? - ((access assemble bit-package) - compiler:block-label - compiler:bits - phase/assemble-finish) - ((access assemble bit-package) - (set! compiler:block-label) - (set! compiler:bits) - phase/assemble-finish))))) + (assemble compiler:block-label compiler:bits phase/assemble-finish) + (assemble (set! compiler:block-label) + (set! compiler:bits) + phase/assemble-finish))))) (define (phase/assemble-finish count code-vector labels bindings linkage-info) linkage-info ;; ignored @@ -691,9 +651,8 @@ MIT in each case. |# (compiler-phase "Generating Debugging Information (pass 2)" (lambda () (let ((info - ((access generation-phase2 debugging-information-package) - compiler:label-bindings - (last-reference compiler:external-labels)))) + (generation-phase2 compiler:label-bindings + (last-reference compiler:external-labels)))) (if (eq? pathname true) ; recursive compilation (begin @@ -707,10 +666,9 @@ MIT in each case. |# (cons (pathname->string *info-output-pathname*) *recursive-compilation-number*))) (begin - (fasdump ((access generate-top-level-info - debugging-information-package) - info *recursive-compilation-results*) - pathname) + (fasdump + (generate-top-level-info info *recursive-compilation-results*) + pathname) (set-compiled-code-block/debugging-info! compiler:code-vector (pathname->string pathname)))))))) @@ -724,15 +682,14 @@ MIT in each case. |# (map (lambda (label) (cons label - (with-interrupt-mask interrupt-mask-none - (lambda (old) - old ;; ignored - ((ucode-primitive &make-object) - type-code:compiled-entry - (make-non-pointer-object - (+ (cdr (or (assq label compiler:label-bindings) - (error "Missing entry point" label))) - (primitive-datum compiler:code-vector)))))))) + (with-absolutely-no-interrupts + (lambda () + ((ucode-primitive &make-object) + type-code:compiled-entry + (make-non-pointer-object + (+ (cdr (or (assq label compiler:label-bindings) + (error "Missing entry point" label))) + (object-datum compiler:code-vector)))))))) compiler:entry-points))) (let ((label->expression (lambda (label) diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index 163d644b6..e2c7b6def 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.4 1988/04/15 02:10:18 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.5 1988/06/14 08:34:06 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -67,17 +67,14 @@ MIT in each case. |# (loop (cdr items) passed (cons (car items) failed)))))) (define (generate-label #!optional prefix) - (if (unassigned? prefix) (set! prefix 'LABEL)) + (if (default-object? prefix) (set! prefix 'LABEL)) (string->symbol (string-append (symbol->string (cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA) ((eq? prefix lambda-tag:let) 'LET) ((eq? prefix lambda-tag:make-environment) 'MAKE-ENVIRONMENT) - ((or (eq? prefix lambda-tag:shallow-fluid-let) - (eq? prefix lambda-tag:deep-fluid-let) - (eq? prefix lambda-tag:common-lisp-fluid-let)) - 'FLUID-LET) + ((eq? prefix lambda-tag:fluid-let) 'FLUID-LET) (else prefix))) "-" (number->string (generate-label-number) 10)))) @@ -89,37 +86,6 @@ MIT in each case. |# (set! *current-label-number* (1+ *current-label-number*)) number)) -(define (copy-alist alist) - (if (null? alist) - '() - (cons (cons (caar alist) (cdar alist)) - (copy-alist (cdr alist))))) - -(define (boolean=? x y) - (if x y (not y))) - -(define (warn message . irritants) - (newline) - (write-string "Warning: ") - (write-string message) - (for-each (lambda (irritant) - (write-string " ") - (write irritant)) - irritants)) - -(define (show-time thunk) - (let ((process-start (process-time-clock)) - (real-start (real-time-clock))) - (let ((value (thunk))) - (let ((process-end (process-time-clock)) - (real-end (real-time-clock))) - (newline) - (write-string "process time: ") - (write (- process-end process-start)) - (write-string "; real time: ") - (write (- real-end real-start))) - value))) - (define (list-filter-indices items indices) (let loop ((items items) (indices indices) (index 0)) (cond ((null? indices) '()) @@ -128,18 +94,6 @@ MIT in each case. |# (loop (cdr items) (cdr indices) (1+ index)))) (else (loop (cdr items) indices (1+ index)))))) - -(define (there-exists? items predicate) - (let loop ((items items)) - (and (not (null? items)) - (or (predicate (car items)) - (loop (cdr items)))))) - -(define (for-all? items predicate) - (let loop ((items items)) - (or (null? items) - (and (predicate (car items)) - (loop (cdr items)))))) (define (all-eq? items) (if (null? items) @@ -148,7 +102,7 @@ MIT in each case. |# (for-all? (cdr items) (let ((item (car items))) (lambda (item*) - (eq? item item)))))) + (eq? item item*)))))) (define (all-eq-map? items map) (if (null? items) @@ -195,7 +149,7 @@ MIT in each case. |# (let-syntax ((define-type-code (macro (var-name #!optional type-name) - (if (unassigned? type-name) (set! type-name var-name)) + (if (default-object? type-name) (set! type-name var-name)) `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: var-name) ',(microcode-type type-name))))) (define-type-code lambda) @@ -209,9 +163,9 @@ MIT in each case. |# (define-type-code compiled-entry)) (define (scode/procedure-type-code *lambda) - (cond ((primitive-type? type-code:lambda *lambda) + (cond ((object-type? type-code:lambda *lambda) type-code:procedure) - ((primitive-type? type-code:extended-lambda *lambda) + ((object-type? type-code:extended-lambda *lambda) type-code:extended-procedure) (else (error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda)))) @@ -235,9 +189,9 @@ MIT in each case. |# (= arity argument-count))))) (define (primitive-procedure-safe? object) - (and (primitive-type? (ucode-type primitive) object) + (and (object-type? (ucode-type primitive) object) (not (memq object unsafe-primitive-procedures)))) - + (define unsafe-primitive-procedures (let-syntax ((primitives (macro names @@ -284,14 +238,15 @@ MIT in each case. |# (make-named-tag "DELAY-LAMBDA")) (define (non-pointer-object? object) - (or (primitive-type? (ucode-type false) object) - (primitive-type? (ucode-type true) object) - (primitive-type? (ucode-type fixnum) object) - (primitive-type? (ucode-type character) object) - (primitive-type? (ucode-type unassigned) object) - (primitive-type? (ucode-type the-environment) object) - (primitive-type? (ucode-type manifest-nm-vector) object) - (primitive-type? (ucode-type manifest-special-nm-vector) object))) + ;; Any reason not to use `object/non-pointer?' here? -- cph + (or (object-type? (ucode-type false) object) + (object-type? (ucode-type true) object) + (object-type? (ucode-type fixnum) object) + (object-type? (ucode-type character) object) + (object-type? (ucode-type unassigned) object) + (object-type? (ucode-type the-environment) object) + (object-type? (ucode-type manifest-nm-vector) object) + (object-type? (ucode-type manifest-special-nm-vector) object))) (define (object-immutable? object) (or (non-pointer-object? object) @@ -308,14 +263,14 @@ MIT in each case. |# (list-transform-positive (map (lambda (name) (lexical-reference system-global-environment name)) - '(PRIMITIVE-TYPE PRIMITIVE-TYPE? + '(OBJECT-TYPE OBJECT-TYPE? EQ? NULL? PAIR? NUMBER? COMPLEX? REAL? RATIONAL? INTEGER? ZERO? POSITIVE? NEGATIVE? ODD? EVEN? EXACT? INEXACT? = < > <= >= MAX MIN + - * / 1+ -1+ ABS QUOTIENT REMAINDER MODULO INTEGER-DIVIDE GCD LCM FLOOR CEILING TRUNCATE ROUND EXP LOG EXPT SQRT SIN COS TAN ASIN ACOS ATAN)) - (access primitive-procedure? system-global-environment)) + (lexical-reference system-global-environment 'PRIMITIVE-PROCEDURE?)) (list (ucode-primitive &+) (ucode-primitive &-) (ucode-primitive &*) (ucode-primitive &/) diff --git a/v7/src/compiler/fggen/canon.scm b/v7/src/compiler/fggen/canon.scm index 072766a1e..61db428c1 100644 --- a/v7/src/compiler/fggen/canon.scm +++ b/v7/src/compiler/fggen/canon.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.1 1988/04/15 02:07:16 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/canon.scm,v 1.2 1988/06/14 08:36:01 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -260,21 +260,21 @@ HIGH: package bodies are treated as top level expressions to be ;;;; More hairy expressions -(define (canonicalize/definition expr bound context) - (scode/definition-components - expr - (lambda (name old-value) - (let ((value (canonicalize/expression old-value bound context))) - (if (memq context '(ONCE-ONLY ARBITRARY)) - (error "canonicalize/definition: unscanned definition" - definition) - (make-canout - (scode/make-combination - (ucode-primitive LOCAL-ASSIGNMENT) - (list (scode/make-variable environment-variable) - name - (canout-expr value))) - (canout-safe? value) true false)))))) +(define (canonicalize/definition expression bound context) + (scode/definition-components expression + (lambda (name value) + (let ((value (canonicalize/expression value bound context))) + (if (memq context '(ONCE-ONLY ARBITRARY)) + (error "canonicalize/definition: unscanned definition" + expression)) + (make-canout (scode/make-combination + (ucode-primitive local-assignment) + (list (scode/make-variable environment-variable) + name + (canout-expr value))) + (canout-safe? value) + true + false))))) (define (canonicalize/the-environment expr bound context) expr bound context ;; ignored @@ -317,7 +317,8 @@ HIGH: package bodies are treated as top level expressions to be (macro (value name) `(or (eq? ,value (ucode-primitive ,name)) (and (scode/absolute-reference? ,value) - (eq? (scode/absolute-reference-name ,value) ',name)))))) + (eq? (scode/absolute-reference-name ,value) + ',name)))))) (define (canonicalize/combination expr bound context) (scode/combination-components @@ -529,7 +530,7 @@ HIGH: package bodies are treated as top level expressions to be (define canonicalize/expression (let ((dispatch-vector - (make-vector number-of-microcode-types canonicalize/constant))) + (make-vector (microcode-type/code-limit) canonicalize/constant))) (let-syntax ((dispatch-entry @@ -576,5 +577,5 @@ HIGH: package bodies are treated as top level expressions to be (dispatch-entries (lambda lexpr extended-lambda) canonicalize/lambda) (dispatch-entries (sequence-2 sequence-3) canonicalize/sequence)) (named-lambda (canonicalize/expression expression bound context) - ((vector-ref dispatch-vector (primitive-type expression)) + ((vector-ref dispatch-vector (object-type expression)) expression bound context)))) \ No newline at end of file diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index 6d38cfa01..b98e527bf 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.5 1988/04/15 02:06:34 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.6 1988/06/14 08:36:12 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -369,7 +369,7 @@ MIT in each case. |# (map* actions scode/make-assignment names values))) (map (lambda (name) name ;; ignored - (scode/make-unassigned-object)) + (make-unassigned-reference-trap)) auxiliary))))))) (define (parse-procedure-body* names actions) @@ -723,7 +723,7 @@ MIT in each case. |# (define generate/expression (let ((dispatch-vector - (make-vector number-of-microcode-types generate/constant)) + (make-vector (microcode-type/code-limit) generate/constant)) (generate/combination (lambda (block continuation expression) (let ((operator (scode/combination-operator expression)) @@ -778,5 +778,5 @@ MIT in each case. |# generate/combination) (dispatch-entry comment generate/comment)) (named-lambda (generate/expression block continuation expression) - ((vector-ref dispatch-vector (primitive-type expression)) + ((vector-ref dispatch-vector (object-type expression)) block continuation expression)))) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/offset.scm b/v7/src/compiler/fgopt/offset.scm index 40b23bcec..b9f0712be 100644 --- a/v7/src/compiler/fgopt/offset.scm +++ b/v7/src/compiler/fgopt/offset.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.2 1988/01/02 16:45:01 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.3 1988/06/14 08:35:09 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -45,7 +45,7 @@ MIT in each case. |# (fluid-let ((*procedure-queue* (make-queue)) (*procedures* '())) (walk-node (expression-entry-node root-expression) 0) - (queue-map! *procedure-queue* + (queue-map!/unsafe *procedure-queue* (lambda (procedure) (if (procedure-continuation? procedure) (walk-node (continuation/entry-node procedure) @@ -75,9 +75,10 @@ MIT in each case. |# (define (enqueue-procedure! procedure) (set! *procedures* (cons procedure *procedures*)) - (enqueue! *procedure-queue* procedure)) + (enqueue!/unsafe *procedure-queue* procedure)) (define (walk-return operator operand offset) + offset (walk-rvalue operator) (let ((continuation (rvalue-known-value operator))) (if (not (and continuation diff --git a/v7/src/compiler/fgopt/order.scm b/v7/src/compiler/fgopt/order.scm index 21381b45f..7ced60ebc 100644 --- a/v7/src/compiler/fgopt/order.scm +++ b/v7/src/compiler/fgopt/order.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.4 1988/03/14 20:51:42 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.5 1988/06/14 08:35:17 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -194,7 +194,7 @@ MIT in each case. |# rest)) (define (push-unassigned block n rest) - (let ((unassigned (make-constant (scode/make-unassigned-object)))) + (let ((unassigned (make-constant (make-unassigned-reference-trap)))) (let loop ((n n) (rest rest)) (if (zero? n) rest diff --git a/v7/src/compiler/fgopt/simapp.scm b/v7/src/compiler/fgopt/simapp.scm index ad16763b2..8ead001dd 100644 --- a/v7/src/compiler/fgopt/simapp.scm +++ b/v7/src/compiler/fgopt/simapp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.2 1987/12/30 06:45:00 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.3 1988/06/14 08:35:26 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -59,6 +59,7 @@ MIT in each case. |# (define process-application-methods (make-method-table rvalue-types (lambda (old operator apply-operator) + old apply-operator (warn "Unapplicable operator" operator) operator))) @@ -119,7 +120,7 @@ MIT in each case. |# "Primitive called with wrong number of arguments" value number-supplied))) - ((not (scode/unassigned-object? value)) + ((not (unassigned-reference-trap? value)) (warn "Inapplicable operator" value))))) (else (warn "Inapplicable operator" operator))))))) @@ -138,7 +139,7 @@ MIT in each case. |# (map lvalue-initial-values (cdr lvalues))))) (define (lvalue-unassigned! lvalue) - (lvalue-connect! lvalue (make-constant (scode/make-unassigned-object)))) + (lvalue-connect! lvalue (make-constant (make-unassigned-reference-trap)))) (define-integrable (lvalue-connect! lvalue rvalue) (if (rvalue/reference? rvalue) diff --git a/v7/src/compiler/machines/bobcat/assmd.scm b/v7/src/compiler/machines/bobcat/assmd.scm index caf824501..3a99f0796 100644 --- a/v7/src/compiler/machines/bobcat/assmd.scm +++ b/v7/src/compiler/machines/bobcat/assmd.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.33 1988/02/17 19:12:01 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.34 1988/06/14 08:46:27 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,36 +36,24 @@ MIT in each case. |# (declare (usual-integrations)) -(declare - (integrate addressing-granularity - scheme-object-width - endianness - maximum-padding-length - maximum-block-offset - block-offset-width) - (integrate-operator block-offset->bit-string - instruction-initial-position - instruction-insert!)) - -(define addressing-granularity 8) -(define scheme-object-width 32) -(define endianness 'BIG) +(define-integrable addressing-granularity 8) +(define-integrable scheme-object-width 32) +(define-integrable endianness 'BIG) ;; Instruction length is always a multiple of 16 ;; Pad with ILLEGAL instructions -(define maximum-padding-length 16) +(define-integrable maximum-padding-length 16) (define padding-string (unsigned-integer->bit-string 16 #b0100101011111100)) ;; Block offsets are always words -(define maximum-block-offset (- (expt 2 16) 2)) -(define block-offset-width 16) +(define-integrable maximum-block-offset (- (expt 2 16) 2)) +(define-integrable block-offset-width 16) -(define (block-offset->bit-string offset start?) - (declare (integrate offset start?)) +(define-integrable (block-offset->bit-string offset start?) (unsigned-integer->bit-string block-offset-width (+ offset (if start? 0 1)))) @@ -81,20 +69,19 @@ MIT in each case. |# (define (object->bit-string object) (bit-string-append - (unsigned-integer->bit-string 24 (primitive-datum object)) - (unsigned-integer->bit-string 8 (primitive-type object)))) - + (unsigned-integer->bit-string 24 (object-datum object)) + (unsigned-integer->bit-string 8 (object-type object)))) + ;;; Machine dependent instruction order -(define (instruction-initial-position block) - (declare (integrate block)) +(define-integrable (instruction-initial-position block) (bit-string-length block)) (define (instruction-insert! bits block position receiver) - (declare (integrate block position receiver)) (let* ((l (bit-string-length bits)) (new-position (- position l))) (bit-substring-move-right! bits 0 l block new-position) (receiver new-position))) -(set! instruction-append bit-string-append-reversed) +(define instruction-append + bit-string-append-reversed) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/dassm1.scm b/v7/src/compiler/machines/bobcat/dassm1.scm index 8b04cb1ff..65c75d38b 100644 --- a/v7/src/compiler/machines/bobcat/dassm1.scm +++ b/v7/src/compiler/machines/bobcat/dassm1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.4 1988/04/15 02:15:37 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.5 1988/06/14 08:46:36 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -51,7 +51,7 @@ MIT in each case. |# (lambda () (let ((object (fasload (pathname-new-type pathname "com"))) (info (let ((pathname (pathname-new-type pathname "binf"))) - (and (if (unassigned? symbol-table?) + (and (if (default-object? symbol-table?) (file-exists? pathname) symbol-table?) (fasload pathname))))) @@ -86,14 +86,14 @@ MIT in each case. |# (let ((the-block (compiled-code-address->block entry))) (fluid-let ((disassembler/write-offsets? true) (disassembler/write-addresses? true) - (disassembler/base-address (primitive-datum the-block))) + (disassembler/base-address (object-datum the-block))) (newline) (newline) (disassembler/write-compiled-code-block the-block (->compiler-info (system-vector-ref the-block - (- (system-vector-size the-block) 2))))))) + (- (system-vector-length the-block) 2))))))) ;;; Operations exported from the disassembler package @@ -108,12 +108,12 @@ MIT in each case. |# (number->string (object-hash block) '(HEUR (RADIX D S)))) (write-string " ") (write-string - (number->string (primitive-datum block) '(HEUR (RADIX X E)))) + (number->string (object-datum block) '(HEUR (RADIX X E)))) (write-string "]")) (define (disassembler/write-compiled-code-block block info #!optional page?) (let ((symbol-table (compiler-info/symbol-table info))) - (if (or (unassigned? page?) page?) + (if (or (default-object? page?) page?) (begin (write-char #\page) (newline))) @@ -160,24 +160,20 @@ MIT in each case. |# (procedure offset instruction) (loop (instruction-stream))))))) -(define disassembler/write-constants-block) -(let () - -(set! disassembler/write-constants-block - (named-lambda (disassembler/write-constants-block block symbol-table) - (fluid-let ((*unparser-radix* 16)) - (let ((end (system-vector-size block))) - (let loop ((index (compiled-code-block/constants-start block))) - (if (< index end) - (begin - (disassembler/write-instruction - symbol-table - (compiled-code-block/index->offset index) - (lambda () - (write-constant block - symbol-table - (system-vector-ref block index)))) - (loop (1+ index))))))))) +(define (disassembler/write-constants-block block symbol-table) + (fluid-let ((*unparser-radix* 16)) + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/constants-start block))) + (if (< index end) + (begin + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-constant block + symbol-table + (system-vector-ref block index)))) + (loop (1+ index)))))))) (define (write-constant block symbol-table constant) (write-string (cdr (write-to-string constant 60))) @@ -188,7 +184,8 @@ MIT in each case. |# (begin (write-string " (") (let ((offset (compiled-code-address->offset expression))) - (let ((label (disassembler/lookup-symbol symbol-table offset))) + (let ((label + (disassembler/lookup-symbol symbol-table offset))) (if label (write-string (string-downcase label)) (write offset)))) @@ -199,7 +196,7 @@ MIT in each case. |# (write-string " in ") (write-block (compiled-code-address->block constant)) (write-string ")")) - (else false)))) + (else false))) (define (disassembler/write-instruction symbol-table offset write-instruction) (if symbol-table @@ -213,16 +210,13 @@ MIT in each case. |# (if disassembler/write-addresses? (begin (write-string - ((access unparse-number-heuristically number-unparser-package) - (+ offset disassembler/base-address) 16 false false)) + (number->string (+ offset disassembler/base-address) + '(HEUR (RADIX X S)))) (write-char #\Tab))) (if disassembler/write-offsets? (begin - (write-string - ((access unparse-number-heuristically number-unparser-package) - offset 16 false false)) - (write-char #\Tab))) + (write-string (number->string offset '(HEUR (RADIX X S)))) (write-char #\Tab))) (if symbol-table (write-string " ")) diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm index aa5340b6e..ecfafa068 100644 --- a/v7/src/compiler/machines/bobcat/dassm2.scm +++ b/v7/src/compiler/machines/bobcat/dassm2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.6 1988/05/19 01:47:37 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.7 1988/06/14 08:46:44 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -142,14 +142,11 @@ MIT in each case. |# (define (read-bits offset size-in-bits) (let ((word (bit-string-allocate size-in-bits))) - (with-interrupt-mask interrupt-mask-none - (lambda (old) - old ; ignored - (read-bits! (if *block - (+ (primitive-datum *block) offset) - offset) - 0 - word))) + (with-absolutely-no-interrupts + (lambda () + (read-bits! (if *block (+ (object-datum *block) offset) offset) + 0 + word))) word)) ;;;; Compiler specific information @@ -233,16 +230,15 @@ MIT in each case. |# (let ((entry (assq offset interpreter-register-assignments))) (if entry (cdr entry) - (let ((entry (assq word-offset interpreter-register-assignments))) - (and entry - (if (= residue 0) - (cdr entry) - `(,@(cdr entry) (,residue))))))))) - -(define (with-aligned-offset offset receiver) - (let ((q/r (integer-divide offset 4))) - (receiver (* (car q/r) 4) (cdr q/r)))) - + (let ((qr (integer-divide offset 2))) + (let ((entry + (assq (integer-divide-quotient qr) + interpreter-register-assignments))) + (and entry + (if (= (integer-divide-quotient qr) 0) + (cdr entry) + `(,@(cdr entry) + (,(integer-divide-quotient qr))))))))))) (define interpreter-register-pointer 6) @@ -276,7 +272,8 @@ MIT in each case. |# interrupt-continuation interrupt-ic-procedure interrupt-procedure interrupt-closure lookup safe-lookup set! access unassigned? unbound? define - reference-trap safe-reference-trap assignment-trap unassigned?-trap + reference-trap safe-reference-trap assignment-trap + unassigned?-trap &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?)))))) (define (make-pc-relative thunk) diff --git a/v7/src/compiler/machines/bobcat/inerly.scm b/v7/src/compiler/machines/bobcat/inerly.scm index 66df50537..2c66b6536 100644 --- a/v7/src/compiler/machines/bobcat/inerly.scm +++ b/v7/src/compiler/machines/bobcat/inerly.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/inerly.scm,v 1.4 1987/07/30 07:08:36 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/inerly.scm,v 1.5 1988/06/14 08:46:53 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -52,14 +52,15 @@ MIT in each case. |# (mapcan (lambda (rule) (apply (lambda (pattern variables categories expression) - (if (and (or (unassigned? modes) (eq-subset? modes categories)) - (or (unassigned? keywords) (not (memq (car pattern) keywords)))) + (if (and (or (default-object? modes) + (eq-subset? modes categories)) + (or (default-object? keywords) + (not (memq (car pattern) keywords)))) (list (early-make-rule pattern variables expression)) '())) rule)) early-ea-database))) - (define (eq-subset? s1 s2) (or (null? s1) (and (memq (car s1) s2) @@ -67,15 +68,16 @@ MIT in each case. |# (syntax-table-define early-syntax-table 'DEFINE-EA-TRANSFORMER (macro (name . restrictions) - `(define-early-transformer ',name (apply make-ea-transformer ',restrictions)))) + `(DEFINE-EARLY-TRANSFORMER ',name + (APPLY MAKE-EA-TRANSFORMER ',restrictions)))) (syntax-table-define early-syntax-table 'DEFINE-SYMBOL-TRANSFORMER (macro (name . assoc) - `(define-early-transformer ',name (make-symbol-transformer ',assoc)))) + `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-SYMBOL-TRANSFORMER ',assoc)))) (syntax-table-define early-syntax-table 'DEFINE-REG-LIST-TRANSFORMER (macro (name . assoc) - `(define-early-transformer ',name (make-bit-mask-transformer 16 ',assoc)))) + `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-BIT-MASK-TRANSFORMER 16 ',assoc)))) ;;;; Instruction and addressing mode macros @@ -136,13 +138,16 @@ MIT in each case. |# rules))))) (define (make-ea-selector-expander late-name index) - ((access scode->scode-expander package/expansion package/scode-optimizer) + (scode->scode-expander (lambda (operands if-expanded if-not-expanded) - (define (default) - (if-expanded (scode/make-combination (scode/make-variable late-name) - operands))) - - (let ((operand (car operands))) + if-not-expanded + (let ((default + (lambda () + (if-expanded + (scode/make-combination + (scode/make-variable late-name) + operands)))) + (operand (car operands))) (if (not (scode/combination? operand)) (default) (scode/combination-components operand @@ -163,7 +168,8 @@ MIT in each case. |# ;;;; Utilities -(define (make-position-independent-early pattern categories mode register . extension) +(define (make-position-independent-early pattern categories mode register + . extension) (let ((keyword (car pattern))) `(early-parse-rule ',pattern @@ -178,10 +184,10 @@ MIT in each case. |# ,(integer-syntaxer register 'UNSIGNED 3) (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL) (DECLARE (INTEGRATE IMMEDIATE-SIZE INSTRUCTION-TAIL)) + IMMEDIATE-SIZE ;ignore if not referenced ,(if (null? extension) 'INSTRUCTION-TAIL - `(CONS-SYNTAX ,(car extension) - INSTRUCTION-TAIL))) + `(CONS-SYNTAX ,(car extension) INSTRUCTION-TAIL))) ',categories))))))) (define (make-position-dependent-early pattern categories code-list) @@ -205,6 +211,7 @@ MIT in each case. |# ,(process-ea-field register) (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL) (DECLARE (INTEGRATE IMMEDIATE-SIZE INSTRUCTION-TAIL)) + IMMEDIATE-SIZE ;ignore if not referenced ,(if (null? extension) 'INSTRUCTION-TAIL `(CONS (LIST 'LABEL ,name) diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm index 00b3b429a..2f754d55c 100644 --- a/v7/src/compiler/machines/bobcat/insmac.scm +++ b/v7/src/compiler/machines/bobcat/insmac.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.123 1987/07/30 07:08:55 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.124 1988/06/14 08:47:02 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -38,11 +38,12 @@ MIT in each case. |# ;;;; Effective addressing -(define ea-database-name 'ea-database) +(define ea-database-name + 'EA-DATABASE) (syntax-table-define assembler-syntax-table 'DEFINE-EA-DATABASE (macro rules - `(define ,ea-database-name + `(DEFINE ,ea-database-name ,(compile-database rules (lambda (pattern actions) (if (null? (cddr actions)) @@ -83,6 +84,7 @@ MIT in each case. |# ,(integer-syntaxer mode 'UNSIGNED 3) ,(integer-syntaxer register 'UNSIGNED 3) (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL) + IMMEDIATE-SIZE ;ignore if not referenced ,(if (null? extension) 'INSTRUCTION-TAIL `(CONS-SYNTAX ,(car extension) INSTRUCTION-TAIL))) @@ -115,6 +117,7 @@ MIT in each case. |# ,(process-ea-field mode) ,(process-ea-field register) (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL) + IMMEDIATE-SIZE ;ignore if not referenced ,(if (null? extension) 'INSTRUCTION-TAIL `(CONS (LIST 'LABEL ,name) @@ -143,16 +146,17 @@ MIT in each case. |# `(define (,name expression) (let ((match-result (pattern-lookup ,ea-database-name expression))) (and match-result - ,(if (unassigned? categories) + ,(if (default-object? categories) `(match-result) `(let ((ea (match-result))) (and ,@(filter categories (lambda (cat exp) `(memq ',cat ,exp)) `(ea-categories ea)) - ,@(if (unassigned? keywords) + ,@(if (default-object? keywords) `() (filter keywords - (lambda (key exp) `(not (eq? ',key ,exp))) + (lambda (key exp) + `(not (eq? ',key ,exp))) `(ea-keyword ea))) ea)))))))) @@ -187,7 +191,7 @@ MIT in each case. |# (else (error "PARSE-INSTRUCTION: unknown expression" expression)))) - (if (or (unassigned? early?) (not early?)) + (if (not early?) (with-normal-selectors kernel) (with-early-selectors kernel))) @@ -203,16 +207,15 @@ MIT in each case. |# (cadr binding) (map (lambda (clause) (if (not (null? (cddr clause))) - (error "PARSE-GROWING-WORD: Extension found in clause" clause)) + (error "Extension found in clause" clause)) (expand-descriptors (cdadr clause) (lambda (instruction size src dst) (if (not (zero? (remainder size 16))) - (error "PARSE-GROWING-WORD: Instructions must be 16 bit multiples" - size) - `(,(collect-word instruction src dst '()) - ,size - ,@(car clause)))))) ; Range + (error "Instructions must be 16 bit multiples" size)) + `(,(collect-word instruction src dst '()) + ,size + ,@(car clause))))) ; Range (cddr expression)))))) ;;;; Fixed width instruction parsing diff --git a/v7/src/compiler/machines/bobcat/instr1.scm b/v7/src/compiler/machines/bobcat/instr1.scm index 0d39b6389..0652753e6 100644 --- a/v7/src/compiler/machines/bobcat/instr1.scm +++ b/v7/src/compiler/machines/bobcat/instr1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr1.scm,v 1.65 1987/07/30 07:09:17 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr1.scm,v 1.66 1988/06/14 08:47:12 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,11 +36,10 @@ MIT in each case. |# ;;; Originally from GJS (who did the hard part). (declare (usual-integrations)) - + ;;; Effective Address description database (define-ea-database - ((D (? r)) (DATA ALTERABLE) #b000 r) ((A (? r)) (ALTERABLE) #b001 r) diff --git a/v7/src/compiler/machines/bobcat/instr3.scm b/v7/src/compiler/machines/bobcat/instr3.scm index 6db2df6e4..7ffbbd569 100644 --- a/v7/src/compiler/machines/bobcat/instr3.scm +++ b/v7/src/compiler/machines/bobcat/instr3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.14 1987/07/30 07:09:49 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.15 1988/06/14 08:47:21 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -368,7 +368,8 @@ MIT in each case. |# (WORD (13 #b0100111001100) (3 rx)))) -;; MOV is a special case, separated for efficiency so there are less rules to try. +;; MOV is a special case, separated for efficiency so there are less +;; rules to try. (define-instruction MOV ((B (? sea ea-all-A) (? dea ea-d&a)) diff --git a/v7/src/compiler/machines/bobcat/insutl.scm b/v7/src/compiler/machines/bobcat/insutl.scm index be05d9b62..923cecd4c 100644 --- a/v7/src/compiler/machines/bobcat/insutl.scm +++ b/v7/src/compiler/machines/bobcat/insutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.5 1987/07/30 07:10:09 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.6 1988/06/14 08:47:30 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -170,7 +170,8 @@ MIT in each case. |# ((POST) (+ #b100 outer-displacement-size)) (else - (error "bad memory indirection-type" memory-indirection-type))))) + (error "bad memory indirection-type" + memory-indirection-type))))) (append-syntax! (output-displacement base-displacement-size base-displacement) (output-displacement outer-displacement-size outer-displacement)))) diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index 6971a72a7..9cf55f1c1 100644 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.8 1988/05/19 18:37:36 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.9 1988/06/14 08:47:38 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -93,9 +93,8 @@ MIT in each case. |# (define-export byte-offset-reference (make-offset-reference (quotient 8 addressing-granularity))) -;;; End PACKAGE -) +) (define (load-dnw n d) (cond ((zero? n) @@ -121,8 +120,8 @@ MIT in each case. |# (define (load-constant constant target) (if (non-pointer-object? constant) - (load-non-pointer (primitive-type constant) - (primitive-datum constant) + (load-non-pointer (object-type constant) + (object-datum constant) target) (INST (MOV L (@PCR ,(constant->label constant)) @@ -134,7 +133,7 @@ MIT in each case. |# (LAP (MOV L (@PCR ,(constant->label constant)) ,register-ref) - ,(remove-type-from-fixmum register-ref)))) + ,(remove-type-from-fixnum register-ref)))) (define (load-non-pointer type datum target) (cond ((not (zero? type)) @@ -231,7 +230,6 @@ MIT in each case. |# (define-integrable (register-effective-address? effective-address) (memq (lap:ea-keyword effective-address) '(A D))) - (package (indirect-reference! indirect-byte-reference!) (define ((make-indirect-reference offset-reference) register offset) @@ -250,9 +248,10 @@ MIT in each case. |# (define-export indirect-reference! (make-indirect-reference offset-reference)) + (define-export indirect-byte-reference! (make-indirect-reference byte-offset-reference)) -;;; End PACKAGE + ) (define (coerce->any register) @@ -280,10 +279,12 @@ MIT in each case. |# (let ((alias (register-alias register false))) (if alias (register-reference alias) - (indirect-char/ascii-reference! regnum:regs-pointer - (pseudo-register-offset register)))))) + (indirect-char/ascii-reference! + regnum:regs-pointer + (pseudo-register-offset register)))))) (define (code-object-label-initialize code-object) + code-object false) (define (generate-n-times n limit instruction-gen with-counter) @@ -301,16 +302,15 @@ MIT in each case. |# (LAP ,(instruction-gen) ,@(loop (-1+ n))))))) - -;;; this fixnum stuff will be moved to fixlap.scm after we can include +;;; This fixnum stuff will be moved to fixlap.scm after we can include ;;; fixlap.scm's dependencies in decls.scm (define (expression->fixnum-register! expression register) -;;; inputs: -;;; - an rtl expression -;;; - a register into which the produced code should place the -;;; result of evaluating the expression. -;;; output: the lap code to move the expression into the register. + ;; inputs: + ;; - an rtl expression + ;; - a register into which the produced code should place the + ;; result of evaluating the expression. + ;; output: the lap code to move the expression into the register. (let ((target (register-reference register))) (case (rtl:expression-type expression) ((REGISTER) @@ -318,88 +318,107 @@ MIT in each case. |# ((OFFSET) (LAP (MOV L - ,(indirect-reference! (rtl:register-number (rtl:offset-register expression)) - (rtl:offset-number expression)) + ,(indirect-reference! + (rtl:register-number (rtl:offset-register expression)) + (rtl:offset-number expression)) ,target))) ((CONSTANT) - (LAP (MOV L (& ,(fixnum-constant (rtl:constant-value expression))) ,target))) + (LAP (MOV L (& ,(fixnum-constant (rtl:constant-value expression))) + ,target))) ((UNASSIGNED) (LAP ,(load-non-pointer type-code:unassigned 0 target))) (else - (error "expression->fixnum-register!:Unknown expression type" (expression)))))) + (error "EXPRESSION->FIXNUM-REGISTER!: Unknown expression type" + expression))))) (define (remove-type-from-fixnum register-reference) -;;; input: a register reference of a register containing some fixnum -;;; with a type-code -;;; output: the lap code to get rid of the type-code and sign extend + ;; input: a register reference of a register containing some fixnum + ;; with a type-code + ;; output: the lap code to get rid of the type-code and sign extend (LAP (LS L L (& 8) ,register-reference) (AS R L (& 8) ,register-reference))) (define (put-type-in-ea type-code effective-address) -;;; inputs: -;;; - a type-code -;;; - an effective address -;;; output: the lap code to stick the type in the top byte of the register + ;; inputs: + ;; - a type-code + ;; - an effective address + ;; output: the lap code to stick the type in the top byte of the register (if (register-effective-address? effective-address) (LAP (AND L ,mask-reference ,effective-address) (OR L (& ,(make-non-pointer-literal type-code 0)) - ,effective-address)) + ,effective-address)) (INST (MOV B (& ,type-code) ,effective-address)))) - + (define (fixnum-constant x) (if (<= (abs x) maximum-positive-fixnum) x (error "Not a fixnum" x))) (define (fixnum-expression? expression) -;;; input: an rtl expression -;;; output: true, if the expression is of some fixnum type. false, otherwise + ;; input: an rtl expression + ;; output: true, if the expression is of some fixnum type. false, otherwise (eq? (rtl:expression-type expression) 'FIXNUM)) (define (commutative-op? op) -;;; input: An operator -;;; output: True, if the op is commutative. + ;; input: An operator + ;; output: True, if the op is commutative. (memq op '(PLUS-FIXNUM MULTIPLY-FIXNUM))) - + (define (fixnum-do-2-args! operator operand-1 operand-2 register) -;;; inputs: -;;; - a fixnum operator -;;; - an operand -;;; - another operand -;;; - the register into which the generated code should place the -;;; result of the calculation -;;; output: the lap code to calculate the fixnum expression -;;; -;;; Note that the final placement of the type-code in the result is -;;; not done here. It must be done in the caller. + ;; inputs: + ;; - a fixnum operator + ;; - an operand + ;; - another operand + ;; - the register into which the generated code should place the + ;; result of the calculation + ;; output: the lap code to calculate the fixnum expression + ;; + ;; Note that the final placement of the type-code in the result is + ;; not done here. It must be done in the caller. (let ((finish - (lambda (operand-1 operand-2) - (LAP ,(expression->fixnum-register! operand-1 register) - ,((fixnum-code-gen operator) operand-2 register))))) + (lambda (operand-1 operand-2) + (LAP ,(expression->fixnum-register! operand-1 register) + ,((fixnum-code-gen operator) operand-2 register))))) (if (and (commutative-op? operator) (rtl:constant? operand-1)) (finish operand-2 operand-1) (finish operand-1 operand-2)))) - (define (fixnum-do-1-arg! operator operand register) -;;; inputs: -;;; - a fixnum operator -;;; - an operand -;;; - the register into which the generated code should place the -;;; result of the calculation -;;; output: the lap code to calculate the fixnum expression -;;; -;;; Note that the final placement of the type-code in the result is -;;; not done here. It must be done in the caller. + ;; inputs: + ;; - a fixnum operator + ;; - an operand + ;; - the register into which the generated code should place the + ;; result of the calculation + ;; output: the lap code to calculate the fixnum expression + ;; + ;; Note that the final placement of the type-code in the result is + ;; not done here. It must be done in the caller. (LAP ,(expression->fixnum-register! operand register) ,((fixnum-code-gen operator) register))) +(define (fixnum-code-gen operator) + ;; input: a fixnum operator + ;; output: a procedure with the following behavior + ;; inputs: + ;; - an operand to a fixnum expression + ;; - a register which already should contain the other + ;; operand to the fixnum expression + ;; output: the lap code to apply the operator to the + ;; operand and register, putting the result in the register + (case operator + ((PLUS-FIXNUM) fixnum-plus-gen) + ((MULTIPLY-FIXNUM) fixnum-multiply-gen) + ((MINUS-FIXNUM) fixnum-minus-gen) + ((ONE-PLUS-FIXNUM) fixnum-one-plus-gen) + ((MINUS-ONE-PLUS-FIXNUM) fixnum-minus-one-plus-gen) + (else (error "Unknown operator" operator)))) + (define fixnum-plus-gen -;;; inputs: -;;; - an rtl expression representing the addend -;;; - a register to which the addend will be added -;;; output: lap code to add the addend to the register + ;; inputs: + ;; - an rtl expression representing the addend + ;; - a register to which the addend will be added + ;; output: lap code to add the addend to the register (lambda (addend register) (let ((target (register-reference register))) (case (rtl:expression-type addend) @@ -407,10 +426,10 @@ MIT in each case. |# (INST (ADD L ,(coerce->any (rtl:register-number addend)) ,target))) ((OFFSET) (INST (ADD L - ,(indirect-reference! - (rtl:register-number (rtl:offset-register addend)) - (rtl:offset-number addend)) - ,target))) + ,(indirect-reference! + (rtl:register-number (rtl:offset-register addend)) + (rtl:offset-number addend)) + ,target))) ((CONSTANT) (let ((constant (fixnum-constant (rtl:constant-value addend)))) (if (and (<= constant 8) (>= constant 1)) @@ -422,52 +441,55 @@ MIT in each case. |# (error "fixnum-plus-gen: Unknown expression type" addend)))))) (define fixnum-multiply-gen -;;; inputs: -;;; - an rtl expression representing the multiplicand -;;; - a register to which the multiplicand will be multiplied -;;; output: lap code to add the multiplicand to the register + ;; inputs: + ;; - an rtl expression representing the multiplicand + ;; - a register to which the multiplicand will be multiplied + ;; output: lap code to add the multiplicand to the register (lambda (multiplicand register) (let ((target (register-reference register))) (case (rtl:expression-type multiplicand) ((REGISTER) - (INST (MUL S L ,(coerce->any (rtl:register-number multiplicand)) ,target))) + (INST (MUL S L ,(coerce->any (rtl:register-number multiplicand)) + ,target))) ((OFFSET) (INST (MUL S L - ,(indirect-reference! - (rtl:register-number (rtl:offset-register multiplicand)) - (rtl:offset-number multiplicand)) - ,target))) + ,(indirect-reference! + (rtl:register-number (rtl:offset-register multiplicand)) + (rtl:offset-number multiplicand)) + ,target))) ((CONSTANT) (let* ((constant (fixnum-constant (rtl:constant-value multiplicand))) - (power-of-2? - (let loop ((power 1) (exponent 0)) - (cond ((< constant power) false) - ((= constant power) exponent) - (else (loop (* 2 power) (1+ exponent))))))) + (power-of-2? + (let loop ((power 1) (exponent 0)) + (cond ((< constant power) false) + ((= constant power) exponent) + (else (loop (* 2 power) (1+ exponent))))))) (if power-of-2? (INST (AS L L (& ,power-of-2?) ,target)) (INST (MUL S L (& ,(fixnum-constant constant)) ,target))))) ((UNASSIGNED) ; this needs to be looked at (LAP ,(load-non-pointer type-code:unassigned 0 target))) (else - (error "fixnum-multiply-gen: Unknown expression type" multiplicand)))))) - + (error "FIXNUM-MULTIPLY-GEN: Unknown expression type" + multiplicand)))))) + (define fixnum-minus-gen -;;; inputs: -;;; - an rtl expression representing the subtrahend -;;; - a register to which the subtrahend will be subtracted -;;; output: lap code to add the subtrahend to the register + ;; inputs: + ;; - an rtl expression representing the subtrahend + ;; - a register to which the subtrahend will be subtracted + ;; output: lap code to add the subtrahend to the register (lambda (subtrahend register) (let ((target (register-reference register))) (case (rtl:expression-type subtrahend) ((REGISTER) - (INST (SUB L ,(coerce->any (rtl:register-number subtrahend)) ,target))) + (INST (SUB L ,(coerce->any (rtl:register-number subtrahend)) + ,target))) ((OFFSET) (INST (SUB L - ,(indirect-reference! - (rtl:register-number (rtl:offset-register subtrahend)) - (rtl:offset-number subtrahend)) - ,target))) + ,(indirect-reference! + (rtl:register-number (rtl:offset-register subtrahend)) + (rtl:offset-number subtrahend)) + ,target))) ((CONSTANT) (let ((constant (fixnum-constant (rtl:constant-value subtrahend)))) (if (and (<= constant 8) (>= constant 1)) @@ -479,42 +501,25 @@ MIT in each case. |# (error "fixnum-minus-gen: Unknown expression type" subtrahend)))))) (define fixnum-one-plus-gen -;;; inputs: -;;; - a register to be incremented -;;; output: lap code to add one to the register + ;; inputs: + ;; - a register to be incremented + ;; output: lap code to add one to the register (lambda (register) (INST (ADDQ L (& 1) ,(register-reference register))))) (define fixnum-minus-one-plus-gen -;;; inputs: -;;; - a register to be deccremented -;;; output: lap code to subtract one from the register + ;; inputs: + ;; - a register to be deccremented + ;; output: lap code to subtract one from the register (lambda (register) (INST (SUBQ L (& 1) ,(register-reference register))))) - -(define (fixnum-code-gen operator) -;;; input: a fixnum operator -;;; output: a procedure with the following behavior -;;; inputs: -;;; - an operand to a fixnum expression -;;; - a register which already should contain the other -;;; operand to the fixnum expression -;;; output: the lap code to apply the operator to the -;;; operand and register, putting the result in the register - (case operator - ((PLUS-FIXNUM) fixnum-plus-gen) - ((MULTIPLY-FIXNUM) fixnum-multiply-gen) - ((MINUS-FIXNUM) fixnum-minus-gen) - ((ONE-PLUS-FIXNUM) fixnum-one-plus-gen) - ((MINUS-ONE-PLUS-FIXNUM) fixnum-minus-one-plus-gen) - )) ;;;; OBJECT->DATUM rules - Mhwu ;;; Similar to fixnum rules, but no sign extension (define (load-constant-datum constant register-ref) (if (non-pointer-object? constant) - (INST (MOV L (& ,(primitive-datum constant)) ,register-ref)) + (INST (MOV L (& ,(object-datum constant)) ,register-ref)) (LAP (MOV L (@PCR ,(constant->label constant)) ,register-ref) @@ -532,14 +537,14 @@ MIT in each case. |# (let ((ascii (char->ascii character))) (if (< ascii 128) ascii (- ascii 256)))) -;;; This code uses a temporary register because right now the register -;;; allocator thinks that it could use the same register for the target -;;; and source, while what we want to happen is to first clear the target -;;; and then move from source to target. -;;; Optimal Code: (CLR L ,target-ref) -;;; (MOV B ,source ,target) -;;; source-register is passed in to check for this. Yuck. (define (byte-offset->register source source-reg target) + ;; This code uses a temporary register because right now the register + ;; allocator thinks that it could use the same register for the target + ;; and source, while what we want to happen is to first clear the target + ;; and then move from source to target. + ;; Optimal Code: (CLR L ,target-ref) + ;; (MOV B ,source ,target) + ;; source-register is passed in to check for this. Yuck. (delete-dead-registers!) (let* ((temp-ref (register-reference (allocate-temporary-register! 'DATA))) (target (allocate-alias-register! target 'DATA))) @@ -555,6 +560,8 @@ MIT in each case. |# register (register-alias register false))) +;;;; Registers/Entries + (define-integrable (data-register? register) (< register 8)) @@ -564,17 +571,16 @@ MIT in each case. |# (define-integrable (lap:ea-keyword expression) (car expression)) -(define-export (lap:make-label-statement label) +(define (lap:make-label-statement label) (INST (LABEL ,label))) -(define-export (lap:make-unconditional-branch label) +(define (lap:make-unconditional-branch label) (INST (BRA (@PCR ,label)))) -(define-export (lap:make-entry-point label block-start-label) +(define (lap:make-entry-point label block-start-label) + block-start-label (LAP (ENTRY-POINT ,label) ,@(make-external-label expression-code-word label))) - -;;;; Registers/Entries (let-syntax ((define-entries (macro (start . names) diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index acdca6758..a54f8742b 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.9 1988/05/19 15:32:53 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.10 1988/06/14 08:48:01 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -56,6 +56,34 @@ MIT in each case. |# (define closure-block-first-offset 2) +(define (rtl:machine-register? rtl-register) + (case rtl-register + ((STACK-POINTER) (interpreter-stack-pointer)) + ((DYNAMIC-LINK) (interpreter-dynamic-link)) + ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) + ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) + (interpreter-register:cache-reference)) + ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) + (interpreter-register:cache-unassigned?)) + ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup)) + ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?)) + ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?)) + (else false))) + +(define (rtl:interpreter-register? rtl-register) + (case rtl-register + ((MEMORY-TOP) 0) + ((STACK-GUARD) 1) + ((VALUE) 2) + ((ENVIRONMENT) 3) + ((TEMPORARY) 4) + ((INTERPRETER-CALL-RESULT:ENCLOSE) 5) + (else false))) + +(define (rtl:interpreter-register->offset locative) + (or (rtl:interpreter-register? locative) + (error "Unknown register type" locative))) + (define (rtl:expression-cost expression) ;; Returns an estimate of the cost of evaluating the expression. ;; For simplicity, we try to estimate the actual number of cycles @@ -111,7 +139,8 @@ MIT in each case. |# ;; move.l reg,reg = 3 ;; sub.l reg,reg = 3 ((MINUS-FIXNUM) 6) - (else (error "rtl:expression-cost - unknown fixnum operator" expression)))) + (else + (error "RTL:EXPRESSION-COST: unknown fixnum operator" expression)))) ((FIXNUM-1-ARG) (case (rtl:fixnum-1-arg-operator expression) ;; move.l reg,reg = 3 @@ -120,40 +149,13 @@ MIT in each case. |# ;; move.l reg,reg = 3 ;; subq.l #1,reg = 3 ((MINUS-ONE-PLUS-FIXNUM) 6) - (else (error "rtl:expression-cost - unknown fixnum operator" expression)))) + (else + (error "RTL:EXPRESSION-COST: unknown fixnum operator" expression)))) ;; The following are preliminary. Check with Jinx (mhwu) ((CHAR->ASCII) 4) ((BYTE-OFFSET) 12) (else (error "Unknown expression type" expression)))) -(define (rtl:machine-register? rtl-register) - (case rtl-register - ((STACK-POINTER) (interpreter-stack-pointer)) - ((DYNAMIC-LINK) (interpreter-dynamic-link)) - ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) - ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) - (interpreter-register:cache-reference)) - ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) - (interpreter-register:cache-unassigned?)) - ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup)) - ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?)) - ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?)) - (else false))) - -(define (rtl:interpreter-register? rtl-register) - (case rtl-register - ((MEMORY-TOP) 0) - ((STACK-GUARD) 1) - ((VALUE) 2) - ((ENVIRONMENT) 3) - ((TEMPORARY) 4) - ((INTERPRETER-CALL-RESULT:ENCLOSE) 5) - (else false))) - -(define (rtl:interpreter-register->offset locative) - (or (rtl:interpreter-register? locative) - (error "Unknown register type" locative))) - (define-integrable d0 0) (define-integrable d1 1) (define-integrable d2 2) @@ -254,10 +256,4 @@ MIT in each case. |# (rtl:make-machine-register regnum:dynamic-link)) (define-integrable (interpreter-dynamic-link? register) - (= (rtl:register-number register) regnum:dynamic-link)) - -;;;; Exports from machines/lapgen - -(define lap:make-label-statement) -(define lap:make-unconditional-branch) -(define lap:make-entry-point) \ No newline at end of file + (= (rtl:register-number register) regnum:dynamic-link)) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 3335c5698..d2c9e7bb3 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.16 1988/06/03 15:14:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.17 1988/06/14 08:48:12 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -32,187 +32,13 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Compiler Make File for MC68020 +;;;; Compiler: System Construction (declare (usual-integrations)) - -(load "base/pkging.bin" system-global-environment) - -(in-package compiler-package - - (define compiler-system - (make-environment - (define :name "Liar (Bobcat 68020)") - (define :version 4) - (define :modification 16) - (define :files) - - (define :rcs-header - - "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.16 1988/06/03 15:14:13 cph Exp $" - - ) - (define :files-lists - (list - (cons system-global-environment - '("base/pbs.bin" ;bit-string read/write syntax - "etc/direct.bin" ;directory reader - "etc/butils.bin" ;system building utilities - )) - - (cons compiler-package - '("base/switch.bin" ;compiler option switches - "base/macros.bin" ;compiler syntax - "base/hashtb.com" ;hash tables - )) - - (cons decls-package - '("base/decls.com" ;declarations - )) - - (cons compiler-package - '("base/object.com" ;tagged object support - "base/enumer.com" ;enumerations - "base/queue.com" ;queue abstraction - "base/sets.com" ;set abstraction - "base/mvalue.com" ;multiple-value support - "base/scode.com" ;SCode abstraction - "base/pmlook.com" ;pattern matcher: lookup - "base/pmpars.com" ;pattern matcher: parser - - "machines/bobcat/machin.com" ;machine dependent stuff - "base/toplev.com" ;top level - "base/debug.com" ;debugging support - "base/utils.com" ;odds and ends - - "base/cfg1.com" ;control flow graph - "base/cfg2.com" - "base/cfg3.com" - "base/ctypes.com" ;CFG datatypes - - "base/rvalue.com" ;Right hand values - "base/lvalue.com" ;Left hand values - "base/blocks.com" ;rvalue: blocks - "base/proced.com" ;rvalue: procedures - "base/contin.com" ;rvalue: continuations - - "base/subprb.com" ;subproblem datatype - - "rtlbase/rgraph.com" ;program graph abstraction - "rtlbase/rtlty1.com" ;RTL: type definitions - "rtlbase/rtlty2.com" ;RTL: type definitions - "rtlbase/rtlexp.com" ;RTL: expression operations - "rtlbase/rtlcon.com" ;RTL: complex constructors - "rtlbase/rtlreg.com" ;RTL: registers - "rtlbase/rtlcfg.com" ;RTL: CFG types - "rtlbase/rtlobj.com" ;RTL: CFG objects - "rtlbase/regset.com" ;RTL: register sets - - "base/infutl.com" ;utilities for info generation, shared - "back/insseq.com" ;LAP instruction sequences - "machines/bobcat/dassm1.com" ;disassembler - )) - - (cons disassembler-package - '("machines/bobcat/dassm2.com" ;disassembler - "machines/bobcat/dassm3.com" - )) - - (cons fg-generator-package - '("fggen/canon.com" ;SCode canonicalizer - "fggen/fggen.com" ;SCode->flow-graph converter - "fggen/declar.com" ;Declaration handling - )) - - (cons fg-optimizer-package - '("fgopt/simapp.com" ;simulate applications - "fgopt/outer.com" ;outer analysis - "fgopt/folcon.com" ;fold constants - "fgopt/operan.com" ;operator analysis - "fgopt/closan.com" ;closure analysis - "fgopt/blktyp.com" ;environment type assignment - "fgopt/contan.com" ;continuation analysis - "fgopt/simple.com" ;simplicity analysis - "fgopt/order.com" ;subproblem ordering - "fgopt/conect.com" ;connectivity analysis - "fgopt/desenv.com" ;environment design - "fgopt/offset.com" ;compute node offsets - )) - - (cons rtl-generator-package - '("rtlgen/rtlgen.com" ;RTL generator - "rtlgen/rgproc.com" ;procedure headers - "rtlgen/rgstmt.com" ;statements - "rtlgen/rgrval.com" ;rvalues - "rtlgen/rgcomb.com" ;combinations - "rtlgen/rgretn.com" ;returns - "rtlgen/fndblk.com" ;find blocks and variables - "rtlgen/opncod.com" ;open-coded primitives - "machines/bobcat/rgspcm.com" ;special close-coded primitives - "rtlbase/rtline.com" ;linearizer - )) - - (cons rtl-cse-package - '("rtlopt/rcse1.com" ;RTL common subexpression eliminator - "rtlopt/rcse2.com" - "rtlopt/rcseep.com" ;CSE expression predicates - "rtlopt/rcseht.com" ;CSE hash table - "rtlopt/rcserq.com" ;CSE register/quantity abstractions - "rtlopt/rcsesr.com" ;CSE stack references - )) - - (cons rtl-optimizer-package - '("rtlopt/rlife.com" ;RTL register lifetime analyzer - "rtlopt/rdeath.com" ;RTL code compression - "rtlopt/rdebug.com" ;RTL optimizer debugging output - "rtlopt/ralloc.com" ;RTL register allocation - )) - - (cons debugging-information-package - '("base/infnew.com" ;debugging information generation - )) - - (cons lap-syntax-package - '("back/lapgn1.com" ;LAP generator. - "back/lapgn2.com" - "back/lapgn3.com" - "back/regmap.com" ;Hardware register allocator. - "back/linear.com" ;LAP linearizer. - "machines/bobcat/lapgen.com" ;code generation rules. - "machines/bobcat/rules1.com" - "machines/bobcat/rules2.com" - "machines/bobcat/rules3.com" - "machines/bobcat/rules4.com" - "back/syntax.com" ;Generic syntax phase - "machines/bobcat/coerce.com" ;Coercions: integer -> bit string - "back/asmmac.com" ;Macros for hairy syntax - "machines/bobcat/insmac.com" ;Macros for hairy syntax - "machines/bobcat/insutl.com" ;Utilities for instructions - "machines/bobcat/instr1.com" ;68000 Effective addressing - "machines/bobcat/instr2.com" ;68000 Instructions - "machines/bobcat/instr3.com" ; " " - "machines/bobcat/instr4.com" ; " " - )) - - (cons bit-package - '("machines/bobcat/assmd.com" ;Machine dependent - "back/symtab.com" ;Symbol tables - "back/bitutl.com" ;Assembly blocks - "back/bittop.com" ;Assembler top level - )) - - )) - - )) - - (load-system! compiler-system)) +(package/system-loader "comp" '() 'QUERY) (for-each (lambda (name) - (local-assignment system-global-environment - name - (lexical-reference compiler-package name))) - '(CF - COMPILE-BIN-FILE - COMPILE-PROCEDURE - COMPILER:RESET! - COMPILER:WRITE-LAP-FILE)) \ No newline at end of file + ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) + '((COMPILER MACROS) + (COMPILER DECLARATIONS))) +(add-system! (make-system "Liar" 14 17 '())) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm index 4a92f5f57..ebd445a0d 100644 --- a/v7/src/compiler/machines/bobcat/rules1.scm +++ b/v7/src/compiler/machines/bobcat/rules1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.12 1988/05/28 04:11:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.13 1988/06/14 08:48:22 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -139,6 +139,12 @@ MIT in each case. |# (move-to-alias-register! source 'DATA target) (LAP)) +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) + (QUALIFIER (pseudo-register? target)) + (let ((target (move-to-alias-register! source 'DATA target))) + (LAP (RO L L (& 8) ,target)))) + (define-rule statement (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? source)))) (QUALIFIER (pseudo-register? target)) @@ -153,19 +159,65 @@ MIT in each case. |# (LAP (AND L ,mask-reference ,target)))) (define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset)))) + (ASSIGN (REGISTER (? target)) + (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset)))) (QUALIFIER (pseudo-register? target)) (let ((source (indirect-reference! address offset))) (delete-dead-registers!) - (let ((target-ref (register-reference (allocate-alias-register! target 'DATA)))) + (let ((target-ref + (register-reference (allocate-alias-register! target 'DATA)))) (LAP (MOV L ,source ,target-ref))))) (define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? datum)))) (QUALIFIER (pseudo-register? target)) - (let ((target (move-to-alias-register! source 'DATA target))) - (LAP (RO L L (& 8) ,target)))) + (delete-dead-registers!) + (let ((target-ref + (register-reference (allocate-alias-register! target 'DATA)))) + (load-constant-datum datum target-ref))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) + (QUALIFIER (pseudo-register? target)) + (let ((target-ref (move-to-alias-register! source 'DATA target))) + (LAP ,(scheme-object->datum target-ref)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset)))) + (QUALIFIER (pseudo-register? target)) + (let ((source (indirect-reference! address offset))) + (delete-dead-registers!) + (let ((target-ref + (register-reference (allocate-alias-register! target 'DATA)))) + (LAP (MOV L ,source ,target-ref) + ,(scheme-object->datum target-ref))))) +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? datum)))) + (QUALIFIER (pseudo-register? target)) + (delete-dead-registers!) + (let ((target-ref + (register-reference (allocate-alias-register! target 'DATA)))) + (load-fixnum-constant datum target-ref))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source)))) + (QUALIFIER (pseudo-register? target)) + (let ((target-ref (move-to-alias-register! source 'DATA target))) + (LAP ,(remove-type-from-fixnum target-ref)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset)))) + (QUALIFIER (pseudo-register? target)) + (let ((source (indirect-reference! address offset))) + (delete-dead-registers!) + (let ((target-ref + (register-reference (allocate-alias-register! target 'DATA)))) + (LAP (MOV L ,source ,target-ref) + ,(remove-type-from-fixnum target-ref))))) + (define-rule statement (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) (QUALIFIER (pseudo-register? target)) @@ -211,38 +263,18 @@ MIT in each case. |# (delete-dead-registers!) (let ((target* (coerce->any target))) (if (register-effective-address? target*) - (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label))) - ,temp) - (MOV L ,temp ,reg:temp) - (MOV B (& ,type) ,reg:temp) - (MOV L ,reg:temp ,target*)) - (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label))) - ,temp) - (MOV L ,temp ,target*) - (MOV B (& ,type) ,target*)))))) + (LAP + (LEA (@PCR ,(rtl-procedure/external-label (label->object label))) + ,temp) + (MOV L ,temp ,reg:temp) + (MOV B (& ,type) ,reg:temp) + (MOV L ,reg:temp ,target*)) + (LAP + (LEA (@PCR ,(rtl-procedure/external-label (label->object label))) + ,temp) + (MOV L ,temp ,target*) + (MOV B (& ,type) ,target*)))))) -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? datum)))) - (QUALIFIER (pseudo-register? target)) - (delete-dead-registers!) - (let ((target-ref (register-reference (allocate-alias-register! target 'DATA)))) - (load-fixnum-constant datum target-ref))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (let ((target-ref (move-to-alias-register! source 'DATA target))) - (LAP ,(remove-type-from-fixnum target-ref)))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset)))) - (QUALIFIER (pseudo-register? target)) - (let ((source (indirect-reference! address offset))) - (delete-dead-registers!) - (let ((target-ref (register-reference (allocate-alias-register! target 'DATA)))) - (LAP (MOV L ,source ,target-ref) - ,(remove-type-from-fixnum target-ref))))) - (define-rule statement (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source)))) (QUALIFIER (pseudo-register? target)) @@ -257,7 +289,7 @@ MIT in each case. |# (let ((temp-reg (allocate-temporary-register! 'DATA))) (let ((operation (LAP ,@(fixnum-do-2-args! operator operand1 operand2 temp-reg) - ,@(put-type-in-ea (ucode fixnum) temp-reg)))) + ,@(put-type-in-ea (ucode-type fixnum) temp-reg)))) (delete-dead-registers!) (add-pseudo-register-alias! target temp-reg false) operation))) @@ -270,7 +302,7 @@ MIT in each case. |# (let ((temp-reg (allocate-temporary-register! 'DATA))) (let ((operation (LAP ,@(fixnum-do-1-arg! operator operand temp-reg) - ,@(put-type-in-ea (ucode fixnum) temp-reg)))) + ,@(put-type-in-ea (ucode-type fixnum) temp-reg)))) (delete-dead-registers!) (add-pseudo-register-alias! target temp-reg false) operation))) @@ -297,34 +329,6 @@ MIT in each case. |# (add-pseudo-register-alias! target temp-reg false) operation))) -;;;; OBJECT->DATUM rules. Assignment is always to a register. - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? datum)))) - (QUALIFIER (pseudo-register? target)) - (delete-dead-registers!) - (let ((target-ref - (register-reference (allocate-alias-register! target 'DATA)))) - (load-constant-datum datum target-ref))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) - (QUALIFIER (pseudo-register? target)) - (let ((target-ref (move-to-alias-register! source 'DATA target))) - (LAP ,(scheme-object->datum target-ref)))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) - (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset)))) - (QUALIFIER (pseudo-register? target)) - (let ((source (indirect-reference! address offset))) - (delete-dead-registers!) - (let ((target-ref - (register-reference (allocate-alias-register! target 'DATA)))) - (LAP (MOV L ,source ,target-ref) - ,(scheme-object->datum target-ref))))) - - ;;;; CHAR->ASCII/BYTE-OFFSET (define-rule statement @@ -367,7 +371,8 @@ MIT in each case. |# ,(indirect-byte-reference! address offset)))) (define-rule statement - (ASSIGN (REGISTER (? target)) (BYTE-OFFSET (REGISTER (? address)) (? offset))) + (ASSIGN (REGISTER (? target)) + (BYTE-OFFSET (REGISTER (? address)) (? offset))) (QUALIFIER (pseudo-register? target)) (byte-offset->register (indirect-byte-reference! address offset) (indirect-register address) @@ -390,7 +395,9 @@ MIT in each case. |# (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (UNASSIGNED)) - (LAP ,(load-non-pointer (ucode-type unassigned) 0 (indirect-reference! a n)))) + (LAP ,(load-non-pointer (ucode-type unassigned) + 0 + (indirect-reference! a n)))) (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) diff --git a/v7/src/compiler/machines/bobcat/rules2.scm b/v7/src/compiler/machines/bobcat/rules2.scm index 777943931..909ae421a 100644 --- a/v7/src/compiler/machines/bobcat/rules2.scm +++ b/v7/src/compiler/machines/bobcat/rules2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.3 1988/04/22 16:21:29 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.4 1988/06/14 08:48:37 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -53,8 +53,9 @@ MIT in each case. |# (TYPE-TEST (REGISTER (? register)) (? type)) (QUALIFIER (pseudo-register? register)) (set-standard-branches! 'EQ) - (LAP ,(test-byte type - (register-reference (load-alias-register! register 'DATA))))) + (LAP ,(test-byte + type + (register-reference (load-alias-register! register 'DATA))))) (define-rule predicate (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type)) @@ -85,8 +86,8 @@ MIT in each case. |# (define (eq-test/constant*register constant register) (set-standard-branches! 'EQ) (if (non-pointer-object? constant) - (LAP ,(test-non-pointer (primitive-type constant) - (primitive-datum constant) + (LAP ,(test-non-pointer (object-type constant) + (object-datum constant) (coerce->any register))) (LAP (CMP L (@PCR ,(constant->label constant)) ,(coerce->machine-register register))))) @@ -94,8 +95,8 @@ MIT in each case. |# (define (eq-test/constant*memory constant memory-reference) (set-standard-branches! 'EQ) (if (non-pointer-object? constant) - (LAP ,(test-non-pointer (primitive-type constant) - (primitive-datum constant) + (LAP ,(test-non-pointer (object-type constant) + (object-datum constant) memory-reference)) (let ((temp (reference-temporary-register! false))) (LAP (MOV L ,memory-reference ,temp) @@ -208,14 +209,14 @@ MIT in each case. |# (define (fixnum-pred/constant*register constant register cc) (set-standard-branches! cc) (if (non-pointer-object? constant) - (LAP (CMPI L (& ,(primitive-datum constant)) ,(coerce->any register))) + (LAP (CMPI L (& ,(object-datum constant)) ,(coerce->any register))) (LAP (CMP L (@PCR ,(constant->label constant)) ,(coerce->machine-register register))))) (define (fixnum-pred/constant*memory constant memory-reference cc) (set-standard-branches! cc) (if (non-pointer-object? constant) - (LAP (CMPI L (& ,(primitive-datum constant)) ,memory-reference)) + (LAP (CMPI L (& ,(object-datum constant)) ,memory-reference)) (let ((temp (reference-temporary-register! false))) (LAP (MOV L ,memory-reference ,temp) (CMP L (@PCR ,(constant->label constant)) @@ -264,19 +265,22 @@ MIT in each case. |# (define-rule predicate (FIXNUM-PRED-2-ARGS (? predicate) - (OFFSET (REGISTER (? register)) (? offset)) (CONSTANT (? constant))) + (OFFSET (REGISTER (? register)) (? offset)) + (CONSTANT (? constant))) (fixnum-pred/constant*memory constant (indirect-reference! register offset) (fixnum-pred->cc predicate))) (define-rule predicate (FIXNUM-PRED-2-ARGS (? predicate) - (CONSTANT (? constant)) (OFFSET (REGISTER (? register)) (? offset))) + (CONSTANT (? constant)) + (OFFSET (REGISTER (? register)) (? offset))) (fixnum-pred/constant*memory constant (indirect-reference! register offset) (invert-cc (fixnum-pred->cc predicate)))) (define-rule predicate (FIXNUM-PRED-2-ARGS (? predicate) - (CONSTANT (? constant)) (POST-INCREMENT (REGISTER 15) 1)) + (CONSTANT (? constant)) + (POST-INCREMENT (REGISTER 15) 1)) (fixnum-pred/constant*memory constant (INST-EA (@A+ 7)) (invert-cc (fixnum-pred->cc predicate)))) @@ -331,7 +335,7 @@ MIT in each case. |# (FIXNUM-PRED-1-ARG (? predicate) (CONSTANT (? constant))) (set-standard-branches! (fixnum-pred->cc predicate)) (if (non-pointer-object? constant) - (test-fixnum (INST-EA (& ,(primitive-datum constant)))) + (test-fixnum (INST-EA (& ,(object-datum constant)))) (test-fixnum (INST-EA (@PCR ,(constant->label constant)))))) (define-rule predicate diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm index 90bc7aac6..c2aedfe67 100644 --- a/v7/src/compiler/machines/bobcat/rules3.scm +++ b/v7/src/compiler/machines/bobcat/rules3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.8 1988/04/23 12:37:41 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.9 1988/06/14 08:48:47 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -46,17 +46,20 @@ MIT in each case. |# (define-rule statement (INVOCATION:APPLY (? frame-size) (? continuation)) + continuation (LAP ,@(clear-map!) ,(load-dnw frame-size 0) (JMP ,entry:compiler-apply))) (define-rule statement (INVOCATION:JUMP (? frame-size) (? continuation) (? label)) + frame-size continuation (LAP ,@(clear-map!) (BRA (@PCR ,label)))) (define-rule statement (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label)) + continuation (LAP ,@(clear-map!) ,(load-dnw number-pushed 0) (LEA (@PCR ,label) (A 0)) @@ -64,6 +67,7 @@ MIT in each case. |# (define-rule statement (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) + continuation (LAP ,@(clear-map!) ;; The following assumes that at label there is ;; (JMP (L )) @@ -74,6 +78,7 @@ MIT in each case. |# (define-rule statement (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension)) + continuation (let ((set-extension (expression->machine-register! extension a3))) (delete-dead-registers!) (LAP ,@set-extension @@ -84,6 +89,7 @@ MIT in each case. |# (define-rule statement (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name)) + continuation (let ((set-environment (expression->machine-register! environment d4))) (delete-dead-registers!) (LAP ,@set-environment @@ -94,6 +100,7 @@ MIT in each case. |# (define-rule statement (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) + continuation (LAP ,@(clear-map!) ,@(if (eq? primitive compiled-error-procedure) (LAP ,(load-dnw frame-size 0) @@ -121,6 +128,7 @@ MIT in each case. |# (? frame-size) (? continuation) ,(make-primitive-procedure name true)) + frame-size continuation ,(list 'LAP (list 'UNQUOTE-SPLICING '(clear-map!)) (list 'JMP diff --git a/v7/src/compiler/machines/bobcat/rules4.scm b/v7/src/compiler/machines/bobcat/rules4.scm index a59fc4598..be306cfbd 100644 --- a/v7/src/compiler/machines/bobcat/rules4.scm +++ b/v7/src/compiler/machines/bobcat/rules4.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.2 1988/03/14 20:18:11 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.3 1988/06/14 08:48:58 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -83,7 +83,8 @@ MIT in each case. |# ,@clear-map ,(load-constant name (INST-EA (A 1))) (JSR ,entry) - ,@(make-external-label continuation-code-word (generate-label))))))) + ,@(make-external-label continuation-code-word + (generate-label))))))) (define-rule statement (INTERPRETER-CALL:DEFINE (? environment) (? name) @@ -110,23 +111,24 @@ MIT in each case. |# (MOV L ,reg:temp (A 2)) ,(load-constant name (INST-EA (A 1))) (JSR ,entry) - ,@(make-external-label continuation-code-word (generate-label))))))) + ,@(make-external-label continuation-code-word + (generate-label))))))) (define-rule statement (INTERPRETER-CALL:DEFINE (? environment) (? name) (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) - (assignment-call:cons-pointer entry:compiler-define environment name type - label)) + (assignment-call:cons-procedure entry:compiler-define environment name type + label)) (define-rule statement (INTERPRETER-CALL:SET! (? environment) (? name) (CONS-POINTER (CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) - (assignment-call:cons-pointer entry:compiler-set! environment name type - label)) + (assignment-call:cons-procedure entry:compiler-set! environment name type + label)) -(define (assignment-call:cons-pointer entry environment name type label) +(define (assignment-call:cons-procedure entry environment name type label) (let ((set-environment (expression->machine-register! environment a0))) (LAP ,@set-environment ,@(clear-map!) @@ -158,7 +160,8 @@ MIT in each case. |# ,@set-value ,@clear-map (JSR ,entry:compiler-assignment-trap) - ,@(make-external-label continuation-code-word (generate-label))))))) + ,@(make-external-label continuation-code-word + (generate-label))))))) (define-rule statement (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) @@ -173,12 +176,14 @@ MIT in each case. |# ,@clear-map (MOV L ,reg:temp (A 1)) (JSR ,entry:compiler-assignment-trap) - ,@(make-external-label continuation-code-word (generate-label))))))) + ,@(make-external-label continuation-code-word + (generate-label))))))) (define-rule statement - (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) - (CONS-POINTER (CONSTANT (? type)) - (ENTRY:PROCEDURE (? label)))) + (INTERPRETER-CALL:CACHE-ASSIGNMENT + (? extension) + (CONS-POINTER (CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) (let ((set-extension (expression->machine-register! extension a0))) (LAP ,@set-extension ,@(clear-map!) diff --git a/v7/src/compiler/rtlbase/regset.scm b/v7/src/compiler/rtlbase/regset.scm index a47017a01..c9b810de1 100644 --- a/v7/src/compiler/rtlbase/regset.scm +++ b/v7/src/compiler/rtlbase/regset.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/regset.scm,v 1.1 1987/06/26 02:21:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/regset.scm,v 1.2 1988/06/14 08:36:51 cph Rel $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -37,9 +37,11 @@ MIT in each case. |# (declare (usual-integrations)) (define-integrable (make-regset n-registers) + n-registers (list 'REGSET)) (define-integrable (regset-allocate n-registers) + n-registers (list 'REGSET)) (define-integrable (for-each-regset-member regset procedure) diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index 49a9d80bc..7c4afd6ce 100644 --- a/v7/src/compiler/rtlbase/rtlcon.scm +++ b/v7/src/compiler/rtlbase/rtlcon.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.8 1988/05/19 15:22:46 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.9 1988/06/14 08:37:00 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -50,16 +50,18 @@ MIT in each case. |# ;; times, then all of those assignments should be ;; address valued expressions. This constraint is not ;; enforced. - (add-rgraph-address-register! *current-rgraph* - (rtl:register-number address))) + (add-rgraph-address-register! + *current-rgraph* + (rtl:register-number address))) ((rtl:fixnum-valued-expression? expression) ;; We don't know for sure that this register is assigned ;; only once. However, if it is assigned multiple ;; times, then all of those assignments should be ;; fixnum valued expressions. This constraint is not ;; enforced. - (add-rgraph-fixnum-register! *current-rgraph* - (rtl:register-number address))))) + (add-rgraph-fixnum-register! + *current-rgraph* + (rtl:register-number address))))) (%make-assign address expression)))))) (define (rtl:make-eq-test expression-1 expression-2) @@ -268,7 +270,9 @@ MIT in each case. |# (lambda (register) (receiver register offset granularity)) (lambda (register offset* granularity*) - (receiver (make-offset register offset* granularity*) offset granularity)))) + (receiver (make-offset register offset* granularity*) + offset + granularity)))) (define (guarantee-address expression scfg-append! receiver) (if (rtl:address-valued-expression? expression) @@ -282,7 +286,8 @@ MIT in each case. |# (receiver expression) (assign-to-temporary expression scfg-append! receiver))) -(define (generate-offset-address expression offset granularity scfg-append! receiver) +(define (generate-offset-address expression offset granularity scfg-append! + receiver) (if (eq? granularity 'OBJECT) (guarantee-address expression scfg-append! (lambda (address) @@ -344,6 +349,7 @@ MIT in each case. |# (lambda (receiver scfg-append! locative) (locative-dereference-1 locative scfg-append! locative-fetch-1 (lambda (register) + register (error "Can't take ADDRESS of a register" locative)) (generator receiver scfg-append!)))) @@ -443,6 +449,7 @@ MIT in each case. |# (define-expression-method 'TYPED-CONS:PROCEDURE (lambda (receiver scfg-append! type entry min max size) + scfg-append! (receiver (rtl:make-typed-cons:procedure type entry min max size)))) (define (object-selector make-object-selector) diff --git a/v7/src/compiler/rtlbase/rtline.scm b/v7/src/compiler/rtlbase/rtline.scm index bb76c8f50..c7c021f79 100644 --- a/v7/src/compiler/rtlbase/rtline.scm +++ b/v7/src/compiler/rtlbase/rtline.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.2 1987/12/30 07:07:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.3 1988/06/14 08:37:09 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -75,6 +75,7 @@ MIT in each case. |# (else (bblock-linearize-rtl bblock)))) (define (linearize-pblock pblock predicate cn an) + pblock (if (node-marked? cn) (if (node-marked? an) `(,(rtl:make-jumpc-statement predicate (bblock-label! cn)) diff --git a/v7/src/compiler/rtlbase/rtlobj.scm b/v7/src/compiler/rtlbase/rtlobj.scm index 49910469a..efdd0cdf7 100644 --- a/v7/src/compiler/rtlbase/rtlobj.scm +++ b/v7/src/compiler/rtlbase/rtlobj.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.2 1987/12/30 07:07:44 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.3 1988/06/14 08:37:16 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -40,9 +40,9 @@ MIT in each case. |# (conc-name rtl-expr/) (constructor make-rtl-expr (rgraph label entry-edge)) (print-procedure - (standard-unparser 'RTL-EXPR - (lambda (expression) - (write (rtl-expr/label expression)))))) + (standard-unparser "RTL-EXPR" + (lambda (state expression) + (unparse-object state (rtl-expr/label expression)))))) (rgraph false read-only true) (label false read-only true) (entry-edge false read-only true)) @@ -63,9 +63,10 @@ MIT in each case. |# (rgraph label entry-edge name n-required n-optional rest? closure? type)) (print-procedure - (standard-unparser 'RTL-PROCEDURE - (lambda (procedure) - (write (rtl-procedure/label procedure)))))) + (standard-unparser "RTL-PROCEDURE" + (lambda (state procedure) + (unparse-object state + (rtl-procedure/label procedure)))))) (rgraph false read-only true) (label false read-only true) (entry-edge false read-only true) @@ -106,9 +107,10 @@ MIT in each case. |# (constructor make-rtl-continuation (rgraph label entry-edge)) (print-procedure - (standard-unparser 'RTL-CONTINUATION - (lambda (continuation) - (write (rtl-continuation/label continuation)))))) + (standard-unparser "RTL-CONTINUATION" (lambda (state continuation) + (unparse-object + state + (rtl-continuation/label continuation)))))) (rgraph false read-only true) (label false read-only true) (entry-edge false read-only true)) @@ -136,9 +138,10 @@ MIT in each case. |# procedure)) procedures) (for-each (lambda (continuation) - (symbol-hash-table/insert! hash-table - (rtl-continuation/label continuation) - continuation)) + (symbol-hash-table/insert! + hash-table + (rtl-continuation/label continuation) + continuation)) continuations) (make/label->object* hash-table))) diff --git a/v7/src/compiler/rtlbase/rtlty2.scm b/v7/src/compiler/rtlbase/rtlty2.scm index 239b86eef..fde72c17d 100644 --- a/v7/src/compiler/rtlbase/rtlty2.scm +++ b/v7/src/compiler/rtlbase/rtlty2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.4 1988/05/09 19:51:06 mhwu Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.5 1988/06/14 08:37:23 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -44,7 +44,7 @@ MIT in each case. |# (define-integrable rtl:test-expression second) (define (rtl:make-constant value) - (if (scode/unassigned-object? value) + (if (unassigned-reference-trap? value) (rtl:make-unassigned) (%make-constant value))) diff --git a/v7/src/compiler/rtlgen/fndblk.scm b/v7/src/compiler/rtlgen/fndblk.scm index c434ca8fe..2a2f5d574 100644 --- a/v7/src/compiler/rtlgen/fndblk.scm +++ b/v7/src/compiler/rtlgen/fndblk.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.6 1988/03/31 21:39:16 mhwu Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.7 1988/06/14 08:42:14 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -62,6 +62,7 @@ MIT in each case. |# (define (find-known-variable block variable offset) (find-variable block variable offset identity-procedure (lambda (environment name) + environment (error "Known variable found in IC frame" name)) (lambda (name) (error "Known variable found in IC frame" name)))) @@ -70,6 +71,7 @@ MIT in each case. |# (find-variable-internal block variable offset identity-procedure (lambda (block locative) + block locative (error "Closure variable in IC frame" variable)))) (define (find-variable-internal block variable offset if-compiler if-ic) @@ -98,9 +100,12 @@ MIT in each case. |# (define (find-definition-variable block lvalue offset) (find-block/variable block lvalue offset (lambda (offset-locative) + offset-locative (lambda (block locative) + block locative (error "Definition of compiled variable" lvalue))) (lambda (block locative) + block (return-2 locative (variable-name lvalue))))) (define (find-block/variable block variable offset if-known if-ic) @@ -213,6 +218,7 @@ MIT in each case. |# (transmit-values (find-block/loop start-block (find-block/same-block? end-block) locative) (lambda (end-block locative) + end-block locative))) (define (internal-block/parent-locative block locative) @@ -242,9 +248,11 @@ MIT in each case. |# ;; This value should make anyone trying to look at it crash. (define (trivial-closure/bogus-locative block locative) + block locative 'TRIVIAL-CLOSURE-BOGUS-LOCATIVE) (define (closure-block/parent-locative block locative) + block (rtl:make-fetch (rtl:locative-offset locative closure-block-first-offset))) diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index 283990f3a..f746b4bd8 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.7 1988/05/19 15:10:36 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.8 1988/06/14 08:42:24 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -87,12 +87,15 @@ MIT in each case. |# (inliner/operands inliner)))) (make-return-operand (lambda (offset) + offset ((vector-ref handler 1) generator expressions)) (lambda (offset finish) + offset ((vector-ref handler 2) generator expressions finish)) (lambda (offset finish) + offset ((vector-ref handler 3) generator expressions finish)) @@ -137,6 +140,7 @@ MIT in each case. |# (finish (rtl:make-fetch temporary))))))) (define (invoke/value->effect generator expressions) + generator expressions (make-null-cfg)) (define (invoke/value->predicate generator expressions finish) @@ -159,7 +163,7 @@ MIT in each case. |# (set! name->open-coders (cons (cons name item) name->open-coders))))))) (lambda (name handler) - (if (pair? name) + (if (list? name) (for-each (lambda (name) (per-name name handler)) name) @@ -212,6 +216,7 @@ MIT in each case. |# (define-open-coder/predicate 'NULL? (lambda (operands) + operands (return-2 (lambda (expressions finish) (finish (pcfg-invert (rtl:make-true-test (car expressions))))) '(0)))) @@ -227,12 +232,13 @@ MIT in each case. |# (lambda (name type) (define-open-coder/predicate name (lambda (operands) + operands (return-2 (open-code/type-test type) '(0))))))) (define/type-test 'PAIR? (ucode-type pair)) (define/type-test 'STRING? (ucode-type string)) (define/type-test 'BIT-STRING? (ucode-type vector-1b))) - (define-open-coder/predicate 'PRIMITIVE-TYPE? + (define-open-coder/predicate 'OBJECT-TYPE? (lambda (operands) (filter/nonnegative-integer (car operands) (lambda (type) @@ -243,6 +249,7 @@ MIT in each case. |# (finish (rtl:make-eq-test (car expressions) (cadr expressions)))))) (define-open-coder/predicate 'EQ? (lambda (operands) + operands (return-2 open-code/eq-test '(0 1))))) (let ((open-code/pair-cons @@ -255,6 +262,7 @@ MIT in each case. |# (define-open-coder/value 'CONS (lambda (operands) + operands (return-2 (open-code/pair-cons (ucode-type pair)) '(0 1)))) (define-open-coder/value 'SYSTEM-PAIR-CONS @@ -291,6 +299,7 @@ MIT in each case. |# (lambda (name index) (define-open-coder/value name (lambda (operands) + operands (return-2 (open-code/memory-length index) '(0))))))) (define/length '(VECTOR-LENGTH SYSTEM-VECTOR-SIZE) 0) (define/length '(STRING-LENGTH BIT-STRING-LENGTH) 1))) @@ -324,6 +333,7 @@ MIT in each case. |# (lambda (name index) (define-open-coder/value name (lambda (operands) + operands (return-2 (open-code/memory-ref/constant index) '(0))))))) (define/ref '(CAR SYSTEM-PAIR-CAR CELL-CONTENTS SYSTEM-HUNK3-CXR0) 0) (define/ref '(CDR SYSTEM-PAIR-CDR SYSTEM-HUNK3-CXR1) 1) @@ -339,7 +349,7 @@ MIT in each case. |# good-constant-index (return-2 open-code/memory-ref/non-constant '(0 1))))))) - + (let ((open-code/general-car-cdr (lambda (pattern) (lambda (expressions finish) @@ -358,7 +368,7 @@ MIT in each case. |# (filter/positive-integer (cadr operands) (lambda (pattern) (return-2 (open-code/general-car-cdr pattern) '(0))))))) - + (let ((open-code/memory-assignment (lambda (index locative-generator) (lambda (expressions finish) @@ -369,80 +379,77 @@ MIT in each case. |# lvalue-locative index))) (let ((assignment - (rtl:make-assignment locative (car (last-pair expressions))))) + (rtl:make-assignment locative + (car (last-pair expressions))))) (if finish (let ((temporary (rtl:make-pseudo-register))) (scfg-append! - (rtl:make-assignment temporary (rtl:make-fetch locative)) + (rtl:make-assignment temporary + (rtl:make-fetch locative)) assignment (finish (rtl:make-fetch temporary)))) assignment))))))))) + ;; For now SYSTEM-XXXX side effect procedures are considered + ;; dangerous to the garbage collector's health. Some day we will + ;; again be able to enable them. + (let ((define/set! (lambda (name index) (define-open-coder/effect name (lambda (operands) + operands (return-2 (open-code/memory-assignment index (lambda (exp finish) (finish (car exp)))) '(0 1))))))) -;;; For now SYSTEM-XXXX procedures with side effects are considered -;;; dangerous to the garbage collectors health. Some day we will again -;;; be able to do the following: -;;; (define/set! '(SET-CAR! SYSTEM-PAIR-SET-CAR! -;;; SET-CELL-CONTENTS! -;;; SYSTEM-HUNK3-SET-CXR0!) -;;; 0) -;;; (define/set! '(SET-CDR! SYSTEM-PAIR-SET-CDR! -;;; SYSTEM-HUNK3-SET-CXR1!) 1) -;;; (define/set! 'SYSTEM-HUNK3-SET-CXR2! -;;; 2)) - (define/set! '(SET-CAR! SET-CELL-CONTENTS!) 0) - (define/set! '(SET-CDR!) 1)) - - -;;; For now SYSTEM-XXXX procedures with side effects are considered -;;; dangerous to the garbage collectors health. Some day we will again -;;; be able to do the following: -;;; (define-open-coder-effect '(vECTOR-SET! SYSTEM-VECTOR-SET!) - - (define-open-coder/effect '(VECTOR-SET!) + (define/set! '(SET-CAR! + SET-CELL-CONTENTS! + #| SYSTEM-PAIR-SET-CAR! |# + #| SYSTEM-HUNK3-SET-CXR0! |#) + 0) + (define/set! '(SET-CDR! + #| SYSTEM-PAIR-SET-CDR! |# + #| SYSTEM-HUNK3-SET-CXR1! |#) + 1) + (define/set! '(#| SYSTEM-HUNK3-SET-CXR2! |#) + 2)) + + (define-open-coder/effect '(VECTOR-SET! #| SYSTEM-VECTOR-SET! |#) (lambda (operands) - (let ((good-constant-index - (filter/nonnegative-integer (cadr operands) - (lambda (index) - (return-2 (open-code/memory-assignment - (1+ index) - (lambda (exp finish) - (finish (car exp)))) - '(0 2)))))) - (if good-constant-index - good-constant-index - (return-2 (open-code/memory-assignment - 1 - (lambda (expressions finish) - (let ((temporary (rtl:make-pseudo-register))) - (scfg-append! - (rtl:make-assignment - temporary - (rtl:make-fixnum-2-args - 'PLUS-FIXNUM - (rtl:make-object->address (car expressions)) - (rtl:make-fixnum-2-args - 'MULTIPLY-FIXNUM - (rtl:make-object->fixnum - (rtl:make-constant - (quotient scheme-object-width - addressing-granularity))) - (rtl:make-object->fixnum - (cadr expressions))))) - (finish (rtl:make-fetch temporary)))))) - '(0 1 2))))))) - + (or (filter/nonnegative-integer (cadr operands) + (lambda (index) + (return-2 (open-code/memory-assignment + (1+ index) + (lambda (exp finish) + (finish (car exp)))) + '(0 2)))) + (return-2 (open-code/memory-assignment + 1 + (lambda (expressions finish) + (let ((temporary (rtl:make-pseudo-register))) + (scfg-append! + (rtl:make-assignment + temporary + (rtl:make-fixnum-2-args + 'PLUS-FIXNUM + (rtl:make-object->address (car expressions)) + (rtl:make-fixnum-2-args + 'MULTIPLY-FIXNUM + (rtl:make-object->fixnum + (rtl:make-constant + (quotient scheme-object-width + addressing-granularity))) + (rtl:make-object->fixnum + (cadr expressions))))) + (finish (rtl:make-fetch temporary)))))) + '(0 1 2)))))) + (let ((define-fixnum-2-args (lambda (fixnum-operator) (define-open-coder/value fixnum-operator (lambda (operands) + operands (return-2 (lambda (expressions finish) (finish (rtl:make-fixnum->object @@ -454,13 +461,13 @@ MIT in each case. |# (for-each define-fixnum-2-args '(PLUS-FIXNUM MINUS-FIXNUM MULTIPLY-FIXNUM - ;; DIVIDE-FIXNUM GCD-FIXNUM - ))) + #| DIVIDE-FIXNUM GCD-FIXNUM |#))) (let ((define-fixnum-1-arg (lambda (fixnum-operator) (define-open-coder/value fixnum-operator (lambda (operand) + operand (return-2 (lambda (expressions finish) (finish (rtl:make-fixnum->object @@ -476,6 +483,7 @@ MIT in each case. |# (lambda (fixnum-pred) (define-open-coder/predicate fixnum-pred (lambda (operands) + operands (return-2 (lambda (expressions finish) (finish (rtl:make-fixnum-pred-2-args @@ -491,6 +499,7 @@ MIT in each case. |# (lambda (fixnum-pred) (define-open-coder/predicate fixnum-pred (lambda (operand) + operand (return-2 (lambda (expressions finish) (finish (rtl:make-fixnum-pred-1-arg @@ -508,6 +517,7 @@ MIT in each case. |# (lambda (character->fixnum rtl:coercion) (define-open-coder/value character->fixnum (lambda (operand) + operand (return-2 (lambda (expressions finish) (finish (rtl:make-cons-pointer (rtl:make-constant (ucode-type fixnum)) @@ -529,8 +539,9 @@ MIT in each case. |# (finish (rtl:make-cons-pointer (rtl:make-constant (ucode-type character)) (rtl:make-fetch - (rtl:locative-byte-offset (car expressions) - (+ string-header-size index)))))) + (rtl:locative-byte-offset + (car expressions) + (+ string-header-size index)))))) '(0)))))) (define-open-coder/effect 'STRING-SET! @@ -548,10 +559,11 @@ MIT in each case. |# (if finish (let ((temporary (rtl:make-pseudo-register))) (scfg-append! - (rtl:make-assignment temporary - (rtl:make-cons-pointer - (rtl:make-constant (ucode-type character)) - (rtl:make-fetch locative))) + (rtl:make-assignment + temporary + (rtl:make-cons-pointer + (rtl:make-constant (ucode-type character)) + (rtl:make-fetch locative))) assignment (finish (rtl:make-fetch temporary)))) assignment))) diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index d6fb9e83a..c1ac23bcb 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.4 1988/03/14 20:53:42 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.5 1988/06/14 08:42:37 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -77,9 +77,9 @@ MIT in each case. |# ((OPEN-EXTERNAL) (finish invocation/jump true)) ((OPEN-INTERNAL) (finish invocation/jump false)) ((CLOSURE) - ;; *** For the time being, known lexpr closures are invoked through - ;; apply. This makes the code simpler and probably does not matter - ;; much. *** + ;; *** For the time being, known lexpr closures are + ;; invoked through apply. This makes the code + ;; simpler and probably does not matter much. *** (if (procedure-rest callee) (finish invocation/apply true) (finish invocation/jump true))) @@ -106,6 +106,7 @@ MIT in each case. |# (procedure-label callee))))))) (define (invocation/apply operator offset frame-size continuation prefix) + operator (invocation/apply* offset frame-size continuation prefix)) (define (invocation/apply* offset frame-size continuation prefix) @@ -257,6 +258,7 @@ MIT in each case. |# (scfg*scfg->scfg! (prefix offset frame-size) (prefix* offset frame-size)))) (define (prefix/null offset frame-size) + offset frame-size (make-null-cfg)) (define (generate/link-prefix block callee continuation callee-external?) @@ -273,6 +275,7 @@ MIT in each case. |# (reduction-continuation/popping-limit continuation))))) (define (link-prefix/subproblem offset frame-size) + offset (rtl:make-assignment register:dynamic-link (rtl:make-address @@ -281,6 +284,7 @@ MIT in each case. |# (define (link-prefix/reduction block block*) (lambda (offset frame-size) + frame-size (rtl:make-assignment register:dynamic-link (popping-limit/locative block offset block* 0)))) diff --git a/v7/src/compiler/rtlgen/rgretn.scm b/v7/src/compiler/rtlgen/rgretn.scm index cfe0d83b5..6f70cccac 100644 --- a/v7/src/compiler/rtlgen/rgretn.scm +++ b/v7/src/compiler/rtlgen/rgretn.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.2 1987/12/30 07:10:22 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.3 1988/06/14 08:42:48 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -48,6 +48,7 @@ MIT in each case. |# (define (trivial-return-operand operand) (make-return-operand (lambda (offset) + offset (make-null-cfg)) (lambda (offset finish) (generate/rvalue operand offset scfg*scfg->scfg! diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index 4afe232ab..ce0fa7a77 100644 --- a/v7/src/compiler/rtlgen/rgrval.scm +++ b/v7/src/compiler/rtlgen/rgrval.scm @@ -1,9 +1,9 @@ d3 1 a4 1 -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.6 1988/04/21 06:58:23 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.7 1988/06/14 08:42:56 cph Exp $ #| -*-Scheme-*- -Copyright (c) 1987 Massachusetts Institute of Technology -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.6 1988/04/21 06:58:23 jinx Exp $ +Copyright (c) 1988 Massachusetts Institute of Technology +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.7 1988/06/14 08:42:56 cph Exp $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -59,10 +59,12 @@ promotional, or sales literature without prior written consent from (return-2 (scfg*scfg->scfg! prefix (rtl:make-assignment register result)) (rtl:make-fetch register)))) (values (scfg*scfg->scfg! prefix assignment) reference)) +#| (define-integrable (expression-value/transform expression-value transform) (transmit-values expression-value (lambda (prefix expression) (return-2 prefix (transform expression))))) +|# result (lambda (constant offset) @@ -205,7 +207,8 @@ promotional, or sales literature without prior written consent from (loop (cdr entries) (scfg*scfg->scfg! (rtl:make-assignment - (cond ;; This is a waste. It should be integrated. + (cond ;; This is a waste. + ;; It should be integrated. ((and value (rvalue/procedure? value) (procedure/closure? value) diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index 9a2ab7dd8..15660190b 100644 --- a/v7/src/compiler/rtlgen/rgstmt.scm +++ b/v7/src/compiler/rtlgen/rgstmt.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.3 1988/03/14 20:55:03 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.4 1988/06/14 08:43:06 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -137,8 +137,9 @@ MIT in each case. |# (generate/rvalue operand offset scfg*scfg->scfg! (lambda (expression) (rtl:make-assignment register expression)))) - + (define (generate/continuation-cons block continuation) + block (let ((closing-block (continuation/closing-block continuation))) (scfg*scfg->scfg! (if (ic-block? closing-block) @@ -201,7 +202,7 @@ MIT in each case. |# (generate/node consequent) (generate/node alternative))) ((and (rvalue/constant? value) - (scode/unassigned-object? (constant-value value))) + (unassigned-reference-trap? (constant-value value))) (generate/node consequent)) (else (generate/node alternative)))))) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index fb18cf934..b326037bf 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.4 1988/03/14 20:55:24 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.5 1988/06/14 08:43:15 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -45,7 +45,7 @@ MIT in each case. |# (*queued-procedures* '()) (*queued-continuations* '())) (set! *rtl-expression* (generate/expression expression)) - (queue-map! *generation-queue* (lambda (thunk) (thunk))) + (queue-map!/unsafe *generation-queue* (lambda (thunk) (thunk))) (set! *rtl-graphs* (list-transform-positive (reverse! *rtl-graphs*) (lambda (rgraph) @@ -57,21 +57,21 @@ MIT in each case. |# (define (enqueue-procedure! procedure) (if (not (memq procedure *queued-procedures*)) (begin - (enqueue! *generation-queue* - (lambda () - (set! *rtl-procedures* - (cons (generate/procedure procedure) - *rtl-procedures*)))) + (enqueue!/unsafe *generation-queue* + (lambda () + (set! *rtl-procedures* + (cons (generate/procedure procedure) + *rtl-procedures*)))) (set! *queued-procedures* (cons procedure *queued-procedures*))))) (define (enqueue-continuation! continuation) (if (not (memq continuation *queued-continuations*)) (begin - (enqueue! *generation-queue* - (lambda () - (set! *rtl-continuations* - (cons (generate/continuation continuation) - *rtl-continuations*)))) + (enqueue!/unsafe *generation-queue* + (lambda () + (set! *rtl-continuations* + (cons (generate/continuation continuation) + *rtl-continuations*)))) (set! *queued-continuations* (cons continuation *queued-continuations*))))) diff --git a/v7/src/compiler/rtlopt/ralloc.scm b/v7/src/compiler/rtlopt/ralloc.scm index 7f6066c33..54527b109 100644 --- a/v7/src/compiler/rtlopt/ralloc.scm +++ b/v7/src/compiler/rtlopt/ralloc.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.14 1988/04/12 18:42:27 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.15 1988/06/14 08:43:53 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -76,6 +76,7 @@ MIT in each case. |# (let ((conflict-matrix (make-initialized-vector next-renumber (lambda (i) + i (make-regset next-renumber))))) (for-each (lambda (bblock) (let ((live (make-regset next-renumber))) diff --git a/v7/src/compiler/rtlopt/rcompr.scm b/v7/src/compiler/rtlopt/rcompr.scm index 8da5e0f3e..1154bfa48 100644 --- a/v7/src/compiler/rtlopt/rcompr.scm +++ b/v7/src/compiler/rtlopt/rcompr.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.4 1988/04/26 18:56:24 markf Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.5 1988/06/14 08:44:38 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -94,11 +94,11 @@ MIT in each case. |# (for-each increment-register-live-length! dead) (set-rinst-dead-registers! next - (eqv-set-union dead - (delv! register - (rinst-dead-registers next))))) + (eqv-set-union + dead + (delv! register (rinst-dead-registers next))))) (for-each-regset-member live - decrement-register-live-length!) + decrement-register-live-length!) (rtl:modify-subexpressions (rinst-rtl next) (lambda (expression set-expression!) diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm index ca9ecf9b7..d53e762ec 100644 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.9 1988/06/03 23:54:57 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.10 1988/06/14 08:44:03 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -70,7 +70,7 @@ MIT in each case. |# (walk-bblock (cdr entry)))) ((not (queue-empty? *initial-queue*)) (state/reset!) - (walk-bblock (dequeue! *initial-queue*))))) + (walk-bblock (dequeue!/unsafe *initial-queue*))))) (define-structure (state (type vector) (conc-name state/)) (register-tables false read-only true) @@ -112,10 +112,10 @@ MIT in each case. |# (if (walk-next? consequent) (if (walk-next? alternative) (if (node-previous>1? consequent) - (begin (enqueue! *initial-queue* consequent) + (begin (enqueue!/unsafe *initial-queue* consequent) (walk-next alternative)) (begin (if (node-previous>1? alternative) - (enqueue! *initial-queue* alternative) + (enqueue!/unsafe *initial-queue* alternative) (set! *branch-queue* (cons (cons (state/get) alternative) *branch-queue*))) @@ -184,7 +184,8 @@ MIT in each case. |# (let ((address (expression-canonicalize address))) (rtl:set-assign-address! statement address) (full-expression-hash address - (lambda (hash volatile?* in-memory?*) + (lambda (hash volatile?* in-memory?) + in-memory? (let ((memory-invalidate! (cond ((stack-push/pop? address) (lambda () 'DONE)) @@ -235,6 +236,7 @@ MIT in each case. |# (memory-invalidate!) (insert-memory-destination! address element false))) |# + hash (insert-source!) (memory-invalidate!) (mention-registers! address)) @@ -274,6 +276,7 @@ MIT in each case. |# rtl:type-test-expression rtl:set-unassigned-test-expression!) (define (method/noop statement) + statement 'DONE) (define-cse-method 'POP-RETURN method/noop) @@ -308,6 +311,7 @@ MIT in each case. |# (define-cse-method 'CONS-CLOSURE (lambda (statement) + statement (expression-invalidate! (interpreter-register:enclose)))) (define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP diff --git a/v7/src/compiler/rtlopt/rcse2.scm b/v7/src/compiler/rtlopt/rcse2.scm index 5795faeb7..17cfe6822 100644 --- a/v7/src/compiler/rtlopt/rcse2.scm +++ b/v7/src/compiler/rtlopt/rcse2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.7 1988/06/03 14:56:55 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.8 1988/06/14 08:44:13 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -268,6 +268,7 @@ MIT in each case. |# (define (expression-hash expression) (full-expression-hash expression (lambda (hash do-not-record? hash-arg-in-memory?) + do-not-record? hash-arg-in-memory? hash))) (define (full-expression-hash expression receiver) diff --git a/v7/src/compiler/rtlopt/rcseht.scm b/v7/src/compiler/rtlopt/rcseht.scm index c8c5b420b..01ad2a70d 100644 --- a/v7/src/compiler/rtlopt/rcseht.scm +++ b/v7/src/compiler/rtlopt/rcseht.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.3 1988/06/03 14:58:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.4 1988/06/14 08:44:22 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -54,8 +54,7 @@ MIT in each case. |# (define-structure (element (constructor %make-element) (constructor make-element (expression)) - (print-procedure (standard-unparser 'ELEMENT false))) - (expression false read-only true) + (print-procedure (standard-unparser "ELEMENT" false))) (expression false read-only true) (cost false) (in-memory? false) (next-hash false) diff --git a/v7/src/compiler/rtlopt/rcserq.scm b/v7/src/compiler/rtlopt/rcserq.scm index 1adc2ab58..f638b1143 100644 --- a/v7/src/compiler/rtlopt/rcserq.scm +++ b/v7/src/compiler/rtlopt/rcserq.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 4.1 1987/12/08 13:55:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 4.2 1988/06/14 08:44:30 cph Exp $ -Copyright (c) 1987 Massachusetts Institute of Technology +Copyright (c) 1988 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,8 +39,7 @@ MIT in each case. |# (define-structure (quantity (copier quantity-copy) - (print-procedure (standard-unparser 'QUANTITY false))) - (number false read-only true) + (print-procedure (standard-unparser "QUANTITY" false))) (number false read-only true) (first-register false) (last-register false)) diff --git a/v7/src/compiler/rtlopt/rlife.scm b/v7/src/compiler/rtlopt/rlife.scm index 936183ba2..9aaf0bf7b 100644 --- a/v7/src/compiler/rtlopt/rlife.scm +++ b/v7/src/compiler/rtlopt/rlife.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.58 1987/08/07 17:08:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.59 1988/06/14 08:44:45 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -136,6 +136,7 @@ MIT in each case. |# (define (mark-set-registers! needed dead rtl bblock) ;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT ;; modes, since they are only used on the stack pointer. + needed (if (rtl:assign? rtl) (let ((address (rtl:assign-address rtl))) (if (interesting-register? address)