--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/refctx.scm,v 1.1 1988/12/12 21:32:12 cph Rel $
+
+Copyright (c) 1988 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. |#
+
+;;;; Reference Contexts
+
+(declare (usual-integrations))
+\f
+;;; In general, generating code for variable (and block) references
+;;; requires only two pieces of knowledge: the block in which the
+;;; reference occurs, and the block being referenced (in the case of
+;;; variables, the latter is the block in which the variable is
+;;; bound). Usually the location of the parent of a given block is
+;;; precisely known, e.g. as a stack offset from that block, and in
+;;; cases where different locations are possible, an explicit static
+;;; link is used to provide that location.
+
+;;; In the case where static links are normally used, it is sometimes
+;;; possible to bypass a static link for a particular reference: this
+;;; because the knowledge of the reference's position within the
+;;; program's control structure implies that the parent block is in a
+;;; known location. In other words, even though that parent block can
+;;; have several different locations relative to its child, from that
+;;; particular place in the program only one of those locations is
+;;; possible.
+
+;;; Reference contexts are a mechanism to capture this kind of control
+;;; structure dependent knowledge. Basically, every point in the flow
+;;; graph that does some kind of environment reference keeps a pointer
+;;; to a reference context. These reference contexts can be
+;;; independently changed to annotate interesting facts.
+
+(define reference-context-tag
+ ;; This tag is used to prevent `define-structure' from redefining
+ ;; the variable `reference-context'.
+ "reference-context")
+
+(define-structure (reference-context
+ (named reference-context-tag)
+ (constructor make-reference-context (block))
+ (conc-name reference-context/))
+ (block false read-only true)
+ (offset false)
+ (adjacent-parents '()))
+
+(define-integrable (reference-context/procedure context)
+ (block-procedure (reference-context/block context)))
+
+(define-integrable (reference-context/adjacent-parent? context block)
+ (memq block (reference-context/adjacent-parents context)))
+
+(define (add-reference-context/adjacent-parents! context blocks)
+ (set-reference-context/adjacent-parents!
+ context
+ (eq-set-union blocks (reference-context/adjacent-parents context))))
+
+#|
+(define (node/reference-context node)
+ (cfg-node-case (tagged-vector/tag node)
+ ((APPLICATION) (application-context node))
+ ((VIRTUAL-RETURN) (virtual-return-context node))
+ ((ASSIGNMENT) (assignment-context node))
+ ((DEFINITION) (definition-context node))
+ ((STACK-OVERWRITE) (stack-overwrite-context node))
+ ((TRUE-TEST) (true-test-context node))
+ ((PARALLEL POP FG-NOOP) false)))
+|#
+\f
+;;; Once the FG graph has been constructed, this procedure will walk
+;;; over it and install reference contexts in all the right places.
+;;; It will also guarantee that all of the rvalues associated with a
+;;; particular CFG node have the same context as the node. This means
+;;; that subsequently it is only necessary to walk over the CFG nodes
+;;; and modify their contexts.
+
+(define (initialize-reference-contexts! expression procedures)
+ (with-new-node-marks
+ (lambda ()
+ (initialize-contexts/node (expression-entry-node expression))
+ (for-each (lambda (procedure)
+ (initialize-contexts/next (procedure-entry-node procedure)))
+ procedures))))
+
+(define (initialize-contexts/next node)
+ (if (and node (not (node-marked? node)))
+ (initialize-contexts/node node)))
+
+(define (initialize-contexts/node node)
+ (node-mark! node)
+ (cfg-node-case (tagged-vector/tag node)
+ ((PARALLEL)
+ (initialize-contexts/parallel node)
+ (initialize-contexts/next (snode-next node)))
+ ((APPLICATION)
+ (initialize-contexts/application node)
+ (initialize-contexts/next (snode-next node)))
+ ((VIRTUAL-RETURN)
+ (initialize-contexts/virtual-return node)
+ (initialize-contexts/next (snode-next node)))
+ ((ASSIGNMENT)
+ (initialize-contexts/assignment node)
+ (initialize-contexts/next (snode-next node)))
+ ((DEFINITION)
+ (initialize-contexts/definition node)
+ (initialize-contexts/next (snode-next node)))
+ ((STACK-OVERWRITE)
+ (initialize-contexts/stack-overwrite node)
+ (initialize-contexts/next (snode-next node)))
+ ((POP FG-NOOP)
+ (initialize-contexts/next (snode-next node)))
+ ((TRUE-TEST)
+ (initialize-contexts/true-test node)
+ (initialize-contexts/next (pnode-consequent node))
+ (initialize-contexts/next (pnode-alternative node)))))
+\f
+(define (initialize-contexts/parallel parallel)
+ (for-each
+ (lambda (subproblem)
+ (let ((prefix (subproblem-prefix subproblem)))
+ (if (not (cfg-null? prefix))
+ (initialize-contexts/next (cfg-entry-node prefix))))
+ (if (subproblem-canonical? subproblem)
+ (initialize-contexts/reference (subproblem-rvalue subproblem))
+ (let* ((continuation (subproblem-continuation subproblem))
+ (old (virtual-continuation/context continuation))
+ (new (guarantee-context old)))
+ (if new
+ (begin
+ (set-virtual-continuation/context! continuation new)
+ (initialize-contexts/rvalue
+ old new
+ (subproblem-rvalue subproblem)))))))
+ (parallel-subproblems parallel)))
+
+(define (initialize-contexts/application application)
+ (let* ((old (application-context application))
+ (new (guarantee-context old)))
+ (if new
+ (begin
+ (set-application-context! application new)
+ (if (application/return? application)
+ (begin
+ (initialize-contexts/rvalue old new
+ (application-operator application))
+ (for-each (lambda (operand)
+ (initialize-contexts/rvalue old new operand))
+ (application-operands application)))))))
+ unspecific)
+
+(define (initialize-contexts/virtual-return return)
+ (let* ((old (virtual-return-context return))
+ (new (guarantee-context old)))
+ (if new
+ (begin
+ (set-virtual-return-context! return new)
+ (initialize-contexts/rvalue old new (virtual-return-operand return))
+ (let ((continuation (virtual-return-operator return)))
+ (if (virtual-continuation/reified? continuation)
+ (initialize-contexts/rvalue
+ old
+ new
+ (virtual-continuation/reification continuation))
+ (guarantee-context! old new continuation
+ virtual-continuation/context
+ set-virtual-continuation/context!)))))))
+\f
+(define (initialize-contexts/assignment assignment)
+ (let* ((old (assignment-context assignment))
+ (new (guarantee-context old)))
+ (if new
+ (begin
+ (set-assignment-context! assignment new)
+ (initialize-contexts/rvalue old new
+ (assignment-rvalue assignment))))))
+
+(define (initialize-contexts/definition assignment)
+ (let* ((old (definition-context assignment))
+ (new (guarantee-context old)))
+ (if new
+ (begin
+ (set-definition-context! assignment new)
+ (initialize-contexts/rvalue old new
+ (definition-rvalue assignment))))))
+
+(define (initialize-contexts/stack-overwrite assignment)
+ (let* ((old (stack-overwrite-context assignment))
+ (new (guarantee-context old)))
+ (if new
+ (set-stack-overwrite-context! assignment new)))
+ unspecific)
+
+(define (initialize-contexts/true-test true-test)
+ (let* ((old (true-test-context true-test))
+ (new (guarantee-context old)))
+ (if new
+ (begin
+ (set-true-test-context! true-test new)
+ (initialize-contexts/rvalue old new (true-test-rvalue true-test))))))
+
+(define (initialize-contexts/rvalue old new rvalue)
+ (enumeration-case rvalue-type (tagged-vector/index rvalue)
+ ((REFERENCE)
+ (if (variable/value-variable? (reference-lvalue rvalue))
+ (initialize-contexts/reference rvalue)
+ (guarantee-context! old new rvalue
+ reference-context set-reference-context!)))
+ ((UNASSIGNED-TEST)
+ (guarantee-context! old new rvalue
+ unassigned-test-context set-unassigned-test-context!))
+ ((PROCEDURE)
+ (let ((context (procedure-closure-context rvalue)))
+ (cond ((reference? context)
+ (initialize-contexts/reference context))
+#|
+ ;; Unnecessary because no procedures have closure
+ ;; contexts when initialize-contexts is run.
+ ((block? context)
+ (guarantee-context! old new rvalue
+ procedure-closure-context
+ set-procedure-closure-context!))
+|#
+ )))))
+
+(define (initialize-contexts/reference rvalue)
+ (set-reference-context! rvalue
+ (make-reference-context (reference-context rvalue))))
+
+(define-integrable (guarantee-context! old new object context set-context!)
+ (guarantee-context!/check-old old (context object))
+ (set-context! object new)
+ unspecific)
+
+(define (guarantee-context!/check-old old context)
+ (if (not (eq? old context))
+ (error "Reference context mismatch" old context)))
+
+(define (guarantee-context old)
+ (and (block? old)
+ (make-reference-context old)))
+\f
+(define (modify-reference-contexts! node limit modification)
+ (with-new-node-marks
+ (lambda ()
+ (if limit (node-mark! limit))
+ (modify-contexts/node modification node))))
+
+(define (modify-contexts/node modification node)
+ (node-mark! node)
+ (cfg-node-case (tagged-vector/tag node)
+ ((PARALLEL)
+ (for-each
+ (lambda (subproblem)
+ (let ((prefix (subproblem-prefix subproblem)))
+ (if (not (cfg-null? prefix))
+ (modify-contexts/next modification (cfg-entry-node prefix))))
+ (if (not (subproblem-canonical? subproblem))
+ (modification
+ (virtual-continuation/context
+ (subproblem-continuation subproblem)))))
+ (parallel-subproblems node))
+ (modify-contexts/next modification (snode-next node)))
+ ((APPLICATION)
+ (modification (application-context node))
+ (modify-contexts/operator modification (application-operator node))
+ (modify-contexts/next modification (snode-next node)))
+ ((VIRTUAL-RETURN)
+ (modification (virtual-return-context node))
+ (let ((continuation (virtual-return-operator node)))
+ (if (virtual-continuation/reified? continuation)
+ (modify-contexts/operator
+ modification
+ (virtual-continuation/reification continuation))
+ (modification (virtual-continuation/context continuation))))
+ (modify-contexts/next modification (snode-next node)))
+ ((ASSIGNMENT)
+ (modification (assignment-context node))
+ (modify-contexts/next modification (snode-next node)))
+ ((DEFINITION)
+ (modification (definition-context node))
+ (modify-contexts/next modification (snode-next node)))
+ ((STACK-OVERWRITE)
+ (modification (stack-overwrite-context node))
+ (modify-contexts/next modification (snode-next node)))
+ ((POP FG-NOOP)
+ (modify-contexts/next modification (snode-next node)))
+ ((TRUE-TEST)
+ (modification (true-test-context node))
+ (modify-contexts/next modification (pnode-consequent node))
+ (modify-contexts/next modification (pnode-alternative node)))))
+
+(define (modify-contexts/operator modification rvalue)
+ (let ((value (rvalue-known-value rvalue)))
+ (if (and value (rvalue/procedure? value))
+ (modify-contexts/next modification (procedure-entry-node value)))))
+
+(define (modify-contexts/next modification node)
+ (if (and node (not (node-marked? node)))
+ (modify-contexts/node modification node)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reord.scm,v 1.1 1988/12/12 21:33:00 cph Rel $
+
+Copyright (c) 1988 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. |#
+
+;;;; Parallel assignment problem
+
+(declare (usual-integrations))
+\f
+#|
+
+Reordering algorithm for operands in tail recursive combinations. The
+problem is NP-hard, so the solution below is not optimal, but it does
+pretty well.
+
+The program below solves the 1-4 vars case optimally, and does an
+almost perfect job on 5 (it loses in less than 2% of the cases). The
+behavior of the program is conceptually quadratic, but since lists are
+used to represent the adjacency matrix (rather than bit strings), it
+could perform cubically if the matrix was dense. In practice, the
+matrix is often very sparse, so quadratic is a better expectation of
+performance.
+
+The program below is guaranteed to find an ordering which requires no
+temporaries if one exists. Thus if the reordering found requires none
+or one temporary, it is an optimal solution.
+
+The algorithm is a greedy algorithm:
+
+- It chooses a variable on which no others depend first, it then
+removes it from the graph. This guarantees the optimality when no
+temporaries are needed.
+
+- If there are none, it chooses a variable according to a set of
+heuristics, and removes it from the graph. The collection of
+heuristics has been found (empirically) to be complete for n = 3 or 4,
+and to do fairly well for n = 5. All of the heuristics choose one of
+the nodes with the highest degree (most dependencies + dependents)
+giving preference to dependencies, dependents, or balance.
+
+Note that "self-loops" (edges from a variable to itself) are
+eliminated at the outset, since they don't have any effect on the
+number of assignments of any ordering.
+
+|#
+\f
+;;;; Graph Abstraction
+
+(define-structure (node
+ (constructor make-node
+ (target
+ value
+ original-dependencies
+ original-dependents)))
+ ;; An assignment representing a target variable (or static link) and
+ ;; an expression which will be assigned to the target.
+ (target false read-only true)
+ (value false read-only true)
+
+ ;; The set of assignments on whose targets the value of this
+ ;; assignment depends.
+ original-dependencies
+
+ ;; The set of assignments whose values depend on this assignment's
+ ;; target.
+ original-dependents
+
+ ;; Copies of the above; modified during the reordering algorithm.
+ (dependencies (list-copy original-dependencies))
+ (dependents (list-copy original-dependents)))
+
+(define (make-node-set targets values dependency-sets)
+ (map (lambda (target value dependencies)
+ (make-node target
+ value
+ dependencies
+ (let loop
+ ((targets targets)
+ (dependency-sets dependency-sets))
+ (cond ((null? targets)
+ '())
+ ;; Why no self-dependents?
+ ((and (not (eq? target (car targets)))
+ (memq target (car dependency-sets)))
+ (cons (car targets)
+ (loop (cdr targets)
+ (cdr dependency-sets))))
+ (else
+ (loop (cdr targets)
+ (cdr dependency-sets)))))))
+ targets
+ values
+ dependency-sets))
+
+(define-integrable (copy-node-set nodes)
+ (map node-copy nodes))
+
+(define (node-copy node)
+ (make-node (node-target node)
+ (node-value node)
+ (node-original-dependencies node)
+ (node-original-dependents node)))
+\f
+;;;; Reordering
+
+(define (reorder-assignments nodes)
+ ;; Optimize trivial cases
+ (let ((n-nodes (length nodes)))
+ (case n-nodes
+ ((0 1)
+ nodes)
+ ((2)
+ (if (zero? (add-up-cost nodes))
+ nodes
+ (reverse nodes)))
+ ((3)
+ (reorder! nodes find-index-most/dependencies))
+ (else
+ (let loop ((heuristics heuristics) (nodes nodes) (cost n-nodes))
+ (if (null? heuristics)
+ nodes
+ (let* ((nodes* (reorder! (copy-node-set nodes) (car heuristics)))
+ (cost* (add-up-cost nodes*)))
+ (cond ((< cost* 2) nodes*)
+ ((< cost* cost) (loop (cdr heuristics) nodes* cost*))
+ (else (loop (cdr heuristics) nodes cost))))))))))
+
+(define (add-up-cost nodes)
+ (if (null? nodes)
+ 0
+ (let loop ((nodes nodes) (cost 0))
+ (if (null? (cdr nodes))
+ cost
+ (loop (cdr nodes)
+ (if (first-node-needs-temporary? nodes) (1+ cost) cost))))))
+
+(define (first-node-needs-temporary? nodes)
+ (there-exists? (cdr nodes)
+ (let ((target (node-target (car nodes))))
+ (lambda (node)
+ (memq target (node-original-dependencies node))))))
+
+(define (reorder! nodes find-index)
+ ;; This is expensive. It could be done for all at once,
+ ;; but for now...
+ (let ((nodes (list->vector nodes)))
+ (let ((last (-1+ (vector-length nodes))))
+ (let loop ((index 0))
+ (if (< index last)
+ (begin
+ (let* ((i (find-index nodes index last))
+ (node (vector-ref nodes i))
+ (target (node-target node)))
+ (let loop ((low index))
+ (if (<= low last)
+ (begin
+ (let ((node* (vector-ref nodes low)))
+ (if (not (eq? node* node))
+ (begin
+ (set-node-dependencies!
+ node*
+ (delq! target (node-dependencies node*)))
+ (set-node-dependents!
+ node*
+ (delq! target (node-dependents node*))))))
+ (loop (1+ low)))))
+ (vector-set! nodes i (vector-ref nodes index))
+ (vector-set! nodes index node))
+ (loop (1+ index))))))
+ (vector->list nodes)))
+\f
+;;;; Heuristics
+
+(define (find-index-maker decision)
+ (lambda (nodes low high)
+ (let ((node (vector-ref nodes low)))
+ (if (null? (node-dependents node))
+ low
+ (let loop
+ ((i (1+ low))
+ (index low)
+ (dependencies (length (node-dependencies node)))
+ (dependents (length (node-dependents node))))
+ (if (> i high)
+ index
+ (let ((node (vector-ref nodes i)))
+ (if (null? (node-dependents node))
+ i
+ (let ((dependencies* (length (node-dependencies node)))
+ (dependents* (length (node-dependents node))))
+ (if (decision dependencies dependents
+ dependencies* dependents*)
+ (loop (1+ i) i dependencies* dependents*)
+ (loop (1+ i)
+ index dependencies dependents)))))))))))
+
+#|
+
+;;; This version chooses the node with the most dependencies.
+;;; Among equals it gives preference to those with the most total.
+
+(define find-index-most-dependencies
+ (find-index-maker
+ (lambda (dependencies dependents dependencies* dependents*)
+ (if (= dependencies* dependencies)
+ (> dependents* dependents)
+ (> dependencies* dependencies)))))
+
+;;; This version chooses the node with the most dependents.
+;;; Among equals it gives preference to those with the most total.
+
+(define find-index-most-dependents
+ (find-index-maker
+ (lambda (dependencies dependents dependencies* dependents*)
+ (if (= dependents* dependents)
+ (> dependencies* dependencies)
+ (> dependents* dependents)))))
+
+|#
+\f
+;;; This version chooses the node with the most total edges.
+;;; Among equals it gives preference to those with an approximately
+;;; equal number of dependencies and dependents.
+
+(define find-index-most/balanced
+ (find-index-maker
+ (lambda (dependencies dependents dependencies* dependents*)
+ (let ((total (+ dependencies dependents))
+ (total* (+ dependencies* dependents*)))
+ (if (= total* total)
+ (< (abs (- dependencies* dependents*))
+ (abs (- dependencies dependents)))
+ (> total* total))))))
+
+;;; This version chooses the node with the most total edges.
+;;; Among equals it gives preference to those with the most
+;;; dependencies.
+
+(define find-index-most/dependencies
+ (find-index-maker
+ (lambda (dependencies dependents dependencies* dependents*)
+ (let ((total (+ dependencies dependents))
+ (total* (+ dependencies* dependents*)))
+ (if (= total* total)
+ (> dependencies* dependencies)
+ (> total* total))))))
+
+;;; This version chooses the node with the most total edges.
+;;; Among equals it gives preference to those with the most
+;;; dependents.
+
+(define find-index-most/dependents
+ (find-index-maker
+ (lambda (dependencies dependents dependencies* dependents*)
+ (let ((total (+ dependencies dependents))
+ (total* (+ dependencies* dependents*)))
+ (if (= total* total)
+ (> dependents* dependents)
+ (> total* total))))))
+
+;;; The following two are like the two above but have preference to
+;;; the right rather than the left.
+
+(define find-index-most/dependencies-
+ (find-index-maker
+ (lambda (dependencies dependents dependencies* dependents*)
+ (let ((total (+ dependencies dependents))
+ (total* (+ dependencies* dependents*)))
+ (if (= total* total)
+ (>= dependencies* dependencies)
+ (> total* total))))))
+
+(define find-index-most/dependents-
+ (find-index-maker
+ (lambda (dependencies dependents dependencies* dependents*)
+ (let ((total (+ dependencies dependents))
+ (total* (+ dependencies* dependents*)))
+ (if (= total* total)
+ (>= dependents* dependents)
+ (> total* total))))))
+
+(define heuristics
+ (list find-index-most/dependencies
+ find-index-most/dependents
+ find-index-most/dependencies-
+ find-index-most/dependents-
+ find-index-most/balanced))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.1 1988/12/12 21:32:29 cph Exp $
+
+Copyright (c) 1988 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. |#
+
+;;;; Reduction Combinations: Frame Reuse
+
+(declare (usual-integrations))
+\f
+(define (setup-frame-adjustments applications)
+ (for-each
+ (lambda (combination)
+ (if (application/combination? combination)
+ (set-combination/frame-adjustment!
+ combination
+ (let ((block (combination/block combination)))
+ (let ((adjustment
+ (let ((callee (combination/model combination)))
+ (let ((callee-internal?
+ (and callee
+ (rvalue/procedure? callee)
+ (procedure/open-internal? callee)))
+ (caller (block-procedure block)))
+ (and (not (combination/inline? combination))
+ (return-operator/reduction?
+ (combination/continuation combination))
+ (rvalue/procedure? caller)
+ (not (procedure/ic? caller))
+ (cond ((procedure/external? caller)
+ (and (not callee-internal?) block))
+ (callee-internal?
+ (let ((block* (procedure-block callee)))
+ (and (not (block-child? block block*))
+ (block-farthest-uncommon-ancestor
+ block
+ (block-parent block*)))))
+ (else
+ (stack-block/external-ancestor block))))))))
+ (and adjustment
+ (if (for-all? (block-popping-limits block)
+ (lambda (limit)
+ (block-ancestor-or-self? adjustment limit)))
+ (cons 'KNOWN adjustment)
+ (let ((limit (block-popping-limit block)))
+ (if limit
+ (cons 'KNOWN
+ (if (block-ancestor? adjustment limit)
+ adjustment
+ limit))
+ (cons 'UNKNOWN adjustment))))))))))
+ applications))
+
+(define (order-subproblems/maybe-overwrite-block combination subproblems rest
+ if-no-overwrite)
+ (let ((caller-block (combination/block combination))
+ ;; This reduces code size.
+ (if-no-overwrite (lambda () (if-no-overwrite))))
+ (let ((overwritten-block
+ (let ((adjustment (combination/frame-adjustment combination)))
+ (and adjustment
+ (eq? (car adjustment) 'KNOWN)
+ (cdr adjustment)))))
+ (if overwritten-block
+ (with-values
+ (lambda ()
+ (subproblems->nodes subproblems
+ caller-block
+ overwritten-block))
+ (lambda (terminal-nodes non-terminal-nodes extra-subproblems)
+ (if (< (length non-terminal-nodes) reuse-size-limit)
+ (begin
+ (set-combination/reuse-existing-frame?! combination
+ overwritten-block)
+ (linearize-subproblems!
+ continuation-type/push
+ extra-subproblems
+ (order-subproblems/overwrite-block caller-block
+ overwritten-block
+ terminal-nodes
+ non-terminal-nodes
+ rest)))
+ (if-no-overwrite))))
+ (if-no-overwrite)))))
+
+(define reuse-size-limit 7)
+\f
+(define (subproblems->nodes subproblems caller-block overwritten-block)
+ (with-values
+ (lambda ()
+ (let ((n-subproblems (length subproblems)))
+ (let ((targets
+ (overwritten-objects caller-block
+ overwritten-block
+ n-subproblems)))
+ (let ((n-targets (length targets))
+ (make-nodes
+ (lambda (subproblems)
+ ;; The subproblems are given to us in pushing order.
+ (let ((subproblems (reverse subproblems)))
+ (make-node-set
+ targets
+ subproblems
+ (map (subproblem/dependency-set targets
+ overwritten-block)
+ subproblems))))))
+ (if (< n-targets n-subproblems)
+ (values (make-nodes (list-head subproblems n-targets))
+ (list-tail subproblems n-targets))
+ (values (make-nodes subproblems) '()))))))
+ (lambda (nodes extra-subproblems)
+ (with-values
+ (lambda ()
+ (discriminate-items nodes
+ (lambda (node)
+ (let ((dependents (node-original-dependents node)))
+ (or (null? dependents)
+ (and (null? (cdr dependents))
+ (eq? (node-target (car dependents))
+ (node-target node))))))))
+ (lambda (terminal-nodes non-terminal-nodes)
+ (values terminal-nodes non-terminal-nodes extra-subproblems))))))
+
+(define (overwritten-objects caller-block overwritten-block overwriting-size)
+ (let ((stack-layout
+ (let loop ((block caller-block))
+ (if (eq? block overwritten-block)
+ (block-layout block)
+ (append! (block-layout block) (loop (block-parent block)))))))
+ (let ((n-items (length stack-layout)))
+ (if (< overwriting-size n-items)
+ (list-tail stack-layout (- n-items overwriting-size))
+ stack-layout))))
+
+(define (block-layout block)
+ ;; When representing static links or closures in the result, we use
+ ;; `block' rather than its parent, because it simplifies locating
+ ;; the parent pointer on the stack.
+ (let ((procedure (block-procedure block)))
+ (append
+ (procedure-names procedure)
+ (if (and (procedure/closure? procedure)
+ (closure-procedure-needs-operator? procedure))
+ (list block)
+ '())
+ (cdr (procedure-required procedure))
+ (procedure-optional procedure)
+ (if (procedure-rest procedure) (list (procedure-rest procedure)) '())
+ (if (and (not (procedure/closure? procedure))
+ (stack-block/static-link? block))
+ (list block)
+ '()))))
+\f
+(define (subproblem/dependency-set targets overwritten-block)
+ (let ((block (and (memq overwritten-block targets) overwritten-block)))
+ (if (not block)
+ (lambda (subproblem)
+ (list-transform-positive (subproblem-free-variables subproblem)
+ (lambda (variable)
+ (memq variable targets))))
+ (lambda (subproblem)
+ (let loop
+ ((variables (subproblem-free-variables subproblem))
+ (dependencies '())
+ (block-dependency false))
+ (cond ((null? variables)
+ (if (or block-dependency
+ (let ((rvalue (subproblem-rvalue subproblem)))
+ (and (rvalue/block? rvalue)
+ (block-ancestor? block rvalue))))
+ (cons block dependencies)
+ dependencies))
+ ((memq (car variables) targets)
+ (loop (cdr variables)
+ (cons (car variables) dependencies)
+ block-dependency))
+ (else
+ (loop (cdr variables)
+ dependencies
+ (or block-dependency
+ (block-dependency? block (car variables)))))))))))
+
+(define (block-dependency? block variable)
+ (let ((definition-block (variable-block variable)))
+ (if (ic-block? definition-block)
+ (and (not (ic-block/use-lookup? definition-block))
+ (block-ancestor? block definition-block))
+ (let ((value (lvalue-known-value variable)))
+ (or (and value
+ (rvalue/procedure? value)
+ (procedure/closure? value)
+ (eq? value (block-procedure block)))
+ (block-ancestor? block definition-block)
+ (let loop ((block block))
+ (if (closure-block? block)
+ (memq variable (block-bound-variables block))
+ (let ((parent (block-parent block)))
+ (and parent (loop parent))))))))))\f
+(define (order-subproblems/overwrite-block caller-block
+ overwritten-block
+ terminal-nodes
+ non-terminal-nodes
+ rest)
+ (let ((node
+ (trivial-assignments
+ terminal-nodes
+ (generate-assignments (reorder-assignments non-terminal-nodes)
+ rest))))
+ (if (not (eq? caller-block overwritten-block))
+ (modify-reference-contexts! node rest
+ (let ((blocks
+ (block-partial-ancestry caller-block overwritten-block)))
+ (lambda (context)
+ (add-reference-context/adjacent-parents! context blocks)))))
+ node))
+
+(define (generate-assignments nodes rest)
+ (cond ((null? nodes)
+ rest)
+ ((first-node-needs-temporary? nodes)
+ (linearize-subproblem!
+ (if (for-all? (cdr nodes)
+ (lambda (node)
+ (subproblem-simple? (node-value node))))
+ continuation-type/register
+ continuation-type/push)
+ (node-value (car nodes))
+ (generate-assignments (cdr nodes)
+ (overwrite (car nodes) rest))))
+ (else
+ (trivial-assignment (car nodes)
+ (generate-assignments (cdr nodes) rest)))))
+
+(define (trivial-assignments nodes rest)
+ (let loop ((nodes nodes))
+ (if (null? nodes)
+ rest
+ (trivial-assignment (car nodes) (loop (cdr nodes))))))
+
+(define (trivial-assignment node rest)
+ (if (node/noop? node)
+ rest
+ (linearize-subproblem! continuation-type/register
+ (node-value node)
+ (overwrite node rest))))
+
+(define (node/noop? node)
+ (let ((target (node-target node))
+ (subproblem (node-value node)))
+ (and (cfg-null? (subproblem-prefix subproblem))
+ (let ((rvalue (subproblem-rvalue subproblem)))
+ (cond ((rvalue/reference? rvalue)
+ (let ((variable (reference-lvalue rvalue)))
+ (and (eq? target variable)
+ (not (variable-in-cell? variable)))))
+ ((rvalue/block? rvalue)
+ (and (block? target)
+ (eq? (block-parent target) rvalue)))
+ (else false))))))
+
+(define (overwrite node rest)
+ (let ((subproblem (node-value node)))
+ (scfg*node->node!
+ (make-stack-overwrite (subproblem-context subproblem)
+ (node-target node)
+ (subproblem-continuation subproblem))
+ rest)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/subfre.scm,v 1.1 1988/12/12 21:32:46 cph Exp $
+
+Copyright (c) 1988 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. |#
+
+;;;; Subproblem Free Variables
+
+(declare (usual-integrations))
+\f
+(define (compute-subproblem-free-variables parallels)
+ (for-each (lambda (parallel)
+ (for-each (lambda (subproblem)
+ (set-subproblem-free-variables! subproblem 'UNKNOWN))
+ (parallel-subproblems parallel)))
+ parallels)
+ (for-each (lambda (parallel)
+ (for-each walk-subproblem (parallel-subproblems parallel)))
+ parallels))
+
+(define (new-subproblem/compute-free-variables! subproblem)
+ (walk-subproblem subproblem))
+
+(define (walk-subproblem subproblem)
+ (let ((free (subproblem-free-variables subproblem)))
+ (if (eq? free 'UNKNOWN)
+ (let ((free
+ (let ((free (walk-rvalue (subproblem-rvalue subproblem))))
+ (if (subproblem-canonical? subproblem)
+ (eq-set-union
+ free
+ (walk-node (subproblem-entry-node subproblem)))
+ free))))
+ (set-subproblem-free-variables! subproblem free)
+ free)
+ free)))
+
+(define (walk-next next free)
+ (if next
+ (eq-set-union (walk-node next) free)
+ free))
+
+(define (walk-node node)
+ (cfg-node-case (tagged-vector/tag node)
+ ((PARALLEL)
+ (walk-next (snode-next node)
+ (map-union walk-subproblem (parallel-subproblems node))))
+ ((APPLICATION)
+ (walk-next
+ (snode-next node)
+ (eq-set-union (walk-rvalue (application-operator node))
+ (map-union walk-rvalue (application-operands node)))))
+ ((VIRTUAL-RETURN)
+ (walk-next
+ (snode-next node)
+ (let ((operator (virtual-return-operator node))
+ (free (walk-rvalue (virtual-return-operand node))))
+ (cond ((not (virtual-continuation? operator))
+ (eq-set-union (walk-rvalue operator) free))
+ ((virtual-continuation/reified? operator)
+ (eq-set-union
+ (walk-rvalue (virtual-continuation/reification operator))
+ free))
+ (else free)))))
+ ((ASSIGNMENT)
+ (walk-next
+ (snode-next node)
+ (eq-set-union (walk-lvalue (assignment-lvalue node))
+ (walk-rvalue (assignment-rvalue node)))))
+ ((DEFINITION)
+ (walk-next
+ (snode-next node)
+ (eq-set-union (walk-lvalue (definition-lvalue node))
+ (walk-rvalue (definition-rvalue node)))))
+ ((TRUE-TEST)
+ (walk-next (pnode-consequent node)
+ (walk-next (pnode-alternative node)
+ (walk-rvalue (true-test-rvalue node)))))
+ ((FG-NOOP)
+ (walk-next (snode-next node) '()))))
+\f
+(define (map-union procedure items)
+ (let loop ((items items) (set '()))
+ (if (null? items)
+ set
+ (loop (cdr items)
+ (eq-set-union (procedure (car items)) set)))))
+
+(define (walk-rvalue rvalue)
+ (enumeration-case rvalue-type (tagged-vector/index rvalue)
+ ((REFERENCE) (walk-lvalue (reference-lvalue rvalue)))
+ ((PROCEDURE)
+ (if (procedure-continuation? rvalue)
+ (walk-next (continuation/entry-node rvalue) '())
+ (list-transform-negative
+ (block-free-variables (procedure-block rvalue))
+ lvalue-integrated?)))
+ (else '())))
+
+(define (walk-lvalue lvalue)
+ (let ((value (lvalue-known-value lvalue)))
+ (cond ((not value) (list lvalue))
+ ((lvalue-integrated? lvalue) (walk-rvalue value))
+ (else (eq-set-adjoin lvalue (walk-rvalue value))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.1 1988/12/12 21:33:15 cph Exp $
+
+Copyright (c) 1988 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. |#
+
+;;;; RTL Generation: Variable Locatives
+
+(declare (usual-integrations))
+\f
+(define (find-variable context variable if-compiler if-ic if-cached)
+ (if (variable/value-variable? variable)
+ (if-compiler
+ (let ((continuation (reference-context/procedure context)))
+ (if (continuation/ever-known-operator? continuation)
+ (continuation/register continuation)
+ register:value)))
+ (find-variable-internal context variable
+ (lambda (locative)
+ (if-compiler
+ (if (variable-in-cell? variable)
+ (rtl:make-fetch locative)
+ locative)))
+ (lambda (block locative)
+ (cond ((variable-in-known-location? context variable)
+ (if-compiler
+ (rtl:locative-offset locative
+ (variable-offset block variable))))
+ ((ic-block/use-lookup? block)
+ (if-ic locative (variable-name variable)))
+ (else
+ (if-cached (variable-name variable))))))))
+
+(define (find-known-variable context variable)
+ (find-variable context variable identity-procedure
+ (lambda (environment name)
+ environment
+ (error "Known variable found in IC frame" name))
+ (lambda (name)
+ (error "Known variable found in IC frame" name))))
+
+(define (find-closure-variable context variable)
+ (find-variable-internal context variable
+ identity-procedure
+ (lambda (block locative)
+ block locative
+ (error "Closure variable in IC frame" variable))))
+
+(define (find-variable-internal context variable if-compiler if-ic)
+ (let ((rvalue (lvalue-known-value variable)))
+ (if (and rvalue
+ (rvalue/procedure? rvalue)
+ (procedure/closure? rvalue)
+ (block-ancestor-or-self? (reference-context/block context)
+ (procedure-block rvalue)))
+ (begin
+ ;; This is just for paranoia.
+ (if (procedure/trivial-closure? rvalue)
+ (error "Trivial closure value encountered"))
+ (if-compiler
+ (block-ancestor-or-self->locative
+ context
+ (procedure-block rvalue)
+ 0
+ (procedure-closure-offset rvalue))))
+ (find-block/variable context variable
+ (lambda (offset-locative)
+ (lambda (block locative)
+ (if-compiler
+ (offset-locative locative (variable-offset block variable)))))
+ if-ic))))
+\f
+(define (find-definition-variable context lvalue)
+ (find-block/variable context lvalue
+ (lambda (offset-locative)
+ offset-locative
+ (lambda (block locative)
+ block locative
+ (error "Definition of compiled variable" lvalue)))
+ (lambda (block locative)
+ block
+ (values locative (variable-name lvalue)))))
+
+(define (find-block/variable context variable if-known if-ic)
+ (with-values
+ (lambda ()
+ (find-block context
+ 0
+ (lambda (block)
+ (if (not block)
+ (error "Unable to find variable" variable))
+ (or (memq variable (block-bound-variables block))
+ (and (not (block-parent block))
+ (memq variable
+ (block-free-variables block)))))))
+ (lambda (block locative)
+ ((enumeration-case block-type (block-type block)
+ ((STACK) (if-known stack-locative-offset))
+ ((CLOSURE) (if-known rtl:locative-offset))
+ ((IC) if-ic)
+ (else (error "Illegal result type" block)))
+ block locative))))
+
+(define (nearest-ic-block-expression context)
+ (with-values
+ (lambda ()
+ (find-block context 0 (lambda (block) (not (block-parent block)))))
+ (lambda (block locative)
+ (if (not (ic-block? block))
+ (error "NEAREST-IC-BLOCK-EXPRESSION: No IC block"))
+ locative)))
+
+(define (closure-ic-locative context block)
+ (with-values
+ (lambda ()
+ (find-block context 0 (lambda (block*) (eq? block* block))))
+ (lambda (block locative)
+ (if (not (ic-block? block))
+ (error "Closure parent not IC block"))
+ locative)))
+
+(define (block-ancestor-or-self->locative context block prefix suffix)
+ (stack-locative-offset
+ (with-values
+ (lambda ()
+ (find-block context prefix (lambda (block*) (eq? block* block))))
+ (lambda (block* locative)
+ (if (not (eq? block* block))
+ (error "Block is not an ancestor" context block))
+ locative))
+ suffix))
+
+(define (popping-limit/locative context block prefix suffix)
+ (rtl:make-address
+ (block-ancestor-or-self->locative context
+ block
+ prefix
+ (+ (block-frame-size block) suffix))))
+
+(define (block-closure-locative context)
+ ;; BLOCK must be the invocation block of a closure.
+ (stack-locative-offset
+ (rtl:make-fetch register:stack-pointer)
+ (+ (procedure-closure-offset (reference-context/procedure context))
+ (reference-context/offset context))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff