From 1c9a11b5b69c13d02b73af06797e4b5b72e92479 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 7 May 1987 00:23:08 +0000 Subject: [PATCH] Initial revision --- v7/src/compiler/rtlgen/rgproc.scm | 141 ++++++++++++++++++++++++++++++ v7/src/compiler/rtlgen/rgstmt.scm | 111 +++++++++++++++++++++++ 2 files changed, 252 insertions(+) create mode 100644 v7/src/compiler/rtlgen/rgproc.scm create mode 100644 v7/src/compiler/rtlgen/rgstmt.scm diff --git a/v7/src/compiler/rtlgen/rgproc.scm b/v7/src/compiler/rtlgen/rgproc.scm new file mode 100644 index 000000000..72cb46e70 --- /dev/null +++ b/v7/src/compiler/rtlgen/rgproc.scm @@ -0,0 +1,141 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 1.1 1987/05/07 00:22:51 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Generation: Procedure Headers + +(declare (usual-integrations)) + +(package (generate/procedure-header) + +(define-export (generate/procedure-header procedure body) + (if (procedure/ic? procedure) + body + (scfg-append! + ((if (or (procedure-rest procedure) + (and (procedure/closure? procedure) + (not (null? (procedure-optional procedure))))) + rtl:make-setup-lexpr + rtl:make-procedure-heap-check) + procedure) + (setup-stack-frame procedure) + body))) + +(define (setup-stack-frame procedure) + (let ((block (procedure-block procedure))) + (define (cellify-variables variables) + (scfg*->scfg! (map cellify-variable variables))) + + (define (cellify-variable variable) + (if (variable-in-cell? variable) + (let ((locative + (stack-locative-offset (rtl:make-fetch register:frame-pointer) + (variable-offset block variable)))) + (rtl:make-assignment + locative + (rtl:make-cell-cons (rtl:make-fetch locative)))) + (make-null-cfg))) + + (let ((names (procedure-names procedure)) + (values (procedure-values procedure))) + (scfg-append! (setup-bindings names values '()) + (setup-auxiliary (procedure-auxiliary procedure) '()) + (rtl:make-assignment + register:frame-pointer + (rtl:make-fetch register:stack-pointer)) + (cellify-variables (procedure-required procedure)) + (cellify-variables (procedure-optional procedure)) + (let ((rest (procedure-rest procedure))) + (if rest + (cellify-variable rest) + (make-null-cfg))) + (scfg*->scfg! + (map (lambda (name value) + (if (and (procedure? value) + (procedure/closure? value)) + (letrec-close block name value) + (make-null-cfg))) + names values)))))) + +(define (setup-bindings names values pushes) + (if (null? names) + (scfg*->scfg! pushes) + (setup-bindings (cdr names) + (cdr values) + (cons (make-auxiliary-push (car names) + (letrec-value (car values))) + pushes)))) + +(define (letrec-value value) + (cond ((constant? value) + (rtl:make-constant (constant-value value))) + ((procedure? value) + (case (procedure/type value) + ((CLOSURE) + (make-closure-cons value (rtl:make-constant '()))) + ((IC) + (make-ic-cons value)) + ((OPEN-EXTERNAL OPEN-INTERNAL) + (error "Letrec value is open procedure" value)) + (else + (error "Unknown procedure type" value)))) + (else + (error "Unknown letrec binding value" value)))) + +(define (letrec-close block variable value) + (transmit-values (make-closure-environment value) + (lambda (prefix environment) + (scfg*scfg->scfg! prefix + (rtl:make-assignment + (closure-procedure-environment-locative + (find-variable block variable + (lambda (locative) locative) + (lambda (nearest-ic-locative name) + (error "Missing closure variable" variable)))) + environment))))) + +(define (setup-auxiliary variables pushes) + (if (null? variables) + (scfg*->scfg! pushes) + (setup-auxiliary (cdr variables) + (cons (make-auxiliary-push (car variables) + (rtl:make-unassigned)) + pushes)))) + +(define (make-auxiliary-push variable value) + (rtl:make-push (if (variable-in-cell? variable) + (rtl:make-cell-cons value) + value))) + +;;; end GENERATE/PROCEDURE-HEADER +) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm new file mode 100644 index 000000000..6b01ed791 --- /dev/null +++ b/v7/src/compiler/rtlgen/rgstmt.scm @@ -0,0 +1,111 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 1.1 1987/05/07 00:23:08 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Generation: Statements + +(declare (usual-integrations)) + +;;;; Statements + +(define-statement-generator definition-tag + (lambda (node subproblem?) + (transmit-values (generate/rvalue (definition-rvalue node)) + (lambda (prefix expression) + (scfg*scfg->scfg! + prefix + (find-variable (definition-block node) (definition-lvalue node) + (lambda (locative) + (error "Definition of compiled variable")) + (lambda (environment name) + (rtl:make-interpreter-call:define environment name + expression)))))))) + +(define-statement-generator assignment-tag + (lambda (node subproblem?) + (let ((lvalue (assignment-lvalue node))) + (if (and (integrated-vnode? lvalue) + (not (value-temporary? lvalue))) + (make-null-cfg) + (transmit-values (generate/rvalue (definition-rvalue node)) + (lambda (prefix expression) + (scfg*scfg->scfg! + prefix + (generate/assignment (assignment-block node) + lvalue + expression + subproblem?)))))))) + +(define (generate/assignment block lvalue expression subproblem?) + ((vector-method lvalue generate/assignment) + block lvalue expression subproblem?)) + +(define (define-assignment tag generator) + (define-vector-method tag generate/assignment generator)) + +(define-assignment variable-tag + (lambda (block lvalue expression subproblem?) + (find-variable block lvalue + (lambda (locative) + (rtl:make-assignment locative expression)) + (lambda (environment name) + (rtl:make-interpreter-call:set! environment + (intern-scode-variable! block name) + expression))))) + +(define-assignment temporary-tag + (lambda (block lvalue expression subproblem?) + (case (temporary-type lvalue) + ((#F) + (rtl:make-assignment lvalue expression)) + ((VALUE) + (assignment/value-register block expression subproblem?)) + (else + (error "Unknown temporary type" lvalue))))) + +(define (assignment/value-register block expression subproblem?) + (if subproblem? (error "Return node has next")) + (scfg*scfg->scfg! + (rtl:make-assignment register:value expression) + (if (stack-block? block) + (if (stack-parent? block) + (rtl:make-message-sender:value (block-frame-size block)) + (scfg*scfg->scfg! + (rtl:make-pop-frame (block-frame-size block)) + (rtl:make-return))) + (rtl:make-return)))) + +(define-assignment value-ignore-tag + (lambda (block lvalue rvalue subproblem? wrap-expression) + (if subproblem? (error "Return node has next")) + (scfg-next-hooks n6))))))))) \ No newline at end of file -- 2.25.1