#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.3 1988/06/14 08:31:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.4 1988/08/18 01:34:39 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define-integrable continuation/label procedure-label)
(define-integrable continuation/returns procedure-applications)
(define-integrable set-continuation/returns! set-procedure-applications!)
-(define-integrable continuation/always-known-operator?
+(define-integrable continuation/ever-known-operator?
procedure-always-known-operator?)
(define-integrable continuation/offset procedure-closure-offset)
(define-integrable set-continuation/offset! set-procedure-closure-offset!)
(set-procedure-register! continuation register)
register)))
+(define-integrable (continuation/always-known-operator? continuation)
+ (eq? (continuation/ever-known-operator? continuation) 'ALWAYS))
+
(define-integrable (continuation/parameter continuation)
(car (procedure-original-required continuation)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.4 1988/07/16 20:54:39 hal Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.5 1988/08/18 01:34:48 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(operators ;used in simulate-application
arguments) ;used in outer-analysis
operand-values ;set by outer-analysis, used by identify-closure-limits
+ continuation-push
)
(define *applications*)
-(define (make-application type block operator operands)
+(define (make-application type block operator operands continuation-push)
(let ((application
(make-snode application-tag
- type block operator operands false '() '())))
+ type block operator operands false '() '()
+ continuation-push)))
(set! *applications* (cons application *applications*))
(add-block-application! block application)
(if (rvalue/reference? operator)
(set! *parallels* (cons parallel *parallels*))
(snode->scfg parallel)))
\f
-(define (make-combination block continuation operator operands)
+(define (make-combination block continuation operator operands
+ continuation-push)
(let ((application
(make-application 'COMBINATION
block
(subproblem-rvalue operator)
(cons continuation
- (map subproblem-rvalue operands)))))
+ (map subproblem-rvalue operands))
+ continuation-push)))
(scfg*scfg->scfg!
(make-parallel (cfg-entry-node application) (cons operator operands))
application)))
(define-integrable combination/frame-size application-operand-values)
(define-integrable set-combination/frame-size! set-application-operand-values!)
(define-integrable combination/inline? combination/inliner)
+(define-integrable combination/continuation-push application-continuation-push)
(define-integrable (combination/continuation combination)
(car (application-operands combination)))
(set-application-operands! combination (list rvalue))))
(define-integrable (make-return block continuation rvalue)
- (make-application 'RETURN block continuation (list rvalue)))
+ (make-application 'RETURN block continuation (list rvalue) false))
(define-integrable (application/return? application)
(eq? (application-type application) 'RETURN))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.8 1988/08/11 20:13:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.9 1988/08/18 01:35:15 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
generator)
(if (virtual-continuation? continuation)
(let ((continuation (virtual-continuation/reify! continuation)))
- (scfg*value->value! (make-push block continuation)
- (generator continuation)))
- (generator continuation)))
+ (let ((push (make-push block continuation)))
+ (scfg*value->value! push
+ (generator (cfg-entry-node push)
+ continuation))))
+ (generator false continuation)))
(define (make-subproblem/canonical prefix continuation)
(make-subproblem prefix
(with-reified-continuation block
continuation
scfg*subproblem->subproblem!
- (lambda (continuation)
+ (lambda (push continuation)
+ push ;ignore
(finish continuation
(lambda (predicate consequent alternative)
(make-subproblem/canonical
(scode/combination-components expression
(lambda (operator operands)
(let ((make-combination
- (lambda (continuation)
+ (lambda (push continuation)
(make-combination
block
(continuation-reference block continuation)
(generate/subproblem/value block
continuation
expression))
- operands)))))
+ operands)
+ push))))
((continuation/case continuation
- (lambda () (make-combination continuation))
+ (lambda () (make-combination false continuation))
(lambda ()
(if (variable? continuation)
(make-combination continuation)
(with-reified-continuation block
continuation
scfg*scfg->scfg!
- (lambda (continuation)
+ (lambda (push continuation)
(make-scfg
- (cfg-entry-node (make-combination continuation))
+ (cfg-entry-node (make-combination push continuation))
(continuation/next-hooks continuation))))))
(lambda ()
(if (eq? not operator)
(generate/expression block continuation (car operands))) (with-reified-continuation block
continuation
scfg*pcfg->pcfg!
- (lambda (continuation)
+ (lambda (push continuation)
(scfg*pcfg->pcfg!
(make-scfg
- (cfg-entry-node (make-combination continuation))
+ (cfg-entry-node (make-combination push continuation))
(continuation/next-hooks continuation))
(make-true-test (continuation/rvalue continuation)))))))
(lambda ()
(with-reified-continuation block
continuation
scfg*subproblem->subproblem!
- (lambda (continuation)
- (make-subproblem/canonical (make-combination continuation)
- continuation))))))))))
+ (lambda (push continuation)
+ (make-subproblem/canonical
+ (make-combination push continuation)
+ continuation))))))))))
(define (generate/operator block continuation operator)
(wrapper/subproblem/value block continuation
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/conect.scm,v 4.1 1987/12/30 06:47:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/conect.scm,v 4.2 1988/08/18 01:35:41 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (procedure-direct-linked? procedure)
(if (procedure-continuation? procedure)
- (continuation/always-known-operator? procedure)
+ (continuation/ever-known-operator? procedure)
(procedure-inline-code? procedure)))
(define (walk-node node color)
(define (walk-continuation continuation color)
(let ((rvalue (rvalue-known-value continuation)))
- (if (and rvalue
- (continuation/always-known-operator? rvalue))
+ (if rvalue
(walk-node (continuation/entry-node rvalue) color))))
)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.3 1988/06/14 08:35:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.4 1988/08/18 01:36:00 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(enumeration-case continuation-type
(virtual-continuation/type operator)
((EFFECT)
+ (if (rvalue/continuation? operand)
+ (begin
+ (set-continuation/offset! operand offset)
+ (enqueue-procedure! operand)))
offset)
((REGISTER VALUE)
(walk-rvalue operand)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.2 1987/12/30 06:44:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.3 1988/08/18 01:36:20 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (analyze/continuation continuation)
(and (not (continuation/passed-out? continuation))
- (let ((returns (continuation/returns continuation))
- (combinations (continuation/combinations continuation)))
- (and (or (not (null? returns))
- (not (null? combinations)))
- (for-all? returns
- (lambda (return)
- (eq? (rvalue-known-value (return/operator return))
- continuation)))
- (for-all? combinations
- (lambda (combination)
- (eq? (rvalue-known-value
- (combination/continuation combination))
- continuation)))))))
+ (3-logic/and
+ (for-some? (continuation/returns continuation)
+ (lambda (return)
+ (eq? (rvalue-known-value (return/operator return))
+ continuation)))
+ (for-some? (continuation/combinations continuation)
+ (lambda (combination)
+ (eq? (rvalue-known-value (combination/continuation combination))
+ continuation))))))
+
+(define (for-some? items predicate)
+ (let loop ((items items) (default false))
+ (cond ((null? items) 'ALWAYS)
+ ((predicate (car items)) (loop (cdr items) 'SOMETIMES))
+ (else default))))
+
+(define (3-logic/and x y)
+ (cond ((and (eq? x 'ALWAYS) (eq? y 'ALWAYS)) 'ALWAYS)
+ ((and (not x) (not y)) false)
+ (else 'SOMETIMES)))
(define (analyze/procedure procedure)
(and (not (procedure-passed-out? procedure))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.7 1988/06/14 08:42:14 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.8 1988/08/18 01:36:46 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(if (variable/value-variable? variable)
(if-compiler
(let ((continuation (block-procedure start-block)))
- (if (continuation/always-known-operator? continuation)
+ (if (continuation/ever-known-operator? continuation)
(continuation/register continuation)
register:value)))
(find-variable-internal start-block variable offset
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.9 1988/06/14 09:37:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.10 1988/08/18 01:36:54 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(for-each (if compiler:open-code-primitives?
(lambda (application)
(if (eq? (application-type application) 'COMBINATION)
- (set-combination/inliner!
- application
- (analyze-combination application))))
+ (let ((inliner (analyze-combination application)))
+ (set-combination/inliner! application inliner)
+ ;; Don't push a return address on the stack
+ ;; if: (1) the combination is inline coded,
+ ;; (2) the continuation is known, and (3) the
+ ;; push is unique for this combination.
+ (let ((push
+ (combination/continuation-push application)))
+ (if (and inliner
+ push
+ (rvalue-known-value
+ (combination/continuation application)))
+ (set-virtual-continuation/type!
+ (virtual-return-operator push)
+ continuation-type/effect))))))
(lambda (application)
(if (eq? (application-type application) 'COMBINATION)
(set-combination/inliner! application false))))
(let ((offset (node/offset combination)))
(generate/return* (combination/block combination)
(combination/continuation combination)
+ (combination/continuation-push combination)
(let ((inliner (combination/inliner combination)))
(let ((handler (inliner/handler inliner))
(generator (inliner/generator inliner))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.3 1988/06/14 08:42:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.4 1988/08/18 01:37:05 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define (generate/return return)
(generate/return* (return/block return)
(return/operator return)
+ false
(trivial-return-operand (return/operand return))
(node/offset return)))
(define (generate/trivial-return block operator operand offset)
- (generate/return* block operator (trivial-return-operand operand) offset))
+ (generate/return* block operator false (trivial-return-operand operand)
+ offset))
(define (trivial-return-operand operand)
(make-return-operand
(package (generate/return*)
-(define-export (generate/return* block operator operand offset)
+(define-export (generate/return* block operator not-on-stack? operand offset)
(let ((continuation (rvalue-known-value operator)))
- (if (and continuation
- (continuation/always-known-operator? continuation))
+ (if continuation
((method-table-lookup simple-methods (continuation/type continuation))
block
operator
+ not-on-stack?
operand
offset
continuation)
(make-method-table continuation-types false))
(define-method-table-entry 'EFFECT simple-methods
- (lambda (block operator operand offset continuation)
+ (lambda (block operator not-on-stack? operand offset continuation)
(scfg-append!
(effect-prefix operand offset)
- (common-prefix block operator offset continuation)
+ (common-prefix block operator not-on-stack? offset continuation)
(generate/node (continuation/entry-node continuation)))))
(define-method-table-entries '(REGISTER VALUE) simple-methods
- (lambda (block operator operand offset continuation)
+ (lambda (block operator not-on-stack? operand offset continuation)
(scfg-append!
(if (lvalue-integrated? (continuation/parameter continuation))
(effect-prefix operand offset)
(lambda (expression)
(rtl:make-assignment (continuation/register continuation)
expression))))
- (common-prefix block operator offset continuation)
+ (common-prefix block operator not-on-stack? offset continuation)
(generate/node (continuation/entry-node continuation)))))
(define-method-table-entry 'PUSH simple-methods
- (lambda (block operator operand offset continuation)
+ (lambda (block operator not-on-stack? operand offset continuation)
(scfg*scfg->scfg!
- (let ((prefix (common-prefix block operator offset continuation)))
+ (let ((prefix
+ (common-prefix block operator not-on-stack? offset continuation)))
(if (cfg-null? prefix)
((return-operand/value-generator operand) offset rtl:make-push)
(use-temporary-register operand offset prefix rtl:make-push)))
(generate/node (continuation/entry-node continuation)))))
\f
(define-method-table-entry 'PREDICATE simple-methods
- (lambda (block operator operand offset continuation)
+ (lambda (block operator not-on-stack? operand offset continuation)
(let ((node (continuation/entry-node continuation))
(value (return-operand/known-value operand))
- (prefix (common-prefix block operator offset continuation)))
+ (prefix
+ (common-prefix block operator not-on-stack? offset continuation)))
(if value
(scfg-append!
(effect-prefix operand offset)
(define-integrable (effect-prefix operand offset)
((return-operand/effect-generator operand) offset))
-(define (common-prefix block operator offset continuation)
- (scfg*scfg->scfg!
- (return-operator/pop-frames block operator offset 0)
- (generate/continuation-entry/ic-block continuation)))
+(define (common-prefix block operator not-on-stack? offset continuation)
+ (if not-on-stack?
+ (return-operator/pop-frames block operator offset 0)
+ (scfg*scfg->scfg!
+ (return-operator/pop-frames block operator offset 1)
+ (generate/continuation-entry/pop-extra continuation))))
)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.4 1988/06/14 08:43:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.5 1988/08/18 01:37:14 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(begin
(enqueue-continuation! continuation)
(scfg*scfg->scfg!
- (if (and (stack-block? closing-block)
- (stack-block/dynamic-link? closing-block))
+ (if (block/dynamic-link? closing-block)
(rtl:make-push-link)
(make-null-cfg))
(rtl:make-push-return (continuation/label continuation))))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.5 1988/06/14 08:43:15 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.6 1988/08/18 01:37:23 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(if (continuation/avoid-check? continuation)
(rtl:make-continuation-entry label)
(rtl:make-continuation-header label))
- (generate/continuation-entry/ic-block continuation)
- (if (block/dynamic-link?
- (continuation/closing-block continuation))
- (rtl:make-pop-link)
- (make-null-cfg))
+ (generate/continuation-entry/pop-extra continuation)
(enumeration-case continuation-type
(continuation/type continuation)
((PUSH)
- (scfg*scfg->scfg!
- (rtl:make-push (rtl:make-fetch register:value))
- (generate/node node)))
+ (rtl:make-push (rtl:make-fetch register:value)))
((REGISTER)
- (scfg*scfg->scfg!
- (rtl:make-assignment (continuation/register continuation)
- (rtl:make-fetch register:value))
- (generate/node node)))
+ (rtl:make-assignment (continuation/register continuation)
+ (rtl:make-fetch register:value)))
+ ((VALUE)
+ (if (continuation/ever-known-operator? continuation)
+ (rtl:make-assignment (continuation/register continuation)
+ (rtl:make-fetch register:value))
+ (make-null-cfg)))
(else
- (generate/node node))))))
+ (make-null-cfg)))
+ (generate/node node))))
(lambda (rgraph entry-edge)
(make-rtl-continuation rgraph label entry-edge)))))
-(define (generate/continuation-entry/ic-block continuation)
- (if (ic-block? (continuation/closing-block continuation))
- (rtl:make-pop register:environment)
- (make-null-cfg)))
+(define (generate/continuation-entry/pop-extra continuation)
+ (let ((block (continuation/closing-block continuation)))
+ (if (ic-block? block)
+ (rtl:make-pop register:environment)
+ (make-null-cfg))
+ (if (and (not (continuation/always-known-operator? continuation))
+ (block/dynamic-link? block))
+ (rtl:make-pop-link)
+ (make-null-cfg)))))
\f
(define (generate/node node)
(let ((memoization (cfg-node-get node memoization-tag)))
projects / mit-scheme.git / commitdiff