From: Chris Hanson Date: Sun, 3 May 1987 20:39:08 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~13562 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f21fa2b70293cd2083c52bc6f0c37a9850ac1791;p=mit-scheme.git Initial revision --- diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm new file mode 100644 index 000000000..26b77e62d --- /dev/null +++ b/v7/src/compiler/rtlgen/rgrval.scm @@ -0,0 +1,201 @@ +d3 1 +a4 1 +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 1.1 1987/05/03 20:39:08 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 1.1 1987/05/03 20:39:08 cph Exp $ + +Copyright (c) 1988, 1990 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 + +;;;; RTL Generation: RValues +;;; package: (compiler rtl-generator generate/rvalue) +(define (generate:rvalue rvalue offset) + ((vector-method rvalue generate:rvalue) rvalue offset)) + +(define (define-rvalue-generator tag generator) + (define-vector-method tag generate:rvalue generator)) + (with-values (lambda () (generate/rvalue* operand)) +(define rvalue-methods + (return-2 (make-null-cfg) expression)) + +(define-integrable (expression-value/transform expression-value transform) + (transmit-values expression-value + (lambda (prefix expression) + (return-2 prefix (transform expression))))) + +(define (generate:constant constant offset) + (expression-value/simple (rtl:make-constant (constant-value constant)))) + +(define-rvalue-generator constant-tag + generate:constant) + +(define-rvalue-generator block-tag + (lambda (block offset) +(define-method-table-entry 'BLOCK rvalue-methods + +(define-rvalue-generator reference-tag + (lambda (reference offset) + (generate:variable (reference-block reference) + (reference-variable reference) + offset))) + +(define (generate:variable block variable offset) + (if (vnode-known-constant? variable) + (generate:constant (vnode-known-value variable) offset) + (find-variable block variable offset + (lambda (locative) + (expression-value/simple (rtl:make-fetch locative))) + (lambda (environment name) + (return-2 + (rtl:make-interpreter-call:lookup environment + (intern-scode-variable! block + name)) + (rtl:interpreter-call-result:lookup)))))) + +(define-rvalue-generator temporary-tag + (lambda (temporary offset) + (if (vnode-known-constant? temporary) + (generate:constant (vnode-known-value temporary) offset) + (let ((type (temporary-type temporary))) + (cond ((not type) + (expression-value/simple (rtl:make-fetch temporary))) + ((eq? type 'VALUE) + (expression-value/simple (rtl:make-fetch register:value))) + (else + (error "Illegal temporary reference" type))))))) + +(define-rvalue-generator access-tag + (lambda (*access offset) + (transmit-values (generate:expression (access-environment *access) offset) + (lambda (prefix expression) + (return-2 + (rtl:make-interpreter-call:access expression (access-name *access)) + (rtl:interpreter-call-result:access)))))) + +(define-rvalue-generator procedure-tag + (lambda (procedure offset) +(define-method-table-entry 'PROCEDURE rvalue-methods + (case (procedure/type procedure) + (expression-value/transform (make-closure-environment procedure offset) + (lambda (environment) + (make-closure-cons procedure environment)))) + (else + (expression-value/simple (make-ic-cons procedure))) + (make-cons-closure-indirection procedure))))) + (error "Reference to open procedure" procedure)) + (if (not (procedure-virtual-closure? procedure)) + (error "Reference to open procedure" procedure)) + +(define (make-ic-cons procedure) + ;; IC procedures have their entry points linked into their headers + ;; at load time by the linker. + (let ((header + (scode/make-lambda (variable-name (procedure-name procedure)) + (map variable-name (procedure-required procedure)) + (map variable-name (procedure-optional procedure)) + (let ((rest (procedure-rest procedure))) + (and rest (variable-name rest))) + (map variable-name + (append (procedure-auxiliary procedure) + (procedure-names procedure))) + '() + false))) + (set! *ic-procedure-headers* + (cons (cons procedure header) + *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)))) + ;; inside another IC procedure? +(define (make-closure-environment procedure offset) + (let ((block (block-parent (procedure-block procedure)))) + (define (ic-locative closure-block block offset) + (let ((loser + (lambda (locative) + (error "Closure parent not IC block")))) + (find-block closure-block block offset loser loser + (lambda (locative nearest-ic-locative) locative)))) +(define (make-non-trivial-closure-cons procedure block**) + (expression-value/simple (rtl:make-constant false))) + ((ic-block? block) + (expression-value/simple + (let ((closure-block (procedure-closure-block procedure))) + (if (ic-block? closure-block) + (rtl:make-fetch register:environment) + (ic-locative closure-block block offset))))) + ((closure-block? block) + (let ((closure-block (procedure-closure-block procedure))) + (define (loop variables n) + (cond ((null? variables) + (return-3 offset n '())) + ((integrated-vnode? (car variables)) + (loop (cdr variables) n)) + (else + (transmit-values (loop (cdr variables) (1+ n)) + (lambda (offset n pushes) + (return-3 + (1+ offset) + n + (cons (rtl:make-push + (rtl:make-fetch + (find-closure-variable closure-block + (car variables) + offset))) + pushes))))))) + + (define (make-frame n pushes) + (return-2 + (scfg*->scfg! + (reverse! + (cons (rtl:make-interpreter-call:enclose n) pushes))) + (rtl:interpreter-call-result:enclose))) + + (transmit-values (loop (block-bound-variables block) 0) + (lambda (offset n pushes) + (let ((parent (block-parent block))) + (if parent + (make-frame (1+ n) + (cons (rtl:make-push + (ic-locative closure-block parent + offset)) + pushes)) + (make-frame n pushes))))))) + (else (error "Unknown block type" block))))) + +(define (make-closure-cons procedure environment) + (rtl:make-typed-cons:pair (rtl:make-constant type-code:compiled-procedure) + (rtl:make-entry:procedure procedure) + environment)) (find-closure-variable context variable))))) + code))))) + (error "Unknown block type" block)))))) + (error "Unknown block type" block))))))