From bb9705a6a9b3bd657d3147d6ba89cc0fe3d04a9b Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Fri, 15 Apr 1988 02:10:18 +0000 Subject: [PATCH] Change the way first class environments are handled. There is an extra phase at the front end which translates implicit environment manipulation operations into explicit ones. --- v7/src/compiler/base/debug.scm | 15 +- v7/src/compiler/base/infnew.scm | 65 +++++- v7/src/compiler/base/lvalue.scm | 10 +- v7/src/compiler/base/proced.scm | 7 +- v7/src/compiler/base/scode.scm | 14 +- v7/src/compiler/base/switch.scm | 12 +- v7/src/compiler/base/toplev.scm | 262 +++++++++++++++------- v7/src/compiler/base/utils.scm | 3 +- v7/src/compiler/fggen/fggen.scm | 135 +++++++---- v7/src/compiler/fgopt/blktyp.scm | 8 +- v7/src/compiler/fgopt/closan.scm | 24 +- v7/src/compiler/machines/bobcat/decls.scm | 8 +- v7/src/compiler/rtlgen/rgproc.scm | 9 +- v7/src/compiler/rtlgen/rgrval.scm | 102 +++++---- 14 files changed, 473 insertions(+), 201 deletions(-) diff --git a/v7/src/compiler/base/debug.scm b/v7/src/compiler/base/debug.scm index ea8800eb9..5c33d70c5 100644 --- a/v7/src/compiler/base/debug.scm +++ b/v7/src/compiler/base/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.3 1988/04/06 17:31:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.4 1988/04/15 02:08:15 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -91,8 +91,17 @@ MIT in each case. |# (lambda () (with-output-to-file (pathname-new-type pathname "rtl") (lambda () - (for-each show-rtl-instruction - (fasload (pathname-new-type pathname "brtl"))))))))) + (let ((obj (fasload (pathname-new-type pathname "brtl")))) + (if (vector? obj) + (for-each (lambda (block) + (write-char #\page) + (newline) + (write-string "Disassembly for object ") + (write (car block)) + (for-each show-rtl-instruction (cdr block)) + (newline)) + (vector->list obj)) + (for-each show-rtl-instruction obj))))))))) (define (dump-rtl filename) (write-instructions diff --git a/v7/src/compiler/base/infnew.scm b/v7/src/compiler/base/infnew.scm index 5cdb5bb12..665d0d8a9 100644 --- a/v7/src/compiler/base/infnew.scm +++ b/v7/src/compiler/base/infnew.scm @@ -1,5 +1,41 @@ -(declare (usual-integrations)) +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.2 1988/04/15 02:08:43 jinx Exp $ + +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 +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Debugging information output. + +(declare (usual-integrations)) + (define (generation-phase2 label-bindings external-labels) (make-compiler-info '() @@ -15,4 +51,29 @@ (else (loop (cdr external-labels))))))) label-bindings) (lambda (x y) - (< (label-info-offset x) (label-info-offset y))))))) \ No newline at end of file + (< (label-info-offset x) (label-info-offset y))))))) + +(define (generate-vector top-level selector others) + (let* ((last (length others)) + (v (make-vector (1+ last) '()))) + (vector-set! v 0 top-level) + (let loop ((l others)) + (if (null? l) + v + (let ((desc (car l))) + (vector-set! v (car desc) (selector desc)) + (loop (cdr l))))))) + +(define (generate-top-level-info top-level others) + (if (null? others) + top-level + (generate-vector top-level cadr others))) + +(define (generate-top-level-object top-level others) + (if (null? others) + top-level + (scode/make-comment + (list compiler-entries-tag + (generate-vector (compiled-code-address->block top-level) + caddr others)) + top-level))) \ No newline at end of file diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index fb551ad54..b911f7bd8 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.4 1988/03/14 20:24:11 jinx Exp $ +$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 $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -193,6 +193,14 @@ MIT in each case. |# (define-integrable (variable-assigned! variable) (set-variable-assigned?! variable true)) +;; Note: +;; If integration of known block values (first class environments) is +;; ever done, the package "optimization" transformations in +;; fggen/canon and fggen/fggen may break. There is a hidden reference +;; to the environment variable from lambda expressions closed in that +;; context. The variable can be eliminated if there are no references +;; and there are no lambda expressions implicitely referencing it. + (define (lvalue-integrated? lvalue) (let ((value (lvalue-known-value lvalue))) (and value diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index a678e36d9..160c14ebc 100644 --- a/v7/src/compiler/base/proced.scm +++ b/v7/src/compiler/base/proced.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.3 1988/03/14 20:24:24 jinx Exp $ +$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 $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -191,13 +191,14 @@ MIT in each case. |# (ic-block? (procedure-block procedure))) (define-integrable (procedure/closure? procedure) - (procedure-closure-block procedure)) + (and (procedure-closure-block procedure) + (not (procedure/ic? procedure)))) (define-integrable (procedure/trivial-closure? procedure) (let ((enclosing (procedure-closing-block procedure))) (or (null? enclosing) (and (ic-block? enclosing) - (not (ic-block/use-lookup? enclosing)))))) + (not (ic-block/use-lookup? enclosing)))))) (define (procedure/closed? procedure) (or (procedure/ic? procedure) diff --git a/v7/src/compiler/base/scode.scm b/v7/src/compiler/base/scode.scm index f7ee30b2d..92f3a0714 100644 --- a/v7/src/compiler/base/scode.scm +++ b/v7/src/compiler/base/scode.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.2 1987/12/30 06:59:28 cph Exp $ +$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 $ -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,7 +67,7 @@ MIT in each case. |# make-open-block open-block? open-block-components primitive-procedure? make-quotation quotation? quotation-expression - make-sequence sequence-actions + make-sequence sequence-actions sequence-components symbol? make-the-environment the-environment? make-unassigned-object unassigned-object? @@ -80,6 +80,14 @@ MIT in each case. |# (define-integrable (scode/constant-value constant) constant) (define scode/constant? (access scode-constant? system-global-environment)) +(define-integrable (scode/quotation-components quot recvr) + (recvr (scode/quotation-expression quot))) + +(define comment-tag:directive (make-named-tag "Expression Directive")) + +(define (scode/make-directive directive code) + (scode/make-comment (list comment-tag:directive directive) + code)) (define (scode/make-let names values . body) (scan-defines (scode/make-sequence body) (lambda (auxiliary declarations body) diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm index efcb45d00..4cea2d842 100644 --- a/v7/src/compiler/base/switch.scm +++ b/v7/src/compiler/base/switch.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.3 1988/03/14 20:24:41 jinx Exp $ +$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 $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,6 +36,8 @@ MIT in each case. |# (declare (usual-integrations)) +;;; Binary switches + (define compiler:enable-integration-declarations? true) (define compiler:enable-expansion-declarations? true) (define compiler:show-subphases? false) @@ -46,4 +48,10 @@ MIT in each case. |# (define compiler:implicit-self-static? false) (define compiler:cse? true) (define compiler:open-code-primitives? true) -(define compiler:generate-rtl-files? false) \ No newline at end of file +(define compiler:generate-rtl-files? false) + +;;; Nary switches + +(define compiler:package-optimization-level + ;; Possible values: NONE LOW HYBRID HIGH + 'HYBRID) \ No newline at end of file diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index cde93c1e4..efea8a100 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.5 1988/03/14 20:24:54 jinx Exp $ +$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 $ -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,7 +37,17 @@ MIT in each case. |# (declare (usual-integrations)) ;;; Global variables + +(define *recursive-compilation-count*) +(define *recursive-compilation-number*) +(define *recursive-compilation-results*) +(define *recursive-compilation-rtl-blocks*) + +(define *info-output-pathname* false) +(define *rtl-output-pathname* false) + (define *input-scode*) +(define *scode*) (define *ic-procedure-headers*) (define *root-block*) (define *root-expression*) @@ -63,7 +73,12 @@ MIT in each case. |# (define compiler:real-time 0) (define (compiler:reset!) + (set! *recursive-compilation-number* 0) + (set! *recursive-compilation-count* 1) + (set! *recursive-compilation-results* '()) + (set! *recursive-compilation-rtl-blocks* '()) (set! *input-scode*) + (set! *scode*) (set! *current-label-number*) (set! *constants*) (set! *blocks*) @@ -91,10 +106,9 @@ MIT in each case. |# (set! compiler:entry-points) (set! compiler:expression)) -(define (in-compiler thunk) - (fluid-let ((compiler:process-time 0) - (compiler:real-time 0) - #|(*input-scode*) +(define (in-compiler-recursively thunk) + (fluid-let ((*input-scode*) + (*scode*) (*current-label-number*) (*constants*) (*blocks*) @@ -106,23 +120,32 @@ MIT in each case. |# (*assignments*) (*ic-procedure-headers*) (*root-expression*) - (*root-block*) - (*rtl-expression*) - (*rtl-procedures*) - (*rtl-continuations*) - (*rtl-graphs*) - (label->object) - (*machine-register-map*) - (compiler:external-labels) - (compiler:label-bindings) - (compiler:block-label) - (compiler:entry-label) - (compiler:bits) - (compiler:code-vector) - (compiler:entry-points) - (compiler:expression)|#) + (*root-block*)) + (fluid-let ((*rtl-expression*) + (*rtl-procedures*) + (*rtl-continuations*) + (*rtl-graphs*) + (label->object) + (*machine-register-map*) + (compiler:external-labels) + (compiler:label-bindings) + (compiler:block-label) + (compiler:entry-label) + (compiler:bits) + (compiler:code-vector) + (compiler:entry-points) + (compiler:expression)) + (thunk)))) + +(define (in-compiler thunk) + (fluid-let ((compiler:process-time 0) + (compiler:real-time 0)) (compiler:reset!) - (let ((value (thunk))) + (let* ((topl (thunk)) + (value + ((access generate-top-level-object + debugging-information-package) + topl *recursive-compilation-results*))) (if (not compiler:preserve-data-structures?) (compiler:reset!)) (compiler-time-report "Total compilation time" @@ -255,37 +278,73 @@ MIT in each case. |# (scode-eval (compile-scode (procedure-lambda procedure) false false) (procedure-environment procedure))) +;; The rtl output should be fixed + +(define (compile-recursively scode) + (let ((my-number *recursive-compilation-count*)) + (set! *recursive-compilation-count* (1+ my-number)) + (newline) + (newline) + (display " *** Recursive compilation ") + (write my-number) + (display " ***") + (let ((val + (fluid-let ((*recursive-compilation-number* my-number) + (compiler:package-optimization-level 'NONE)) + (compile-scode scode + (and *rtl-output-pathname* true) + (and *info-output-pathname* true) + in-compiler-recursively)))) + (newline) + (display " *** Done with recursive compilation ") + (write my-number) + (display " ***") + (newline) + val))) + (define (compile-scode scode #!optional rtl-output-pathname - info-output-pathname) + info-output-pathname + wrapper) (if (unassigned? rtl-output-pathname) (set! rtl-output-pathname false)) (if (unassigned? info-output-pathname) (set! info-output-pathname false)) - (in-compiler - (lambda () - (set! *input-scode* scode) - (phase/fg-generation) - (phase/fg-optimization) - (phase/rtl-generation) -#| - (if info-output-pathname - (phase/info-generation-1 info-output-pathname)) -|# - (phase/rtl-optimization) - (if rtl-output-pathname - (phase/rtl-file-output rtl-output-pathname)) - (phase/bit-generation) - (phase/bit-linearization) - (phase/assemble) - (if info-output-pathname - (phase/info-generation-2 info-output-pathname)) - (phase/link) - compiler:expression - ))) + (fluid-let ((*info-output-pathname* + (if (and info-output-pathname + (not (eq? info-output-pathname true))) + info-output-pathname + *info-output-pathname*)) + (*rtl-output-pathname* + (if (and rtl-output-pathname + (not (eq? rtl-output-pathname true))) + rtl-output-pathname + *rtl-output-pathname*))) + ((if (unassigned? wrapper) + in-compiler + wrapper) + (lambda () + (set! *input-scode* scode) + (phase/fg-generation) + (phase/fg-optimization) + (phase/rtl-generation) + #| + (if info-output-pathname + (phase/info-generation-1 info-output-pathname)) + |# + (phase/rtl-optimization) + (if rtl-output-pathname + (phase/rtl-file-output rtl-output-pathname)) + (phase/bit-generation) + (phase/bit-linearization) + (phase/assemble) + (if info-output-pathname + (phase/info-generation-2 info-output-pathname)) + (phase/link) + compiler:expression)))) (define (compiler-phase name thunk) (compiler-phase/visible name @@ -336,28 +395,40 @@ MIT in each case. |# (SET! ,name))) (define (phase/fg-generation) - (compiler-phase "Generating the Flow Graph" - (lambda () - (set! *current-label-number* 0) - (set! *constants* '()) - (set! *blocks* '()) - (set! *expressions* '()) - (set! *procedures* '()) - (set! *lvalues* '()) - (set! *applications* '()) - (set! *parallels* '()) - (set! *assignments* '()) - (set! *root-expression* - ((access construct-graph fg-generator-package) - (if compiler:preserve-data-structures? - *input-scode* - (set! *input-scode*)))) - (set! *root-block* (expression-block *root-expression*)) - (if (or (null? *expressions*) - (not (null? (cdr *expressions*)))) - (error "Multiple expressions")) - (set! *expressions*)))) + (compiler-superphase + "Generating the Flow Graph" + (lambda () + (phase/canonicalize-scode) + (phase/translate-scode)))) + +(define (phase/canonicalize-scode) + (compiler-subphase "Canonicalizing Scode" + (lambda () + (set! *scode* + ((access canonicalize/top-level fg-generator-package) + (last-reference *input-scode*)))))) +(define (phase/translate-scode) + (compiler-subphase "Translating Scode into Flow Graph" + (lambda () + (set! *current-label-number* 0) + (set! *constants* '()) + (set! *blocks* '()) + (set! *expressions* '()) + (set! *procedures* '()) + (set! *lvalues* '()) + (set! *applications* '()) + (set! *parallels* '()) + (set! *assignments* '()) + (set! *root-expression* + ((access construct-graph fg-generator-package) + (last-reference *scode*))) + (set! *root-block* (expression-block *root-expression*)) + (if (or (null? *expressions*) + (not (null? (cdr *expressions*)))) + (error "Multiple expressions")) + (set! *expressions*)))) + (define (phase/fg-optimization) (compiler-superphase "Optimizing the Flow Graph" (lambda () @@ -483,9 +554,7 @@ MIT in each case. |# (set! *ic-procedure-headers* '()) (initialize-machine-register-map!) ((access generate/top-level rtl-generator-package) - (if compiler:preserve-data-structures? - *root-expression* - (set! *root-expression*))) + (last-reference *root-expression*)) (set! label->object (make/label->object *rtl-expression* *rtl-procedures* @@ -538,8 +607,17 @@ MIT in each case. |# (define (phase/rtl-file-output pathname) (compiler-phase "RTL File Output" (lambda () - (fasdump ((access linearize-rtl rtl-generator-package) *rtl-graphs*) - pathname)))) + (let ((lin ((access linearize-rtl rtl-generator-package) *rtl-graphs*))) + (if (eq? pathname true) + ;; recursive compilation + (set! *recursive-compilation-rtl-blocks* + (cons (cons *recursive-compilation-number* lin) + *recursive-compilation-rtl-blocks*)) + (fasdump (if (null? *recursive-compilation-rtl-blocks*) + lin + (list->vector + (cons (cons 0 lin) *recursive-compilation-rtl-blocks*))) + pathname)))))) (define (phase/register-allocation) (compiler-subphase "Allocating Registers" @@ -582,9 +660,7 @@ MIT in each case. |# (lap:make-entry-point compiler:entry-label compiler:block-label) ((access linearize-bits lap-syntax-package) - (if compiler:preserve-data-structures? - *rtl-graphs* - (set! *rtl-graphs*)))))))) + (last-reference *rtl-graphs*))))))) (define (phase/assemble) (compiler-phase "Assembling" @@ -600,6 +676,7 @@ MIT in each case. |# phase/assemble-finish))))) (define (phase/assemble-finish count code-vector labels bindings linkage-info) + linkage-info ;; ignored (set! compiler:code-vector code-vector) (set! compiler:entry-points labels) (set! compiler:label-bindings bindings) @@ -612,27 +689,44 @@ MIT in each case. |# (define (phase/info-generation-2 pathname) (compiler-phase "Generating Debugging Information (pass 2)" - (lambda () - (fasdump ((access generation-phase2 debugging-information-package) - compiler:label-bindings - (if compiler:preserve-data-structures? - compiler:external-labels - (set! compiler:external-labels))) - pathname) - (set-compiled-code-block/debugging-info! compiler:code-vector - (pathname->string pathname))))) + (lambda () + (let ((info + ((access generation-phase2 debugging-information-package) + compiler:label-bindings + (last-reference compiler:external-labels)))) + + (if (eq? pathname true) ; recursive compilation + (begin + (set! *recursive-compilation-results* + (cons (list *recursive-compilation-number* + info + compiler:code-vector) + *recursive-compilation-results*)) + (set-compiled-code-block/debugging-info! + compiler:code-vector + (cons (pathname->string *info-output-pathname*) + *recursive-compilation-number*))) + (begin + (fasdump ((access generate-top-level-info + debugging-information-package) + info *recursive-compilation-results*) + pathname) + (set-compiled-code-block/debugging-info! + compiler:code-vector + (pathname->string pathname)))))))) (define (phase/link) (compiler-phase "Linking" (lambda () - ;; This has sections locked against GC since the code may not be - ;; purified. + ;; This has sections locked against GC to prevent relocation + ;; while computing addresses. (let ((bindings (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 diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index f2eab1fb6..163d644b6 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.3 1988/03/14 20:25:13 jinx Exp $ +$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 $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -253,7 +253,6 @@ MIT in each case. |# within-control-point call-with-current-continuation non-reentrant-call-with-current-continuation - with-threaded-continuation with-interrupt-mask with-interrupts-reduced execute-at-new-state-point diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index 4dd338da1..6d38cfa01 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.4 1988/03/14 20:48:00 jinx Exp $ +$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 $ -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 @@ -212,6 +212,7 @@ MIT in each case. |# (continue/rvalue-constant block continuation (make-constant expression))) (define (generate/the-environment block continuation expression) + expression ;; ignored (continue/rvalue-constant block continuation block)) (define (continue/rvalue-constant block continuation rvalue) @@ -225,6 +226,7 @@ MIT in each case. |# rvalue)) (define (continue/predicate-constant block continuation rvalue) + block continuation ;; ignored (if (and (rvalue/constant? rvalue) (false? (constant-value rvalue))) (snode->pcfg-false (make-fg-noop)) @@ -244,11 +246,13 @@ MIT in each case. |# (make-return block (make-reference block continuation true) rvalue)) (define (continue/effect block continuation rvalue) + rvalue ;; ignored (if (variable? continuation) (continue/unknown block continuation (make-constant false)) (make-null-cfg))) (define-integrable (continue/predicate block continuation rvalue) + block continuation ;; ignored (make-true-test rvalue)) (define (continue/value block continuation rvalue) @@ -308,9 +312,10 @@ MIT in each case. |# (search block)) (define (generate/lambda block continuation expression) - (generate/lambda* block continuation expression false)) + (generate/lambda* block continuation expression false false)) -(define (generate/lambda* block continuation expression continuation-type) +(define (generate/lambda* block continuation expression + continuation-type closure-block) (continue/rvalue-constant block continuation @@ -324,6 +329,19 @@ MIT in each case. |# (optional (make-variables block optional)) (rest (and rest (make-variable block rest))) (names (make-variables block names))) + (define (kernel) + (make-procedure + continuation-type/procedure + block name (cons continuation required) optional rest names + (map + (lambda (value) + ;; The other parts of this subproblem are not + ;; interesting since `value' is guaranteed to + ;; be either a constant or a procedure. + (subproblem-rvalue + (generate/subproblem/value block continuation value))) + values) + (generate/body block continuation declarations body))) (set-continuation-variable/type! continuation continuation-type) (set-block-bound-variables! block `(,continuation @@ -331,17 +349,11 @@ MIT in each case. |# ,@optional ,@(if rest (list rest) '()) ,@names)) - (make-procedure - continuation-type/procedure - block name (cons continuation required) optional rest names - (map (lambda (value) - ;; The other parts of this subproblem are not - ;; interesting since `value' is guaranteed to - ;; be either a constant or a procedure. - (subproblem-rvalue - (generate/subproblem/value block continuation value))) - values) - (generate/body block continuation declarations body)))))))))) + (if closure-block + (let ((proc (kernel))) + (set-procedure-closure-block! proc closure-block) + proc) + (kernel)))))))))) (define (parse-procedure-body auxiliary body) (transmit-values @@ -355,7 +367,9 @@ MIT in each case. |# lambda-tag:let auxiliary '() false names '() (scode/make-sequence (map* actions scode/make-assignment names values))) - (map (lambda (name) (scode/make-unassigned-object)) + (map (lambda (name) + name ;; ignored + (scode/make-unassigned-object)) auxiliary))))))) (define (parse-procedure-body* names actions) @@ -512,7 +526,8 @@ MIT in each case. |# (generate/lambda* block continuation* operator - (continuation/known-type continuation)) + (continuation/known-type continuation) + false) (generate/expression block continuation* operator))))) @@ -617,11 +632,52 @@ MIT in each case. |# (scode/make-combination (ucode-primitive lexical-reference) (list environment name)))))) -(define (generate/comment block continuation expression) - (generate/expression block - continuation - (scode/comment-expression expression))) - +;; Handle directives inserted by the canonicalizer + +(define (generate/comment block continuation comment) + (scode/comment-components comment + (lambda (text expression) + (if (or (not (pair? text)) + (not (eq? (car text) comment-tag:directive)) + (null? (cdr text)) + (not (pair? (cadr text)))) (generate/expression block continuation expression) + (case (caadr text) + ((PROCESSED) + (generate/expression block continuation expression)) + ((COMPILE) + (if (not (scode/quotation? expression)) + (error "generate/comment: Bad compile directive" comment)) + (continue/rvalue-constant block continuation + (make-constant + (compile-recursively (scode/quotation-expression expression))))) ((ENCLOSE) + (generate/enclose block continuation expression)) + (else + (warn "generate/comment: Unknown directive" (cadr text) comment) + (generate/expression block continuation expression))))))) + +;; Enclose directives are generated only for lambda expressions +;; evaluated in environments whose manipulation has been made +;; explicit. The code should include a syntatic check. The;; expression must be a call to scode-eval with a quotation of a +;; lambda and a variable as arguments. +;; NOTE: This code depends on lvalue-integrated? never integrating +;; the hidden reference within the procedure object. See base/lvalue +;; for some more information. + +(define (generate/enclose block continuation expression) + (scode/combination-components + expression + (lambda (operator operands) + operator ;; ignored + (generate/lambda* + (block-parent block) + continuation + (scode/quotation-expression (car operands)) + false + (make-reference block + (find-name block + (scode/variable-name (cadr operands))) + false))))) + (define (generate/delay block continuation expression) (generate/combination block @@ -642,31 +698,18 @@ MIT in each case. |# (scode/make-combination compiled-error-procedure (cons message irritants)))))) -;; For now - -(define (compile-recursively expression block) - (error "compile-recursively: invoked!" expression)) - -(define (compile-recursively? block) - false) - (define (generate/in-package block continuation expression) - (let ((recursive? (compile-recursively? block))) - (if (not recursive?) - (warn "dynamic IN-PACKAGE not supported; body will be interpreted" - expression)) - (scode/in-package-components expression - (lambda (environment expression) - (generate/combination - block - continuation - (scode/make-combination - (ucode-primitive scode-eval) - (list (if recursive? - (scode/make-constant - (compile-recursively expression false)) - (scode/make-quotation expression)) - environment))))))) + (warn "generate/in-package: expression will be interpreted" + expression) + (scode/in-package-components expression + (lambda (environment expression) + (generate/combination + block + continuation + (scode/make-combination + (ucode-primitive scode-eval) + (list (scode/make-quotation expression) + environment)))))) (define (generate/quotation block continuation expression) (generate/combination diff --git a/v7/src/compiler/fgopt/blktyp.scm b/v7/src/compiler/fgopt/blktyp.scm index 24081325b..2b8451e13 100644 --- a/v7/src/compiler/fgopt/blktyp.scm +++ b/v7/src/compiler/fgopt/blktyp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.3 1988/03/14 20:51:26 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.4 1988/04/15 02:06:00 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -68,6 +68,12 @@ MIT in each case. |# (define (close-procedure! block) (let ((procedure (block-procedure block)) (parent (block-parent block))) + ;; Note: this should be innocuous if there is already a closure block. + ;; In particular, if there is a closure block which happens to be a + ;; reference placed there by the first-class environment transformation + ;; in fggen/fggen and fggen/canon, and it is replaced by the line below, + ;; the presumpt first-class environment is not really used as one, so + ;; the procedure is being "demoted" from first-class to closure. (set-procedure-closure-block! procedure parent) (((find-closure-bindings (lambda (closure-frame-block size) diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm index 7efa0a294..899608c55 100644 --- a/v7/src/compiler/fgopt/closan.scm +++ b/v7/src/compiler/fgopt/closan.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.2 1987/12/30 06:44:12 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.3 1988/04/15 02:05:28 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -60,6 +60,15 @@ construction mechanism that optimizes by means of a stack, because use of a stack associates procedure extent with block scope. For many simple techniques it generates more information than is needed. +**** Unfortunately the analysis is not compatible with the current +implementation of closures. If a closure invokes another procedure +which is not a child, the current implementation requires that the +other procedure also be a closure. However, if the closing-limit of +the caller is the same as the closure-block of the callee, the callee +will not be marked as a closure. This has disastrous results. As a +result, the analysis has been modified to force the closure-limit to +#F whenever a closure is identified. + |# (package (identify-closure-limits!) @@ -94,11 +103,15 @@ simple techniques it generates more information than is needed. (and procedure (rvalue/procedure? procedure) (procedure-always-known-operator? procedure) - (procedure-block procedure))))) + ;; **** Force trivial closure limit. + ;; (procedure-block procedure) + false)))) (define (close-assignment-values! assignment) (close-rvalue! (assignment-rvalue assignment) - (variable-block (assignment-lvalue assignment)))) + ;; **** Force trivial closure limit. + ;; (variable-block (assignment-lvalue assignment)) + false)) (define-integrable (close-rvalue! rvalue binding-block) (close-values! (rvalue-values rvalue) binding-block)) @@ -119,8 +132,9 @@ simple techniques it generates more information than is needed. (if (not (eq? new-closing-limit closing-limit)) (begin (set-procedure-closing-limit! procedure new-closing-limit) - ;; The following line forces the procedure's type to CLOSURE. - (set-procedure-closure-block! procedure true) + (if (not (procedure-closure-block procedure)) + ;; The following line forces the procedure's type to CLOSURE. + (set-procedure-closure-block! procedure true)) (close-callees! (procedure-block procedure) new-closing-limit)))))) (define (close-callees! block new-closing-limit) diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 1e5f39400..c924e38c0 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.3 1988/03/14 20:23:52 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.4 1988/04/15 02:08:28 jinx 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 @@ -228,7 +228,7 @@ MIT in each case. |# (filename/append "machines/bobcat" "insmac" "machin" "rgspcm") (filename/append "fggen" - "declar" "fggen") + "declar" "fggen" "canon") (filename/append "fgopt" "blktyp" "closan" "conect" "contan" "desenv" "folcon" "offset" "operan" "order" "outer" "simapp" "simple") @@ -320,7 +320,7 @@ MIT in each case. |# (file-dependency/integration/join (append (filename/append "fggen" - "declar" "fggen") + "declar" "fggen") ; "canon" needs no integrations (filename/append "fgopt" "blktyp" "closan" "conect" "contan" "desenv" "folcon" "offset" "operan" "order" "outer" "simapp" "simple")) diff --git a/v7/src/compiler/rtlgen/rgproc.scm b/v7/src/compiler/rtlgen/rgproc.scm index 55e65a27d..df42d1095 100644 --- a/v7/src/compiler/rtlgen/rgproc.scm +++ b/v7/src/compiler/rtlgen/rgproc.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.2 1988/03/14 20:54:09 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.3 1988/04/15 02:04:53 jinx 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 @@ -146,8 +146,7 @@ MIT in each case. |# (recvr (make-non-trivial-closure-cons value) (rtl:interpreter-call-result:enclose)))) ((IC) - (recvr (make-null-cfg) - (make-ic-cons value))) + (make-ic-cons value 'USE-ENV recvr)) ((OPEN-EXTERNAL OPEN-INTERNAL) (error "Letrec value is open procedure" value)) (else @@ -161,8 +160,10 @@ MIT in each case. |# (find-variable block variable 0 rtl:make-fetch (lambda (nearest-ic-locative name) + nearest-ic-locative name ;; ignored (error "Missing closure variable" variable)) (lambda (name) + name ;; ignored (error "Missing closure variable" variable))))) ;;; end GENERATE/PROCEDURE-HEADER diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index 0720ffe81..2e4c42b3c 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.4 1988/03/14 20:54:28 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.5 1988/04/15 02:04:18 jinx 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.4 1988/03/14 20:54:28 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.5 1988/04/15 02:04:18 jinx Exp $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -36,7 +36,7 @@ promotional, or sales literature without prior written consent from ;;;; RTL Generation: RValues ;;; package: (compiler rtl-generator generate/rvalue) -(package (generate/rvalue load-closure-environment) +(package (generate/rvalue load-closure-environment make-ic-cons) (define-export (generate/rvalue operand offset scfg*cfg->cfg! generator) (transmit-values (generate/rvalue* operand offset) @@ -66,6 +66,7 @@ promotional, or sales literature without prior written consent from result (lambda (constant offset) + offset ;; ignored (generate/constant constant))) (define-method-table-entry 'CONSTANT rvalue-methods (define (generate/constant constant) @@ -73,6 +74,7 @@ promotional, or sales literature without prior written consent from (lambda (constant) (lambda (block offset) + block offset ;; ignored (define-method-table-entry 'BLOCK rvalue-methods block ;; ignored @@ -160,25 +162,37 @@ promotional, or sales literature without prior written consent from (rtl:make-fetch register)))) (rtl:make-fetch register))))) (else - (expression-value/simple (make-ic-cons procedure))) + (make-ic-cons procedure offset + (lambda (scfg expr) (return-2 scfg expr)))) (make-cons-closure-indirection procedure))))) (error "Reference to open procedure" procedure)) (if (not (procedure-virtual-closure? procedure)) (error "Reference to open procedure" procedure)) ;; inside another IC procedure? (define-export (load-closure-environment procedure offset closure-locative) + (define (load-closure-parent block force?) + (if (and (not force?) + (or (not block) + (not (ic-block/use-lookup? block)))) + (make-null-cfg) + (let ((closure-block (procedure-closure-block procedure))) + (rtl:make-assignment + (rtl:locative-offset closure-locative closure-block-first-offset) + (cond ((not (ic-block/use-lookup? block)) + (rtl:make-constant false)) + ((reference? closure-block) + (error "load-closure-environment: bad closure block" + procedure)) + ((ic-block? closure-block) + (rtl:make-fetch register:environment)) + (else + (closure-ic-locative closure-block block offset))))))) + (enqueue-procedure! procedure) (let ((block (procedure-closing-block procedure))) (define (make-non-trivial-closure-cons procedure block**) (make-null-cfg)) ((ic-block? block) - (rtl:make-assignment - (rtl:locative-offset closure-locative closure-block-first-offset) - (if (ic-block/use-lookup? block) - (let ((closure-block (procedure-closure-block procedure))) - (if (ic-block? closure-block) - (rtl:make-fetch register:environment) - (closure-ic-locative closure-block block offset))) - (rtl:make-constant false)))) + (load-closure-parent block true)) ((closure-block? block) (let ((closure-block (procedure-closure-block procedure))) (define (loop entries code) @@ -211,44 +225,50 @@ promotional, or sales literature without prior written consent from (loop (block-closure-offsets block) - (if (let ((parent (block-parent block))) - (and parent (ic-block/use-lookup? parent))) - (rtl:make-assignment - (rtl:locative-offset closure-locative - closure-block-first-offset) - (if (ic-block? closure-block) - (rtl:make-fetch register:environment) - (closure-ic-locative closure-block block offset))) - (make-null-cfg))))) + (load-closure-parent (block-parent block) false)))) (else (error "Unknown block type" block))))) - -;;; end GENERATE/RVALUE -) -(define (make-ic-cons procedure) +(define-export (make-ic-cons procedure offset recvr) ;; IC procedures have their entry points linked into their headers ;; at load time by the linker. - (let ((header - (scode/make-lambda (procedure-name procedure) - (map variable-name - (procedure-required-arguments procedure)) - (map variable-name (procedure-optional procedure)) - (let ((rest (procedure-rest procedure))) - (and rest (variable-name rest))) - (map variable-name (procedure-names procedure)) - '() - false))) + (let* ((header + (scode/make-lambda (procedure-name procedure) + (map variable-name + (procedure-required-arguments procedure)) + (map variable-name (procedure-optional procedure)) + (let ((rest (procedure-rest procedure))) + (and rest (variable-name rest))) + (map variable-name (procedure-names procedure)) + '() + false)) + (kernel + (lambda (scfg expr) + (recvr scfg + (rtl:make-typed-cons:pair + (rtl:make-constant (scode/procedure-type-code header)) + (rtl:make-constant header) + expr))))) (set! *ic-procedure-headers* (cons (cons header (procedure-label procedure)) *ic-procedure-headers*)) - (rtl:make-typed-cons:pair - (rtl:make-constant (scode/procedure-type-code header)) - (rtl:make-constant header) - ;; Is this right if the procedure is being closed - ;; inside another IC procedure? - (rtl:make-fetch register:environment)))) + + (cond ((not (reference? (procedure-closure-block procedure))) + ;; Is this right if the procedure is being closed + ;; inside another IC procedure? + (kernel (make-null-cfg) + (rtl:make-fetch register:environment))) + ((eq? offset 'USE-ENV) + (error "make-ic-cons: offset unavailable" procedure)) + (else + (transmit-values + (generate/rvalue* (procedure-closure-block procedure) + offset) + kernel))))) +;;; end GENERATE/RVALUE +) + (define (make-trivial-closure-cons procedure) (rtl:make-cons-pointer (rtl:make-constant type-code:compiled-entry) -- 2.25.1