--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.1 1987/12/04 19:27:53 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Flow Graph Generation
+
+(declare (usual-integrations))
+\f
+(define (construct-graph scode)
+ (fluid-let ((*virtual-continuations* '()))
+ (let ((block (make-block false 'EXPRESSION)))
+ (let ((continuation (make-continuation-variable block)))
+ (let ((expression
+ (make-expression
+ block
+ continuation
+ (transmit-values
+ (if (scode/open-block? scode)
+ (scode/open-block-components scode
+ (lambda (names declarations body)
+ (return-3 (make-variables block names)
+ declarations
+ (unscan-defines names '() body))))
+ (return-3 '() '() scode))
+ (lambda (variables declarations scode)
+ (set-block-bound-variables! block variables)
+ (generate/body block continuation declarations scode))))))
+ (for-each (lambda (procedure)
+ (if (procedure-continuation? procedure)
+ (set-procedure-entry-node!
+ procedure
+ (snode-next (procedure-entry-node procedure)))))
+ *procedures*)
+ (for-each (lambda (continuation)
+ (set-virtual-continuation/parent! continuation false))
+ *virtual-continuations*)
+ expression)))))
+
+(define (make-variables block names)
+ (map (lambda (name) (make-variable block name)) names))
+
+(define (generate/body block continuation declarations expression)
+ ;; The call to `process-declarations!' must come after the
+ ;; expression is generated because it can refer to the set of free
+ ;; variables in the expression.
+ (let ((node (generate/expression block continuation expression)))
+ (process-declarations! block declarations)
+ node))
+
+(define (continue/rvalue block continuation rvalue)
+ ((continuation/case continuation
+ (lambda ()
+ (make-return block (make-reference block continuation true) rvalue))
+ (lambda ()
+ (make-null-cfg))
+ (lambda ()
+ (make-true-test rvalue))
+ (lambda ()
+ (if (not (virtual-continuation? continuation))
+ (error "Continuation should be virtual" continuation))
+ (make-subproblem (make-null-cfg) continuation rvalue)))))
+\f
+;;;; Continuations
+
+(define (continuation/case continuation unknown effect predicate value)
+ (cond ((variable? continuation) unknown)
+ ((procedure? continuation)
+ (let ((type (continuation/type continuation)))
+ (cond ((eq? type continuation-type/effect) effect)
+ ((eq? type continuation-type/predicate) predicate)
+ ((eq? type continuation-type/value) value)
+ (else (error "Illegal continuation type" type)))))
+ ((virtual-continuation? continuation)
+ (let ((type (virtual-continuation/type continuation)))
+ (cond ((eq? type continuation-type/effect) effect)
+ ((eq? type continuation-type/predicate) predicate)
+ ((eq? type continuation-type/value) value)
+ (else (error "Illegal virtual continuation type" type)))))
+ (else (error "Illegal continuation" continuation))))
+
+(define (continuation/type? continuation type)
+ (cond ((variable? continuation) false)
+ ((procedure? continuation)
+ (eq? (continuation/type continuation) type))
+ ((virtual-continuation? continuation)
+ (eq? (virtual-continuation/type continuation) type))
+ (else
+ (error "Illegal continuation" continuation))))
+
+(define-integrable (continuation/effect? continuation)
+ (continuation/type? continuation continuation-type/effect))
+
+(define-integrable (continuation/predicate? continuation)
+ (continuation/type? continuation continuation-type/predicate))
+
+(define (continuation/rvalue continuation)
+ (make-reference (continuation/block continuation)
+ (continuation/parameter continuation)
+ true))
+
+(define-integrable (continuation/next-hooks continuation)
+ (list (make-hook (continuation/entry-node continuation)
+ set-snode-next-edge!)))
+
+(define-integrable (continuation-reference block continuation)
+ (cond ((variable? continuation) (make-reference block continuation true))
+ ((procedure? continuation) continuation)
+ (else (error "Illegal continuation" continuation))))
+\f
+;;;; Subproblems
+
+(define (subproblem-canonicalize subproblem)
+ (if (subproblem-canonical? subproblem)
+ subproblem
+ (let ((continuation
+ (continuation/reify! (subproblem-continuation subproblem))))
+ (make-subproblem/canonical
+ (scfg*scfg->scfg! (subproblem-prefix subproblem)
+ (make-return (subproblem-block subproblem)
+ continuation
+ (subproblem-rvalue subproblem)))
+ continuation))))
+
+(define (continuation/reify! continuation)
+ (if (virtual-continuation? continuation)
+ (virtual-continuation/reify! continuation)
+ continuation))
+
+(define (make-subproblem/canonical prefix continuation)
+ (make-subproblem prefix
+ continuation
+ (continuation/rvalue continuation)))
+
+(define (scfg*subproblem->subproblem! scfg subproblem)
+ (make-subproblem (scfg*scfg->scfg! scfg (subproblem-prefix subproblem))
+ (subproblem-continuation subproblem)
+ (subproblem-rvalue subproblem)))
+
+(define (pcfg*subproblem->subproblem! predicate consequent alternative)
+ ;; This depends on the fact that, after canonicalizing two
+ ;; subproblems which were generated with the same continuation, the
+ ;; block, continuation, and rvalue of each subproblem are identical.
+ (let ((consequent (subproblem-canonicalize consequent))
+ (alternative (subproblem-canonicalize alternative)))
+ (make-subproblem (pcfg*scfg->scfg! predicate
+ (subproblem-prefix consequent)
+ (subproblem-prefix alternative))
+ (subproblem-continuation consequent)
+ (subproblem-rvalue consequent))))
+\f
+(define (generator/subproblem type scfg*value->value!)
+ (lambda (block continuation expression)
+ (let ((continuation (virtual-continuation/make block continuation type)))
+ (let ((value (generate/expression block continuation expression)))
+ (if (virtual-continuation/reified? continuation)
+ (scfg*value->value!
+ (make-push block (virtual-continuation/reification continuation))
+ value)
+ value)))))
+
+(define *virtual-continuations*)
+
+(define (virtual-continuation/make block parent type)
+ (let ((continuation (virtual-continuation/%make block parent type)))
+ (set! *virtual-continuations* (cons continuation *virtual-continuations*))
+ continuation))
+
+(define generate/subproblem/effect
+ (generator/subproblem continuation-type/effect scfg*scfg->scfg!))
+
+(define generate/subproblem/predicate
+ (generator/subproblem continuation-type/predicate scfg*pcfg->pcfg!))
+
+(define generate/subproblem/value
+ (generator/subproblem continuation-type/value scfg*subproblem->subproblem!))
+\f
+;;;; Values
+
+(define (generate/constant block continuation expression)
+ (continue/rvalue block continuation (make-constant expression)))
+
+(define (generate/the-environment block continuation expression)
+ (continue/rvalue block continuation block))
+
+(define (generate/variable block continuation expression)
+ (continue/rvalue block
+ continuation
+ (make-reference block
+ (find-name block
+ (scode/variable-name expression))
+ false)))
+
+(define (generate/safe-variable block continuation expression)
+ (continue/rvalue
+ block
+ continuation
+ (make-reference block
+ (find-name block (scode/safe-variable-name expression))
+ true)))
+
+(define-integrable (scode/make-safe-variable name)
+ (cons safe-variable-tag name))
+
+(define-integrable (scode/safe-variable-name reference)
+ (cdr reference))
+
+(define safe-variable-tag
+ "safe-variable")
+
+(define (generate/unassigned? block continuation expression)
+ (if (continuation/predicate? continuation)
+ (continue/rvalue block
+ continuation
+ (make-unassigned-test
+ block
+ (find-name block (scode/unassigned?-name expression))))
+ (generate/conditional block
+ continuation
+ (scode/make-conditional expression #T #F))))
+
+(define (find-name block name)
+ (define (search block)
+ (or (variable-assoc name (block-bound-variables block))
+ (variable-assoc name (block-free-variables block))
+ (let ((variable
+ (if (block-parent block)
+ (search (block-parent block))
+ (make-variable block name))))
+ (set-block-free-variables! block
+ (cons variable
+ (block-free-variables block)))
+ variable)))
+ (search block))
+\f
+(define (generate/lambda block continuation expression)
+ (continue/rvalue
+ block
+ continuation
+ (scode/lambda-components expression
+ (lambda (name required optional rest auxiliary declarations body)
+ (transmit-values (parse-procedure-body auxiliary body)
+ (lambda (names values body)
+ (let ((block (make-block block 'PROCEDURE)))
+ (let ((continuation (make-continuation-variable block))
+ (required (make-variables block required))
+ (optional (make-variables block optional))
+ (rest (and rest (make-variable block rest)))
+ (names (make-variables block names)))
+ (set-block-bound-variables! block
+ `(,continuation
+ ,@required
+ ,@optional
+ ,@(if rest (list rest) '())
+ ,@names))
+ (make-procedure
+ continuation-type/procedure
+ block name (cons continuation required) optional rest names
+ (map (lambda (value)
+ ;; The other parts of this subproblem are not
+ ;; interesting since `value' is guaranteed to
+ ;; be either a constant or a procedure.
+ (subproblem-rvalue
+ (generate/subproblem/value block continuation value)))
+ values)
+ (generate/body block continuation declarations body))))))))))
+\f
+(define (parse-procedure-body auxiliary body)
+ (transmit-values
+ (parse-procedure-body* auxiliary (scode/sequence-actions body))
+ (lambda (names values auxiliary actions)
+ (if (null? auxiliary)
+ (return-3 names values (scode/make-sequence actions))
+ (return-3 '() '()
+ (scode/make-combination
+ (scode/make-lambda
+ lambda-tag:let auxiliary '() false names '()
+ (scode/make-sequence
+ (map* actions scode/make-assignment names values)))
+ (map (lambda (name) (scode/make-unassigned-object))
+ auxiliary)))))))
+
+(define (parse-procedure-body* names actions)
+ ;; Extract any definitions that do not depend on the order of
+ ;; events.
+ (cond ((null? names)
+ (return-4 '() '() '() actions))
+ ((null? actions)
+ (error "Extraneous auxiliaries" names))
+
+ ;; Because `scan-defines' returns the auxiliary names in a
+ ;; particular order, we can expect to encounter them in that
+ ;; same order when looking through the body's actions.
+
+ ((and (scode/assignment? (car actions))
+ (eq? (scode/assignment-name (car actions)) (car names)))
+ (transmit-values (parse-procedure-body* (cdr names) (cdr actions))
+ (let ((value (scode/assignment-value (car actions))))
+ (if (or (scode/lambda? value)
+ (scode/delay? value)
+ (scode/constant? value))
+ (lambda (names* values auxiliary actions*)
+ (return-4 (cons (car names) names*)
+ (cons value values)
+ auxiliary
+ (if (null? actions*)
+ (list undefined-conditional-branch)
+ actions*)))
+ (lambda (names* values auxiliary actions*)
+ (return-4 names*
+ values
+ (cons (car names) auxiliary)
+ (cons (car actions) actions*)))))))
+ (else
+ (transmit-values (parse-procedure-body* names (cdr actions))
+ (lambda (names* values auxiliary actions*)
+ (return-4 names*
+ values
+ auxiliary
+ (cons (car actions) actions*)))))))
+\f
+;;;; Combinators
+
+(define (generate/combination block continuation expression)
+ (let ((continuation (continuation/reify! continuation)))
+ (let ((generator
+ (lambda (expression)
+ (generate/subproblem/value block #|(make-block block 'JOIN)|#
+ continuation
+ expression))))
+ (scode/combination-components expression
+ (lambda (operator operands)
+ (let ((combination
+ (make-combination block
+ (continuation-reference block continuation)
+ (generator operator)
+ (map generator operands))))
+ ((continuation/case continuation
+ (lambda ()
+ combination)
+ (lambda ()
+ (make-scfg (cfg-entry-node combination)
+ (continuation/next-hooks continuation)))
+ (lambda ()
+ (scfg*pcfg->pcfg!
+ (make-scfg (cfg-entry-node combination)
+ (continuation/next-hooks continuation))
+ (make-true-test (continuation/rvalue continuation))))
+ (lambda ()
+ (make-subproblem/canonical combination continuation))))))))))
+
+(define (generate/sequence block continuation expression)
+ (let ((join
+ (continuation/case continuation
+ scfg*scfg->scfg!
+ scfg*scfg->scfg!
+ scfg*pcfg->pcfg!
+ scfg*subproblem->subproblem!)))
+ (let loop ((actions (scode/sequence-actions expression)))
+ (if (null? (cdr actions))
+ (generate/expression block continuation (car actions))
+ (join (generate/subproblem/effect block continuation (car actions))
+ (loop (cdr actions)))))))
+
+(define (generate/conditional block continuation expression)
+ (scode/conditional-components expression
+ (lambda (predicate consequent alternative)
+ ((continuation/case continuation
+ pcfg*scfg->scfg!
+ pcfg*scfg->scfg!
+ pcfg*pcfg->pcfg!
+ pcfg*subproblem->subproblem!)
+ (generate/subproblem/predicate block continuation predicate)
+ (generate/expression block continuation consequent)
+ (generate/expression block continuation alternative)))))
+\f
+;;;; Assignments
+
+(define (generate/assignment* maker find-name block continuation name value)
+ (let ((subproblem (generate/subproblem/value block continuation value)))
+ (scfg*scfg->scfg!
+ (if (subproblem-canonical? subproblem)
+ (make-scfg
+ (cfg-entry-node (subproblem-prefix subproblem))
+ (continuation/next-hooks (subproblem-continuation subproblem)))
+ (subproblem-prefix subproblem))
+ (maker block (find-name block name) (subproblem-rvalue subproblem)))))
+
+(define (generate/assignment block continuation expression)
+ (scode/assignment-components expression
+ (lambda (name value)
+ (if (continuation/effect? continuation)
+ (generate/assignment* make-assignment find-name
+ block continuation name value)
+ (generate/combination
+ block
+ continuation
+ (let ((old-value-temp (generate-uninterned-symbol))
+ (new-value-temp (generate-uninterned-symbol)))
+ (scode/make-let (list old-value-temp new-value-temp)
+ (list (scode/make-safe-variable name) value)
+ (scode/make-assignment
+ name
+ (scode/make-variable new-value-temp))
+ (scode/make-variable old-value-temp))))))))
+\f
+(define (generate/definition block continuation expression)
+ (scode/definition-components expression
+ (lambda (name value)
+ (if (continuation/effect? continuation)
+ (generate/assignment* make-definition make-definition-variable
+ block continuation name
+ (insert-letrec name value))
+ (generate/sequence block
+ continuation
+ (scode/make-sequence
+ (list (scode/make-definition name value)
+ name)))))))
+
+(define (make-definition-variable block name)
+ (let ((bound (block-bound-variables block)))
+ (or (variable-assoc name bound)
+ (let ((variable (make-variable block name)))
+ (set-block-bound-variables! block (cons variable bound))
+ variable))))
+
+(define (insert-letrec name value)
+ (if (and compiler:implicit-self-static?
+ (scode/lambda? value))
+ (scode/make-let '() '()
+ (scode/make-definition name value)
+ (scode/make-variable name))
+ value))
+\f
+;;;; Rewrites
+
+(define (generate/access block continuation expression)
+ (scode/access-components expression
+ (lambda (environment name)
+ (generate/combination
+ block
+ continuation
+ (scode/make-combination (ucode-primitive lexical-reference)
+ (list environment name))))))
+
+(define (generate/comment block continuation expression)
+ (generate/expression block
+ continuation
+ (scode/comment-expression expression)))
+
+(define (generate/delay block continuation expression)
+ (generate/lambda block
+ continuation
+ (scode/make-lambda lambda-tag:delay '() '() false '() '()
+ (scode/delay-expression expression))))
+
+(define (generate/disjunction block continuation expression)
+ (scode/disjunction-components expression
+ (lambda (predicate alternative)
+ (generate/combination
+ block
+ continuation
+ (let ((temp (generate-uninterned-symbol)))
+ (scode/make-let (list temp)
+ (list predicate)
+ (let ((predicate (scode/make-variable temp)))
+ (scode/make-conditional predicate
+ predicate
+ alternative))))))))
+
+(define (generate/error-combination block continuation expression)
+ (scode/error-combination-components expression
+ (lambda (message irritants)
+ (generate/combination
+ block
+ continuation
+ (scode/make-combination compiled-error-procedure
+ (cons message irritants))))))
+\f
+(define (generate/in-package block continuation expression)
+ (warn "IN-PACKAGE not supported; body will be interpreted" expression)
+ (scode/in-package-components expression
+ (lambda (environment expression)
+ (generate/combination
+ block
+ continuation
+ (scode/make-combination (ucode-primitive scode-eval)
+ (list (scode/make-quotation expression)
+ environment))))))
+
+(define (generate/quotation block continuation expression)
+ (generate/combination
+ block
+ continuation
+ (scode/make-combination
+ (ucode-primitive car)
+ (list (list (scode/quotation-expression expression))))))
+
+(define (scode/make-let names values . body)
+ (scan-defines (scode/make-sequence body)
+ (lambda (auxiliary declarations body)
+ (scode/make-combination
+ (scode/make-lambda lambda-tag:let names '() false
+ auxiliary declarations body)
+ values))))
+\f
+;;;; Dispatcher
+
+(define generate/expression
+ (let ((dispatch-vector
+ (make-vector number-of-microcode-types generate/constant))
+ (generate/combination
+ (lambda (block continuation expression)
+ (let ((operator (scode/combination-operator expression))
+ (operands (scode/combination-operands expression)))
+ (cond ((and (eq? operator (ucode-primitive lexical-unassigned?))
+ (the-environment? (car operands))
+ (scode/symbol? (cadr operands)))
+ (generate/unassigned? block continuation expression))
+ ((or (eq? operator (ucode-primitive error-procedure))
+ (and (scode/absolute-reference? operator)
+ (eq? (scode/absolute-reference-name operator)
+ 'ERROR-PROCEDURE)))
+ (generate/error-combination block continuation expression))
+ (else
+ (generate/combination block continuation expression))))))
+ (generate/pair
+ (lambda (block continuation expression)
+ (if (eq? (car expression) safe-variable-tag)
+ (generate/safe-variable block continuation expression)
+ (generate/constant block continuation expression)))))
+\f
+ (let-syntax
+ ((dispatch-entry
+ (macro (type handler)
+ `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type) ,handler)))
+ (dispatch-entries
+ (macro (types handler)
+ `(BEGIN ,@(map (lambda (type)
+ `(DISPATCH-ENTRY ,type ,handler))
+ types))))
+ (standard-entry
+ (macro (name)
+ `(DISPATCH-ENTRY ,name ,(symbol-append 'GENERATE/ name)))))
+ (standard-entry access)
+ (standard-entry assignment)
+ (standard-entry conditional)
+ (standard-entry definition)
+ (standard-entry delay)
+ (standard-entry disjunction)
+ (standard-entry in-package)
+ (standard-entry pair)
+ (standard-entry quotation)
+ (standard-entry the-environment)
+ (standard-entry variable)
+ (dispatch-entries (lambda lexpr extended-lambda) generate/lambda)
+ (dispatch-entries (sequence-2 sequence-3) generate/sequence)
+ (dispatch-entries (combination-1 combination-2 combination
+ primitive-combination-0
+ primitive-combination-1
+ primitive-combination-2
+ primitive-combination-3)
+ generate/combination)
+ (dispatch-entry comment generate/comment))
+ (named-lambda (generate/expression block continuation expression)
+ ((vector-ref dispatch-vector (primitive-type expression))
+ block continuation expression))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.1 1987/12/04 19:27:30 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Closure Analysis
+
+(declare (usual-integrations))
+\f
+#|
+
+The closure analysis operates by identifying the "closing limit" of
+each procedure, which is defined as the nearest ancestor of the
+procedure's closing block which is active during the procedure's
+lifetime. The closing limit is false whenever the extent of the
+procedure is not fully known, or if the procedure must be fully closed
+for any reason (including canonicalization).
+
+Procedures that are called from a closed procedure must inherit that
+procedure's closing limit since only the blocks farther away than the
+closing limit can be assumed to exist when those procedures are
+called.
+
+The procedure's free variables which are bound in blocks up to the
+closing limit (exclusive) must be consed in the heap. Other free
+variables don't necessarily need to be allocated on the heap, provided
+that there is a known way to get to them.
+
+This analysis is maximal in that it is required for ANY closure
+construction mechanism that optimizes by means of a stack, because use
+of a stack associates procedure extent with block scope. For many
+simple techniques it generates more information than is needed.
+
+|#
+\f
+(package (identify-closure-limits!)
+
+(define-export (identify-closure-limits! procedures applications assignments)
+ (for-each initialize-closure-limit! procedures)
+ (for-each close-application-arguments! applications)
+ (for-each close-assignment-values! assignments))
+
+(define (initialize-closure-limit! procedure)
+ (if (not (procedure-continuation? procedure))
+ (set-procedure-closing-limit!
+ procedure
+ (and (not (procedure-passed-out? procedure))
+ (procedure-closing-block procedure)))))
+
+(define (close-application-arguments! application)
+ (close-values!
+ (application-operand-values application)
+ (let ((procedure (rvalue-known-value (application-operator application))))
+ (and procedure
+ (rvalue/procedure? procedure)
+ (procedure-always-known-operator? procedure)
+ (procedure-block procedure)))))
+
+(define (close-assignment-values! assignment)
+ (close-rvalue! (assignment-rvalue assignment)
+ (variable-block (assignment-lvalue assignment))))
+
+(define-integrable (close-rvalue! rvalue binding-block)
+ (close-values! (rvalue-values rvalue) binding-block))
+
+(define (close-values! values binding-block)
+ (for-each (lambda (value)
+ (if (and (rvalue/procedure? value)
+ (not (procedure-continuation? value)))
+ (close-procedure! value binding-block)))
+ values))
+
+(define (close-procedure! procedure binding-block)
+ (let ((closing-limit (procedure-closing-limit procedure)))
+ (let ((new-closing-limit
+ (and binding-block
+ closing-limit
+ (block-nearest-common-ancestor binding-block closing-limit))))
+ (if (not (eq? new-closing-limit closing-limit))
+ (begin
+ (set-procedure-closing-limit! procedure new-closing-limit)
+ (for-each-block-descendent! (procedure-block procedure)
+ (lambda (block)
+ (for-each (lambda (application)
+ (close-rvalue! (application-operator application)
+ new-closing-limit))
+ (block-applications block)))))))))
+
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/contan.scm,v 4.1 1987/12/04 19:27:35 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Continuation Analysis
+
+(declare (usual-integrations))
+\f
+(package (continuation-analysis)
+
+;;; Determine when static or dynamic links are to be used. For static
+;;; links, we compute the `block-stack-link' which is the set of
+;;; blocks which might be immediately adjacent (away from the top of
+;;; the stack) to the given block on the stack. If it is possible to
+;;; find the parent in a consistent way with any one of these adjacent
+;;; blocks, we do not need a static link. Otherwise, we set
+;;; `block-stack-link' to the empty list and use a static link.
+
+;;; For dynamic links, we compute the popping limit of a procedure's
+;;; continuation variable, which is the farthest ancestor of the
+;;; procedure's block that is be popped when invoking the
+;;; continuation. If we cannot compute the limit statically (value is
+;;; #F), we must use a dynamic link.
+
+;;; This code takes advantage of the fact that the continuation
+;;; variable is not referenced in blocks other than the procedure's
+;;; block. This may change if call/cc is handled specially.
+
+(define-export (continuation-analysis blocks procedures)
+ (for-each (lambda (procedure)
+ (if (procedure-continuation? procedure)
+ (begin
+ (set-continuation/lvalues! procedure '())
+ (set-continuation/dynamic-link?! procedure false))))
+ procedures)
+ (for-each (lambda (block)
+ (if (stack-block? block)
+ (analyze-continuation block)))
+ blocks)
+ (for-each (lambda (block)
+ (if (stack-block? block)
+ (let ((lvalue (stack-block/continuation-lvalue block)))
+ (if (not (variable-popping-limit lvalue))
+ (force-dynamic-link! lvalue)))))
+ blocks)
+ (for-each (lambda (block)
+ (if (stack-block? block)
+ (lvalue-mark-clear! (stack-block/continuation-lvalue block)
+ dynamic-link-marker)))
+ blocks))
+\f
+(define (force-dynamic-link! lvalue)
+ (if (not (lvalue-mark-set? lvalue dynamic-link-marker))
+ (begin
+ (lvalue-mark-set! lvalue dynamic-link-marker)
+ (for-each (lambda (continuation)
+ (if (not (continuation/dynamic-link? continuation))
+ (begin
+ (set-continuation/dynamic-link?! continuation true)
+ (for-each (lambda (lvalue)
+ (if (variable-popping-limit lvalue)
+ (force-dynamic-link! lvalue)))
+ (continuation/lvalues continuation)))))
+ (lvalue-values lvalue)))))
+
+(define dynamic-link-marker
+ "dynamic-link")
+
+(define (analyze-continuation block)
+ (let ((lvalue (stack-block/continuation-lvalue block)))
+ (for-each (lambda (continuation)
+ (set-continuation/lvalues!
+ continuation
+ (cons lvalue (continuation/lvalues continuation))))
+ (lvalue-values lvalue))
+ (set-variable-popping-limit!
+ lvalue
+ (if (stack-parent? block)
+ (let ((external (stack-block/external-ancestor block)))
+ (let ((joins (continuation-join-blocks block lvalue external)))
+ (set-block-stack-link! block (adjacent-blocks block lvalue joins))
+ (and (not (null? joins))
+ (null? (cdr joins))
+ (or (car joins) external))))
+ block))))
+\f
+(define (adjacent-blocks block lvalue joins)
+ (let ((parent (block-parent block)))
+ (transmit-values
+ (discriminate-items joins
+ (lambda (join)
+ (or (eq? join block)
+ (eq? join parent))))
+ (lambda (internal external)
+ (cond ((null? internal)
+ ;; The procedure is never invoked as a subproblem.
+ ;; Therefore its ancestor frame and all intermediate
+ ;; frames are always immediately adjacent on the stack.
+ (list parent))
+ ((and (null? external)
+ (null? (cdr internal))
+ ;; Eliminate pathological case of procedure which
+ ;; is always invoked as a subproblem of itself.
+ ;; This can be written but the code can never be
+ ;; invoked.
+ (not (block-ancestor-or-self? (car internal) block)))
+ ;; The procedure is always invoked as a subproblem, and
+ ;; all of the continuations are closed in the same
+ ;; block. Therefore we can reach the ancestor frame by
+ ;; reference to that block.
+ (map continuation/block (lvalue-values lvalue)))
+ (else
+ ;; The relative position of the ancestor frame is not
+ ;; statically determinable.
+ '()))))))
+
+(define (continuation-join-blocks block lvalue external)
+ (let ((ancestry (memq external (block-ancestry block '()))))
+ (let ((blocks
+ (map->eq-set
+ (lambda (block*)
+ (let ((ancestry* (memq external (block-ancestry block* '()))))
+ (and ancestry*
+ (let loop
+ ((ancestry (cdr ancestry))
+ (ancestry* (cdr ancestry*)))
+ (cond ((null? ancestry) block)
+ ((and (not (null? ancestry*))
+ (eq? (car ancestry) (car ancestry*)))
+ (loop (cdr ancestry) (cdr ancestry*)))
+ (else (car ancestry)))))))
+ (map->eq-set continuation/closing-block
+ (lvalue-values lvalue)))))
+ (if (lvalue-passed-in? lvalue)
+ (eq-set-adjoin false blocks)
+ blocks))))
+
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/desenv.scm,v 4.1 1987/12/04 19:27:45 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Environment Design
+
+(declare (usual-integrations))
+\f
+;;;; Frame Layout
+
+#|
+
+Layout of stack frames. The top of each frame is where the frame
+pointer points to, which is the most recently pushed item in the
+frame (i.e. the item closest to the top of stack). There are two
+kinds of frames, depending on what kind of procedure this is.
+
+Open procedure frame:
+
++-------+-------+-------+-------+
+| Auxiliary 1 |
++-------+-------+-------+-------+
+: : :
++-------+-------+-------+-------+
+| Auxiliary M |
++-------+-------+-------+-------+
+| Argument 1 |
++-------+-------+-------+-------+
+: : :
++-------+-------+-------+-------+
+| Argument N |
++-------+-------+-------+-------+
+| Rest Argument | (omitted if none)
++-------+-------+-------+-------+
+| Pointer to parent frame | (omitted if known)
++-------+-------+-------+-------+
+
+Closed procedure frame:
+
++-------+-------+-------+-------+
+| Auxiliary 1 |
++-------+-------+-------+-------+
+: : :
++-------+-------+-------+-------+
+| Auxiliary M |
++-------+-------+-------+-------+
+| Operator | (omitted if not needed)
++-------+-------+-------+-------+
+| Argument 1 |
++-------+-------+-------+-------+
+: : :
++-------+-------+-------+-------+
+| Argument N |
++-------+-------+-------+-------+
+| Rest Argument | (omitted if none)
++-------+-------+-------+-------+
+
+|#
+\f
+(package (design-environment-frames!)
+
+(define-export (design-environment-frames! blocks)
+ (for-each (lambda (block)
+ (enumeration-case block-type (block-type block)
+ ((IC)
+ (if (rvalue/procedure? (block-procedure block))
+ (setup-ic-block-offsets! block)))
+ ((STACK)
+ (delete-integrated-parameters! block)
+ (for-each (lambda (variable)
+ (if (variable-assigned? variable)
+ (set-variable-in-cell?! variable true)))
+ (block-bound-variables block))
+ (setup-stack-block-offsets! block))
+ ((CONTINUATION)
+ (set-block-frame-size!
+ block
+ (continuation/frame-size (block-procedure block))))
+ ((CLOSURE) 'DONE)
+ (else
+ (error "Illegal block type" block))))
+ blocks))
+\f
+(package (delete-integrated-parameters!)
+
+(define-export (delete-integrated-parameters! block)
+ (let ((deletions '())
+ (procedure (block-procedure block)))
+ (if (procedure-interface-optimizible? procedure)
+ (begin
+ (let ((delete-integrations
+ (lambda (get-names set-names!)
+ (transmit-values
+ (find-integrated-variables (get-names procedure))
+ (lambda (not-integrated integrated)
+ (if (not (null? integrated))
+ (begin
+ (set-names! procedure not-integrated)
+ (set! deletions
+ (eq-set-union deletions integrated)))))))))
+ (delete-integrations (lambda (procedure)
+ (cdr (procedure-required procedure)))
+ (lambda (procedure required)
+ (set-cdr! (procedure-required procedure)
+ required)))
+ (delete-integrations procedure-optional set-procedure-optional!))
+ (let ((rest (procedure-rest procedure)))
+ (if (and rest (lvalue-integrated? rest))
+ (begin (set! deletions (eq-set-adjoin deletions rest))
+ (set-procedure-rest! procedure false))))))
+ (transmit-values
+ (find-integrated-bindings (procedure-names procedure)
+ (procedure-values procedure))
+ (lambda (names values integrated)
+ (set-procedure-names! procedure names)
+ (set-procedure-values! procedure values)
+ (set! deletions (eq-set-union deletions integrated))))
+ (if (not (null? deletions))
+ (set-block-bound-variables!
+ block
+ (eq-set-difference (block-bound-variables block) deletions)))))
+\f
+(define (find-integrated-bindings names values)
+ (if (null? names)
+ (return-3 '() '() '())
+ (transmit-values (find-integrated-bindings (cdr names) (cdr values))
+ (lambda (names* values* integrated)
+ (if (lvalue-integrated? (car names))
+ (return-3 names* values* (cons (car names) integrated))
+ (return-3 (cons (car names) names*)
+ (cons (car values) values*)
+ integrated))))))
+
+(define (find-integrated-variables variables)
+ (if (null? variables)
+ (return-2 '() '())
+ (transmit-values (find-integrated-variables (cdr variables))
+ (lambda (not-integrated integrated)
+ (if (lvalue-integrated? (car variables))
+ (return-2 not-integrated
+ (cons (car variables) integrated))
+ (return-2 (cons (car variables) not-integrated)
+ integrated))))))
+
+)
+\f
+(package (setup-ic-block-offsets! setup-stack-block-offsets!)
+
+(define-export (setup-ic-block-offsets! block)
+ (let ((procedure (block-procedure block)))
+ (setup-variable-offsets!
+ (procedure-names procedure)
+ (setup-variable-offset!
+ (procedure-rest procedure)
+ (setup-variable-offsets!
+ (procedure-optional procedure)
+ (setup-variable-offsets! (cdr (procedure-required procedure))
+ ic-block-first-parameter-offset))))))
+
+(define-export (setup-stack-block-offsets! block)
+ (let ((procedure (block-procedure block)))
+ (set-block-frame-size!
+ block
+ (let ((offset
+ (setup-variable-offset!
+ (procedure-rest procedure)
+ (setup-variable-offsets!
+ (procedure-optional procedure)
+ (setup-variable-offsets!
+ (cdr (procedure-required procedure))
+ (let ((offset
+ (setup-variable-offsets! (procedure-names procedure) 0)))
+ (if (and (procedure/closure? procedure)
+ (closure-procedure-needs-operator? procedure))
+ (begin (set-procedure-closure-offset! procedure offset)
+ (1+ offset))
+ offset)))))))
+ (if (or (procedure/closure? procedure)
+ (not (stack-block/static-link? block)))
+ offset
+ (1+ offset))))))
+
+(define (setup-variable-offsets! variables offset)
+ (if (null? variables)
+ offset
+ (begin (set-variable-normal-offset! (car variables) offset)
+ (setup-variable-offsets! (cdr variables) (1+ offset)))))
+
+(define (setup-variable-offset! variable offset)
+ (if variable
+ (begin (set-variable-normal-offset! variable offset)
+ (1+ offset))
+ offset))
+
+)
+
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.1 1987/12/04 19:28:06 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Operator Analysis
+
+(declare (usual-integrations))
+\f
+(package (operator-analysis)
+
+(define-export (operator-analysis procedures applications)
+ (for-each (lambda (procedure)
+ (if (procedure-continuation? procedure)
+ (set-continuation/combinations! procedure '())))
+ procedures)
+ (for-each (lambda (application)
+ (if (eq? (application-type application) 'COMBINATION)
+ (analyze/combination application)))
+ applications)
+ (for-each (lambda (procedure)
+ (if (procedure-continuation? procedure)
+ (set-continuation/passed-out?!
+ procedure
+ (continuation-passed-out? procedure))))
+ procedures)
+ (for-each (lambda (procedure)
+ (set-procedure-always-known-operator?!
+ procedure
+ (if (procedure-continuation? procedure)
+ (analyze/continuation procedure)
+ (analyze/procedure procedure))))
+ procedures))
+
+(define (analyze/combination combination)
+ (for-each (lambda (continuation)
+ (set-continuation/combinations!
+ continuation
+ (cons combination
+ (continuation/combinations continuation))))
+ (rvalue-values (combination/continuation combination))))
+\f
+(define (continuation-passed-out? continuation)
+ (there-exists? (continuation/combinations continuation)
+ (lambda (combination)
+ (and (not (combination/inline? combination))
+ (there-exists? (rvalue-values (combination/operator combination))
+ (lambda (rvalue) (not (rvalue/procedure? rvalue))))))))
+
+(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)))))))
+
+(define (analyze/procedure procedure)
+ (and (not (procedure-passed-out? procedure))
+ (let ((combinations (procedure-applications procedure)))
+ (and (not (null? combinations))
+ (for-all? combinations
+ (lambda (combination)
+ (eq? (rvalue-known-value (combination/operator combination))
+ procedure)))))))
+
+;;; end OPERATOR-ANALYSIS
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.1 1987/12/04 19:28:12 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Argument Ordering Analysis
+
+(declare (usual-integrations))
+\f
+(package (subproblem-ordering)
+
+(define-export (subproblem-ordering parallels)
+ (for-each (lambda (parallel)
+ (let ((previous-edges (node-previous-edges parallel))
+ (next-edge (snode-next-edge parallel)))
+ (let ((rest
+ (or (edge-next-node next-edge)
+ (error "PARALLEL node missing next" parallel))))
+ (edges-disconnect-right! previous-edges)
+ (edge-disconnect! next-edge)
+ (edges-connect-right!
+ previous-edges
+ (parallel-replacement-node parallel rest)))))
+ parallels))
+
+(define (parallel-replacement-node parallel rest)
+ (transmit-values
+ (order-subproblems/application (parallel-application-node parallel)
+ (parallel-subproblems parallel))
+ (lambda (subproblems suffix)
+ (linearize-subproblems subproblems (scfg*node->node! suffix rest)))))
+
+(define (linearize-subproblems subproblems rest)
+ (let loop ((subproblems subproblems))
+ (if (null? subproblems)
+ rest
+ (linearize-subproblem (car subproblems)
+ (loop (cdr subproblems))))))
+
+(define (linearize-subproblem subproblem rest)
+ (let ((continuation (subproblem-continuation subproblem))
+ (prefix (subproblem-prefix subproblem)))
+ (if (subproblem-canonical? subproblem)
+ (begin
+ (if (continuation/entry-node continuation)
+ (error "Attempt to reattach continuation body"
+ continuation))
+ (set-continuation/entry-node! continuation rest)
+ (cfg-entry-node prefix))
+ (scfg*node->node!
+ prefix
+ (scfg*node->node!
+ (if (eq? continuation-type/effect
+ (virtual-continuation/type continuation))
+ (make-null-cfg)
+ (make-virtual-return continuation
+ (subproblem-rvalue subproblem)))
+ rest)))))
+\f
+(define (order-subproblems/application application subproblems)
+ (case (application-type application)
+ ((COMBINATION)
+ (if (combination/inline? application)
+ (order-subproblems/combination/inline application subproblems)
+ (return-2 (order-subproblems/combination/out-of-line application
+ subproblems)
+ (make-null-cfg))))
+ ((RETURN)
+ (set-subproblem-types! subproblems continuation-type/effect)
+ (return-2 subproblems (make-null-cfg)))
+ (else
+ (error "Unknown application type" application))))
+
+(define (order-subproblems/combination/inline combination subproblems)
+ (let ((inliner (combination/inliner combination)))
+ (let ((operands
+ (list-filter-indices (cdr subproblems) (inliner/operands inliner))))
+ (set-inliner/operands! inliner (map subproblem-continuation operands))
+ (order-subproblems/inline (car subproblems) operands))))
+
+(define (order-subproblems/inline operator operands)
+ (set-subproblem-type! operator continuation-type/effect)
+ (transmit-values (discriminate-items operands subproblem-simple?)
+ (lambda (simple complex)
+ (if (null? complex)
+ (begin
+ (set-subproblem-types! simple continuation-type/value)
+ (return-2 (cons operator operands) (make-null-cfg)))
+ (let ((push-set (cdr complex))
+ (value-set (cons (car complex) simple)))
+ (set-subproblem-types! push-set continuation-type/push)
+ (set-subproblem-types! value-set continuation-type/register)
+ (return-2 (cons operator (append! push-set value-set))
+ (scfg*->scfg!
+ (reverse!
+ (map (lambda (subproblem)
+ (make-pop (subproblem-continuation subproblem)))
+ push-set)))))))))
+\f
+(define (order-subproblems/combination/out-of-line combination subproblems)
+ (let ((subproblems
+ (order-subproblems/out-of-line
+ (combination/block combination)
+ (car subproblems)
+ (cdr subproblems)
+ (rvalue-known-value (combination/operator combination)))))
+ (set-combination/frame-size!
+ combination
+ (let loop ((subproblems subproblems) (accumulator 0))
+ (if (null? subproblems)
+ accumulator
+ (loop (cdr subproblems)
+ (if (eq? (subproblem-type (car subproblems))
+ continuation-type/push)
+ (1+ accumulator)
+ accumulator)))))
+ subproblems))
+
+(define (order-subproblems/out-of-line block operator operands callee)
+ (set-subproblem-type! operator (operator-type (subproblem-rvalue operator)))
+ (if (and callee
+ (rvalue/procedure? callee)
+ (procedure/open? callee))
+ (generate/static-link
+ block
+ callee
+ (if (procedure-interface-optimizible? callee)
+ (optimized-combination-ordering block operator operands callee)
+ (standard-combination-ordering operator operands)))
+ (standard-combination-ordering operator operands)))
+\f
+(define (optimized-combination-ordering block operator operands callee)
+ (transmit-values (sort-subproblems/out-of-line operands callee)
+ (lambda (prefix integrated non-integrated)
+ (set-subproblem-types! integrated continuation-type/effect)
+ (set-subproblem-types! non-integrated continuation-type/push)
+ (push-unassigned block
+ prefix
+ (append! integrated non-integrated (list operator))))))
+
+(define (standard-combination-ordering operator operands)
+ (set-subproblem-types! operands continuation-type/push)
+ (reverse (cons operator operands)))
+
+(define (generate/static-link block procedure rest)
+ (if (stack-block/static-link? (procedure-block procedure))
+ (cons (make-push block (block-parent (procedure-block procedure))) rest)
+ rest))
+
+(define (push-unassigned block n rest)
+ (let ((unassigned (make-constant (scode/make-unassigned-object))))
+ (let loop ((n n) (rest rest))
+ (if (zero? n)
+ rest
+ (loop (-1+ n)
+ (cons (make-push block unassigned) rest))))))
+
+(define (make-push block rvalue)
+ (make-subproblem (make-null-cfg)
+ (virtual-continuation/make block continuation-type/push)
+ rvalue))
+
+(define (set-subproblem-types! subproblems type)
+ (for-each (lambda (subproblem)
+ (set-subproblem-type! subproblem type))
+ subproblems))
+\f
+(define (sort-subproblems/out-of-line subproblems callee)
+ (transmit-values
+ (sort-integrated (procedure-original-required callee)
+ subproblems
+ '()
+ '())
+ (lambda (required subproblems integrated non-integrated)
+ (if (null? required)
+ (transmit-values
+ (sort-integrated (procedure-original-optional callee)
+ subproblems
+ integrated
+ non-integrated)
+ (lambda (optional subproblems integrated non-integrated)
+ (let ((rest (procedure-original-rest callee)))
+ (cond ((not (null? optional))
+ (return-3 (if rest
+ 0
+ ;; In this case the caller will
+ ;; make slots for the optionals.
+ (length optional))
+ integrated
+ non-integrated))
+ ((and rest (lvalue-integrated? rest))
+ (return-3 0
+ (append! (reverse subproblems) integrated)
+ non-integrated))
+ (else
+ (return-3 0
+ integrated
+ (append! (reverse subproblems)
+ non-integrated)))))))
+ ;; This is a wrong number of arguments case, so the code
+ ;; we generate will not be any good.
+ (return-3 0 integrated non-integrated)))))
+
+(define (sort-integrated lvalues subproblems integrated non-integrated)
+ (cond ((or (null? lvalues) (null? subproblems))
+ (return-4 lvalues subproblems integrated non-integrated))
+ ((lvalue-integrated? (car lvalues))
+ (sort-integrated (cdr lvalues)
+ (cdr subproblems)
+ (cons (car subproblems) integrated)
+ non-integrated))
+ (else
+ (sort-integrated (cdr lvalues)
+ (cdr subproblems)
+ integrated
+ (cons (car subproblems) non-integrated)))))
+\f
+(define (operator-type operator)
+ (let ((callee (rvalue-known-value operator)))
+ (cond ((not callee)
+ (if (reference? operator)
+ continuation-type/effect
+ continuation-type/apply))
+ ((rvalue/constant? callee)
+ (if (normal-primitive-procedure? (constant-value callee))
+ continuation-type/effect
+ continuation-type/apply))
+ ((rvalue/procedure? callee)
+ (case (procedure/type callee)
+ ((OPEN-EXTERNAL OPEN-INTERNAL) continuation-type/effect)
+ ((CLOSURE) continuation-type/push)
+ ((IC) continuation-type/apply)
+ (else (error "Unknown procedure type" callee))))
+ (else
+ continuation-type/apply))))
+
+(define-integrable continuation-type/apply
+ continuation-type/push)
+
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simple.scm,v 4.1 1987/12/04 19:28:21 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Argument Simplicity Analysis
+
+(declare (usual-integrations))
+\f
+(package (simplicity-analysis)
+
+(define-export (simplicity-analysis parallels)
+ (for-each (lambda (parallel)
+ (for-each (lambda (subproblem)
+ (set-subproblem-simple?! subproblem 'UNKNOWN))
+ (parallel-subproblems parallel)))
+ parallels)
+ (for-each (lambda (parallel)
+ (if (let ((application (parallel-application-node parallel)))
+ (and application
+ (application/combination? application)
+ (combination/inline? application)))
+ (for-each %subproblem-simple?
+ (parallel-subproblems parallel))))
+ parallels))
+
+(define (%subproblem-simple? subproblem)
+ (let ((simple? (subproblem-simple? subproblem)))
+ (if (eq? simple? 'UNKNOWN)
+ (let ((simple?
+ (and (rvalue-simple? (subproblem-rvalue subproblem))
+ (or (not (subproblem-canonical? subproblem))
+ (node-simple? (subproblem-entry-node subproblem)
+ (subproblem-continuation subproblem))))))
+ (set-subproblem-simple?! subproblem simple?)
+ simple?)
+ simple?)))
+
+(define (node-simple? node continuation)
+ ((cfg-node-case (tagged-vector/tag node)
+ ((PARALLEL) parallel-simple?)
+ ((APPLICATION)
+ (case (application-type node)
+ ((COMBINATION) combination-simple?)
+ ((RETURN) return-simple?)
+ (else (error "Unknown application type" node))))
+ ((VIRTUAL-RETURN) virtual-return-simple?)
+ ((ASSIGNMENT) assignment-simple?)
+ ((DEFINITION) definition-simple?)
+ ((TRUE-TEST) true-test-simple?)
+ ((FG-NOOP) fg-noop-simple?))
+ node continuation))
+\f
+(define (parallel-simple? parallel continuation)
+ (and (for-all? (parallel-subproblems parallel) %subproblem-simple?)
+ (node-simple? (snode-next parallel) continuation)))
+
+(define (combination-simple? combination continuation)
+ (and (combination/inline? combination)
+ (continuation-simple? (combination/continuation combination)
+ continuation)))
+
+(define (return-simple? return continuation)
+ (continuation-simple? (return/operator return) continuation))
+
+(define (virtual-return-simple? return continuation)
+ (continuation-simple? (virtual-return-operator return) continuation))
+
+(define (continuation-simple? rvalue continuation)
+ (or (eq? rvalue continuation)
+ (and (rvalue/continuation? rvalue)
+ (node-simple? (continuation/entry-node rvalue) continuation))))
+
+(define (assignment-simple? assignment continuation)
+ (and (lvalue-simple? (assignment-lvalue assignment))
+ (rvalue-simple? (assignment-rvalue assignment))
+ (node-simple? (snode-next assignment) continuation)))
+
+(define (definition-simple? definition continuation)
+ (and (lvalue-simple? (definition-lvalue definition))
+ (rvalue-simple? (definition-rvalue definition))
+ (node-simple? (snode-next definition) continuation)))
+
+(define (true-test-simple? true-test continuation)
+ (and (rvalue-simple? (true-test-rvalue true-test))
+ (node-simple? (pnode-consequent true-test) continuation)
+ (node-simple? (pnode-alternative true-test) continuation)))
+
+(define (fg-noop-simple? fg-noop continuation)
+ (node-simple? (snode-next fg-noop) continuation))
+
+(define (rvalue-simple? rvalue)
+ (or (not (rvalue/reference? rvalue))
+ (let ((lvalue (reference-lvalue rvalue)))
+ (or (lvalue-known-value lvalue)
+ (lvalue-simple? lvalue)))))
+
+(define (lvalue-simple? lvalue)
+ (not (block-passed-out? (variable-block lvalue))))
+
+)
\ No newline at end of file
projects / mit-scheme.git / commitdiff