From acc1eaa7c5d7e7a28741b76e95aac2224d85a527 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 20 Dec 1986 22:53:46 +0000 Subject: [PATCH] Initial revision --- v7/src/compiler/rtlgen/rgcomb.scm | 513 ++++++++++++++++++++++++++++++ v7/src/compiler/rtlgen/rtlgen.scm | 444 ++++++++++++++++++++++++++ 2 files changed, 957 insertions(+) create mode 100644 v7/src/compiler/rtlgen/rgcomb.scm create mode 100644 v7/src/compiler/rtlgen/rtlgen.scm diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm new file mode 100644 index 000000000..11a2528c9 --- /dev/null +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -0,0 +1,513 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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: Combinations + +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.1 1986/12/20 22:53:13 cph Exp $ + +(declare (usual-integrations)) +(using-syntax (access compiler-syntax-table compiler-package) + +(define-generator combination-tag + (lambda (combination offset) + ((cond ((combination-constant? combination) combination:constant) + ((let ((operator (combination-known-operator combination))) + (and operator + (normal-primitive-constant? operator))) + combination:primitive) + (else combination:normal)) + combination offset))) + +(define (combination:normal combination offset) + ;; For the time being, all close-coded combinations will return + ;; their values in the value register. If the value of a + ;; combination is not a temporary, it is either a value-register + ;; or a value-ignore, which is alright. + (let ((value (combination-value combination))) + (if (temporary? value) + (let ((type* (temporary-type value))) + (if type* + (if (not (eq? 'VALUE type*)) + (error "COMBINATION:NORMAL: bad temporary type" type*)) + (set-temporary-type! value 'VALUE))))) + ((if (snode-next combination) combination:subproblem combination:reduction) + combination offset)) + +(define (combination:constant combination offset) + (let ((value (combination-value combination)) + (next (snode-next combination))) + (cond ((or (value-register? value) + (value-temporary? value)) + (generate-assignment (combination-block combination) + value + (combination-constant-value combination) + next + offset)) + ((value-ignore? value) + (generate:next next)) + (else (error "Unknown combination value" value))))) + +(define (combination:primitive combination offset) + (let ((open-coder + (assq (constant-value (combination-known-operator combination)) + primitive-open-coders))) + (or (and open-coder + ((cdr open-coder) combination offset)) + (combination:normal combination offset)))) + +(define (define-open-coder primitive open-coder) + (let ((entry (assq primitive primitive-open-coders))) + (if entry + (set-cdr! entry open-coder) + (set! primitive-open-coders + (cons (cons primitive open-coder) + primitive-open-coders)))) + primitive) + +(define primitive-open-coders + '()) + +(define-open-coder pair? + (lambda (combination offset) + (and (combination-compiled-for-predicate? combination) + (open-code:type-test combination offset (ucode-type pair) 0)))) + +(define-open-coder primitive-type? + (lambda (combination offset) + (and (combination-compiled-for-predicate? combination) + (operand->index combination 0 + (lambda (type) + (open-code:type-test combination offset type 1)))))) + +(define (open-code:type-test combination offset type operand) + (let ((next (snode-next combination)) + (operand (list-ref (combination-operands combination) operand))) + (scfg*pcfg->pcfg! + (generate:cfg (subproblem-cfg operand) offset) + (pcfg*scfg->pcfg! + (rvalue->pexpression (subproblem-value operand) offset + (lambda (expression) + (rtl:make-type-test (rtl:make-object->type expression) type))) + (generate:next (pnode-consequent next) offset) + (generate:next (pnode-alternative next) offset))))) + +(define-open-coder car + (lambda (combination offset) + (open-code:memory-reference combination offset 0))) + +(define-open-coder cdr + (lambda (combination offset) + (open-code:memory-reference combination offset 1))) + +(define-open-coder cell-contents + (lambda (combination offset) + (open-code:memory-reference combination offset 0))) + +(define-open-coder vector-length + (lambda (combination offset) + (open-code-expression-1 combination offset + (lambda (operand) + (rtl:make-cons-pointer + (rtl:make-constant (ucode-type fixnum)) + (rtl:make-fetch (rtl:locative-offset operand 0))))))) + +(define-open-coder vector-ref + (lambda (combination offset) + (operand->index combination 1 + (lambda (index) + (open-code:memory-reference combination offset index))))) + +(define (open-code:memory-reference combination offset index) + (open-code-expression-1 combination offset + (lambda (operand) + (rtl:make-fetch (rtl:locative-offset operand index))))) + +(define (open-code-expression-1 combination offset receiver) + (let ((operand (car (combination-operands combination)))) + (scfg*scfg->scfg! + (generate:cfg (subproblem-cfg operand) offset) + (rvalue->sexpression (subproblem-value operand) + (lambda (expression) + (generate-assignment (combination-block combination) + (combination-value combination) + (receiver expression) + (snode-next combination) + offset)))))) + +(define (operand->index combination n receiver) + (let ((operand (list-ref (combination-operands combination) n))) + (and (subproblem-known-constant? operand) + (let ((value (subproblem-constant-value operand))) + (and (integer? value) + (not (negative? value)) + (receiver value)))))) + +(define-integrable (combination-compiled-for-predicate? combination) + (eq? 'PREDICATE (combination-compilation-type combination))) + +;;;; Subproblems + +(define (combination:subproblem combination offset) + (let ((block (combination-block combination)) + (finish + (lambda (offset delta call-prefix continuation-prefix) + (let ((continuation + (make-continuation + (scfg*scfg->scfg! continuation-prefix + (generate:next (snode-next combination) + offset)) + delta))) + (scfg*scfg->scfg! (call-prefix continuation) + (combination:subproblem-body combination + (+ offset delta) + continuation)))))) + (cond ((ic-block? block) + ;; **** Actually, should only do this if the environment + ;; will be needed by the continuation. + (finish (1+ offset) 1 + (lambda (continuation) + (scfg*scfg->scfg! + (rtl:make-push (rtl:make-fetch register:environment)) + (rtl:make-push-return continuation))) + (rtl:make-pop register:environment))) + ((and (stack-block? block) + (let ((operator (combination-known-operator combination))) + (and operator + (procedure? operator) + (stack-procedure? operator)))) + (finish offset + (rtl:message-receiver-size:subproblem) + rtl:make-message-receiver:subproblem + (make-null-cfg))) + (else + (finish offset 1 rtl:make-push-return (make-null-cfg)))))) + +(define (combination:subproblem-body combination offset continuation) + ((let ((operator (combination-known-operator combination))) + (cond ((normal-primitive-constant? operator) make-call:primitive) + ((or (not operator) (not (procedure? operator))) make-call:unknown) + ((ic-procedure? operator) make-call:ic) + ((closure-procedure? operator) make-call:closure) + ((stack-procedure? operator) + (let ((block (combination-block combination))) + (cond ((stack-block? block) make-call:stack-with-link) + ((ic-block? block) + (error "IC procedure calling stack procedure" + combination)) + (else (error "Unknown caller type" block))))) + (else (error "Unknown callee type" operator)))) + combination offset invocation-prefix:null continuation)) + +;;;; Reductions + +(define (combination:reduction combination offset) + (fluid-let ((*continuation* false)) + (let ((operator (combination-known-operator combination)) + (block (combination-block combination))) + (define (choose-generator ic closure stack) + ((cond ((ic-block? block) ic) + ((closure-procedure-block? block) closure) + ((stack-procedure-block? block) stack) + (else (error "Unknown caller type" block))) + combination offset)) + (cond ((normal-primitive-constant? operator) + (choose-generator reduction:ic->primitive + reduction:closure->primitive + reduction:stack->primitive)) + ((or (not operator) + (not (procedure? operator))) + (choose-generator reduction:ic->unknown + reduction:closure->unknown + reduction:stack->unknown)) + ((ic-procedure? operator) + (choose-generator reduction:ic->ic + reduction:closure->ic + reduction:stack->ic)) + ((closure-procedure? operator) + (choose-generator reduction:ic->closure + reduction:closure->closure + reduction:stack->closure)) + ((stack-procedure? operator) + (choose-generator reduction:ic->stack + reduction:closure->stack + (let ((block* (procedure-block operator))) + (cond ((block-child? block block*) + reduction:stack->child) + ((block-sibling? block block*) + reduction:stack->sibling) + (else + reduction:stack->ancestor))))) + (else (error "Unknown callee type" operator)))))) + +(define (reduction:ic->unknown combination offset) + (make-call:unknown combination offset invocation-prefix:null false)) + +(define (reduction:ic->ic combination offset) + (make-call:ic combination offset invocation-prefix:null false)) + +(define (reduction:ic->primitive combination offset) + (make-call:primitive combination offset invocation-prefix:null false)) + +(define (reduction:ic->closure combination offset) + (make-call:closure combination offset invocation-prefix:null false)) + +(define (reduction:ic->stack combination offset) + ;; The callee must be a child of the caller, but in that case it + ;; should be a closure -- so this is a logic error. + (error "IC procedure calling stack procedure" combination)) + +(define (reduction:closure->unknown combination offset) + (make-call:unknown combination offset invocation-prefix:move-frame-up false)) + +(define (reduction:closure->ic combination offset) + (make-call:ic combination offset invocation-prefix:move-frame-up false)) + +(define (reduction:closure->primitive combination offset) + (make-call:primitive combination offset invocation-prefix:move-frame-up + false)) + +(define (reduction:closure->closure combination offset) + (make-call:closure combination offset invocation-prefix:move-frame-up false)) + +(define (reduction:closure->stack combination offset) + ;; The callee is known to be a child of the caller because the + ;; analyzer prohibits the other cases. + (make-call:child combination offset + rtl:make-message-receiver:closure + rtl:message-receiver-size:closure)) + +(define (reduction:stack->unknown combination offset) + (make-call:unknown combination offset invocation-prefix:stack->closure + false)) + +(define (reduction:stack->ic combination offset) + (make-call:ic combination offset invocation-prefix:stack->closure false)) + +(define (reduction:stack->primitive combination offset) + (make-call:primitive combination offset invocation-prefix:stack->closure + false)) + +(define (reduction:stack->closure combination offset) + (make-call:closure combination offset invocation-prefix:stack->closure + false)) + +(define (reduction:stack->child combination offset) + (make-call:child combination offset + rtl:make-message-receiver:stack + rtl:message-receiver-size:stack)) + +(define (reduction:stack->sibling combination offset) + (make-call:stack combination offset invocation-prefix:stack->sibling false)) + +(define (reduction:stack->ancestor combination offset) + (make-call:stack-with-link combination offset + invocation-prefix:stack->ancestor false)) + +;;;; Calls + +(define (make-call:apply combination offset invocation-prefix continuation) + (make-call:push-operator combination offset + (lambda (number-pushed) + (rtl:make-invocation:apply number-pushed + (invocation-prefix combination number-pushed) + continuation)))) + +(define (make-call:lookup combination offset invocation-prefix continuation) + (make-call:dont-push-operator combination offset + (lambda (number-pushed) + (let ((operator (subproblem-value (combination-operator combination)))) + (let ((block (reference-block operator)) + (name (variable-name (reference-variable operator)))) + (rtl:make-invocation:lookup + number-pushed + (invocation-prefix combination number-pushed) + continuation + (nearest-ic-block-expression block (+ offset number-pushed)) + (intern-scode-variable! block name))))))) + +(define (make-call:unknown combination offset invocation-prefix continuation) + (let ((operator (subproblem-value (combination-operator combination)))) + ((cond ((or (not (reference? operator)) + (reference-to-known-location? operator)) + make-call:apply) + ;; **** Need to add code for links here. + (else make-call:lookup)) + combination offset invocation-prefix continuation))) + +;;; For now, use apply. Later we can optimize for the cases where +;;; the callee's closing frame is easily available, such as calling a +;;; sibling, self-recursion, or an ancestor. + +(define make-call:ic make-call:apply) + +(define (make-call:primitive combination offset invocation-prefix continuation) + (make-call:dont-push-operator combination offset + (lambda (number-pushed) + (rtl:make-invocation:primitive + number-pushed + (invocation-prefix combination number-pushed) + continuation + (constant-value (combination-known-operator combination)))))) + +(define (make-call:closure combination offset invocation-prefix continuation) + (make-call:push-operator combination offset + (lambda (number-pushed) + (let ((operator (combination-known-operator combination))) + ((if (procedure-rest operator) + rtl:make-invocation:lexpr + rtl:make-invocation:jump) + number-pushed + (invocation-prefix combination number-pushed) + continuation + operator))))) + +(define (make-call:stack combination offset invocation-prefix continuation) + (make-call:dont-push-operator combination offset + (lambda (number-pushed) + (let ((operator (combination-known-operator combination))) + ((if (procedure-rest operator) + rtl:make-invocation:lexpr + rtl:make-invocation:jump) + number-pushed + (invocation-prefix combination number-pushed) + continuation + operator))))) + +(define (make-call:stack-with-link combination offset invocation-prefix + continuation) + (scfg*scfg->scfg! + (rtl:make-push + (rtl:make-address + (block-ancestor-or-self->locative + (combination-block combination) + (block-parent (procedure-block (combination-known-operator combination))) + offset))) + (make-call:stack combination (1+ offset) invocation-prefix continuation))) + +(define (make-call:child combination offset make-receiver receiver-size) + (scfg*scfg->scfg! + (make-receiver (block-frame-size (combination-block combination))) + (make-call:stack-with-link combination (+ offset (receiver-size)) + invocation-prefix:null false))) + +;;;; Prefixes + +(define (invocation-prefix:null combination number-pushed) + '(NULL)) + +(define (invocation-prefix:move-frame-up combination number-pushed) + `(MOVE-FRAME-UP ,number-pushed + ,(block-frame-size (combination-block combination)))) + +(define (invocation-prefix:stack->closure combination number-pushed) + ;; The message sender will shift the new stack frame down to the + ;; correct position when it is done, then reset the stack pointer. + `(APPLY-CLOSURE ,number-pushed + ,(+ number-pushed + (block-frame-size (combination-block combination))))) + +(define (invocation-prefix:stack->ancestor combination number-pushed) + (let ((block (combination-block combination))) + `(APPLY-STACK ,number-pushed + ,(+ number-pushed (block-frame-size block)) + ,(block-ancestor-distance + block + (procedure-block + (combination-known-operator combination)))))) + +(define (invocation-prefix:stack->sibling combination number-pushed) + `(MOVE-FRAME-UP ,number-pushed + ;; -1+ means reuse the existing static link. + ,(-1+ (block-frame-size (combination-block combination))))) + +;;;; Call Sequence Kernels + +(define (make-call-maker operator-cfg wrap-n) + (lambda (combination offset make-invocation) + (let ((operator (combination-known-operator combination)) + (operands (combination-operands combination))) + (let ((n-operands (length operands)) + (finish + (lambda (n offset) + (scfg*->scfg! + (let operand-loop + ((operands (reverse operands)) + (offset offset)) + (if (null? operands) + (list + (operator-cfg (combination-operator combination) offset) + (make-invocation (wrap-n n))) + (cons (subproblem->push (car operands) offset) + (operand-loop (cdr operands) (1+ offset))))))))) + (if (and operator + (procedure? operator) + (not (procedure-rest operator)) + (stack-block? (procedure-block operator))) + (let ((n-parameters (+ (length (procedure-required operator)) + (length (procedure-optional operator))))) + (let ((delta (- n-parameters n-operands))) + (scfg*scfg->scfg! + (scfg*->scfg! (push-n-unassigned delta)) + (finish n-parameters (+ offset delta))))) + (finish n-operands offset)))))) + +(define (push-n-unassigned n) + (if (zero? n) + '() + (cons (rtl:make-push (rtl:make-unassigned)) + (push-n-unassigned (-1+ n))))) + +(define (subproblem->push subproblem offset) + (scfg*scfg->scfg! (generate:cfg (subproblem-cfg subproblem) offset) + (rvalue->sexpression (subproblem-value subproblem) offset + rtl:make-push))) + +(define make-call:dont-push-operator + (make-call-maker subproblem-cfg identity-procedure)) + +(define make-call:push-operator + (make-call-maker subproblem->push 1+)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access rtl-generator-package compiler-package) +;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package) +;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package) +;;; End: + ,(-1+ (block-frame-size (combination-block combination))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm new file mode 100644 index 000000000..e4c6575c4 --- /dev/null +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -0,0 +1,444 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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 + +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.1 1986/12/20 22:53:46 cph Exp $ + +(declare (usual-integrations)) +(using-syntax (access compiler-syntax-table compiler-package) + +(define *nodes*) + +(define (generate-rtl quotations procedures) + (with-new-node-marks + (lambda () + (fluid-let ((*nodes* '())) + (for-each generate:quotation quotations) + (for-each generate:procedure procedures) + (for-each generate:remove-memo *nodes*))))) + +(define (generate:cfg cfg offset) + (generate:node (cfg-entry-node cfg) offset)) + +(define (generate:next node offset) + (cond ((not node) (make-null-cfg)) + ((node-marked? node) + (let ((memo (node-property-get node generate:node))) + (if (not (= (car memo) offset)) + (error "Node entered at different offsets" node)) + (cdr memo))) + (else (generate:node node offset)))) + +(define (generate:node node offset) + (node-mark! node) + (let ((cfg ((vector-method node generate:node) node offset))) + (node-property-put! node generate:node (cons offset cfg)) + (set! *nodes* (cons node *nodes*)) + cfg)) + +(define (generate:remove-memo rnode) + (node-property-remove! rnode generate:node)) + +(define (define-generator tag generator) + (define-vector-method tag generate:node generator)) + +(define (generate:quotation quotation) + (set-quotation-rtl! quotation + (generate:cfg (quotation-cfg quotation) 0))) + +(define (generate:procedure procedure) + (set-procedure-rtl! + procedure + ((cond ((ic-procedure? procedure) identity-procedure) + ((closure-procedure? procedure) generate:closure-procedure) + ((stack-procedure? procedure) generate:stack-procedure) + (else (error "Unknown procedure type" procedure))) + procedure + (generate:cfg (procedure-cfg procedure) 0)))) + +(define (generate:closure-procedure procedure cfg) + (scfg-append! (if (or (not (null? (procedure-optional procedure))) + (procedure-rest procedure)) + ((if (closure-procedure-needs-operator? procedure) + rtl:make-setup-closure-lexpr + rtl:make-setup-stack-lexpr) + procedure) + (rtl:make-procedure-heap-check procedure)) + (setup-stack-frame procedure) + cfg)) + +(define (generate:stack-procedure procedure cfg) + (scfg-append! (if (procedure-rest procedure) + (rtl:make-setup-stack-lexpr procedure) + (rtl:make-procedure-heap-check procedure)) + (setup-stack-frame procedure) + cfg)) + +(define (setup-stack-frame procedure) + (define (loop variables pushes) + (if (null? variables) + (scfg*->scfg! pushes) + (loop (cdr variables) + (cons (rtl:make-push + (if (variable-assigned? (car variables)) + (rtl:make-cell-cons (rtl:make-unassigned)) + (rtl:make-unassigned))) + pushes)))) + + (define (cellify-variables variables) + (scfg*->scfg! (map cellify-variable variables))) + + (define (cellify-variable variable) + (if (variable-assigned? variable) + (let ((locative + (stack-locative-offset + register:stack-pointer + (variable-offset (procedure-block procedure) variable)))) + (rtl:make-assignment locative + (rtl:make-cell-cons (rtl:make-fetch locative)))) + (make-null-cfg))) + + (scfg-append! (loop (procedure-auxiliary procedure) '()) + (cellify-variables (procedure-required procedure)) + (cellify-variables (procedure-optional procedure)) + (let ((rest (procedure-rest procedure))) + (if rest + (cellify-variable rest) + (make-null-cfg))))) + +;;;; Statements + +(define-generator definition-tag + (lambda (definition offset) + (scfg-append! (rvalue->sexpression (definition-rvalue definition) offset + (lambda (expression) + (find-variable (definition-block definition) + (definition-lvalue definition) + offset + (lambda (locative) + (error "Definition of compiled variable")) + (lambda (environment name) + (rtl:make-interpreter-call:define environment + name + expression))))) + (generate:next (snode-next definition) offset)))) + +(define-generator assignment-tag + (lambda (assignment offset) + (generate-assignment (assignment-block assignment) + (assignment-lvalue assignment) + (assignment-rvalue assignment) + (snode-next assignment) + offset))) + +(define (generate-assignment block lvalue rvalue next offset) + ((vector-method lvalue generate-assignment) block lvalue rvalue next offset)) + +(define (define-assignment tag generator) + (define-vector-method tag generate-assignment generator)) + +(define-assignment variable-tag + (lambda (block variable rvalue next offset) + (scfg-append! (if (integrated-vnode? variable) + (make-null-cfg) + (rvalue->sexpression rvalue offset + (lambda (expression) + (find-variable block variable offset + (lambda (locative) + (rtl:make-assignment locative expression)) + (lambda (environment name) + (rtl:make-interpreter-call:set! + environment + (intern-scode-variable! block name) + expression)))))) + (generate:next next offset)))) + +(define (assignment:value-register block value-register rvalue next offset) + (if next (error "Return node has next")) + (scfg-append! (if (or (value-register? rvalue) + (value-temporary? rvalue)) + (make-null-cfg) + (rvalue->sexpression rvalue offset + (lambda (expression) + (rtl:make-assignment register:value expression)))) + (if (stack-procedure-block? block) + (rtl:make-message-sender:value + (+ offset (block-frame-size block))) + (scfg-append! + (if (closure-procedure-block? block) + (rtl:make-pop-frame (block-frame-size block)) + (make-null-cfg)) + (rtl:make-return))))) + +(define-assignment value-register-tag + assignment:value-register) + +(define-assignment value-push-tag + (lambda (block value-push rvalue next offset) + (rvalue->sexpression rvalue offset + (lambda (expression) + (scfg-append! (rtl:make-push expression) + (generate:next next (1+ offset))))))) + +(define-assignment value-ignore-tag + (lambda (block value-ignore rvalue next offset) + (if next (error "Return node has next")) + (make-null-cfg))) + +(define-assignment temporary-tag + (lambda (block temporary rvalue next offset) + (let ((type (temporary-type temporary))) + (case type + ((#F) + (scfg-append! + (if (integrated-vnode? temporary) + (make-null-cfg) + (rvalue->sexpression rvalue offset + (lambda (expression) + (rtl:make-assignment temporary expression)))) + (generate:next next offset))) + ((VALUE) + (assignment:value-register block temporary rvalue next offset)) + (else + (error "Unknown temporary type" type)))))) + +;;;; Predicates + +(define-generator true-test-tag + (lambda (test offset) + (pcfg*scfg->pcfg! + (let ((rvalue (true-test-rvalue test))) + (if (rvalue-known-constant? rvalue) + (constant->pcfg (rvalue-constant-value rvalue)) + (rvalue->pexpression rvalue offset rtl:make-true-test))) + (generate:next (pnode-consequent test) offset) + (generate:next (pnode-alternative test) offset)))) + +(define-generator unassigned-test-tag + (lambda (test offset) + (pcfg*scfg->pcfg! + (find-variable (unassigned-test-block test) + (unassigned-test-variable test) + offset + (lambda (locative) + (rtl:make-unassigned-test (rtl:make-fetch locative))) + (lambda (environment name) + (scfg*pcfg->pcfg! + (rtl:make-interpreter-call:unassigned? environment name) + (rtl:make-true-test (rtl:interpreter-call-result:unassigned?))))) + (generate:next (pnode-consequent test) offset) + (generate:next (pnode-alternative test) offset)))) + +(define-generator unbound-test-tag + (lambda (test offset) + (pcfg*scfg->pcfg! + (let ((variable (unbound-test-variable test))) + (if (ic-block? (variable-block variable)) + (scfg*pcfg->pcfg! + (rtl:make-interpreter-call:unbound? + (nearest-ic-block-expression (unbound-test-block test) offset) + (variable-name variable)) + (rtl:make-true-test (rtl:interpreter-call-result:unbound?))) + (make-false-pcfg))) + (generate:next (pnode-consequent test) offset) + (generate:next (pnode-alternative test) offset)))) + +;;;; Expressions + +(define (rvalue->sexpression rvalue offset receiver) + (rvalue->expression rvalue offset (prepend-to-scfg receiver))) + +(define ((prepend-to-scfg receiver) expression prefix) + (scfg-append! prefix (receiver expression))) + +(define (rvalue->pexpression rvalue offset receiver) + (rvalue->expression rvalue offset (prepend-to-pcfg receiver))) + +(define ((prepend-to-pcfg receiver) expression prefix) + (scfg*pcfg->pcfg! prefix (receiver expression))) + +(define (rvalue->expression rvalue offset receiver) + ((vector-method rvalue rvalue->expression) rvalue offset receiver)) + +(define (define-rvalue->expression tag generator) + (define-vector-method tag rvalue->expression generator)) + +(define (constant->expression constant offset receiver) + (receiver (rtl:make-constant (constant-value constant)) + (make-null-cfg))) + +(define-rvalue->expression constant-tag + constant->expression) + +(define-rvalue->expression block-tag + (lambda (block offset receiver) + (receiver (rtl:make-fetch register:environment) (make-null-cfg)))) + +(define-rvalue->expression value-register-tag + (lambda (value-register offset receiver) + (receiver (rtl:make-fetch register:value) (make-null-cfg)))) + +(define-rvalue->expression reference-tag + (lambda (reference offset receiver) + (reference->expression (reference-block reference) + (reference-variable reference) + offset + receiver))) + +(define (reference->expression block variable offset receiver) + (if (vnode-known-constant? variable) + (constant->expression (vnode-known-value variable) offset receiver) + (find-variable block variable offset + (lambda (locative) + (receiver (rtl:make-fetch locative) (make-null-cfg))) + (lambda (environment name) + (receiver (rtl:interpreter-call-result:lookup) + (rtl:make-interpreter-call:lookup + environment + (intern-scode-variable! block name))))))) + +(define-rvalue->expression temporary-tag + (lambda (temporary offset receiver) + (if (vnode-known-constant? temporary) + (constant->expression (vnode-known-value temporary) offset receiver) + (let ((type (temporary-type temporary))) + (cond ((not type) + (receiver (rtl:make-fetch temporary) + (make-null-cfg))) + ((eq? type 'VALUE) + (receiver (rtl:make-fetch register:value) + (make-null-cfg))) + (else (error "Illegal temporary reference" type))))))) + +(define-rvalue->expression access-tag + (lambda (*access offset receiver) + (receiver (rtl:interpreter-call-result:access) + (rtl:make-interpreter-call:access (access-environment *access) + (access-name *access))))) + +(define-rvalue->expression procedure-tag + (lambda (procedure offset receiver) + ((cond ((ic-procedure? procedure) rvalue->expression:ic-procedure) + ((closure-procedure? procedure) + rvalue->expression:closure-procedure) + ((stack-procedure? procedure) + (error "RVALUE->EXPRESSION: Stack procedure reference" procedure)) + (else (error "Unknown procedure type" procedure))) + procedure offset receiver))) + +(define (rvalue->expression:ic-procedure procedure offset receiver) + ;; 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 (procedure-auxiliary procedure)) + '() + false))) + (set! *ic-procedure-headers* + (cons (cons procedure header) + *ic-procedure-headers*)) + (receiver (rtl:make-typed-cons:pair + (rtl:make-constant (scode:procedure-type-code header)) + (rtl:make-constant header) + (rtl:make-fetch register:environment)) + (make-null-cfg)))) + +(define (rvalue->expression:closure-procedure procedure offset receiver) + (let ((block (block-parent (procedure-block procedure)))) + (define (finish environment prefix) + (receiver (rtl:make-typed-cons:pair + (rtl:make-constant type-code:compiled-procedure) + (rtl:make-entry:procedure procedure) + environment) + prefix)) + (cond ((not block) + (finish (rtl:make-constant false) (make-null-cfg))) + ((ic-block? block) + (finish (rtl:make-fetch register:environment) (make-null-cfg))) + ((closure-block? block) + (let ((closure-block (procedure-closure-block procedure))) + (define (loop variables n receiver) + (if (null? variables) + (receiver offset n '()) + (loop (cdr variables) (1+ n) + (lambda (offset n pushes) + (receiver (1+ offset) n + (cons (rtl:make-push + (rtl:make-fetch + (find-closure-variable closure-block + (car variables) + offset))) + pushes)))))) + + (define (make-frame n pushes) + (finish (rtl:interpreter-call-result:enclose) + (scfg*->scfg! + (reverse! + (cons (rtl:make-interpreter-call:enclose n) + pushes))))) + + (define (loser locative) + (error "Closure parent not IC block")) + + (loop (block-bound-variables block) 0 + (lambda (offset n pushes) + (let ((parent (block-parent block))) + (if parent + (find-block closure-block parent offset + loser + loser + (lambda (locative nearest-ic-locative) + (make-frame (1+ n) + (cons (rtl:make-push locative) + pushes)))) + (make-frame n pushes))))))) + (else (error "Unknown block type" block))))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access rtl-generator-package compiler-package) +;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package) +;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package) +;;; End: + "node rtl arguments") \ No newline at end of file -- 2.25.1