#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.14 1987/04/29 21:53:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.15 1987/05/07 00:20:53 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define-generator combination-tag
- (lambda (combination offset rest-generator)
- ((cond ((combination-constant? combination) combination:constant)
+ (lambda (combination subproblem?)
+ ((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 rest-generator)))
-
-(define (combination:constant combination offset rest-generator)
- (let ((value (combination-value combination))
- (next (snode-next combination)))
- (cond ((temporary? value)
- (generate-assignment (combination-block combination)
- value
- (vnode-known-value value)
- next
- offset
- rest-generator
- rvalue->sexpression))
- ((value-ignore? value)
- (generate:next next offset rest-generator))
- (else (error "Unknown combination value" value)))))
-
-(define (combination:normal combination offset rest-generator)
- ;; 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 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 (generate:next-is-null? (snode-next combination) rest-generator)
- (combination:reduction combination offset)
- (combination:subproblem combination offset rest-generator)))
+ combination/primitive)
+ (else combination/normal))
+ combination subproblem?)))
+
+(define combination/constant
+ (normal-statement-generator
+ (lambda (combination subproblem?)
+ (let ((value (combination-value combination)))
+ (cond ((temporary? value)
+ (transmit-values (generate/rvalue (vnode-known-value value))
+ (lambda (prefix expression)
+ (scfg*scfg->scfg!
+ prefix
+ (generate/assignment (combination-block combination)
+ value
+ expression
+ subproblem?)))))
+ ((value-ignore? value)
+ (make-null-cfg))
+ (else
+ (error "Unknown combination value" value)))))))
+
+(define combination/normal
+ (normal-statement-generator
+ (lambda (combination subproblem?)
+ ;; For the time being, all close-coded combinations will return
+ ;; their values in the value register.
+ (let ((value (combination-value combination)))
+ (cond ((temporary? value)
+ (let ((type (temporary-type value)))
+ (if type
+ (if (not (eq? 'VALUE type))
+ (error "Bad temporary type" type))
+ (set-temporary-type! value 'VALUE))))
+ ((not (value-ignore? value))
+ (error "Unknown combination value" value))))
+ ((if subproblem? combination/subproblem combination/reduction)
+ combination))))
\f
;;;; Subproblems
-(define (combination:subproblem combination offset rest-generator)
+(define (combination/subproblem combination)
(let ((block (combination-block combination))
(finish
- (lambda (offset delta call-prefix continuation-prefix)
- (let ((continuation (make-continuation delta)))
- (set-continuation-rtl-entry!
- continuation
- (scfg*node->node!
- (scfg*scfg->scfg!
- (rtl:make-continuation-heap-check continuation)
- continuation-prefix)
- (generate:next (snode-next combination) offset rest-generator)))
- (scfg*node->node! (call-prefix continuation)
- (combination:subproblem-body combination
- (+ offset delta)
- continuation))))))
+ (lambda (call-prefix continuation-prefix)
+ (let ((continuation (make-continuation)))
+ (let ((continuation-cfg
+ (scfg*scfg->scfg!
+ (rtl:make-continuation-heap-check continuation)
+ continuation-prefix)))
+ (set-continuation-rtl-entry! continuation
+ (cfg-entry-node continuation-cfg))
+ (make-scfg (cfg-entry-node
+ (scfg*scfg->scfg!
+ (call-prefix continuation)
+ (combination/subproblem-body combination
+ continuation)))
+ (scfg-next-hooks continuation-cfg)))))))
(cond ((ic-block? block)
;; **** Actually, should only do this if the environment
;; will be needed by the continuation.
- (finish (1+ offset) 1
- (lambda (continuation)
+ (finish (lambda (continuation)
(scfg*scfg->scfg!
(rtl:make-push (rtl:make-fetch register:environment))
(rtl:make-push-return continuation)))
(and operator
(procedure? operator)
(procedure/open-internal? operator))))
- (finish offset
- (rtl:message-receiver-size:subproblem)
- rtl:make-message-receiver:subproblem
- (make-null-cfg)))
+ (finish rtl:make-message-receiver:subproblem (make-null-cfg)))
(else
- (finish offset 1 rtl:make-push-return (make-null-cfg))))))
+ (finish rtl:make-push-return (make-null-cfg))))))
-(define (combination:subproblem-body combination offset continuation)
+(define (combination/subproblem-body combination continuation)
((let ((operator (combination-known-operator combination)))
- (cond ((normal-primitive-constant? operator) make-call:primitive)
- ((or (not operator) (not (procedure? operator))) make-call:unknown)
+ (cond ((normal-primitive-constant? operator) make-call/primitive)
+ ((or (not operator) (not (procedure? operator))) make-call/unknown)
(else
(case (procedure/type operator)
- ((OPEN-INTERNAL) make-call:stack-with-link)
- ((OPEN-EXTERNAL) make-call:open-external)
- ((CLOSURE) make-call:closure)
- ((IC) make-call:ic)
+ ((OPEN-INTERNAL) make-call/stack-with-link)
+ ((OPEN-EXTERNAL) make-call/open-external)
+ ((CLOSURE) make-call/closure)
+ ((IC) make-call/ic)
(else (error "Unknown callee type" operator))))))
- combination offset invocation-prefix:null continuation))
+ combination invocation-prefix/null continuation))
\f
;;;; Reductions
-(define (combination:reduction combination offset)
- (let ((callee (combination-known-operator combination))
- (block (combination-block combination)))
- (define (choose-generator ic external internal)
- ((let ((caller (block-procedure block)))
+(define (combination/reduction combination)
+ ((let ((callee (combination-known-operator combination))
+ (block (combination-block combination)))
+ (define (choose-generator ic external internal)
+ (let ((caller (block-procedure block)))
(cond ((or (not caller) (procedure/ic? caller)) ic)
((procedure/external? caller) external)
- (else internal)))
- combination offset))
- (cond ((normal-primitive-constant? callee)
- (choose-generator reduction:ic->primitive
- reduction:external->primitive
- reduction:internal->primitive))
- ((or (not callee)
- (not (procedure? callee)))
- (choose-generator reduction:ic->unknown
- reduction:external->unknown
- reduction:internal->unknown))
- (else
- (case (procedure/type callee)
- ((IC)
- (choose-generator reduction:ic->ic
- reduction:external->ic
- reduction:internal->ic))
- ((CLOSURE)
- (choose-generator reduction:ic->closure
- reduction:external->closure
- reduction:internal->closure))
- ((OPEN-EXTERNAL)
- (choose-generator reduction:ic->open-external
- reduction:external->open-external
- reduction:internal->open-external))
- ((OPEN-INTERNAL)
- (choose-generator reduction:ic->child
- reduction:external->child
- (let ((block* (procedure-block callee)))
- (cond ((block-child? block block*)
- reduction:internal->child)
- ((block-sibling? block block*)
- reduction:internal->sibling)
- (else
- reduction:internal->ancestor)))))
- (else (error "Unknown callee type" callee)))))))
+ (else internal))))
+ (cond ((normal-primitive-constant? callee)
+ (choose-generator reduction/ic->primitive
+ reduction/external->primitive
+ reduction/internal->primitive))
+ ((or (not callee)
+ (not (procedure? callee)))
+ (choose-generator reduction/ic->unknown
+ reduction/external->unknown
+ reduction/internal->unknown))
+ (else
+ (case (procedure/type callee)
+ ((IC)
+ (choose-generator reduction/ic->ic
+ reduction/external->ic
+ reduction/internal->ic))
+ ((CLOSURE)
+ (choose-generator reduction/ic->closure
+ reduction/external->closure
+ reduction/internal->closure))
+ ((OPEN-EXTERNAL)
+ (choose-generator reduction/ic->open-external
+ reduction/external->open-external
+ reduction/internal->open-external))
+ ((OPEN-INTERNAL)
+ (choose-generator reduction/ic->child
+ reduction/external->child
+ (let ((block* (procedure-block callee)))
+ (cond ((block-child? block block*)
+ reduction/internal->child)
+ ((block-sibling? block block*)
+ reduction/internal->sibling)
+ (else
+ reduction/internal->ancestor)))))
+ (else (error "Unknown callee type" callee))))))
+ combination))
\f
-(define (reduction:ic->unknown combination offset)
- (make-call:unknown combination offset invocation-prefix:null false))
+(define (reduction/ic->unknown combination)
+ (make-call/unknown combination invocation-prefix/null false))
-(define (reduction:ic->ic combination offset)
- (make-call:ic combination offset invocation-prefix:null false))
+(define (reduction/ic->ic combination)
+ (make-call/ic combination invocation-prefix/null false))
-(define (reduction:ic->primitive combination offset)
- (make-call:primitive combination offset invocation-prefix:null false))
+(define (reduction/ic->primitive combination)
+ (make-call/primitive combination invocation-prefix/null false))
-(define (reduction:ic->closure combination offset)
- (make-call:closure combination offset invocation-prefix:null false))
+(define (reduction/ic->closure combination)
+ (make-call/closure combination invocation-prefix/null false))
-(define (reduction:ic->open-external combination offset)
- (make-call:open-external combination offset invocation-prefix:null false))
+(define (reduction/ic->open-external combination)
+ (make-call/open-external combination invocation-prefix/null false))
-(define (reduction:ic->child combination offset)
+(define (reduction/ic->child combination)
(error "Calling internal procedure from IC procedure"))
-(define (reduction:external->unknown combination offset)
- (make-call:unknown combination offset invocation-prefix:move-frame-up false))
+(define (reduction/external->unknown combination)
+ (make-call/unknown combination invocation-prefix/move-frame-up false))
-(define (reduction:external->ic combination offset)
- (make-call:ic combination offset invocation-prefix:move-frame-up false))
+(define (reduction/external->ic combination)
+ (make-call/ic combination invocation-prefix/move-frame-up false))
-(define (reduction:external->primitive combination offset)
- (make-call:primitive combination offset invocation-prefix:move-frame-up
- false))
+(define (reduction/external->primitive combination)
+ (make-call/primitive combination invocation-prefix/move-frame-up false))
-(define (reduction:external->closure combination offset)
- (make-call:closure combination offset invocation-prefix:move-frame-up false))
+(define (reduction/external->closure combination)
+ (make-call/closure combination invocation-prefix/move-frame-up false))
-(define (reduction:external->open-external combination offset)
- (make-call:open-external combination offset invocation-prefix:move-frame-up
- false))
+(define (reduction/external->open-external combination)
+ (make-call/open-external combination invocation-prefix/move-frame-up false))
-(define (reduction:external->child combination offset)
- (make-call:child combination offset
+(define (reduction/external->child combination)
+ (make-call/child combination
rtl:make-message-receiver:closure
rtl:message-receiver-size:closure))
\f
-(define (reduction:internal->unknown combination offset)
- (make-call:unknown combination offset invocation-prefix:internal->closure
- false))
+(define (reduction/internal->unknown combination)
+ (make-call/unknown combination invocation-prefix/internal->closure false))
-(define (reduction:internal->ic combination offset)
- (make-call:ic combination offset invocation-prefix:internal->closure false))
+(define (reduction/internal->ic combination)
+ (make-call/ic combination invocation-prefix/internal->closure false))
-(define (reduction:internal->primitive combination offset)
- (make-call:primitive combination offset invocation-prefix:internal->closure
- false))
+(define (reduction/internal->primitive combination)
+ (make-call/primitive combination invocation-prefix/internal->closure false))
-(define (reduction:internal->closure combination offset)
- (make-call:closure combination offset invocation-prefix:internal->closure
- false))
+(define (reduction/internal->closure combination)
+ (make-call/closure combination invocation-prefix/internal->closure false))
-(define (reduction:internal->open-external combination offset)
- (make-call:open-external combination offset
- invocation-prefix:internal->closure
+(define (reduction/internal->open-external combination)
+ (make-call/open-external combination invocation-prefix/internal->closure
false))
-(define (reduction:internal->child combination offset)
- (make-call:child combination offset
+(define (reduction/internal->child combination)
+ (make-call/child combination
rtl:make-message-receiver:stack
rtl:message-receiver-size:stack))
-(define (reduction:internal->sibling combination offset)
- (make-call:stack combination offset invocation-prefix:internal->sibling
- false))
+(define (reduction/internal->sibling combination)
+ (make-call/stack combination invocation-prefix/internal->sibling false))
-(define (reduction:internal->ancestor combination offset)
- (make-call:stack-with-link combination offset
- invocation-prefix:internal->ancestor false))
+(define (reduction/internal->ancestor combination)
+ (make-call/stack-with-link combination invocation-prefix/internal->ancestor
+ false))
\f
;;;; Calls
-(define (make-call:apply combination offset invocation-prefix continuation)
- (make-call:push-operator combination offset
+(define (make-call/apply combination invocation-prefix continuation)
+ (make-call/push-operator combination
(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
+(define (make-call/lookup combination invocation-prefix continuation)
+ (make-call/dont-push-operator combination
(lambda (number-pushed)
(let ((operator (subproblem-value (combination-operator combination))))
(let ((block (reference-block operator))
number-pushed
(invocation-prefix combination number-pushed)
continuation
- (nearest-ic-block-expression block (+ offset number-pushed))
+ (nearest-ic-block-expression block)
(intern-scode-variable! block name)))))))
-(define (make-call:unknown combination offset invocation-prefix continuation)
+(define (make-call/unknown combination invocation-prefix continuation)
(let ((operator (subproblem-value (combination-operator combination))))
((cond ((or (not (reference? operator))
(reference-to-known-location? operator))
- make-call:apply)
+ make-call/apply)
;; **** Need to add code for links here.
- (else make-call:lookup))
- combination offset invocation-prefix continuation)))
+ (else make-call/lookup))
+ combination 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/ic make-call/apply)
-(define (make-call:primitive combination offset invocation-prefix continuation)
- (make-call:dont-push-operator combination offset
+(define (make-call/primitive combination invocation-prefix continuation)
+ (make-call/dont-push-operator combination
(lambda (number-pushed)
(rtl:make-invocation:primitive
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
- (external-call combination invocation-prefix continuation)))
+(define (make-call/closure combination invocation-prefix continuation)
+ (make-call/push-operator combination
+ (internal-call combination invocation-prefix continuation 0)))
-(define (make-call:open-external combination offset invocation-prefix
- continuation)
- (scfg*node->node!
+(define (make-call/open-external combination invocation-prefix continuation)
+ (scfg*scfg->scfg!
(rtl:make-push (rtl:make-fetch register:environment))
- (make-call:dont-push-operator combination offset
- (external-call combination invocation-prefix continuation))))
-
-(define (external-call combination invocation-prefix continuation)
- (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))))
-\f
-(package (make-call:stack make-call:stack-with-link make-call:child)
+ (make-call/dont-push-operator combination
+ (internal-call combination invocation-prefix continuation 0))))
-(define-export (make-call:stack combination offset invocation-prefix
- continuation)
- (stack-call combination offset invocation-prefix continuation 0))
+(define (make-call/stack combination invocation-prefix continuation)
+ (stack-call combination invocation-prefix continuation 0))
-(define-export (make-call:stack-with-link combination offset invocation-prefix
- continuation)
- (link-call combination offset invocation-prefix continuation 0))
+(define (make-call/stack-with-link combination invocation-prefix continuation)
+ (link-call combination invocation-prefix continuation 0))
-(define-export (make-call:child combination offset make-receiver receiver-size)
- (scfg*node->node!
+(define (make-call/child combination make-receiver receiver-size)
+ (scfg*scfg->scfg!
(make-receiver (block-frame-size (combination-block combination)))
- (let ((extra (receiver-size)))
- (link-call combination (+ offset extra) invocation-prefix:null false
- extra))))
+ (link-call combination invocation-prefix/null false (receiver-size))))
-(define (link-call combination offset invocation-prefix continuation extra)
- (scfg*node->node!
+(define (link-call combination invocation-prefix continuation extra)
+ (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)))
- (stack-call combination (1+ offset) invocation-prefix continuation
- (1+ extra))))
+ (block-parent
+ (procedure-block (combination-known-operator combination))))))
+ (stack-call combination invocation-prefix continuation (1+ extra))))
-(define (stack-call combination offset invocation-prefix continuation extra)
- (make-call:dont-push-operator combination offset
- (lambda (number-pushed)
- (let ((number-pushed (+ number-pushed extra))
- (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 (stack-call combination invocation-prefix continuation extra)
+ (make-call/dont-push-operator combination
+ (internal-call combination invocation-prefix continuation extra)))
+
+(define (internal-call combination invocation-prefix continuation extra)
+ (lambda (number-pushed)
+ (let ((operator (combination-known-operator combination))
+ (number-pushed (+ number-pushed extra)))
+ ((if (procedure-rest operator)
+ rtl:make-invocation:lexpr
+ rtl:make-invocation:jump)
+ number-pushed
+ (invocation-prefix combination number-pushed)
+ continuation
+ operator))))
\f
;;;; Prefixes
-(define (invocation-prefix:null combination number-pushed)
+(define (invocation-prefix/null combination number-pushed)
'(NULL))
-(define (invocation-prefix:move-frame-up combination number-pushed)
+(define (invocation-prefix/move-frame-up combination number-pushed)
`(MOVE-FRAME-UP ,number-pushed
,(block-frame-size (combination-block combination))))
-(define (invocation-prefix:internal->closure combination number-pushed)
+(define (invocation-prefix/internal->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:internal->ancestor combination number-pushed)
+(define (invocation-prefix/internal->ancestor combination number-pushed)
(let ((block (combination-block combination)))
`(APPLY-STACK ,number-pushed
,(+ number-pushed (block-frame-size block))
(procedure-block
(combination-known-operator combination))))))))
-(define (invocation-prefix:internal->sibling combination number-pushed)
+(define (invocation-prefix/internal->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
-(package (make-call:dont-push-operator make-call:push-operator)
+(package (make-call/dont-push-operator make-call/push-operator)
-(define (make-call-maker generate:operator wrap-n)
- (lambda (combination offset make-invocation)
+(define (make-call-maker generate/operator wrap-n)
+ (lambda (combination make-invocation)
(let ((operator (combination-known-operator combination))
(operands (combination-operands combination)))
- (let ((n-operands (length operands))
- (finish
- (lambda (n offset)
- (let operand-loop
- ((operands (reverse operands))
- (offset offset))
- (if (null? operands)
- (generate:operator (combination-operator combination)
- offset
- (lambda (offset)
- (cfg-entry-node (make-invocation (wrap-n n)))))
- (subproblem->push (car operands) offset
- (lambda (offset)
- (operand-loop (cdr operands) 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))))))
+ (scfg-append!
+ (scfg*->scfg!
+ (map generate/subproblem-push (reverse operands)))
+ (generate/operator (combination-operator combination))
+ (let ((n-operands (length operands)))
+ (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)))))
+ (scfg*scfg->scfg!
+ (scfg*->scfg!
+ (push-n-unassigned (- n-parameters n-operands)))
+ (make-invocation (wrap-n n-parameters))))
+ (make-invocation (wrap-n n-operands))))))))
(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 receiver)
- (generate:subproblem subproblem offset
- (lambda (offset)
- (scfg*node->node!
- (rvalue->sexpression (subproblem-value subproblem) offset rtl:make-push)
- (receiver (1+ offset))))))
-
-(define-export make-call:dont-push-operator
- (make-call-maker generate:subproblem identity-procedure))
+(define-export make-call/dont-push-operator
+ (make-call-maker generate/subproblem-cfg identity-procedure))
-(define-export make-call:push-operator
- (make-call-maker subproblem->push 1+))
+(define-export make-call/push-operator
+ (make-call-maker generate/subproblem-push 1+))
,(-1+ (block-frame-size (combination-block combination)))))
\ No newline at end of file
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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 1.2 1987/05/07 00:21:56 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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 1.2 1987/05/07 00:21:56 cph Exp $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
;;;; RTL Generation: RValues
;;; package: (compiler rtl-generator generate/rvalue)
-(define (generate:rvalue rvalue offset)
- ((vector-method rvalue generate:rvalue) rvalue offset))
+(define (generate/rvalue rvalue)
+ ((vector-method rvalue generate/rvalue) rvalue))
(define (define-rvalue-generator tag generator)
- (define-vector-method tag generate:rvalue generator))
+ (define-vector-method tag generate/rvalue generator))
(with-values (lambda () (generate/rvalue* operand))
(define rvalue-methods
(return-2 (make-null-cfg) expression))
(lambda (prefix expression)
(return-2 prefix (transform expression)))))
-(define (generate:constant constant offset)
+(define (generate/constant constant)
(expression-value/simple (rtl:make-constant (constant-value constant))))
(define-rvalue-generator constant-tag
- generate:constant)
+ generate/constant)
(define-rvalue-generator block-tag
- (lambda (block offset)
+ (lambda (block)
(define-method-table-entry 'BLOCK rvalue-methods
(define-rvalue-generator reference-tag
- (lambda (reference offset)
- (generate:variable (reference-block reference)
- (reference-variable reference)
- offset)))
+ (lambda (reference)
+ (generate/variable (reference-block reference)
+ (reference-variable reference))))
-(define (generate:variable block variable offset)
+(define (generate/variable block variable)
(if (vnode-known-constant? variable)
- (generate:constant (vnode-known-value variable) offset)
- (find-variable block variable offset
+ (generate/constant (vnode-known-value variable))
+ (find-variable block variable
(lambda (locative)
(expression-value/simple (rtl:make-fetch locative)))
(lambda (environment name)
(rtl:interpreter-call-result:lookup))))))
(define-rvalue-generator temporary-tag
- (lambda (temporary offset)
+ (lambda (temporary)
(if (vnode-known-constant? temporary)
- (generate:constant (vnode-known-value temporary) offset)
+ (generate/constant (vnode-known-value temporary))
(let ((type (temporary-type temporary)))
(cond ((not type)
(expression-value/simple (rtl:make-fetch temporary)))
(error "Illegal temporary reference" type)))))))
\f
(define-rvalue-generator access-tag
- (lambda (*access offset)
- (transmit-values (generate:expression (access-environment *access) offset)
+ (lambda (*access)
+ (transmit-values (generate/rvalue (access-environment *access))
(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)
+ (lambda (procedure)
(define-method-table-entry 'PROCEDURE rvalue-methods
(case (procedure/type procedure)
- (expression-value/transform (make-closure-environment procedure offset)
+ (expression-value/transform (make-closure-environment procedure)
(lambda (environment)
(make-closure-cons procedure environment))))
(else
;; inside another IC procedure?
(rtl:make-fetch register:environment))))
;; inside another IC procedure?
-(define (make-closure-environment procedure offset)
+(define (make-closure-environment procedure)
(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)
(let ((closure-block (procedure-closure-block procedure)))
(if (ic-block? closure-block)
(rtl:make-fetch register:environment)
- (ic-locative closure-block block offset)))))
+ (closure-ic-locative closure-block block)))))
((closure-block? block)
(let ((closure-block (procedure-closure-block procedure)))
- (define (loop variables n)
- (cond ((null? variables)
- (return-3 offset n '()))
+ (define (loop variables)
+ (cond ((null? variables) '())
((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)
+ (loop (cdr variables)))
+ (else
+ (cons (rtl:make-push
+ (rtl:make-fetch
+ (find-closure-variable closure-block
+ (car variables))))
+ (loop (cdr variables))))))
+
+ (let ((pushes
+ (let ((parent (block-parent block))
+ (pushes (loop (block-bound-variables block))))
+ (if parent
+ (cons (rtl:make-push
+ (closure-ic-locative closure-block
+ parent))
+ pushes)
+ 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)))))
+ (cons (rtl:make-interpreter-call:enclose (length pushes))
+ pushes)))
+ (rtl:interpreter-call-result:enclose)))))
+ (else
+ (error "Unknown block type" block)))))
(define (make-closure-cons procedure environment)
(rtl:make-typed-cons:pair (rtl:make-constant type-code:compiled-procedure)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.11 1987/05/03 20:39:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.12 1987/05/07 00:22:05 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define *nodes*)
-
(define (generate-rtl quotations procedures)
(with-new-node-marks
(lambda ()
- (fluid-let ((*nodes* '()))
- (for-each (lambda (quotation)
- (set-quotation-rtl-entry!
- quotation
- (generate:top-level (quotation-fg-entry quotation))))
- quotations)
- (for-each generate:procedure procedures)
- (for-each (lambda (rnode)
- (node-property-remove! rnode generate:node))
- *nodes*)))))
-
-(define-integrable (generate:top-level expression)
- (generate:node expression 0 false))
-
-(define (generate:subproblem subproblem offset rest-generator)
- (let ((cfg (subproblem-cfg subproblem)))
- (if (cfg-null? cfg)
- (and rest-generator (rest-generator offset))
- (generate:node (cfg-entry-node cfg) offset rest-generator))))
-
-(define (generate:next node offset rest-generator)
- (cond ((not node) (and rest-generator (rest-generator offset)))
- ((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 rest-generator))))
-
-(define (generate:node node offset rest-generator)
- (node-mark! node)
- (let ((cfg ((vector-method node generate:node) node offset rest-generator)))
- (node-property-put! node generate:node (cons offset cfg))
- (set! *nodes* (cons node *nodes*))
- cfg))
-
-(define-integrable (generate:next-is-null? next rest-generator)
- (and (not next)
- (not rest-generator)))
-
-(define (rvalue->sexpression rvalue offset receiver)
- (transmit-values (generate:rvalue rvalue offset)
- (lambda (prefix expression)
- (scfg*scfg->scfg! prefix (receiver expression)))))
-
-(define (rvalue->pexpression rvalue offset receiver)
- (transmit-values (generate:rvalue rvalue offset)
- (lambda (prefix expression)
- (scfg*pcfg->pcfg! prefix (receiver expression)))))
-\f
-(define (generate:procedure procedure)
+ (for-each generate/quotation quotations)
+ (for-each generate/procedure procedures))))
+
+(define (generate/quotation quotation)
+ (set-quotation-rtl-entry!
+ quotation
+ (cfg-entry-node
+ (scfg*scfg->scfg!
+ (rtl:make-assignment register:frame-pointer
+ (rtl:make-fetch register:stack-pointer))
+ (generate/node (quotation-fg-entry quotation) false)))))
+
+(define (generate/procedure procedure)
(set-procedure-rtl-entry!
procedure
- (let ((body (generate:top-level (procedure-fg-entry procedure))))
- (if (procedure/ic? procedure)
- body
- (scfg*node->node!
- (scfg*scfg->scfg!
- ((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:stack-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) '())
- (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))))))
-\f
-(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))))
+ (cfg-entry-node
+ (generate/procedure-header procedure
+ (generate/node (procedure-fg-entry procedure)
+ false)))))
+
+(define (generate/node node subproblem?)
+ ;; This won't work when there are loops in the RTL.
+ (cond ((not (node-marked? node))
+ (node-mark! node)
+ (set-node-rtl-arguments! node subproblem?)
+ (let ((result ((vector-method node generate/node) node subproblem?)))
+ (set-node-rtl-result! node result)
+ result))
(else
- (error "Unknown letrec binding value" value))))
-
-(define (letrec-close block variable value)
- (transmit-values (make-closure-environment value 0)
- (lambda (prefix environment)
- (scfg*scfg->scfg! prefix
- (rtl:make-assignment
- (closure-procedure-environment-locative
- (find-variable block variable 0
- (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)))
-\f
-;;;; Statements
+ (if (not (boolean=? (node-rtl-arguments node) subproblem?))
+ (error "Node regenerated with different arguments" node))
+ (node-rtl-result node))))
(define (define-generator tag generator)
- (define-vector-method tag generate:node generator))
-
-(define-generator definition-tag
- (lambda (definition offset rest-generator)
- (scfg*node->node!
- (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 rest-generator))))
-
-(define-generator assignment-tag
- (lambda (assignment offset rest-generator)
- (generate-assignment (assignment-block assignment)
- (assignment-lvalue assignment)
- (assignment-rvalue assignment)
- (snode-next assignment)
- offset
- rest-generator
- rvalue->sexpression)))
-
-(define (generate-assignment block lvalue rvalue next offset rest-generator
- rvalue->sexpression)
- ((vector-method lvalue generate-assignment)
- block lvalue rvalue next offset rest-generator rvalue->sexpression))
-
-(define (define-assignment tag generator)
- (define-vector-method tag generate-assignment generator))
-
-(define-assignment variable-tag
- (lambda (block variable rvalue next offset rest-generator
- rvalue->sexpression)
- (scfg*node->node! (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 rest-generator))))
+ (define-vector-method tag generate/node generator))
\f
-(define-assignment temporary-tag
- (lambda (block temporary rvalue next offset rest-generator
- rvalue->sexpression)
- (case (temporary-type temporary)
- ((#F)
- (scfg*node->node!
- (if (integrated-vnode? temporary)
- (make-null-cfg)
- (rvalue->sexpression rvalue offset
- (lambda (expression)
- (rtl:make-assignment temporary expression))))
- (generate:next next offset rest-generator)))
- ((VALUE)
- (assignment:value-register block rvalue next offset
- rest-generator rvalue->sexpression))
- (else
- (error "Unknown temporary type" temporary)))))
-
-(define (assignment:value-register block rvalue next offset
- rest-generator rvalue->sexpression)
- (if (not (generate:next-is-null? next rest-generator))
- (error "Return node has next"))
- (scfg*node->node!
- (scfg*scfg->scfg! (if (value-temporary? rvalue)
- (make-null-cfg)
- (rvalue->sexpression rvalue offset
- (lambda (expression)
- (rtl:make-assignment register:value expression))))
- (if (stack-block? block)
- (if (stack-parent? block)
- (rtl:make-message-sender:value
- (+ offset (block-frame-size block)))
- (scfg*scfg->scfg!
- (rtl:make-pop-frame (block-frame-size block))
- (rtl:make-return)))
- (rtl:make-return)))
- (generate:next next offset rest-generator)))
-
-(define-assignment value-ignore-tag
- (lambda (block value-ignore rvalue next offset rest-generator
- rvalue->sexpression)
- (if (not (generate:next-is-null? next rest-generator))
- (error "Return node has next"))
- (generate:next next offset rest-generator)))
+(define (generate/subproblem-cfg subproblem)
+ (if (cfg-null? (subproblem-cfg subproblem))
+ (make-null-cfg)
+ (generate/node (cfg-entry-node (subproblem-cfg subproblem)) true)))
+
+(define (generate/subproblem subproblem)
+ ;; The subproblem-cfg must be generated before the subproblem-value,
+ ;; because if it is a combination, the combination-value must be
+ ;; marked as a value-temporary before the code for referencing it
+ ;; can be generated.
+ (let ((cfg (generate/subproblem-cfg subproblem)))
+ (transmit-values (generate/rvalue (subproblem-value subproblem))
+ (lambda (prefix expression)
+ (return-2 (scfg*scfg->scfg! cfg prefix)
+ expression)))))
+
+(define (generate/subproblem-push subproblem)
+ (transmit-values (generate/subproblem subproblem)
+ (lambda (cfg expression)
+ (scfg*scfg->scfg! cfg (rtl:make-push expression)))))
+
+(define (define-statement-generator tag generator)
+ (define-generator tag (normal-statement-generator generator)))
+
+(define (normal-statement-generator generator)
+ (lambda (node subproblem?)
+ (generate/normal-statement node subproblem? generator)))
+
+(define (generate/normal-statement node subproblem? generator)
+ (if (snode-next node)
+ (scfg*scfg->scfg! (generator node true)
+ (generate/node (snode-next node) subproblem?))
+ (generator node subproblem?)))
+
+(define (define-predicate-generator tag generator)
+ (define-generator tag (normal-predicate-generator generator)))
+
+(define (normal-predicate-generator generator)
+ (lambda (node subproblem?)
+ (pcfg*scfg->scfg!
+ (generator node)
+ (generate/node (pnode-consequent node) subproblem?)
+ (generate/node (pnode-alternative node) subproblem?))))
\f
-;;;; Predicates
+(define-integrable (node-rtl-result node)
+ (node-property-get node tag/node-rtl-result))
-(define (define-predicate-generator tag node-generator)
- (define-generator tag
- (lambda (pnode offset rest-generator)
- (generate:predicate pnode offset rest-generator
- (node-generator pnode offset)))))
+(define-integrable (set-node-rtl-result! node cfg)
+ (node-property-put! node tag/node-rtl-result cfg))
-(define (generate:predicate pnode offset rest-generator pcfg)
- (pcfg*node->node!
- pcfg
- (generate:next (pnode-consequent pnode) offset rest-generator)
- (generate:next (pnode-alternative pnode) offset rest-generator)))
+(define tag/node-rtl-result
+ "node rtl result")
-(define-predicate-generator true-test-tag
- (lambda (test offset)
- (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)))))
+(define-integrable (node-rtl-arguments node)
+ (node-property-get node tag/node-rtl-arguments))
-(define-predicate-generator unassigned-test-tag
- (lambda (test offset)
- (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?)))))))
+(define-integrable (set-node-rtl-arguments! node arguments)
+ (node-property-put! node tag/node-rtl-arguments arguments))
-(define-predicate-generator unbound-test-tag
- (lambda (test offset)
- (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?)))
+(define tag/node-rtl-arguments
"node rtl arguments")
\ No newline at end of file
projects / mit-scheme.git / commitdiff