#| -*-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
\f
(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)))))))
\f
-;;;; 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
+ '())
+\f
+(define (combination/subproblem combination operator operands)
(let ((block (combination-block combination))
(finish
(lambda (call-prefix continuation-prefix)
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.
(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))
-\f
-;;;; 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))
-\f
-(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))
\f
-(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))))))))))
\f
;;;; 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
(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))))))
\f
-(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
(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))))
+
+)
+\f
+(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))))
\f
;;;; 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
(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)))))
-\f
-;;;; 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
projects / mit-scheme.git / commitdiff