--- /dev/null
+;;; -*-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)
+\f
+(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))))
+\f
+(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)))))
+\f
+(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)))
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+(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))
+\f
+;;;; 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))))))
+\f
+(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)))
+\f
+;;;; 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)))))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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)
+\f
+(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))))
+\f
+(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)))))
+\f
+;;;; 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))))
+\f
+(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))))))
+\f
+;;;; 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))))
+\f
+;;;; 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)))))
+\f
+(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))))
+\f
+(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
projects / mit-scheme.git / commitdiff