From: Chris Hanson Date: Thu, 7 May 1987 00:22:05 +0000 (+0000) Subject: Rewrite of RTL generator. Flush `next-generator' mechanism, use X-Git-Tag: 20090517-FFI~13548 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=38ee893d5b60f334f1fbe6fc5d9c606c79634fc9;p=mit-scheme.git Rewrite of RTL generator. Flush `next-generator' mechanism, use multiple value return and explicit gluing of CFGs. Flush offset argument, use frame-pointer instead; offset will be computed at LAP generation time. --- diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index fe0e81f5b..70b5fc8ae 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -37,69 +37,73 @@ MIT in each case. |# (declare (usual-integrations)) (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)))) ;;;; 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))) @@ -109,156 +113,146 @@ MIT in each case. |# (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)) ;;;; 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)) -(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)) -(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)) ;;;; 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)) @@ -267,26 +261,26 @@ MIT in each case. |# 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 @@ -294,88 +288,70 @@ MIT in each case. |# continuation (constant-value (combination-known-operator combination)))))) -(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)))) - -(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)))) ;;;; 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)) @@ -386,43 +362,35 @@ MIT in each case. |# (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))))) ;;;; 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) @@ -430,17 +398,10 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index 26b77e62d..e4b16deb2 100644 --- a/v7/src/compiler/rtlgen/rgrval.scm +++ b/v7/src/compiler/rtlgen/rgrval.scm @@ -1,9 +1,9 @@ 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 @@ -36,11 +36,11 @@ promotional, or sales literature without prior written consent from ;;;; RTL Generation: RValues ;;; package: (compiler rtl-generator generate/rvalue) -(define (generate:rvalue rvalue offset) - ((vector-method rvalue generate:rvalue) rvalue offset)) +(define (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)) @@ -50,26 +50,25 @@ promotional, or sales literature without prior written consent from (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) @@ -80,9 +79,9 @@ promotional, or sales literature without prior written consent from (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))) @@ -92,18 +91,18 @@ promotional, or sales literature without prior written consent from (error "Illegal temporary reference" type))))))) (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 @@ -137,14 +136,8 @@ promotional, or sales literature without prior written consent from ;; 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) @@ -152,45 +145,37 @@ promotional, or sales literature without prior written consent from (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) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index 58ed04114..aace2a87e 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -36,300 +36,103 @@ MIT in each case. |# (declare (usual-integrations)) -(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))))) - -(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)))))) - -(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))) - -;;;; 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)) -(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?)))) -;;;; 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