From dd88b698d3e4b58597d642b7ab9509e987afc588 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 14 Jun 1988 08:11:04 +0000 Subject: [PATCH] First checkin for runtime version 14. --- v7/src/compiler/back/asmmac.scm | 9 +++--- v7/src/compiler/back/bittop.scm | 9 +++--- v7/src/compiler/back/lapgn1.scm | 6 ++-- v7/src/compiler/back/linear.scm | 8 ++---- v7/src/compiler/back/regmap.scm | 5 ++-- v7/src/compiler/back/syerly.scm | 51 ++++++++++++++++++--------------- v7/src/compiler/back/syntax.scm | 11 ++++--- 7 files changed, 52 insertions(+), 47 deletions(-) diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm index deee5218b..991b86e49 100644 --- a/v7/src/compiler/back/asmmac.scm +++ b/v7/src/compiler/back/asmmac.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/asmmac.scm,v 1.5 1987/08/13 01:59:58 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/asmmac.scm,v 1.6 1988/06/14 08:09:40 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 @@ -42,6 +42,7 @@ MIT in each case. |# ',keyword ,(compile-database rules (lambda (pattern actions) + pattern (if (null? actions) (error "DEFINE-INSTRUCTION: Too few forms") (parse-instruction (car actions) (cdr actions) false))))))) @@ -57,8 +58,6 @@ MIT in each case. |# (procedure pattern actions)))))) cases))) - -;;;; Group Optimization (define optimize-group-syntax (let () @@ -104,4 +103,4 @@ MIT in each case. |# `(,(if early? 'OPTIMIZE-GROUP-EARLY 'OPTIMIZE-GROUP) - ,@components))))))) + ,@components))))))) \ No newline at end of file diff --git a/v7/src/compiler/back/bittop.scm b/v7/src/compiler/back/bittop.scm index 1c52893f7..f6018e61a 100644 --- a/v7/src/compiler/back/bittop.scm +++ b/v7/src/compiler/back/bittop.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.8 1988/02/19 20:57:27 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.9 1988/06/14 08:09:54 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 @@ -84,6 +84,7 @@ MIT in each case. |# count (with-values (lambda () (phase-2 vars)) (lambda (any-modified? number-of-vars) + number-of-vars (if any-modified? (begin (clear-symbol-table!) @@ -118,14 +119,14 @@ MIT in each case. |# (let* ((ol (length objects)) (v (make-vector (+ ol bl)))) (write-bits! v scheme-object-width block) - (insert-objects! (primitive-set-type (ucode-type compiled-code-block) v) + (insert-objects! (object-new-type (ucode-type compiled-code-block) v) objects bl)))) (define (insert-objects! v objects where) (cond ((not (null? objects)) (system-vector-set! v where (cadar objects)) (insert-objects! v (cdr objects) (1+ where))) - ((not (= where (system-vector-size v))) + ((not (= where (system-vector-length v))) (error "insert-objects!: object phase error" where)) (else v))) diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index 0e251ef55..89f07c2c9 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.1 1987/12/30 06:53:23 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.2 1988/06/14 08:10:09 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -95,7 +95,7 @@ MIT in each case. |# (if (not (null? deletions)) (delete-pseudo-registers map deletions - (lambda (map aliases) map)) + (lambda (map aliases) aliases map)) map))))) (if (not (register-map-clear? map)) (let ((sblock (make-sblock (clear-map-instructions map)))) @@ -150,7 +150,7 @@ MIT in each case. |# (regset->list (regset-difference (bblock-live-at-exit previous) (bblock-live-at-entry bblock))) - (lambda (map aliases) map))))))) + (lambda (map aliases) aliases map))))))) (define *cgen-rules* '()) (define *assign-rules* '()) diff --git a/v7/src/compiler/back/linear.scm b/v7/src/compiler/back/linear.scm index b0b285cfc..718cf9e0d 100644 --- a/v7/src/compiler/back/linear.scm +++ b/v7/src/compiler/back/linear.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.1 1987/12/30 06:57:09 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.2 1988/06/14 08:10:23 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,9 +36,7 @@ MIT in each case. |# (declare (usual-integrations)) -(package (bblock-linearize-bits) - -(define-export (bblock-linearize-bits bblock) +(define (bblock-linearize-bits bblock) (node-mark! bblock) (if (and (not (bblock-label bblock)) (node-previous>1? bblock)) @@ -79,8 +77,6 @@ MIT in each case. |# (LAP) (bblock-linearize-bits cn))))))) -) - (define (map-lap procedure objects) (let loop ((objects objects)) (if (null? objects) diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm index d179eccd0..5da681ef9 100644 --- a/v7/src/compiler/back/regmap.scm +++ b/v7/src/compiler/back/regmap.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.3 1988/06/03 14:51:51 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.4 1988/06/14 08:10: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 @@ -485,6 +485,7 @@ REGISTER-RENUMBERs are equal. ((input-loop input-map '()) (map-entries input-map))) (define (input-loop map tail) + map (define (loop entries) (if (null? entries) tail diff --git a/v7/src/compiler/back/syerly.scm b/v7/src/compiler/back/syerly.scm index aaa566ecd..73e3a2937 100644 --- a/v7/src/compiler/back/syerly.scm +++ b/v7/src/compiler/back/syerly.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.4 1987/08/13 02:01:16 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.5 1988/06/14 08:10: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 @@ -39,7 +39,7 @@ MIT in each case. |# ;;;; Early instruction assembly (define lap:syntax-instruction-expander - ((access scode->scode-expander package/expansion package/scode-optimizer) + (scode->scode-expander (lambda (operands if-expanded if-not-expanded) (define (kernel opcode instruction rules) (early-pattern-lookup @@ -58,7 +58,8 @@ MIT in each case. |# (let ((instruction (scode/unquasiquote (car operands)))) (cond ((not (pair? instruction)) - (error "lap:syntax-instruction-expander: bad instruction" instruction)) + (error "LAP:SYNTAX-INSTRUCTION-EXPANDER: bad instruction" + instruction)) ((eq? (car instruction) 'UNQUOTE) (if-not-expanded)) ((memq (car instruction) @@ -72,7 +73,9 @@ MIT in each case. |# (if (null? place) (error "lap:syntax-instruction-expander: unknown opcode" (car instruction)) - (kernel (car instruction) (cdr instruction) (cdr place)))))))))) + (kernel (car instruction) + (cdr instruction) + (cdr place)))))))))) ;;;; Quasiquote unsyntaxing @@ -112,25 +115,28 @@ MIT in each case. |# ;;; SYNTAX-EVALUATION and OPTIMIZE-GROUP expanders (define syntax-evaluation-expander - ((access scode->scode-expander package/expansion package/scode-optimizer) - (lambda (operands if-expanded if-not-expanded) - (if (and (scode/constant? (car operands)) - (scode/variable? (cadr operands)) - (not (lexical-unreferenceable? - (access lap-syntax-package compiler-package) - (scode/variable-name (cadr operands))))) - (if-expanded - (scode/make-constant - ((lexical-reference (access lap-syntax-package compiler-package) - (scode/variable-name (cadr operands))) - (scode/constant-value (car operands))))) - (if-not-expanded))))) + (scode->scode-expander + (let ((environment + (package/environment (find-package '(COMPILER LAP-SYNTAXER))))) + (lambda (operands if-expanded if-not-expanded) + (if (and (scode/constant? (car operands)) + (scode/variable? (cadr operands)) + (not (lexical-unreferenceable? + environment + (scode/variable-name (cadr operands))))) + (if-expanded + (scode/make-constant + ((lexical-reference environment + (scode/variable-name (cadr operands))) + (scode/constant-value (car operands))))) + (if-not-expanded)))))) ;; This relies on the fact that scode/constant-value = identity-procedure. (define optimize-group-expander - ((access scode->scode-expander package/expansion package/scode-optimizer) + (scode->scode-expander (lambda (operands if-expanded if-not-expanded) + if-not-expanded (optimize-group-internal operands (lambda (result make-group?) @@ -153,7 +159,7 @@ MIT in each case. |# (eq? (scode/absolute-reference-name expr) name)))) (define cons-syntax-expander - ((access scode->scode-expander package/expansion package/scode-optimizer) + (scode->scode-expander (lambda (operands if-expanded if-not-expanded) (define (default) (cond ((not (scode/constant? (cadr operands))) @@ -220,8 +226,7 @@ MIT in each case. |# operator (list (car operands) rest)))))))))))) - - ((access scode->scode-expander package/expansion package/scode-optimizer) + (scode->scode-expander (lambda (operands if-expanded if-not-expanded) (if (not (scode/combination? (car operands))) (if-not-expanded) @@ -237,4 +242,4 @@ MIT in each case. |# 'CONS (list rest (scode/make-variable - (car binding)))))))))))))) + (car binding)))))))))))))) \ No newline at end of file diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm index 1749eb247..d4383f23b 100644 --- a/v7/src/compiler/back/syntax.scm +++ b/v7/src/compiler/back/syntax.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.20 1987/08/13 01:59:05 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.21 1988/06/14 08:11:04 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,7 +59,7 @@ MIT in each case. |# (set-cdr! tail directives2)) directives1)))) -(define-export (lap:syntax-instruction instruction) +(define (lap:syntax-instruction instruction) (if (memq (car instruction) '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL BLOCK-OFFSET)) (directive->instruction-sequence instruction) @@ -157,12 +157,15 @@ MIT in each case. |# (let ((chosen (choose-clause expression clauses))) `(LET ((,name ,expression)) (DECLARE (INTEGRATE ,name)) + ,name ;ignore if not referenced (CAR ,(car chosen)))) `(SYNTAX-VARIABLE-WIDTH-EXPRESSION ,expression (LIST ,@(map (LAMBDA (clause) - `(CONS (LAMBDA (,name) ,(car clause)) + `(CONS (LAMBDA (,name) + ,name ;ignore if not referenced + ,(car clause)) ',(cdr clause))) clauses))))) -- 2.25.1