From: Chris Hanson Date: Sat, 9 May 1987 06:24:34 +0000 (+0000) Subject: Restructure so that operator/operand code is generated before the X-Git-Tag: 20090517-FFI~13532 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7d5f4bc35c63e32c4eb8025dfc2a57ec21b3853d;p=mit-scheme.git Restructure so that operator/operand code is generated before the combination and passed through. This is because the primitive open coders will examine the already-generated operands to determine things about them. --- diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index 553d3bad6..15bbf0253 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.16 1987/05/07 04:36:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.17 1987/05/09 06:24:34 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -38,52 +38,83 @@ MIT in each case. |# (define-generator combination-tag (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 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)))) + (if (combination-constant? combination) + (combination/constant combination subproblem?) + (let ((callee (combination-known-operator combination)) + (operator + (generate/subproblem-cfg (combination-operator combination))) + (operands + (map generate/operand (combination-operands combination)))) + (or (and callee + (normal-primitive-constant? callee) + (let ((open-coder + (assq (constant-value callee) + primitive-open-coders))) + (and open-coder + ((cdr open-coder) combination + subproblem? + operator + operands)))) + (combination/normal combination + subproblem? + operator + operands)))))) + +(define (combination/constant combination subproblem?) + (generate/normal-statement combination subproblem? + (lambda (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))))))) -;;;; Subproblems - -(define (combination/subproblem combination) +(define (combination/normal combination subproblem? operator operands) + ;; 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)))) + (generate/normal-statement combination subproblem? + (lambda (subproblem?) + ((if subproblem? combination/subproblem combination/reduction) + combination + operator + operands)))) + +(define (define-open-coder primitive open-coder) + (let ((kernel + (lambda (primitive) + (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))))))) + (if (pair? primitive) + (for-each kernel primitive) + (kernel primitive))) + primitive) + +(define primitive-open-coders + '()) + +(define (combination/subproblem combination operator operands) (let ((block (combination-block combination)) (finish (lambda (call-prefix continuation-prefix) @@ -94,12 +125,25 @@ MIT in each case. |# 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))))))) + (make-scfg + (cfg-entry-node + (scfg*scfg->scfg! + (call-prefix continuation) + ((let ((callee (combination-known-operator combination))) + (cond ((normal-primitive-constant? callee) + make-call/primitive) + ((or (not callee) (not (procedure? callee))) + make-call/unknown) + (else + (case (procedure/type callee) + ((OPEN-INTERNAL) make-call/stack-with-link) + ((OPEN-EXTERNAL) make-call/stack-with-link) + ((CLOSURE) make-call/closure) + ((IC) make-call/ic) + (else (error "Unknown callee type" callee)))))) + combination operator operands invocation-prefix/null + continuation))) + (scfg-next-hooks continuation-cfg))))))) (cond ((ic-block? block) ;; **** Actually, should only do this if the environment ;; will be needed by the continuation. @@ -109,169 +153,93 @@ MIT in each case. |# (rtl:make-push-return continuation))) (rtl:make-pop register:environment))) ((and (stack-block? block) - (let ((operator (combination-known-operator combination))) - (and operator - (procedure? operator) - (procedure/open-internal? operator)))) + (let ((callee (combination-known-operator combination))) + (and callee + (procedure? callee) + (procedure/open-internal? callee)))) (finish rtl:make-message-receiver:subproblem (make-null-cfg))) (else (finish rtl:make-push-return (make-null-cfg)))))) - -(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) - (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) - (else (error "Unknown callee type" operator)))))) - combination invocation-prefix/null continuation)) - -;;;; Reductions - -(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)))) - (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) - (make-call/unknown combination invocation-prefix/null false)) - -(define (reduction/ic->ic combination) - (make-call/ic combination invocation-prefix/null false)) - -(define (reduction/ic->primitive combination) - (make-call/primitive combination invocation-prefix/null false)) - -(define (reduction/ic->closure combination) - (make-call/closure combination invocation-prefix/null false)) - -(define (reduction/ic->open-external combination) - (make-call/open-external combination invocation-prefix/null false)) - -(define (reduction/ic->child combination) - (error "Calling internal procedure from IC procedure")) - -(define (reduction/external->unknown combination) - (make-call/unknown combination 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) - (make-call/primitive combination 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) - (make-call/open-external combination invocation-prefix/move-frame-up false)) - -(define (reduction/external->child combination) - (make-call/child combination - rtl:make-message-receiver:closure - rtl:message-receiver-size:closure)) -(define (reduction/internal->unknown combination) - (make-call/unknown combination invocation-prefix/internal->closure false)) - -(define (reduction/internal->ic combination) - (make-call/ic combination invocation-prefix/internal->closure false)) - -(define (reduction/internal->primitive combination) - (make-call/primitive combination 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) - (make-call/open-external combination invocation-prefix/internal->closure - false)) - -(define (reduction/internal->child combination) - (make-call/child combination - rtl:make-message-receiver:stack - rtl:message-receiver-size:stack)) - -(define (reduction/internal->sibling combination) - (make-call/stack combination invocation-prefix/internal->sibling false)) - -(define (reduction/internal->ancestor combination) - (make-call/stack-with-link combination invocation-prefix/internal->ancestor - false)) +(define (combination/reduction combination operator operands) + (let ((block (combination-block combination)) + (callee (combination-known-operator combination))) + (let ((caller (block-procedure block)) + (generator + (cond ((normal-primitive-constant? callee) + make-call/primitive) + ((or (not callee) + (not (procedure? callee))) + make-call/unknown) + (else + (case (procedure/type callee) + ((IC) make-call/ic) + ((CLOSURE) make-call/closure) + ((OPEN-EXTERNAL) make-call/stack-with-link) + ((OPEN-INTERNAL) false) + (else (error "Unknown callee type" callee))))))) + (cond ((or (not caller) (procedure/ic? caller)) + (if generator + (generator combination operator operands + invocation-prefix/null false) + (error "Calling internal procedure from IC procedure"))) + ((procedure/external? caller) + (if generator + (generator combination operator operands + invocation-prefix/move-frame-up false) + (make-call/child combination operator operands + rtl:make-message-receiver:closure))) + (else + (if generator + (generator combination operator operands + invocation-prefix/internal->closure false) + (let ((block* (procedure-block callee))) + (cond ((block-child? block block*) + (make-call/child combination operator operands + rtl:make-message-receiver:stack)) + ((block-sibling? block block*) + (make-call/stack combination operator operands + invocation-prefix/internal->sibling + false)) + (else + (make-call/stack-with-link + combination operator operands + invocation-prefix/internal->ancestor + false)))))))))) ;;;; Calls -(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) +(define (make-call/apply combination operator operands prefix + continuation) + (make-call true combination operator operands + (lambda (frame-size) + (rtl:make-invocation:apply frame-size + (prefix combination frame-size) continuation)))) -(define (make-call/lookup combination invocation-prefix continuation) - (make-call/dont-push-operator combination - (lambda (number-pushed) +(define (make-call/lookup combination operator operands prefix + continuation) + (make-call false combination operator operands + (lambda (frame-size) (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) + frame-size + (prefix combination frame-size) continuation (nearest-ic-block-expression block) (intern-scode-variable! block name))))))) -(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)) +(define (make-call/unknown combination operator operands prefix + continuation) + (let ((callee (subproblem-value (combination-operator combination)))) + ((cond ((or (not (reference? callee)) + (reference-to-known-location? callee)) make-call/apply) ;; **** Need to add code for links here. (else make-call/lookup)) - combination invocation-prefix continuation))) + combination operator operands 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 @@ -279,37 +247,35 @@ MIT in each case. |# (define make-call/ic make-call/apply) -(define (make-call/primitive combination invocation-prefix continuation) - (make-call/dont-push-operator combination - (lambda (number-pushed) +(define (make-call/primitive combination operator operands prefix + continuation) + (make-call false combination operator operands + (lambda (frame-size) (rtl:make-invocation:primitive - number-pushed - (invocation-prefix combination number-pushed) + frame-size + (prefix combination frame-size) continuation (constant-value (combination-known-operator combination)))))) -(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 invocation-prefix continuation) +(define (make-call/child combination operator operands make-receiver) (scfg*scfg->scfg! - (rtl:make-push (rtl:make-fetch register:environment)) - (make-call/dont-push-operator combination - (internal-call combination invocation-prefix continuation 0)))) + (make-receiver (block-frame-size (combination-block combination))) + (make-call/stack-with-link combination operator operands + invocation-prefix/null false))) -(define (make-call/stack combination invocation-prefix continuation) - (stack-call combination invocation-prefix continuation 0)) +(package (make-call/closure make-call/stack make-call/stack-with-link) -(define (make-call/stack-with-link combination invocation-prefix continuation) - (link-call combination invocation-prefix continuation 0)) +(define-export (make-call/closure combination operator operands prefix + continuation) + (make-call true combination operator operands + (internal-call combination prefix continuation 0))) -(define (make-call/child combination make-receiver receiver-size) - (scfg*scfg->scfg! - (make-receiver (block-frame-size (combination-block combination))) - (link-call combination invocation-prefix/null false (receiver-size)))) +(define-export (make-call/stack combination operator operands prefix + continuation) + (stack-call combination operator operands prefix continuation 0)) -(define (link-call combination invocation-prefix continuation extra) +(define-export (make-call/stack-with-link combination operator operands prefix + continuation) (scfg*scfg->scfg! (rtl:make-push (rtl:make-address @@ -317,42 +283,84 @@ MIT in each case. |# (combination-block combination) (block-parent (procedure-block (combination-known-operator combination)))))) - (stack-call combination invocation-prefix continuation (1+ extra)))) + (stack-call combination operator operands prefix continuation 1))) -(define (stack-call combination invocation-prefix continuation extra) - (make-call/dont-push-operator combination - (internal-call combination invocation-prefix continuation extra))) +(define (stack-call combination operator operands prefix continuation extra) + (make-call false combination operator operands + (internal-call combination prefix continuation extra))) -(define (internal-call combination invocation-prefix continuation extra) - (lambda (number-pushed) +(define (internal-call combination prefix continuation extra) + (lambda (frame-size) (let ((operator (combination-known-operator combination)) - (number-pushed (+ number-pushed extra))) + (frame-size (+ frame-size extra))) ((if (procedure-rest operator) rtl:make-invocation:lexpr rtl:make-invocation:jump) - number-pushed - (invocation-prefix combination number-pushed) + frame-size + (prefix combination frame-size) continuation operator)))) + +) + +(define (make-call push-operator? combination operator operands generator) + (let ((callee (combination-known-operator combination)) + (n-operands (length operands)) + (finish + (lambda (frame-size) + (scfg-append! + (scfg*->scfg! + (map (lambda (operand) + (transmit-values operand + (lambda (cfg prefix expression) + (scfg-append! cfg + prefix + (rtl:make-push expression))))) + (reverse operands))) + operator + (if push-operator? + (transmit-values + (generate/rvalue + (subproblem-value (combination-operator combination))) + (lambda (prefix expression) + (scfg-append! prefix + (rtl:make-push expression) + (generator (1+ frame-size))))) + (generator frame-size)))))) + (if (and callee + (procedure? callee) + (not (procedure-rest callee)) + (stack-block? (procedure-block callee))) + (let ((n-parameters (+ (length (procedure-required callee)) + (length (procedure-optional callee))))) + (scfg*scfg->scfg! + (scfg*->scfg! + (let loop ((n (- n-parameters n-operands))) + (if (zero? n) + '() + (cons (rtl:make-push (rtl:make-unassigned)) + (loop (-1+ n)))))) + (finish n-parameters))) + (finish n-operands)))) ;;;; Prefixes -(define (invocation-prefix/null combination number-pushed) +(define (invocation-prefix/null combination frame-size) '(NULL)) -(define (invocation-prefix/move-frame-up combination number-pushed) - `(MOVE-FRAME-UP ,number-pushed +(define (invocation-prefix/move-frame-up combination frame-size) + `(MOVE-FRAME-UP ,frame-size ,(block-frame-size (combination-block combination)))) -(define (invocation-prefix/internal->closure combination number-pushed) +(define (invocation-prefix/internal->closure combination frame-size) ;; 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 + `(APPLY-CLOSURE ,frame-size ,(block-frame-size (combination-block combination)))) -(define (invocation-prefix/internal->ancestor combination number-pushed) +(define (invocation-prefix/internal->ancestor combination frame-size) (let ((block (combination-block combination))) - `(APPLY-STACK ,number-pushed + `(APPLY-STACK ,frame-size ,(block-frame-size block) ,(-1+ (block-ancestor-distance @@ -361,46 +369,7 @@ MIT in each case. |# (procedure-block (combination-known-operator combination)))))))) -(define (invocation-prefix/internal->sibling combination number-pushed) - `(MOVE-FRAME-UP ,number-pushed +(define (invocation-prefix/internal->sibling combination frame-size) + `(MOVE-FRAME-UP ,frame-size ;; -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) - -(define (make-call-maker generate/operator wrap-n) - (lambda (combination make-invocation) - (let ((operator (combination-known-operator combination)) - (operands (combination-operands combination))) - (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-export make-call/dont-push-operator - (make-call-maker generate/subproblem-cfg identity-procedure)) - -(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