#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.7 1989/08/21 19:30:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.8 1989/10/26 07:34:56 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
(*pending-bblocks* '()))
(for-each (lambda (edge)
(if (not (node-marked? (edge-right-node edge)))
- (cgen-entry edge)))
+ (cgen-entry rgraph edge)))
(rgraph-entry-edges rgraph))
(if (not (null? *pending-bblocks*))
(error "CGEN-RGRAPH: pending blocks left at end of pass"))))
\f
-(define (cgen-entry edge)
+(define (cgen-entry rgraph edge)
(define (loop bblock map)
(cgen-bblock bblock map)
(if (sblock? bblock)
(let ((next (edge-next-node edge)))
(if (and next (not (node-marked? next)))
(let ((previous (node-previous-edges next)))
- (cond ((not (for-all? previous edge-left-node))
+ (cond ((for-all? previous
+ (lambda (edge)
+ (memq edge (rgraph-entry-edges rgraph))))
;; Assumption: no action needed to clear existing
;; register map at this point.
(loop next (empty-register-map)))
- ((null? (cdr previous))
+ ((and (null? (cdr previous))
+ (edge-left-node (car previous)))
(loop
next
(let ((previous (edge-left-node edge)))
(loop)))))))
(define (adjust-maps-at-merge! bblock)
- (let ((edges (node-previous-edges bblock))) (let ((maps
+ (let ((edges
+ (list-transform-positive (node-previous-edges bblock)
+ edge-left-node)))
+ (let ((maps
(map
(let ((live-registers (bblock-live-at-entry bblock)))
(lambda (edge)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.10 1989/07/25 12:42:02 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.11 1989/10/26 07:35:00 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
(set! *register-map* map)
(prefix-instructions! instructions)))))
\f
-(define (standard-register-reference register preferred-type)
+(define (standard-register-reference register preferred-type alternate-types?)
;; Generate a standard reference for `register'. This procedure
;; uses a number of heuristics, aided by `preferred-type', to
;; determine the optimum reference. This should be used only when
;; the reference need not have any special properties, as the result
;; is not even guaranteed to be a register reference.
- (let ((no-preference
- (lambda ()
- ;; Next, attempt to find an alias of any type. If there
- ;; are no aliases, and the register is not dead, allocate
- ;; an alias of the preferred type. This is desirable
- ;; because the register will be used again. Otherwise,
- ;; this is the last use of this register, so we might as
- ;; well just use the register's home.
- (let ((alias (register-alias register false)))
- (cond (alias
- (register-reference alias))
- ((dead-register? register)
- (pseudo-register-home register))
- (else
- (reference-alias-register! register preferred-type)))))))
- (cond ((machine-register? register)
- (register-reference register))
+ (if (machine-register? register)
+ (if alternate-types?
+ (register-reference register)
+ (machine-register-reference register preferred-type))
+ (let ((no-reuse-possible
+ (lambda ()
+ ;; If there are no aliases, and the register is not dead,
+ ;; allocate an alias of the preferred type. This is
+ ;; desirable because the register will be used again.
+ ;; Otherwise, this is the last use of this register, so we
+ ;; might as well just use the register's home.
+ (if (and (dead-register? register)
+ (register-saved-into-home? register))
+ (pseudo-register-home register)
+ (reference-alias-register! register preferred-type)))))
+ (let ((no-preference
+ (lambda ()
+ ;; Next, attempt to find an alias of any type.
+ (let ((alias (register-alias register false)))
+ (if alias
+ (register-reference alias)
+ (no-reuse-possible))))))
;; First, attempt to find an alias of the preferred type.
- (preferred-type
- (let ((alias (register-alias register preferred-type)))
- (if alias
- (register-reference alias)
- (no-preference))))
- (else
- (no-preference)))))
+ (if preferred-type
+ (let ((alias (register-alias register preferred-type)))
+ (cond (alias (register-reference alias))
+ (alternate-types? (no-preference))
+ (else (no-reuse-possible))))
+ (no-preference))))))
(define (machine-register-reference register type)
;; Returns a reference to a machine register which contains the same
temp))
(load-alias-register! register type))))
-(define (float-register-reference register)
- (register-reference
- (if (machine-register? register)
- register
- (load-alias-register! register 'FLOAT))))
-
(define (load-machine-register! source-register machine-register)
(if (machine-register? source-register)
(if (eqv? source-register machine-register)
(if (is-alias-for-register? machine-register source-register)
(LAP)
(reference->register-transfer
- (standard-register-reference source-register false)
+ (standard-register-reference source-register false true)
machine-register))))
\f
(define (move-to-alias-register! source type target)
(delete-dead-registers!)
(if-reusable alias))
(lambda ()
- (let ((source (standard-register-reference source false))) (delete-dead-registers!)
+ (let ((source (standard-register-reference source false true)))
+ (delete-dead-registers!)
(if-not source)))))
(define (reuse-pseudo-register-alias! source type if-reusable if-not)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.7 1988/11/06 14:50:00 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.8 1989/10/26 07:35:04 cph Exp $
Copyright (c) 1987, 1988 Massachusetts Institute of Technology
(node-mark! bblock)
(queue-continuations! bblock)
(if (and (not (bblock-label bblock))
- (let ((edges (node-previous-edges bblock)))
- (and (not (null? edges))
- (not (null? (cdr edges)))))) (bblock-label! bblock))
+ (node-previous>1? bblock))
+ (bblock-label! bblock))
(let ((kernel
(lambda ()
(LAP ,@(bblock-instructions bblock)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.23 1989/04/15 18:04:59 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.24 1989/10/26 07:35:06 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
\f
(define (integer-syntaxer expression coercion-type size)
(let ((name (make-coercion-name coercion-type size)))
- (if (integer? expression)
+ (if (exact-integer? expression)
`',((lookup-coercion name) expression)
`(SYNTAX-EVALUATION ,expression ,name))))
(define (syntax-evaluation expression coercion)
- (if (integer? expression)
+ (if (exact-integer? expression)
(coercion expression)
`(EVALUATION ,expression ,(coercion-size coercion) ,coercion)))
(choose-clause value (cdr clauses))))
(define (variable-width-expression-syntaxer name expression clauses)
- (if (integer? expression)
+ (if (exact-integer? expression)
(let ((chosen (choose-clause expression clauses)))
`(LET ((,name ,expression))
(DECLARE (INTEGRATE ,name))
clauses)))))
(define (syntax-variable-width-expression expression clauses)
- (if (integer? expression) (let ((chosen (choose-clause expression clauses)))
+ (if (exact-integer? expression)
+ (let ((chosen (choose-clause expression clauses)))
(car ((car chosen) expression)))
`(VARIABLE-WIDTH-EXPRESSION
,expression
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.11 1989/08/10 11:05:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.12 1989/10/26 07:35:27 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
closure-offsets ;for closure block, alist of bound variable offsets
debugging-info ;dbg-block, if used
stack-link ;for stack block, adjacent block on stack
+ static-link? ;for stack block, true iff static link to parent
popping-limits ;for stack block (see continuation analysis)
popping-limit ;for stack block (see continuation analysis)
layout-frozen? ;used by frame reuse to tell parameter
(procedure block)
(for-each loop (block-children block))))
-(define-integrable (internal-block/parent-known? block)
- (block-stack-link block))
-
-(define (stack-block/static-link? block)
- (and (not (null? (block-free-variables block)))
- (let ((parent (block-parent block)))
- (and parent
- (cond ((stack-block? parent)
- (not (internal-block/parent-known? block)))
- ((ic-block? parent)
- (ic-block/use-lookup? parent))
- (else true))))))
+(define-integrable (stack-block/static-link? block)
+ (block-static-link? block))
+
(define-integrable (stack-block/continuation-lvalue block)
(procedure-continuation-lvalue (block-procedure block)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 4.3 1987/12/31 10:01:31 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 4.4 1989/10/26 07:35:30 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (delete-node-previous-edge! node edge)
(set-node-previous-edges! node (delq! edge (node-previous-edges node))))
-\f
-;;;; Edge Datatype
-
-(define-structure (edge (type vector)) left-node left-connect right-node)
-
-(define (edge-next-node edge)
- (and edge (edge-right-node edge)))
(define-integrable (snode-next snode)
(edge-next-node (snode-next-edge snode)))
(define-integrable (pnode-alternative pnode)
(edge-next-node (pnode-alternative-edge pnode)))
+(define (cfg-node-get node key)
+ (let ((entry (assq key (node-alist node))))
+ (and entry
+ (cdr entry))))
+
+(define (cfg-node-put! node key item)
+ (let ((entry (assq key (node-alist node))))
+ (if entry
+ (set-cdr! entry item)
+ (set-node-alist! node (cons (cons key item) (node-alist node))))))
+
+(define (cfg-node-remove! node key)
+ (set-node-alist! node (del-assq! key (node-alist node))))
+\f
+;;;; Edge Datatype
+
+(define-structure (edge (type vector))
+ left-node
+ left-connect
+ right-node)
+
(define (create-edge! left-node left-connect right-node)
(let ((edge (make-edge left-node left-connect right-node)))
(if left-node
(add-node-previous-edge! right-node edge))
edge))
+(define-integrable (node->edge node)
+ (create-edge! false false node))
+
+(define (edge-next-node edge)
+ (and edge (edge-right-node edge)))
+
(define (edge-connect-left! edge left-node left-connect)
(if (edge-left-node edge)
(error "Attempt to doubly connect left node of edge" edge))
(begin
(set-edge-right-node! edge right-node)
(add-node-previous-edge! right-node edge))))
-\f
+
(define (edge-disconnect-left! edge)
(let ((left-node (edge-left-node edge))
(left-connect (edge-left-connect edge)))
(set-edge-right-node! edge false)
(delete-node-previous-edge! right-node edge)))))
-(define (edges-connect-right! edges right-node)
- (for-each (lambda (edge) (edge-connect-right! edge right-node)) edges))
-
(define (edge-disconnect! edge)
(edge-disconnect-left! edge)
(edge-disconnect-right! edge))
-(define (edges-disconnect-right! edges)
- (for-each edge-disconnect-right! edges))
-\f
-;;;; Node Properties
+(define (edge-replace-left! edge left-node left-connect)
+ (edge-disconnect-left! edge)
+ (edge-connect-left! edge left-node left-connect))
-(define (cfg-node-get node key)
- (let ((entry (assq key (node-alist node))))
- (and entry
- (cdr entry))))
+(define (edge-replace-right! edge right-node)
+ (edge-disconnect-right! edge)
+ (edge-connect-right! edge right-node))
-(define (cfg-node-put! node key item)
- (let ((entry (assq key (node-alist node))))
- (if entry
- (set-cdr! entry item)
- (set-node-alist! node (cons (cons key item) (node-alist node))))))
+(define (edges-connect-right! edges right-node)
+ (for-each (lambda (edge) (edge-connect-right! edge right-node)) edges))
-(define (cfg-node-remove! node key)
- (set-node-alist! node (del-assq! key (node-alist node))))
\ No newline at end of file
+(define (edges-disconnect-right! edges)
+ (for-each edge-disconnect-right! edges))
+
+(define (edges-replace-right! edges right-node)
+ (for-each (lambda (edge) (edge-replace-right! edge right-node)) edges))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 4.2 1987/12/30 06:58:00 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 4.3 1989/10/26 07:35:34 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;;; Editing
(define (snode-delete! snode)
- (let ((previous-edges (node-previous-edges snode))
- (next-edge (snode-next-edge snode)))
+ (let ((next-edge (snode-next-edge snode)))
(if next-edge
- (let ((node (edge-right-node next-edge)))
- (edges-disconnect-right! previous-edges)
- (edge-disconnect! next-edge)
- (edges-connect-right! previous-edges node))
- (edges-disconnect-right! previous-edges))))
+ (begin
+ (edges-replace-right! (node-previous-edges snode)
+ (edge-right-node next-edge))
+ (edge-disconnect! next-edge))
+ (edges-disconnect-right! (node-previous-edges snode)))))
(define (edge-insert-snode! edge snode)
(let ((next (edge-right-node edge)))
- (edge-disconnect-right! edge)
- (edge-connect-right! edge snode)
+ (edge-replace-right! edge snode)
(create-edge! snode set-snode-next-edge! next)))
(define (node-insert-snode! node snode)
- (let ((previous-edges (node-previous-edges node)))
- (edges-disconnect-right! previous-edges)
- (edges-connect-right! previous-edges snode)
- (create-edge! snode set-snode-next-edge! node)))
-
-(define-integrable (node->edge node)
- (create-edge! false false node))
-
-(define-integrable (cfg-entry-edge cfg)
- (node->edge (cfg-entry-node cfg)))\f
+ (edges-replace-right! (node-previous-edges node) snode)
+ (create-edge! snode set-snode-next-edge! node))
+
+(define-integrable (node-disconnect-on-right! node)
+ (edges-disconnect-right! (node-previous-edges node)))
+
+(define (node-disconnect-on-left! node)
+ (if (snode? node)
+ (snode-disconnect-on-left! node)
+ (pnode-disconnect-on-left! node)))
+
+(define (snode-disconnect-on-left! node)
+ (let ((edge (snode-next-edge node)))
+ (if edge
+ (edge-disconnect-left! edge))))
+
+(define (pnode-disconnect-on-left! node)
+ (let ((edge (pnode-consequent-edge node)))
+ (if edge
+ (edge-disconnect-left! edge)))
+ (let ((edge (pnode-alternative-edge node)))
+ (if edge
+ (edge-disconnect-left! edge))))
+
+(define (node-replace! old-node new-node)
+ (if (snode? old-node)
+ (snode-replace! old-node new-node)
+ (pnode-replace! old-node new-node)))
+
+(define (snode-replace! old-node new-node)
+ (node-replace-on-right! old-node new-node)
+ (snode-replace-on-left! old-node new-node))
+
+(define (pnode-replace! old-node new-node)
+ (node-replace-on-right! old-node new-node)
+ (pnode-replace-on-left! old-node new-node))
+
+(define-integrable (node-replace-on-right! old-node new-node)
+ (edges-replace-right! (node-previous-edges old-node) new-node))
+
+(define (node-replace-on-left! old-node new-node)
+ (if (snode? old-node)
+ (snode-replace-on-left! old-node new-node)
+ (pnode-replace-on-left! old-node new-node)))
+
+(define (snode-replace-on-left! old-node new-node)
+ (let ((edge (snode-next-edge old-node)))
+ (if edge
+ (edge-replace-left! edge new-node set-snode-next-edge!))))
+
+(define (pnode-replace-on-left! old-node new-node)
+ (let ((edge (pnode-consequent-edge old-node)))
+ (if edge
+ (edge-replace-left! edge new-node set-pnode-consequent-edge!)))
+ (let ((edge (pnode-alternative-edge old-node)))
+ (if edge
+ (edge-replace-left! edge new-node set-pnode-alternative-edge!))))
+\f
;;;; Previous Connections
(define-integrable (node-previous=0? node)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 4.3 1989/03/28 20:41:57 arthur Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 4.4 1989/10/26 07:35:37 cph Rel $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(vector-ref pcfg 3))
(define-integrable (make-null-cfg) false)
-(define-integrable cfg-null? false?)\f
+(define-integrable cfg-null? false?)
+
+(define-integrable (cfg-entry-edge cfg)
+ (node->edge (cfg-entry-node cfg)))
+\f
(define-integrable (snode->scfg snode)
(node->scfg snode set-snode-next-edge!))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.4 1989/08/21 19:32:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/crstop.scm,v 1.5 1989/10/26 07:35:41 cph Exp $
$MC68020-Header: toplev.scm,v 4.16 89/04/26 05:09:52 GMT cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(if (default-object? info-output-pathname)
(set! info-output-pathname false))
- (fluid-let ((*info-output-pathname*
- (if (and info-output-pathname
- (not (eq? info-output-pathname true)))
- info-output-pathname
- *info-output-pathname*))
+ (fluid-let ((*info-output-filename*
+ (if (pathname? info-output-pathname)
+ (pathname->string info-output-pathname)
+ *info-output-filename*))
(*rtl-output-pathname*
- (if (and rtl-output-pathname
- (not (eq? rtl-output-pathname true))) rtl-output-pathname
+ (if (pathname? rtl-output-pathname)
+ rtl-output-pathname
*rtl-output-pathname*)))
((if (default-object? wrapper)
in-compiler
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.13 1989/08/10 11:05:10 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.14 1989/10/26 07:35:44 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
operand-values ;set by outer-analysis, used by identify-closure-limits
continuation-push
model ;set by identify-closure-limits, used in generation
- destination-block ;used by identify-closure-limits to quench propagation
frame-adjustment ;set by setup-frame-adjustments, used in generation
reuse-existing-frame? ;set by setup-frame-adjustments, used in generation
)
(let ((application
(make-snode application-tag
type block operator operands false '() '()
- continuation-push false true false false)))
+ continuation-push false false false)))
(set! *applications* (cons application *applications*))
(add-block-application! block application)
(if (rvalue/reference? operator)
(define-integrable (combination/operands combination)
(cdr (application-operands combination)))
+(define (combination/simple-inline? combination)
+ (let ((inliner (combination/inliner combination)))
+ (and inliner
+ (not (inliner/internal-close-coding? inliner)))))
+
(define-structure (inliner (type vector) (conc-name inliner/))
(handler false read-only true)
(generator false read-only true)
- operands)
+ operands
+ internal-close-coding?)
\f
(define-integrable (make-return block continuation rvalue)
(make-application 'RETURN block continuation (list rvalue) false))
(define-integrable return/context application-context)
(define-integrable return/operator application-operator)
(define-integrable return/continuation-push application-continuation-push)
+(define-integrable return/equivalence-class application-model)
+(define-integrable set-return/equivalence-class! set-application-model!)
+
(define-integrable (return/operand return)
(car (application-operands return)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.10 1989/08/21 19:32:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.11 1989/10/26 07:35:47 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(compiled-code-address->block object)))
(write-string "\nOffset: ")
(write-string
- (number->string (compiled-code-address->offset object)
- '(HEUR (RADIX X S))))) (else
+ (number->string (compiled-code-address->offset object) 16)))
+ (else
(error "debug/where -- what?" object))))
\f
(define (compiler:write-rtl-file input-path #!optional output-path)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.5 1989/08/21 19:32:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.6 1989/10/26 07:35:51 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(define (variable->dbg-variable variable)
(or (lvalue-get variable dbg-variable-tag)
- (let ((integrated? (lvalue-integrated? variable)))
+ (let ((integrated? (lvalue-integrated? variable))
+ (indirection (variable-indirection variable)))
(let ((dbg-variable
(make-dbg-variable (variable-name variable)
(cond (integrated? 'INTEGRATED)
+ (indirection 'INDIRECTED)
((variable-in-cell? variable) 'CELL)
(else 'NORMAL))
- (and integrated?
- (lvalue-known-value variable))))) (if integrated?
+ (cond (integrated?
+ (lvalue-known-value variable))
+ (indirection
+ (variable->dbg-variable indirection))
+ (else
+ false)))))
+ (if integrated?
(set! *integrated-variables*
(cons dbg-variable *integrated-variables*)))
(lvalue-put! variable dbg-variable-tag dbg-variable)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.15 1989/08/10 11:05:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.16 1989/10/26 07:35:56 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
register ;register for parameters passed in registers
stack-overwrite-target?
;true iff variable is the target of a stack overwrite
+ indirection ;alias for this variable [variable or #f]
)
(define continuation-variable/type variable-in-cell?)
(define (make-variable block name)
(make-lvalue variable-tag block name '() false false '() false false
- false))
+ false false))
(define variable-assoc
(association-procedure eq? variable-name))
(define-named-variable continuation)
(define-named-variable value))
-(define-integrable (variable/register variable)
+(define (variable/register variable)
(let ((maybe-delayed-register (variable-register variable)))
(if (promise? maybe-delayed-register)
(force maybe-delayed-register)
variable
(cons assignment (variable-assignments variable))))
-(define (variable-assigned? variable)
+(define-integrable (variable-assigned? variable)
(not (null? (variable-assignments variable))))
;; Note:
(or (rvalue/constant? value)
(and (rvalue/procedure? value)
(procedure/virtually-open? value))))))
+
+(define (variable-unused? variable)
+ (or (lvalue-integrated? variable)
+ (variable-indirection variable)))
\f
(define (lvalue=? lvalue lvalue*)
(or (eq? lvalue lvalue*)
(define-integrable (lvalue/external-source? lvalue)
;; (number? (lvalue-passed-in? lvalue))
- (and (lvalue-passed-in? lvalue)
- (not (eq? (lvalue-passed-in? lvalue) 'INHERITED))))
+ (let ((passed-in? (lvalue-passed-in? lvalue)))
+ (and passed-in?
+ (not (eq? passed-in? 'INHERITED)))))
(define-integrable (lvalue/internal-source? lvalue)
(not (null? (lvalue-initial-values lvalue))))
;; is the outermost IC block of the expression in
;; which the variable is referenced.
(memq variable
- (block-bound-variables reference-block))))))))
\ No newline at end of file
+ (block-bound-variables reference-block))))))))
+\f
+(define (lvalue/articulation-points lvalue)
+ ;; This won't work if (memq lvalue (lvalue-backward-links lvalue))?
+ (let ((articulation-points '())
+ (number-tag "number-tag"))
+ (let ((articulation-point!
+ (lambda (lvalue)
+ (if (not (memq lvalue articulation-points))
+ (begin
+ (set! articulation-points (cons lvalue articulation-points))
+ unspecific))))
+ (allocate-number!
+ (let ((n 0))
+ (lambda ()
+ (let ((number n))
+ (set! n (1+ n))
+ number)))))
+ (with-new-lvalue-marks
+ (lambda ()
+ (let loop ((lvalue lvalue) (parent false) (number (allocate-number!)))
+ (lvalue-mark! lvalue)
+ (lvalue-put! lvalue number-tag number)
+ (if (lvalue/source? lvalue)
+ number
+ (apply min
+ (cons number
+ (map (lambda (link)
+ (cond ((not (lvalue-marked? link))
+ (let ((low
+ (loop link
+ lvalue
+ (allocate-number!))))
+ (if (<= number low)
+ (articulation-point! lvalue))
+ low))
+ ((eq? link parent)
+ number)
+ (else
+ (lvalue-get link number-tag))))
+ (lvalue-initial-backward-links lvalue)))))))))
+ (set! articulation-points
+ (sort (delq! lvalue articulation-points)
+ (lambda (x y)
+ (< (lvalue-get x number-tag) (lvalue-get y number-tag)))))
+ (for-each (lambda (lvalue) (lvalue-remove! lvalue number-tag))
+ (cons lvalue (lvalue-backward-links lvalue)))
+ articulation-points))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.7 1989/08/10 11:05:19 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.8 1989/10/26 07:36:00 cph Rel $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(vector-tag? (tagged-vector/tag object))))
(define (->tagged-vector object)
- (let ((object (if (integer? object) (unhash object) object))) (and (or (tagged-vector? object)
+ (let ((object
+ (if (exact-nonnegative-integer? object)
+ (unhash object)
+ object)))
+ (and (or (tagged-vector? object)
(named-structure? object))
object)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.14 1989/08/10 11:05:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.15 1989/10/26 07:36:03 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(define-integrable set-procedure-passed-out?!
set-rvalue-%passed-out?!)
-
-(define (close-procedure? procedure)
- (not (eq? (procedure-closing-limit procedure)
- (procedure-closing-block procedure))))
\f
(define-integrable (closure-procedure-needs-operator? procedure)
;; This must be true if the closure needs its parent frame since the
(assq 'TRIVIAL (procedure-properties procedure)))
(define (procedure-inline-code? procedure)
- (or (procedure/trivial? procedure)
- (and (procedure-always-known-operator? procedure)
- (procedure-application-unique? procedure)
- (procedure/virtually-open? procedure))))
+ (and (not (procedure-rest procedure))
+ (or (procedure/trivial? procedure)
+ (and (procedure-always-known-operator? procedure)
+ (procedure-application-unique? procedure)
+ (procedure/virtually-open? procedure)))))
(define-integrable (open-procedure-needs-static-link? procedure)
(stack-block/static-link? (procedure-block procedure)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.21 1989/09/24 03:39:40 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.22 1989/10/26 07:36:07 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(phase/fold-constants)
(phase/open-coding-analysis)
(phase/operator-analysis)
+ (phase/variable-indirection)
(phase/environment-optimization)
(phase/identify-closure-limits)
(phase/setup-block-types) (phase/compute-call-graph)
(phase/side-effect-analysis)
(phase/continuation-analysis)
- (phase/setup-frame-adjustments)
(phase/subproblem-analysis)
(phase/delete-integrated-parameters)
(phase/subproblem-ordering)
(phase/design-environment-frames)
(phase/connectivity-analysis)
(phase/compute-node-offsets)
+ (phase/return-equivalencing)
(phase/info-generation-1)
(phase/fg-optimization-cleanup))))
(lambda ()
(operator-analysis *procedures* *applications*))))
+(define (phase/variable-indirection)
+ (compiler-subphase "Variable Indirection"
+ (lambda ()
+ (initialize-variable-indirections! *lvalues*))))
+
(define (phase/environment-optimization)
(compiler-subphase "Environment Optimization"
(lambda ()
(define (phase/identify-closure-limits)
(compiler-subphase "Closure Limit Identification"
(lambda ()
- (identify-closure-limits! *procedures* *applications* *lvalues*))))
+ (identify-closure-limits! *procedures* *applications* *lvalues*)
+ (if (not compiler:preserve-data-structures?)
+ (for-each (lambda (procedure)
+ (if (not (procedure-continuation? procedure))
+ (begin
+ (set-procedure-free-callees! procedure '())
+ (set-procedure-free-callers! procedure '())
+ (set-procedure-variables! procedure '()))))
+ *procedures*)))))
(define (phase/setup-block-types)
(compiler-subphase "Block Type Determination"
(define (phase/continuation-analysis)
(compiler-subphase "Continuation Analysis"
(lambda ()
- (continuation-analysis *blocks*))))
+ (continuation-analysis *blocks*)
+ (setup-frame-adjustments *applications*)
+ (setup-block-static-links! *blocks*))))
\f
-(define (phase/setup-frame-adjustments)
- (compiler-subphase "Frame Adjustment Determination"
- (lambda ()
- (setup-frame-adjustments *applications*))))
-
(define (phase/subproblem-analysis)
(compiler-subphase "Subproblem Analysis"
(lambda ()
(lambda ()
(compute-node-offsets *root-expression*))))
+(define (phase/return-equivalencing)
+ (compiler-subphase "Return Equivalencing"
+ (lambda ()
+ (find-equivalent-returns! *lvalues* *applications*))))
+
(define (phase/info-generation-1)
(compiler-subphase "Debugging Information Initialization"
(lambda ()
(if compiler:cse?
(phase/common-subexpression-elimination))
(phase/invertible-expression-elimination)
+ (phase/common-suffix-merging)
(phase/lifetime-analysis)
(if compiler:code-compression?
(phase/code-compression))
(compiler-subphase "Invertible Expression Elimination"
(lambda ()
(invertible-expression-elimination *rtl-graphs*))))
-\f(define (phase/lifetime-analysis)
+\f
+(define (phase/common-suffix-merging)
+ (compiler-subphase "Common Suffix Merging"
+ (lambda ()
+ (merge-common-suffixes! *rtl-graphs*))))
+
+(define (phase/lifetime-analysis)
(compiler-subphase "Lifetime Analysis"
(lambda ()
(lifetime-analysis *rtl-graphs*))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.13 1989/08/28 18:33:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.14 1989/10/26 07:36:11 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
((eq? prefix lambda-tag:fluid-let) 'FLUID-LET)
(else prefix)))
"-"
- (number->string (generate-label-number) 10))))
+ (number->string (generate-label-number)))))
(define *current-label-number*)
(scode/primitive-procedure? object)
(eq? object compiled-error-procedure)))
\f
-(define function-names
+(define boolean-valued-function-names
'(
- ;; Predicates
OBJECT-TYPE? EQ? FALSE? NULL? PAIR? VECTOR? SYMBOL? STRING?
- NUMBER? CHAR? PROMISE? BIT-STRING? CELL? CHAR-ASCII?
-
- ;; Numbers
+ NUMBER? CHAR? PROMISE? BIT-STRING? CELL?
COMPLEX? REAL? RATIONAL? INTEGER? EXACT? INEXACT?
ZERO? POSITIVE? NEGATIVE? ODD? EVEN?
- = < > <= >= MAX MIN
- + - * / 1+ -1+ ABS QUOTIENT REMAINDER MODULO INTEGER-DIVIDE
- GCD LCM FLOOR CEILING TRUNCATE ROUND
- EXP LOG EXPT SQRT SIN COS TAN ASIN ACOS ATAN
- FIX:ZERO? FIX:NEGATIVE? FIX:POSITIVE?
- FIX:= FIX:< FIX:> FIX:1+ FIX:-1+ FIX:+ FIX:- FIX:*
- FIX:DIVIDE FIX:GCD FIX:QUOTIENT FIX:REMAINDER
-
- ;; Random
- OBJECT-TYPE NOT ASCII->CHAR CHAR->INTEGER CHAR-BITS CHAR-CODE
- CHAR-DOWNCASE CHAR-UPCASE INTEGER->CHAR MAKE-CHAR
- PRIMITIVE-PROCEDURE-ARITY
-
- ;; References (assumes immediate constants are immutable)
- CAR CDR LENGTH
- VECTOR-REF VECTOR-LENGTH
- STRING-REF STRING-LENGTH STRING-MAXIMUM-LENGTH
- BIT-STRING-REF BIT-STRING-LENGTH
+ = < > <= >=
+ FIX:FIXNUM? FIX:ZERO? FIX:NEGATIVE? FIX:POSITIVE? FIX:= FIX:< FIX:>
+ FLO:FLONUM? FLO:ZERO? FLO:NEGATIVE? FLO:POSITIVE? FLO:= FLO:< FLO:>
+ INT:INTEGER? INT:ZERO? INT:NEGATIVE? INT:POSITIVE? INT:= INT:< INT:>
+ NOT BIT-STRING-REF
))
+(define function-names
+ (append
+ boolean-valued-function-names
+ '(
+ ;; Numbers
+ MAX MIN + - * / 1+ -1+ CONJUGATE ABS QUOTIENT REMAINDER MODULO
+ INTEGER-DIVIDE GCD LCM NUMERATOR DENOMINATOR FLOOR CEILING TRUNCATE ROUND
+ FLOOR->EXACT CEILING->EXACT TRUNCATE->EXACT ROUND->EXACT
+ RATIONALIZE RATIONALIZE->EXACT SIMPLEST-RATIONAL SIMPLEST-EXACT-RATIONAL
+ EXP LOG SIN COS TAN ASIN ACOS ATAN SQRT EXPT MAKE-RECTANGULAR MAKE-POLAR
+ REAL-PART IMAG-PART MAGNITUDE ANGLE EXACT->INEXACT INEXACT->EXACT
+ FIX:1+ FIX:-1+ FIX:+ FIX:- FIX:*
+ FIX:DIVIDE FIX:GCD FIX:QUOTIENT FIX:REMAINDER
+ INT:+ INT:- INT:* INT:DIVIDE INT:QUOTIENT INT:REMAINDER INT:ABS
+ INT:1+ INT:-1+ INT:NEGATE
+ FLO:+ FLO:- FLO:* FLO:/ FLO:NEGATE FLO:ABS FLO:EXP FLO:LOG FLO:SIN FLO:COS
+ FLO:TAN FLO:ASIN FLO:ACOS FLO:ATAN FLO:ATAN2 FLO:SQRT FLO:EXPT FLO:FLOOR
+ FLO:CEILING FLO:TRUNCATE FLO:ROUND FLO:FLOOR->EXACT FLO:CEILING->EXACT
+ FLO:TRUNCATE->EXACT FLO:ROUND->EXACT
+
+ ;; Random
+ OBJECT-TYPE CHAR-ASCII? ASCII->CHAR CHAR->INTEGER CHAR-BITS CHAR-CODE
+ CHAR-DOWNCASE CHAR-UPCASE INTEGER->CHAR MAKE-CHAR
+ PRIMITIVE-PROCEDURE-ARITY
+
+ ;; References (assumes immediate constants are immutable)
+ CAR CDR LENGTH
+ VECTOR-REF VECTOR-LENGTH
+ STRING-REF STRING-LENGTH STRING-MAXIMUM-LENGTH
+ BIT-STRING-LENGTH
+ )))
+
;; The following definition is used to avoid computation if possible.
;; Not to avoid recomputation. To avoid recomputation, function-names
;; should be used.
LIST->VECTOR VECTOR->LIST MAKE-BIT-STRING MAKE-CELL STRING->SYMBOL
))
+(define additional-boolean-valued-function-primitives
+ (list (ucode-primitive zero?)
+ (ucode-primitive positive?)
+ (ucode-primitive negative?)
+ (ucode-primitive &=)
+ (ucode-primitive &<)
+ (ucode-primitive &>)))
+
(define additional-function-primitives
- (list
- (ucode-primitive &+) (ucode-primitive &-)
- (ucode-primitive &*) (ucode-primitive &/)
- (ucode-primitive &<) (ucode-primitive &>)
- (ucode-primitive &=) (ucode-primitive &atan)))
+ (list (ucode-primitive 1+)
+ (ucode-primitive -1+)
+ (ucode-primitive &+)
+ (ucode-primitive &-)
+ (ucode-primitive &*)
+ (ucode-primitive &/)))
\f
;;;; "Foldable" and side-effect-free operators
-(define function-variables
- (map (lambda (name)
- (cons name
- (lexical-reference system-global-environment name)))
- function-names))
+(define boolean-valued-function-variables)
+(define function-variables)
+(define side-effect-free-variables)
+(define boolean-valued-function-primitives)
+(define function-primitives)
+(define side-effect-free-primitives)
+
+(let ((global-valued
+ (lambda (names)
+ (list-transform-negative names
+ (lambda (name)
+ (lexical-unreferenceable? system-global-environment name)))))
+ (global-value
+ (lambda (name)
+ (lexical-reference system-global-environment name)))
+ (primitives
+ (let ((primitive-procedure?
+ (lexical-reference system-global-environment
+ 'PRIMITIVE-PROCEDURE?)))
+ (lambda (procedures)
+ (list-transform-positive procedures primitive-procedure?)))))
+ (let ((names (global-valued boolean-valued-function-names)))
+ (let ((procedures (map global-value names)))
+ (set! boolean-valued-function-variables (map cons names procedures))
+ (set! boolean-valued-function-primitives
+ (append! (primitives procedures)
+ additional-boolean-valued-function-primitives))))
+ (let ((names (global-valued function-names)))
+ (let ((procedures (map global-value names)))
+ (set! function-variables
+ (map* boolean-valued-function-variables cons names procedures))
+ (set! function-primitives
+ (append! (primitives procedures)
+ (append additional-function-primitives
+ boolean-valued-function-primitives)))))
+ (let ((names (global-valued side-effect-free-additional-names)))
+ (let ((procedures (map global-value names)))
+ (set! side-effect-free-variables
+ (map* function-variables cons names procedures))
+ (set! side-effect-free-primitives
+ (append! (primitives procedures)
+ function-primitives))
+ unspecific)))
+
+(define-integrable (boolean-valued-function-variable? name)
+ (assq name boolean-valued-function-variables))
(define-integrable (constant-foldable-variable? name)
(assq name function-variables))
-(define side-effect-free-variables
- (map* function-variables
- (lambda (name)
- (cons name
- (lexical-reference system-global-environment name)))
- side-effect-free-additional-names))
-
(define-integrable (side-effect-free-variable? name)
(assq name side-effect-free-variables))
(and place
(cdr place))))
-(define function-primitives
- (append!
- (list-transform-positive (map cdr function-variables)
- (lexical-reference system-global-environment 'PRIMITIVE-PROCEDURE?))
- additional-function-primitives))
+(define-integrable (boolean-valued-function-primitive? operator)
+ (memq operator boolean-valued-function-primitives))
-(define (constant-foldable-primitive? operator)
+(define-integrable (constant-foldable-primitive? operator)
(memq operator function-primitives))
-(define side-effect-free-primitives
- (append!
- (list-transform-positive (map cdr side-effect-free-variables)
- (lexical-reference system-global-environment 'PRIMITIVE-PROCEDURE?))
- additional-function-primitives))
-
-(define (side-effect-free-primitive? operator) (memq operator side-effect-free-primitives))
+(define-integrable (side-effect-free-primitive? operator)
+ (memq operator side-effect-free-primitives))
(define procedure-object?
(lexical-reference system-global-environment 'PROCEDURE?))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.22 1989/09/20 16:39:24 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.23 1989/10/26 07:36:21 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(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))
+ (with-values
+ (lambda ()
+ (let ((collect
+ (lambda (names declarations body)
+ (values (make-variables block names)
+ declarations
+ (unscan-defines names '() body)))))
+ (if (scode/open-block? scode)
+ (scode/open-block-components scode collect)
+ (scan-defines scode collect))))
(lambda (variables declarations scode)
(set-block-bound-variables! block variables)
(generate/body block continuation declarations scode))))))
(define (generate/disjunction/value 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))))))))
+ (if (and (scode/combination? predicate)
+ (boolean-valued-operator?
+ (scode/combination-operator predicate)))
+ (generate/conditional
+ block
+ continuation
+ (scode/make-conditional predicate true 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 (boolean-valued-operator? operator)
+ (cond ((scode/primitive-procedure? operator)
+ (boolean-valued-function-primitive? operator))
+ ((scode/absolute-reference? operator)
+ (boolean-valued-function-variable?
+ (scode/absolute-reference-name operator)))
+ (else
+ false)))
\f
(define (generate/access block continuation expression)
(scode/access-components expression
;; Enclose directives are generated only for lambda expressions
;; evaluated in environments whose manipulation has been made
-;; explicit. The code should include a syntatic check. The;; expression must be a call to scode-eval with a quotation of a
+;; explicit. The code should include a syntactic check. The
+;; expression must be a call to scode-eval with a quotation of a
;; lambda and a variable as arguments.
;; NOTE: This code depends on lvalue-integrated? never integrating
;; the hidden reference within the procedure object. See base/lvalue
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.12 1989/09/24 03:37:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.13 1989/10/26 07:36:36 cph Exp $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(block-type! block block-type/ic)
(begin
(block-type! block block-type/stack)
- (maybe-close-procedure! block))))
+ (maybe-close-procedure! (block-procedure block)))))
((CONTINUATION)
(for-each loop (block-children block)))
((EXPRESSION)
(loop root-block))
-(define (maybe-close-procedure! block)
- (if (procedure-closure-context (block-procedure block))
- (close-procedure! block)))
-
-(define (close-procedure! block)
- (let ((procedure (block-procedure block))
- (current-parent (block-parent block)))
-
- (define (uninteresting-variable? variable)
- (or (lvalue-integrated? variable)
- ;; Some of this is redundant
- (let ((value (lvalue-known-value variable)))
- (and value
- (or (eq? value procedure)
- (and (rvalue/procedure? value)
- (procedure/trivial-or-virtual? value)))))))
-
- (let ((previously-trivial? (procedure/trivial-closure? procedure))
- (parent (or (procedure-target-block procedure) current-parent)))
- ;; Note: this should be innocuous if there is already a closure block.
- ;; In particular, if there is a closure block which happens to be a
- ;; reference placed there by the first-class environment transformation
- ;; in fggen/fggen and fggen/canon, and it is replaced by the line below,
- ;; the presumpt first-class environment is not really used as one, so
- ;; the procedure is being "demoted" from first-class to closure.
+(define (maybe-close-procedure! procedure)
+ (if (eq? true (procedure-closure-context procedure))
+ (close-procedure! procedure)))
+
+(define (close-procedure! procedure)
+ (let ((block (procedure-block procedure))
+ (previously-trivial? (procedure/trivial-closure? procedure))
+ (original-parent (procedure-target-block procedure)))
+ (let ((parent (block-parent block)))
(set-procedure-closure-context! procedure
- (make-reference-context parent))
+ (make-reference-context original-parent))
(with-values
(lambda ()
- (find-closure-bindings
- parent
- (list-transform-negative (block-free-variables block)
- (lambda (lvalue)
- (or (uninteresting-variable? lvalue)
- (begin
- (set-variable-closed-over?! lvalue true)
- false))))
- '()
- (list-transform-negative (block-variables-nontransitively-free
- block)
- uninteresting-variable?)))
+ (let ((uninteresting-variable?
+ (lambda (variable)
+ (or (lvalue-integrated? variable)
+ (let ((value (lvalue-known-value variable)))
+ (and value
+ (or (eq? value procedure)
+ (and (rvalue/procedure? value)
+ (procedure/trivial-or-virtual?
+ value)))))))))
+ (find-closure-bindings
+ original-parent
+ (list-transform-negative (block-free-variables block)
+ (lambda (lvalue)
+ (or (uninteresting-variable? lvalue)
+ (begin
+ (set-variable-closed-over?! lvalue true)
+ false))))
+ '()
+ (list-transform-negative
+ (block-variables-nontransitively-free block)
+ uninteresting-variable?))))
(lambda (closure-frame-block size)
(set-block-parent! block closure-frame-block)
(set-procedure-closure-size! procedure size)))
- (let ((new (procedure/trivial-closure? procedure)))
- (if (or (and previously-trivial? (not new))
- (and (not previously-trivial?) new))
- (error "close-procedure! trivial becoming non-trivial or viceversa"
- procedure))))
- (disown-block-child! current-parent block)))
+ (if (if previously-trivial?
+ (not (procedure/trivial-closure? procedure))
+ (procedure/trivial-closure? procedure))
+ (error "trivial procedure becoming non-trivial or vice-versa"
+ procedure))
+ (set-block-children! parent (delq! block (block-children parent)))
+ (if (eq? parent original-parent)
+ (set-block-disowned-children!
+ parent
+ (cons block (block-disowned-children parent)))))))
\f
(define (find-closure-bindings block free-variables bound-variables
variables-nontransitively-free)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.9 1989/09/24 03:33:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.10 1989/10/26 07:36:40 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
(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.
-
-**** Unfortunately the analysis is not compatible with the current
-implementation of closures. If a closure invokes another procedure
-which is not a child, the current implementation requires that the
-other procedure also be a closure. However, if the closing-limit of
-the (closed) caller is the same as that of the (open) callee, the
-callee will not be marked as a closure. This has disastrous results.
-As a result, the analysis has been modified to force the closing-limit
-to #F whenever a closure is identified.
-
-|#
-\f
(define (identify-closure-limits! procs&conts applications lvalues)
(let ((procedures
- (list-transform-negative procs&conts procedure-continuation?)))
- (for-each initialize-lvalues-lists! lvalues)
- (for-each initialize-closure-limit! procedures)
- (for-each initialize-arguments! applications)
- (transitive-closure
- (lambda ()
- (for-each (lambda (procedure)
- (if (procedure-passed-out? procedure)
- (maybe-close-procedure! procedure
- false
- 'PASSED-OUT
- false)))
- procedures))
- (lambda (item)
- (if (rvalue/procedure? item)
- (analyze-procedure item)
- (analyze-application item)))
- (append procedures applications))
- ;; Clean up
- (if (not compiler:preserve-data-structures?)
- (for-each (lambda (procedure)
- (set-procedure-free-callees! procedure '())
- (set-procedure-free-callers! procedure '())
- (set-procedure-variables! procedure '()))
- procedures))))
-
-(define (initialize-lvalues-lists! lvalue)
- (if (lvalue/variable? lvalue)
- (for-each (lambda (value)
- (if (rvalue/procedure? value)
- (set-procedure-variables!
- value
- (cons lvalue (procedure-variables value)))))
- (lvalue-values lvalue))))
-
-(define (initialize-closure-limit! procedure)
- (set-procedure-closing-limit! procedure (procedure-closing-block procedure))
- ;; This sorting is crucial! It causes a procedure's ancestors to be
- ;; considered for undrifting prior to the procedure being
- ;; considered. This matters because the decision to undrift a
- ;; procedure can be affected by whether or not the ancestors have
- ;; been undrifted.
- (set-procedure-free-callers!
- procedure
- (sort (procedure-free-callers procedure)
- (lambda (x y)
- (let ((y (procedure-block y))
- (x (procedure-block x)))
- (and (not (eq? y x))
- (original-block-ancestor-or-self? y x)))))))
-
-(define (initialize-arguments! application)
- (if (application/combination? application)
- (begin
- (let ((values
- (let ((operands (application-operands application)))
- (if (null? operands)
- '()
- (eq-set-union* (rvalue-values (car operands))
- (map rvalue-values (cdr operands)))))))
- (set-application-operand-values! application values)
- (for-each
- (lambda (value)
- (if (and (rvalue/procedure? value)
- (not (procedure-continuation? value)))
- (set-procedure-virtual-closure?! value true)))
- values))
- (set-combination/model!
- application
- (rvalue-known-value (combination/operator application))))))
+ (list-transform-negative procs&conts procedure-continuation?))
+ (combinations
+ (list-transform-positive applications application/combination?)))
+ (for-each (lambda (procedure)
+ (set-procedure-variables! procedure '()))
+ procedures)
+ (for-each
+ (lambda (lvalue)
+ (if (lvalue/variable? lvalue)
+ (for-each (lambda (value)
+ (if (rvalue/procedure? value)
+ (set-procedure-variables!
+ value
+ (cons lvalue (procedure-variables value)))))
+ (lvalue-values lvalue))))
+ lvalues)
+ (for-each
+ (lambda (combination)
+ (let ((values
+ (let ((operands (application-operands combination)))
+ (if (null? operands)
+ '()
+ (eq-set-union* (rvalue-values (car operands))
+ (map rvalue-values (cdr operands)))))))
+ (set-application-operand-values! combination values)
+ (for-each
+ (lambda (value)
+ (if (and (rvalue/procedure? value)
+ (not (procedure-continuation? value)))
+ (set-procedure-virtual-closure?! value true)))
+ values))
+ (set-combination/model!
+ combination
+ (rvalue-known-value (combination/operator combination))))
+ combinations)
+ (undrift-procedures!
+ (fluid-let ((*undrifting-constraints* '()))
+ (with-new-node-marks
+ (lambda ()
+ (transitive-closure
+ (lambda ()
+ (for-each (lambda (procedure)
+ (if (procedure-passed-out? procedure)
+ (close-procedure! procedure 'PASSED-OUT false)
+ (analyze-procedure procedure)))
+ procedures))
+ analyze-combination
+ combinations)))
+ *undrifting-constraints*))))
\f
(define (analyze-procedure procedure)
- (for-each (lambda (variable)
- (maybe-close-procedure! procedure
- (variable-block variable)
- 'EXPORTED
- variable))
- (procedure-variables procedure)))
+ (for-each
+ (lambda (variable)
+ ;; If this procedure is the value of a variable which is bound
+ ;; in a non-descendent block, we must close it.
+ (if (not (procedure-closure-context procedure))
+ (close-if-unreachable! (variable-block variable)
+ (procedure-closing-block procedure)
+ procedure
+ 'EXPORTED
+ variable)))
+ (procedure-variables procedure)))
-(define (analyze-application application)
- (let* ((operator (application-operator application))
+(define (analyze-combination combination)
+ (let* ((operator (combination/operator combination))
(proc (rvalue-known-value operator))
(procs (rvalue-values operator)))
- (cond ((not (application/combination? application))
- ;; If the combination is not an application, we need not
- ;; examine the operators for compatibility.
- unspecific)
- ((rvalue-passed-in? operator)
+ (cond ((rvalue-passed-in? operator)
;; We don't need to close the operands because
;; they have been marked as passed out already.
- (close-rvalue! operator 'APPLY-COMPATIBILITY application))
+ (close-rvalue! operator 'APPLY-COMPATIBILITY combination))
((null? procs)
;; The (null? procs) case is the NOP node case. This combination
;; should not be executed, so it should have no effect on any items
((not proc)
(let ((class (compatibility-class procs))
(model (car procs)))
- (set-combination/model! application
+ (set-combination/model! combination
(if (eq? class 'APPLY-COMPATIBILITY)
false
model))
(set-procedure-virtual-closure?! proc true))
procs)
(begin
- (close-rvalue! operator class application)
- (close-application-arguments! application false)))))
+ (close-rvalue! operator class combination)
+ (close-combination-arguments! combination)))))
((or (not (rvalue/procedure? proc))
(procedure-closure-context proc))
- (close-application-arguments! application false))
+ (close-combination-arguments! combination))
(else
unspecific))))
-\f
-(define (close-application-arguments! application block)
- (let ((previous (application-destination-block application)))
- (let ((new
- (if (eq? previous true)
- block
- (and previous
- block
- (block-nearest-common-ancestor block previous)))))
- (if (not (eq? new previous))
- (begin
- (set-application-destination-block! application new)
- (close-values! (application-operand-values application)
- new
- 'ARGUMENT
- application))))))
+
+(define (close-combination-arguments! combination)
+ (if (not (node-marked? combination))
+ (begin
+ (node-mark! combination)
+ (close-values! (application-operand-values combination)
+ 'ARGUMENT
+ combination))))
(define (compatibility-class procs)
(if (not (for-all? procs rvalue/procedure?))
'APPLY-COMPATIBILITY
(let* ((model (car procs))
- (model-env (procedure-closing-limit model)))
+ (model-env (procedure-closing-block model)))
(with-values (lambda () (procedure-arity-encoding model))
(lambda (model-min model-max)
(let loop
(= model-max this-max))
(loop (cdr procs)
(if (and (not (procedure/closure? this))
- (eq? (procedure-closing-limit this)
+ (eq? (procedure-closing-block this)
model-env))
class
'COMPATIBILITY))
'APPLY-COMPATIBILITY)))))))))))
\f
(define-integrable (close-rvalue! rvalue reason1 reason2)
- (close-values! (rvalue-values rvalue) false reason1 reason2))
+ (close-values! (rvalue-values rvalue) reason1 reason2))
-(define (close-values! values binding-block reason1 reason2)
+(define (close-values! values reason1 reason2)
(for-each (lambda (value)
(if (and (rvalue/procedure? value)
(not (procedure-continuation? value)))
- (maybe-close-procedure! value
- binding-block
- reason1
- reason2)))
+ (close-procedure! value reason1 reason2)))
values))
-(define (maybe-close-procedure! procedure binding-block reason1 reason2)
- (let ((closing-limit (procedure-closing-limit procedure)))
- (cond ((not closing-limit)
- (add-closure-reason! procedure reason1 reason2))
- ((not (and binding-block
- (block-ancestor-or-self? binding-block closing-limit)))
- (close-procedure! procedure reason1 reason2)))))
+(define (close-if-unreachable! block block* procedure reason1 reason2)
+ ;; If `block*' is not an ancestor of `block', close `procedure'.
+ (if (not (block-ancestor-or-self? block block*))
+ ;; However, if it was an ancestor before procedure-drifting took
+ ;; place, don't close, just undo the drifting.
+ (if (original-block-ancestor? block block*)
+ (undrifting-constraint! block block* procedure reason1 reason2)
+ (close-procedure! procedure reason1 reason2))))
(define (close-procedure! procedure reason1 reason2)
- (set-procedure-closing-limit! procedure false)
- (if (procedure-virtual-closure? procedure)
- (set-procedure-virtual-closure?! procedure false))
- (let ((previously-trivial? (procedure/trivial-closure? procedure)))
- ;; We can't change the closing block yet. `setup-block-types!'
- ;; has a consistency check that depends on the closing block
- ;; remaining the same.
- (add-closure-reason! procedure reason1 reason2)
- ;; Force the procedure's type to CLOSURE.
- (if (not (procedure-closure-context procedure))
- (set-procedure-closure-context! procedure true))
- ;; The code generator needs all callees to be closed.
- (let ((block (procedure-block procedure)))
- (for-each-callee! block
- (lambda (value)
- (if (not (block-ancestor-or-self? (procedure-block value) block))
- (maybe-close-procedure! value false 'CONTAGION procedure)))))
- ;; The environment optimizer may have moved some procedures in the
- ;; environment tree based on the (now incorrect) assumption that this
- ;; procedure was not closed. Fix this.
- ;; On the other hand, if it was trivial before, it is still trivial
- ;; now, so the callers are not affected.
- (if (not previously-trivial?)
- (examine-free-callers! procedure))
- ;; We need to reexamine those applications which may have this procedure
- ;; as an operator, since the compatibility class of the operator may have
- ;; changed.
- (enqueue-nodes! (procedure-applications procedure))))
+ (add-closure-reason! procedure reason1 reason2)
+ (if (not (procedure-closure-context procedure))
+ (begin
+
+ ;; Force the procedure's type to CLOSURE. Don't change the
+ ;; closing block yet -- that will be taken care of by
+ ;; `setup-block-types!'.
+ (set-procedure-closure-context! procedure true)
+ (if (procedure-virtual-closure? procedure)
+ (set-procedure-virtual-closure?! procedure false))
+ (cancel-dependent-undrifting-constraints! procedure)
+ (close-non-descendent-callees! procedure (procedure-block procedure))
+
+ ;; The procedure-drifting may have moved some procedures in
+ ;; the environment tree based on the (now incorrect)
+ ;; assumption that this procedure was not closed. Fix this.
+ ;; On the other hand, if it was trivial before, it is still
+ ;; trivial now, so the callers are not affected.
+ (if (not (procedure/trivial-closure? procedure))
+ (examine-free-callers! procedure))
+
+ ;; We need to reexamine those applications which may have
+ ;; this procedure as an operator, since the compatibility
+ ;; class of the operator may have changed.
+ (enqueue-nodes! (procedure-applications procedure)))))
-(define (for-each-callee! block procedure)
+(define (close-non-descendent-callees! procedure block)
(for-each-block-descendent! block
(lambda (block*)
- (for-each (lambda (application)
- (for-each (lambda (value)
- (if (and (rvalue/procedure? value)
- (not (procedure-continuation? value)))
- (procedure value)))
- (rvalue-values
- (application-operator application))))
- (block-applications block*)))))
-\f
+ (for-each
+ (lambda (application)
+ (for-each (lambda (value)
+ (if (and (rvalue/procedure? value)
+ (not (procedure-continuation? value)))
+ (close-if-unreachable! (procedure-block value) block
+ value 'CONTAGION procedure)))
+ (rvalue-values (application-operator application))))
+ (block-applications block*)))))
+
(define (examine-free-callers! procedure)
- (let ((block (procedure-block procedure)))
- (for-each
- (lambda (procedure*)
- (if (not (procedure-closure-context procedure*))
- (let ((parent (procedure-closing-block procedure*))
- (original-parent (procedure-target-block procedure*)))
- ;; No need to do anything if PROCEDURE* hasn't drifted
- ;; relative to PROCEDURE.
- (if (and (not (eq? parent original-parent))
- (not (block-ancestor-or-self? parent block)))
- (let ((binding-block
- (reduce original-block-nearest-common-ancestor
- false
- (map variable-block
- (cdr (assq procedure
- (procedure-free-callees
- procedure*)))))))
- (if (not (block-ancestor-or-self? parent binding-block))
- ;; PROCEDURE* has drifted towards the
- ;; environment root past the point where we
- ;; have access to PROCEDURE (by means of free
- ;; variables). We must drift it away from
- ;; the root until we regain access to PROCEDURE.
- (undrift-procedure! procedure* binding-block)))))))
- (procedure-free-callers procedure))))
+ (for-each
+ (lambda (procedure*)
+ (let ((block (procedure-block procedure*)))
+ (for-each
+ (lambda (block*)
+ (if (not (block-ancestor-or-self? block block*))
+ (undrifting-constraint! block block* false false false)))
+ (map->eq-set
+ variable-block
+ (cdr (or (assq procedure (procedure-free-callees procedure*))
+ (error "missing free-callee" procedure procedure*)))))))
+ (procedure-free-callers procedure)))
+\f
+(define *undrifting-constraints*)
+
+(define (undrifting-constraint! block block* procedure reason1 reason2)
+ (if (and procedure (procedure-closure-context procedure))
+ (add-closure-reason! procedure reason1 reason2)
+ (let ((block
+ (let loop ((block block))
+ (if (or (eq? (block-parent block) (original-block-parent block))
+ (original-block-ancestor? (block-parent block) block*))
+ (loop (block-parent block))
+ block)))
+ (condition (and procedure (list procedure reason1 reason2))))
+ (let ((entry (assq block *undrifting-constraints*))
+ (check-inheritance
+ (lambda ()
+ (let loop ((block* block*))
+ (if block*
+ (let ((procedure (block-procedure block*)))
+ (if (eq? true (procedure-closure-context procedure))
+ (close-non-descendent-callees! procedure block)
+ (loop (block-parent block*)))))))))
+ (if (not entry)
+ (begin
+ (set! *undrifting-constraints*
+ (cons (list block (list block* condition))
+ *undrifting-constraints*))
+ (check-inheritance))
+ (let ((entry* (assq block* (cdr entry))))
+ (cond ((not entry*)
+ (set-cdr! entry
+ (cons (list block* condition) (cdr entry)))
+ (check-inheritance))
+ ((not
+ (if condition
+ (list-search-positive (cdr entry*)
+ (lambda (condition*)
+ (and
+ (eq? (car condition) (car condition*))
+ (eqv? (cadr condition) (cadr condition*))
+ (eqv? (caddr condition) (caddr condition*)))))
+ (memq false (cdr entry*))))
+ (set-cdr! entry* (cons condition (cdr entry*)))
+ unspecific))))))))
-(define (undrift-procedure! procedure new-parent)
- (let ((block (procedure-block procedure))
- (parent (procedure-closing-block procedure))
- (original-parent (procedure-target-block procedure)))
- ;; (assert! (eq? parent (procedure-closing-limit procedure)))
- (set-block-children! parent (delq! block (block-children parent)))
- (set-block-parent! block new-parent)
- (set-block-children! new-parent (cons block (block-children new-parent)))
- (set-procedure-closing-limit! procedure new-parent)
- (enqueue-nodes! (cons procedure (procedure-applications procedure)))
- (if (eq? new-parent original-parent)
- (set-block-disowned-children!
- original-parent
- (delq! block (block-disowned-children original-parent)))
- (let ((parent-procedure (block-procedure original-parent)))
- (if (and (not (block-ancestor-or-self? original-parent new-parent))
- (rvalue/procedure? parent-procedure)
- (not (procedure-closure-context parent-procedure)))
- ;; My original parent has drifted to a place where I
- ;; can't be closed. I must drag it back.
- (if (original-block-ancestor-or-self? original-parent new-parent)
- (undrift-procedure! parent-procedure new-parent)
- (error "Procedure has free variables in hyperspace!"
- procedure)))))
- (examine-free-callers! procedure)))
+(define (cancel-dependent-undrifting-constraints! procedure)
+ (for-each
+ (let ((block (procedure-block procedure)))
+ (lambda (entry)
+ (for-each
+ (lambda (entry*)
+ (set-cdr! entry*
+ (list-transform-negative! (cdr entry*)
+ (lambda (constraint)
+ (and constraint (eq? procedure (car constraint)))))))
+ (cdr entry))
+ (if (there-exists? (cdr entry)
+ (lambda (entry*)
+ (and (not (null? (cdr entry*)))
+ (block-ancestor-or-self? (car entry*) block))))
+ (close-non-descendent-callees! procedure (car entry)))))
+ *undrifting-constraints*))
\f
-;;; These are like the corresponding standard block operations, but
-;;; they ignore any block drifting caused by envopt.
+(define (undrift-procedures! constraints)
+ (for-each
+ (lambda (entry)
+ (let ((entries
+ (list-transform-negative! (cdr entry)
+ (lambda (entry*)
+ (null? (cdr entry*))))))
+ (if (not (null? entries))
+ (undrift-block! (car entry)
+ (reduce original-block-nearest-ancestor
+ false
+ (map car entries))))))
+ constraints))
+
+(define-integrable (list-transform-negative! items predicate)
+ ((list-deletor! predicate) items))
-(define (original-block-ancestor-or-self? block block*)
- (or (eq? block block*)
- (let loop ((block (original-block-parent block)))
- (and block
- (or (eq? block block*)
- (loop (original-block-parent block)))))))
+(define (undrift-block! block new-parent)
+ (let ((parent (block-parent block)))
+ (set-block-children! parent (delq! block (block-children parent))))
+ (own-block-child! new-parent block)
+ (if (eq? new-parent (original-block-parent block))
+ (set-block-disowned-children!
+ new-parent
+ (delq! block (block-disowned-children new-parent)))))
-(define (original-block-nearest-common-ancestor block block*)
- (let loop
- ((join false)
- (ancestry (original-block-ancestry block '()))
- (ancestry* (original-block-ancestry block* '())))
- (if (and (not (null? ancestry))
- (not (null? ancestry*))
- (eq? (car ancestry) (car ancestry*)))
- (loop (car ancestry) (cdr ancestry) (cdr ancestry*))
- join)))
+(define (original-block-ancestor? block block*)
+ (let loop ((block (original-block-parent block)))
+ (and block
+ (or (eq? block block*)
+ (loop (original-block-parent block))))))
-(define (original-block-ancestry block path)
- (let ((parent (original-block-parent block)))
- (if parent
- (original-block-ancestry parent (cons block path))
- (cons block path))))
\ No newline at end of file
+(define (original-block-nearest-ancestor block block*)
+ (cond ((or (eq? block block*) (original-block-ancestor? block block*)) block)
+ ((original-block-ancestor? block* block) block*)
+ (else (error "unrelated blocks" block block*))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/contan.scm,v 4.8 1988/12/19 20:25:08 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/contan.scm,v 4.9 1989/10/26 07:36:44 cph Rel $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(and (block-ancestor? block parent)
block))))))))
\f
+(define (setup-block-static-links! blocks)
+ (for-each
+ (lambda (block)
+ (if (stack-block? block)
+ (set-block-static-link?! block (compute-block-static-link? block))))
+ blocks))
+
+(define (compute-block-static-link? block)
+ ;; (and (not (block/no-free-references? block)) ...)
+ (let ((parent (block-parent block)))
+ (and parent
+ (cond ((stack-block? parent) (not (block-stack-link block)))
+ ((ic-block? parent) (ic-block/use-lookup? parent))
+ (else true)))))
+
+(define (block/no-free-references? block)
+ (and (for-all? (block-free-variables block)
+ (lambda (variable)
+ (or (lvalue-integrated? variable)
+ (let ((block (variable-block variable)))
+ (and (ic-block? block)
+ (not (ic-block/use-lookup? block)))))))
+ (let loop ((block* block))
+ (and (not
+ (there-exists? (block-applications block*)
+ (lambda (application)
+ (let ((block*
+ (if (application/combination? application)
+ (let ((adjustment
+ (combination/frame-adjustment
+ application)))
+ (and adjustment
+ (cdr adjustment)))
+ (block-popping-limit
+ (reference-context/block
+ (application-context application))))))
+ (and block* (block-ancestor? block block*))))))
+ (for-all? (block-children block*) loop)))))
+\f
(define (compute-block-popping-limits block)
(let ((external (stack-block/external-ancestor block)))
(map->eq-set
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/delint.scm,v 1.1 1989/04/21 18:54:53 markf Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/delint.scm,v 1.2 1989/10/26 07:36:48 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Delete intergrated parameters
+;;;; Delete integrated parameters
+(declare (usual-integrations))
+\f
(define (delete-integrated-parameters blocks)
(for-each
(lambda (block)
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))))))
+ (if (and rest (variable-unused? rest))
+ (begin
+ (set! deletions (eq-set-adjoin deletions rest))
+ (set-procedure-rest! procedure false))))))
(with-values
(lambda ()
(find-integrated-bindings (procedure-names procedure)
(set-block-bound-variables!
block
(eq-set-difference (block-bound-variables block) deletions)))))
-\f
+
(define (find-integrated-bindings names vals)
(if (null? names)
(values '() '() '())
(lambda ()
(find-integrated-bindings (cdr names) (cdr vals)))
(lambda (names* values* integrated)
- (if (lvalue-integrated? (car names))
+ (if (variable-unused? (car names))
(values names* values* (cons (car names) integrated))
(values (cons (car names) names*)
(cons (car vals) values*)
(find-integrated-variables (cdr variables)))
(lambda (not-integrated integrated)
(if (or (variable-register (car variables))
- (lvalue-integrated? (car variables)))
+ (variable-unused? (car variables)))
(values not-integrated
(cons (car variables) integrated))
(values (cons (car variables) not-integrated)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.6 1989/05/08 22:21:09 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.7 1989/10/26 07:36:51 cph Rel $
Copyright (c) 1987, 1989 Massachusetts Institute of Technology
(define (continuation-passed-out? continuation)
(there-exists? (continuation/combinations continuation)
(lambda (combination)
- (and (not (combination/inline? combination))
+ (and (not (combination/simple-inline? combination))
(let ((operator (combination/operator combination)))
(or (rvalue-passed-in? operator)
(there-exists? (rvalue-values operator)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.12 1989/05/31 20:01:50 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.13 1989/10/26 07:36:55 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
(define (subproblem-ordering parallels)
- (for-each
- (lambda (parallel)
- (order-parallel! parallel false))
- parallels))
+ (for-each (lambda (parallel)
+ (order-parallel! parallel false))
+ parallels))
(define (order-parallel! parallel constraints)
- (fluid-let ((*current-constraints* constraints))
- (let ((previous-edges (node-previous-edges parallel))
- (next-edge (snode-next-edge parallel)))
- (let ((rest
- (edge-next-node next-edge)))
- (if rest
- (begin
- (edges-disconnect-right! previous-edges)
- (edge-disconnect! next-edge)
- (with-values
- (lambda ()
- (order-subproblems/application
- (parallel-application-node parallel)
- (parallel-subproblems parallel)
- rest))
- (lambda (cfg subproblem-order)
- subproblem-order
- (edges-connect-right! previous-edges cfg)
- cfg))))))))
-
-(define *current-constraints*)
-
-(define (order-subproblems-per-current-constraints subproblems)
- (if *current-constraints*
- (order-per-constraints subproblems *current-constraints*)
- subproblems))
+ constraints ;ignore
+ (let ((previous-edges (node-previous-edges parallel))
+ (next-edge (snode-next-edge parallel)))
+ (let ((rest (edge-next-node next-edge)))
+ (if rest
+ (begin
+ (edges-disconnect-right! previous-edges)
+ (edge-disconnect! next-edge)
+ (with-values
+ (lambda ()
+ (order-subproblems/application
+ (parallel-application-node parallel)
+ (parallel-subproblems parallel)
+ rest))
+ (lambda (cfg subproblem-order)
+ subproblem-order
+ (edges-connect-right! previous-edges cfg)
+ cfg)))))))
(define (order-subproblems/application application subproblems rest)
(case (application-type application)
((COMBINATION)
- ((if (combination/inline? application)
- order-subproblems/inline
- order-subproblems/out-of-line)
- application subproblems rest))
+ (if (and (combination/inline? application)
+ (or (combination/simple-inline? application)
+ (not (return-operator/reduction?
+ (combination/continuation application)))))
+ (order-subproblems/inline application subproblems rest)
+ (order-subproblems/out-of-line application subproblems rest)))
((RETURN)
(values
(linearize-subproblems! continuation-type/effect subproblems rest)
subproblems))
(else
(error "Unknown application type" application))))
-
+\f
(define (linearize-subproblems! continuation-type subproblems rest)
(set-subproblem-types! subproblems continuation-type)
(linearize-subproblems subproblems rest))
simple
continuation-type/register)
(values
- (linearize-subproblem!
- continuation-type/effect
- operator
- (linearize-subproblems simple rest))
+ (linearize-subproblem! continuation-type/effect
+ operator
+ (linearize-subproblems simple rest))
(cons operator simple)))
(let ((push-set (cdr complex))
- (value-set
- (cons (car complex)
- (order-subproblems-per-current-constraints
- simple))))
+ (value-set (cons (car complex) simple)))
(inline-subproblem-types! context
push-set
continuation-type/push)
\f
(define (order-subproblems/out-of-line combination subproblems rest)
(with-values
- (combination-ordering
- (combination/context combination)
- (car subproblems)
- (cdr subproblems)
- (combination/model combination))
- (lambda (effect-subproblems push-subproblems register-subproblems)
+ (combination-ordering (combination/context combination)
+ (car subproblems)
+ (cdr subproblems)
+ (combination/model combination))
+ (lambda (effect-subproblems push-subproblems)
(set-combination/frame-size! combination (length push-subproblems))
(with-values
(lambda ()
- (let ((rest
- (linearize-subproblems! continuation-type/register
- register-subproblems
- rest)))
- (order-subproblems/maybe-overwrite-block
- combination push-subproblems rest
- (lambda ()
- (values (linearize-subproblems! continuation-type/push
- push-subproblems
- rest)
- push-subproblems)))))
+ (order-subproblems/maybe-overwrite-block
+ combination push-subproblems rest
+ (lambda ()
+ (values (linearize-subproblems! continuation-type/push
+ push-subproblems
+ rest)
+ push-subproblems))))
(lambda (cfg push-subproblem-order)
- (values (linearize-subproblems!
- continuation-type/effect
- effect-subproblems
- cfg)
- (append effect-subproblems
- push-subproblem-order
- register-subproblems)))))))
+ (values (linearize-subproblems! continuation-type/effect
+ effect-subproblems
+ cfg)
+ (append effect-subproblems push-subproblem-order)))))))
(define (combination-ordering context operator operands model)
(let ((standard
operator
(operator-needed? (subproblem-rvalue operator))
'()
- (reverse operands)
- '())))
+ (reverse operands))))
(optimized
(lambda ()
(optimized-combination-ordering context operator operands model)))
(stack-block/static-link? model-block))
(lambda ()
(with-values thunk
- (lambda (effect-subproblems
- push-subproblems
- register-subproblems)
+ (lambda (effect-subproblems push-subproblems)
(values
effect-subproblems
(cons (new-subproblem context
(block-parent model-block))
- push-subproblems)
- register-subproblems))))
+ push-subproblems)))))
thunk))))
standard)))
\f
(lambda ()
(sort-subproblems/out-of-line operands callee))
(lambda (n-unassigned integrated non-integrated)
- (with-values
- (lambda ()
- (sort-subproblems/pass-in-registers
- non-integrated
- operator
- operands))
- (lambda (registerizable non-registerizable)
- (handle-operator
- context
- operator
- (operator-needed? (subproblem-rvalue operator))
- integrated
- (make-unassigned-subproblems context n-unassigned non-registerizable)
- registerizable))))))
+ (handle-operator context
+ operator
+ (operator-needed? (subproblem-rvalue operator))
+ integrated
+ (make-unassigned-subproblems context
+ n-unassigned
+ non-integrated)))))
(define (known-combination-ordering context operator operands procedure)
(if (and (not (procedure/closure? procedure))
(n-optional (length (procedure-original-optional procedure))))
(let ((n-expected (+ n-required n-optional)))
(if (or (< n-supplied n-required) (> n-supplied n-expected))
- (error
- "known-combination-ordering: wrong number of arguments"
- procedure n-supplied n-expected))
+ (error "known-combination-ordering: wrong number of arguments"
+ procedure n-supplied n-expected))
(- n-expected n-supplied)))
- (reverse operands))
- '()))
+ (reverse operands))))
-(define (handle-operator context operator operator-needed?
- effect push register)
+(define (handle-operator context operator operator-needed? effect push)
(if operator-needed?
- (values
- (order-subproblems-per-current-constraints effect)
- (append! push (list operator))
- (order-subproblems-per-current-constraints register))
+ (values effect (append! push (list operator)))
(begin
(update-subproblem-contexts! context operator)
- (values
- (order-subproblems-per-current-constraints (cons operator effect))
- push
- (order-subproblems-per-current-constraints register)))))
+ (values (cons operator effect) push))))
(define (make-unassigned-subproblems context n rest)
(let ((unassigned (make-constant (make-unassigned-reference-trap))))
0 ; unassigned-count might work too
;; In this case the caller will
;; make slots for the optionals.
- (+ unassigned-count (length optional)))
+ (+ unassigned-count
+ (length
+ (list-transform-negative optional
+ lvalue-integrated?))))
integrated
non-integrated))
((and (not (null? subproblems)) (not rest))
(values unassigned-count
integrated
non-integrated))
- ((and rest (lvalue-integrated? rest))
+ ((and rest (variable-unused? rest))
(values unassigned-count
(append! (reverse subproblems) integrated)
non-integrated))
(define (sort-integrated lvalues subproblems integrated non-integrated)
(cond ((or (null? lvalues) (null? subproblems))
(values lvalues subproblems integrated non-integrated))
- ((lvalue-integrated? (car lvalues))
+ ((variable-unused? (car lvalues))
(sort-integrated (cdr lvalues)
(cdr subproblems)
(cons (car subproblems) integrated)
integrated
(cons (car subproblems) non-integrated)))))
-(define (sort-subproblems/pass-in-registers subproblems operator
- operands)
- (let ((operator-value
- (rvalue-known-value
- (subproblem-rvalue operator))))
- (if (and (rvalue/procedure? operator-value)
- (procedure-maybe-registerizable? operator-value))
- (with-values
- (lambda ()
- (discriminate-items subproblems subproblem-simple?))
- (lambda (simple complex)
- (connect-subproblems-to-parameters! operator-value
- operands
- simple
- complex)))
- (values '() subproblems))))
-
-
(define (operator-needed? operator)
(let ((callee (rvalue-known-value operator)))
(cond ((not callee)
(if (let ((context* (procedure-closure-context rvalue)))
(and (reference-context? context*)
(check-old context*)))
- (set-procedure-closure-context! rvalue context))))))
-\f
-(define (connect-subproblems-to-parameters! operator operands simple
- complex)
- (let ((subproblems->requireds
- (map cons
- operands
- (cdr (procedure-original-required operator))))
- (registerable-variables (parameter-analysis operator)))
-
- (define (reorder-subproblems subproblems)
- (reverse
- (list-transform-positive
- operands
- (lambda (operand)
- (memq operand subproblems)))))
-
- (define (good-subproblem?! subproblem)
- (let ((parameter-variable
- (cdr (assq subproblem subproblems->requireds))))
- (and (not (variable-stack-overwrite-target? parameter-variable))
- (eq-set-subset? (list->eq-set (list parameter-variable))
- registerable-variables)
- (begin
- (set-variable-register!
- parameter-variable
- (delay (subproblem-register subproblem)))
- (set-subproblem-type! subproblem
- continuation-type/register)
- true))))
-
- (let loop ((subproblems simple)
- (in-register '())
- (not-in-register complex))
- (if (null? subproblems)
- (let ((squeeze-it-in
- (list-search-positive complex good-subproblem?!))
- (ordered-pushes (reorder-subproblems not-in-register)))
- (if squeeze-it-in
- (values (cons squeeze-it-in in-register)
- (delq squeeze-it-in ordered-pushes))
- (values in-register ordered-pushes)))
- (let ((subproblem (car subproblems)))
- (if (good-subproblem?! subproblem)
- (loop (cdr subproblems)
- (cons subproblem in-register)
- not-in-register)
- (loop (cdr subproblems)
- in-register
- (cons subproblem not-in-register))))))))
-
+ (set-procedure-closure-context! rvalue context))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/param.scm,v 1.1 1989/04/21 16:23:27 markf Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/param.scm,v 1.2 1989/10/26 07:36:59 cph Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
;;;; Procedure parameter analysis
#|
-A procedure is eligible for having it's parameters be placed in
+
+A procedure is eligible for having its parameters be placed in
registers (i.e. the procedure is "registerizable") if the procedure
will be inlined and the frame reuse routine has not tried to overwrite
-any thing in the stack frame of this procedure or the stack frame
+anything in the stack frame of this procedure or the stack frame
associated with any ancestors of this procedure's block.
Assuming that a procedure is registerizable, the parameter analysis
registers.
A parameter will be passed in a register if all references to that
-parameter in the procedure occur before any calls to complex procedures. A
-complex procedure is essentially a non-inlined, non-open-coded
-procedure. Additionally, we must check to make sure that there are no
-references to the parameter in any closures or descendant blocks. Note
-that inlined and open-coded procedures that are called within the
-analysed procedure are considered to be part of that procedure.
+parameter in the procedure occur before any calls to complex
+procedures. A complex procedure is essentially a non-inlined,
+non-open-coded procedure. Additionally, we must check to make sure
+that there are no references to the parameter in any closures or
+descendent blocks. Note that inlined and open-coded procedures that
+are called within the analysed procedure are considered to be part of
+that procedure.
At certain times (when we hit an as yet unordered parallel) we have
the opportunity to suggest an ordering of subproblems for a particular
A major deficit with the current scheme is the restriction on
registerizable procedures caused by the frame reuse stuff. The frame
-reuse code is very aggressive and consequently there are very
+reuse code is very aggressive and consequently there are very few
occasions where we can in fact place parameters in registers. The
-problem is that the frame resue code needs to know the stack layout,
+problem is that the frame reuse code needs to know the stack layout,
but the placing of parameters in registers affects the use of the
stack. And because the parameter analysis code may call the subproblem
-ordering code which may call the frame resue code, we have a very
+ordering code which may call the frame reuse code, we have a very
tricky timing problem. The correct solution may be to use a relaxation
technique and iterate the subproblem ordering so that we can put more
parameters in registers.
+
|#
-\f
+
(define (parameter-analysis procedure)
(fluid-let ((*inlined-procedures* '()))
(let ((interesting-parameters
- (list-transform-positive
- (procedure-required procedure)
+ (list-transform-positive (procedure-required procedure)
interesting-variable?)))
- (and interesting-parameters
- (let ((registerizable-parameters
- (search-for-complex-combination
- procedure
- (lambda (node)
- (walk-next node
- find-all-variable-references
- eq-set-union))
- (lambda () empty-eq-set))))
- ;; We have to check here if this procedure's block layout
- ;; has been frozen by the frame reuse stuff which may
- ;; have been called due to a call to order-parallel!
- (and (not (block-layout-frozen?
- (procedure-block procedure)))
- (eq-set-difference
- (eq-set-difference
- (list->eq-set interesting-parameters)
- registerizable-parameters)
- (list->eq-set (bad-free-variables procedure)))))))))
-
-(define *inlined-procedures*)
-
-(define (search-for-complex-combination procedure
- if-found
- if-not-found)
- (walk-proc-for-search (procedure-entry-node procedure)
- if-found
- if-not-found))
+ (if interesting-parameters
+ (let ((registerizable-parameters
+ (with-new-node-marks
+ (lambda ()
+ (walk-node-for-search
+ (procedure-entry-node procedure))))))
+ ;; We have to check here if this procedure's block layout
+ ;; has been frozen by the frame reuse stuff which may
+ ;; have been called due to a call to order-parallel!
+ (if (block-layout-frozen? (procedure-block procedure))
+ '()
+ (eq-set-difference
+ (eq-set-difference interesting-parameters
+ registerizable-parameters)
+ (bad-free-variables procedure))))
+ '()))))
\f
-(define (walk-proc-for-search entry-node if-found if-not-found)
-
- (define (walk-node-for-search node)
- (if (and node
- (or (node-marked? node)
- (begin
- (node-mark! node)
- (not (node-previous>1? node)))))
- (or
- (node/bad-variables node)
- (cond
- ((and (application? node)
- (application/combination? node)
- (combination-complex? node))
- (if-found node))
- ((parallel? node)
- (walk-node-for-search
- (if (for-all? (parallel-subproblems node)
- subproblem-simple?)
- (parallel->node node)
- (handle-complex-parallel
- node
- (if-found node)))))
- (else (walk-next node
- walk-node-for-search
- eq-set-union))))
- (if-not-found)))
+(define (walk-node-for-search node)
+ (if (and node
+ (or (node-marked? node)
+ (begin
+ (node-mark! node)
+ (not (node-previous>1? node)))))
+ (or (node/bad-variables node)
+ (cond ((and (application? node)
+ (application/combination? node)
+ (not (combination/simple-inline? node))
+ (not (let ((operator
+ (rvalue-known-value
+ (application-operator node))))
+ (and operator
+ (rvalue/procedure? operator)
+ (procedure-inline-code? operator)))))
+ (walk-next node walk-node-for-variables))
+ ((parallel? node)
+ (walk-node-for-search
+ (order-parallel!
+ node
+ (let ((subproblems (parallel-subproblems node)))
+ (if (for-all? subproblems subproblem-simple?)
+ false
+ (complex-parallel-constraints
+ subproblems
+ (walk-next node walk-node-for-variables)))))))
+ (else
+ (walk-next node walk-node-for-search))))
+ '()))
+
+(define (walk-next node walker)
+ (cond ((application? node)
+ (case (application-type node)
+ ((COMBINATION)
+ (let ((operator (rvalue-known-value (application-operator node))))
+ (if (and operator
+ (rvalue/procedure? operator)
+ (procedure-inline-code? operator))
+ (begin
+ (set! *inlined-procedures*
+ (cons operator *inlined-procedures*))
+ (walker (procedure-entry-node operator)))
+ (walk-continuation (combination/continuation node) walker))))
+ ((RETURN)
+ (walk-continuation (return/operator node) walker))
+ (else
+ (error "Illegal application type" node))))
+ ((snode? node)
+ (walker (snode-next node)))
+ ((pnode? node)
+ (eq-set-union (walker (pnode-consequent node))
+ (walker (pnode-alternative node))))
+ (else
+ (error "Illegal node" node))))
- (with-new-node-marks
- (lambda ()
- (walk-node-for-search
- entry-node))))
-\f
-(define (walk-next node walker combiner)
- (cfg-node-case (tagged-vector/tag node)
- ((APPLICATION)
- (case (application-type node)
- ((COMBINATION)
- (let ((operator
- (rvalue-known-value
- (application-operator node))))
- (if (and operator
- (rvalue/procedure? operator)
- (procedure-inline-code? operator))
- (begin
- (set! *inlined-procedures*
- (cons operator *inlined-procedures*))
- (walker (procedure-entry-node operator)))
- (walk-continuation (combination/continuation node)
- walker))))
- ((RETURN)
- (walk-continuation (return/operator node)
- walker))))
- ((PARALLEL VIRTUAL-RETURN POP ASSIGNMENT
- DEFINITION FG-NOOP STACK-OVERWRITE)
- (walker (snode-next node)))
- ((TRUE-TEST)
- (combiner (walker (pnode-consequent node))
- (walker (pnode-alternative node))))))
+(define *inlined-procedures*)
(define (walk-continuation continuation walker)
(let ((rvalue (rvalue-known-value continuation)))
- (walker (and rvalue
- (continuation/entry-node rvalue)))))
-
+ (walker (and rvalue (continuation/entry-node rvalue)))))
\f
(define (walk-node-for-variables node)
(if node
(if (parallel? node)
- (walk-node-for-variables
- (parallel->node node))
+ (walk-node-for-variables (order-parallel! node false))
(begin
(node-mark! node)
- (or
- (node/bad-variables node)
- (let ((bad-variables
- (eq-set-union
- (with-values
- (lambda ()
- (find-node-values node))
- values->variables)
- (walk-next
- node
- walk-node-for-variables
- eq-set-union))))
- (set-node/bad-variables! node bad-variables)
- bad-variables))))
- empty-eq-set))
+ (or (node/bad-variables node)
+ (let ((bad-variables
+ (eq-set-union
+ (with-values (lambda () (find-node-values node))
+ values->variables)
+ (walk-next node walk-node-for-variables))))
+ (set-node/bad-variables! node bad-variables)
+ bad-variables))))
+ '()))
-(define find-all-variable-references walk-node-for-variables)
-\f
(define (find-node-values node)
-
- (define (finish lval rval)
- (values lval (list rval)))
-
- (cfg-node-case (tagged-vector/tag node)
- ((APPLICATION)
- (case (application-type node)
- ((COMBINATION)
- (if (combination/inline? node)
- (values false (combination/operands node))
- (values false (cons
- (combination/operator node)
- (combination/operands node)))))
- ((RETURN)
- (finish false (return/operand node)))))
- ((VIRTUAL-RETURN)
- (finish false (virtual-return-operand node)))
- ((ASSIGNMENT)
- (finish (assignment-lvalue node)
- (assignment-rvalue node)))
- ((DEFINITION)
- (finish (definition-lvalue node)
- (definition-rvalue node)))
- ((STACK-OVERWRITE)
- (finish (let ((target (stack-overwrite-target node)))
- (and (lvalue? target) target))
- false))
- ((PARALLEL)
- (values
- false
- (safe-mapcan subproblem-free-variables
- (parallel-subproblems node))))
- ((POP FG-NOOP)
- (finish false false))
- ((TRUE-TEST)
- (finish false (true-test-rvalue node)))))
+ (let ((finish
+ (lambda (lvalue rvalue)
+ (values lvalue (if rvalue (list rvalue) '())))))
+ (cfg-node-case (tagged-vector/tag node)
+ ((APPLICATION)
+ (case (application-type node)
+ ((COMBINATION)
+ (values false
+ (cons (combination/operator node)
+ (combination/operands node))))
+ ((RETURN)
+ (finish false (return/operand node)))
+ (else
+ (error "Illegal application type" node))))
+ ((VIRTUAL-RETURN)
+ (finish false (virtual-return-operand node)))
+ ((ASSIGNMENT)
+ (finish (assignment-lvalue node)
+ (assignment-rvalue node)))
+ ((DEFINITION)
+ (finish (definition-lvalue node)
+ (definition-rvalue node)))
+ ((STACK-OVERWRITE)
+ (values (let ((target (stack-overwrite-target node)))
+ (and (lvalue? target) target))
+ '()))
+ ((PARALLEL)
+ (values false
+ (append-map subproblem-free-variables
+ (parallel-subproblems node))))
+ ((POP FG-NOOP)
+ (values false '()))
+ ((TRUE-TEST)
+ (finish false (true-test-rvalue node))))))
(define (values->variables lvalue rvalues)
(eq-set-union
(lvalue/variable? lvalue)
(interesting-variable? lvalue)
(list lvalue)))
- (list->eq-set
- (map
- (lambda (rvalue)
- (reference-lvalue rvalue))
- (list-transform-positive
- rvalues
- (lambda (rvalue)
- (and
- rvalue
- (rvalue/reference? rvalue)
- (let ((ref-lvalue
- (reference-lvalue rvalue)))
- (and ref-lvalue
- (lvalue/variable? ref-lvalue)
- (interesting-variable? ref-lvalue))))))))))
+ (map->eq-set (lambda (rvalue) (reference-lvalue rvalue))
+ (list-transform-positive rvalues
+ (lambda (rvalue)
+ (and (rvalue/reference? rvalue)
+ (let ((lvalue (reference-lvalue rvalue)))
+ (and lvalue
+ (lvalue/variable? lvalue)
+ (interesting-variable? lvalue)))))))))
\f
-(define (combination-complex? combination)
- (not
- (or (and (combination/inline? combination)
- (combination/inline/simple? combination))
- (let ((operator (rvalue-known-value
- (application-operator
- combination))))
- (and operator
- (rvalue/procedure? operator)
- (procedure-inline-code? operator))))))
-
-(define (safe-mapcan proc list)
- (let loop ((list list))
- (cond ((null? list) '())
- (else (append (proc (car list))
- (loop (cdr list)))))))
-
-(define empty-eq-set (list->eq-set '()))
-
-(define (handle-complex-parallel parallel vars-referenced-later)
- (with-values
- (lambda ()
- (discriminate-items (parallel-subproblems parallel)
- subproblem-simple?))
+(define (complex-parallel-constraints subproblems vars-referenced-later)
+ (with-values (lambda () (discriminate-items subproblems subproblem-simple?))
(lambda (simple complex)
- (order-parallel!
- parallel
- (simplicity-constraints
- vars-referenced-later
- simple
- complex)))))
-
-(define (parallel->node parallel)
- (order-parallel! parallel false))
-
-(define (simplicity-constraints bad-vars simple complex)
-
- (define (discriminate-by-bad-vars subproblems)
- (discriminate-items
- subproblems
- (lambda (subproblem)
- (there-exists?
- (subproblem-free-variables subproblem)
- (lambda (var)
- (memq var bad-vars))))))
+ (let ((discriminate-by-bad-vars
+ (lambda (subproblems)
+ (discriminate-items subproblems
+ (lambda (subproblem)
+ (there-exists? (subproblem-free-variables subproblem)
+ (lambda (var)
+ (memq var vars-referenced-later)))))))
+ (constraint-graph (make-constraint-graph)))
+ (with-values (lambda () (discriminate-by-bad-vars simple))
+ (lambda (good-simples bad-simples)
+ (with-values (lambda () (discriminate-by-bad-vars complex))
+ (lambda (good-complex bad-complex)
+ (add-constraint-set! good-simples
+ good-complex
+ constraint-graph)
+ (add-constraint-set! good-complex
+ (append bad-simples bad-complex)
+ constraint-graph)))
+ constraint-graph))))))
- (let ((constraint-graph (make-constraint-graph)))
- (with-values
- (lambda ()
- (discriminate-by-bad-vars simple))
- (lambda (good-simples bad-simples)
- (with-values
- (lambda ()
- (discriminate-by-bad-vars complex))
- (lambda (good-complex bad-complex)
- (add-constraint-set! good-simples
- good-complex
- constraint-graph)
- (add-constraint-set!
- good-complex
- (append bad-simples bad-complex)
- constraint-graph)))
- constraint-graph))))
-
-(define (bad-subproblem-vars subproblem-order)
- (safe-mapcan subproblem-free-variables
- (list-search-negative subproblem-order
- subproblem-simple?)))
-\f
(define-integrable (node/bad-variables node)
(cfg-node-get node node/bad-variables-tag))
"bad-variables-tag")
(define (bad-free-variables procedure)
- (safe-mapcan
- block-variables-nontransitively-free
- (list-transform-negative
- (cdr (linearize-block-tree
- (procedure-block procedure)))
- (lambda (block)
- (memq (block-procedure block)
- *inlined-procedures*)))))
+ (append-map block-variables-nontransitively-free
+ (list-transform-negative
+ (cdr (linearize-block-tree (procedure-block procedure)))
+ (lambda (block)
+ (memq (block-procedure block) *inlined-procedures*)))))
;;; Since the order of this linearization is not important we could
;;; make this routine more efficient. I'm not sure that it is worth
;;; "(delq block (line..."
(define (linearize-block-tree block)
(let ((children
- (append (block-children block)
- (block-disowned-children block))))
+ (append (block-children block) (block-disowned-children block))))
(if (null? children)
(list block)
- (cons block
- (mapcan
- linearize-block-tree
- children)))))
+ (cons block (mapcan linearize-block-tree children)))))
(define (interesting-variable? variable)
;;; variables that will be in cells are eliminated from
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.3 1989/05/21 03:57:49 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.4 1989/10/26 07:37:03 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(rvalue/procedure? callee)
(procedure/open-internal? callee)))
(caller (block-procedure block)))
- (and (not (combination/inline? combination))
+ (and (not (combination/simple-inline? combination))
(return-operator/reduction?
(combination/continuation combination))
(rvalue/procedure? caller)
(generate-assignments (cdr nodes) rest)))))
(define (trivial-assignments nodes rest)
- (let loop ((nodes
- (order-nodes-per-current-constraints nodes)))
+ (let loop ((nodes nodes))
(if (null? nodes)
rest
(trivial-assignment (car nodes) (loop (cdr nodes))))))
(make-stack-overwrite (subproblem-context subproblem)
target
(subproblem-continuation subproblem))
- rest)))
-
-(define (order-nodes-per-current-constraints nodes)
- (if *current-constraints*
- (order-per-constraints/extracted
- nodes
- *current-constraints*
- node-value)
- nodes))
-
+ rest)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simple.scm,v 4.5 1989/07/18 20:22:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simple.scm,v 4.6 1989/10/26 07:37:06 cph Rel $
Copyright (c) 1987, 1989 Massachusetts Institute of Technology
((APPLICATION)
(case (application-type node)
((COMBINATION)
- (if (and (combination/inline? node)
- (combination/inline/simple? node))
+ (if (combination/simple-inline? node)
(walk/return-operator (combination/continuation node) continuation)
(let ((callee (rvalue-known-value (combination/operator node))))
(and callee
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/subfre.scm,v 1.2 1989/04/03 22:03:55 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/subfre.scm,v 1.3 1989/10/26 07:37:09 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(define (walk-lvalue lvalue walk-rvalue)
(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
+ (if value
+ (if (lvalue-integrated? lvalue)
+ (walk-rvalue value)
+ (eq-set-adjoin lvalue (walk-rvalue value)))
+ (if (and (variable? lvalue)
+ (variable-indirection lvalue))
+ (walk-lvalue (variable-indirection lvalue) walk-rvalue)
+ (list lvalue)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.24 1989/08/21 19:33:33 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.25 1989/10/26 07:37:23 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(parent (compiler fg-optimizer))
(export (compiler top-level) operator-analysis))
+(define-package (compiler fg-optimizer variable-indirection)
+ (files "fgopt/varind")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) initialize-variable-indirections!))
+
(define-package (compiler fg-optimizer environment-optimization)
(files "fgopt/envopt")
(parent (compiler fg-optimizer))
(define-package (compiler fg-optimizer continuation-analysis)
(files "fgopt/contan")
(parent (compiler fg-optimizer))
- (export (compiler top-level) continuation-analysis))
+ (export (compiler top-level)
+ continuation-analysis
+ setup-block-static-links!))
(define-package (compiler fg-optimizer compute-node-offsets)
(files "fgopt/offset")
(parent (compiler fg-optimizer subproblem-ordering))
(export (compiler fg-optimizer subproblem-ordering)
parameter-analysis))
+
+(define-package (compiler fg-optimizer return-equivalencing)
+ (files "fgopt/reteqv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) find-equivalent-returns!))
\f
(define-package (compiler rtl-generator)
(files "rtlgen/rtlgen" ;RTL generator
(files "rtlgen/rgcomb")
(parent (compiler rtl-generator))
(export (compiler rtl-generator)
- generate/combination))
+ generate/combination)
+ (export (compiler rtl-generator combination/inline)
+ generate/invocation-prefix))
(define-package (compiler rtl-generator generate/return)
(files "rtlgen/rgretn")
(files "rtlopt/rinvex")
(parent (compiler rtl-optimizer))
(export (compiler top-level) invertible-expression-elimination))
+
+(define-package (compiler rtl-optimizer common-suffix-merging)
+ (files "rtlopt/rtlcsm")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) merge-common-suffixes!))
+
(define-package (compiler rtl-optimizer lifetime-analysis)
(files "rtlopt/rlife")
(parent (compiler rtl-optimizer))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.13 1989/08/21 19:33:40 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.14 1989/10/26 07:37:28 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(if disassembler/write-addresses?
(begin
(write-string
- (number->string (+ offset disassembler/base-address)
- '(HEUR (RADIX X S))))
+ (number->string (+ offset disassembler/base-address) 16))
(write-char #\Tab)))
(if disassembler/write-offsets?
(begin
- (write-string (number->string offset '(HEUR (RADIX X S)))) (write-char #\Tab)))
+ (write-string (number->string offset 16))
+ (write-char #\Tab)))
(if symbol-table
(write-string " "))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.13 1989/07/25 12:40:44 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.14 1989/10/26 07:37:31 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(case (car effective-address)
((@AO)
(and (or (eq? (cadr effective-address) 'REGS-POINTER)
- (and (number? (cadr effective-address))
- (= (cadr effective-address)
- interpreter-register-pointer))) (interpreter-register interpreter-register-pointer
+ (eqv? (cadr effective-address) interpreter-register-pointer))
+ (interpreter-register interpreter-register-pointer
(caddr effective-address))))
((REGISTER TEMPORARY ENTRY) effective-address)
(else false))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.23 1989/08/28 18:33:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.24 1989/10/26 07:37:35 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(filename/append "fgopt"
"blktyp" "closan" "conect" "contan" "delint"
"desenv" "envopt" "folcon" "offset" "operan"
- "order" "outer" "param" "reord" "reuse"
- "sideff" "simapp" "simple" "subfre")
+ "order" "outer" "param" "reord" "reteqv" "reuse"
+ "sideff" "simapp" "simple" "subfre" "varind")
(filename/append "rtlbase"
"regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
"rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
(filename/append "rtlopt"
"ralloc" "rcse1" "rcse2" "rcseep" "rcseht"
"rcserq" "rcsesr" "rdeath" "rdebug" "rinvex"
- "rlife"))
+ "rlife" "rtlcsm"))
compiler-syntax-table)
(file-dependency/syntax/join
(filename/append "machines/bobcat"
(filename/append "fgopt"
"blktyp" "closan" "conect" "contan" "delint" "desenv"
"envopt" "folcon" "offset" "operan" "order" "param"
- "outer" "reuse" "sideff" "simapp" "simple" "subfre"))
+ "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
+ "subfre" "varind"))
(append bobcat-base front-end-base))
(define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
(file-dependency/integration/join
(append cse-base
(filename/append "rtlopt" "ralloc" "rdeath" "rdebug" "rinvex"
- "rlife")) (append bobcat-base rtl-base))
+ "rlife" "rtlcsm"))
+ (append bobcat-base rtl-base))
(file-dependency/integration/join cse-base cse-base)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.124 1988/06/14 08:47:02 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.125 1989/10/26 07:37:39 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
',categories)))
(define (process-ea-field field)
- (if (integer? field) (integer-syntaxer field 'UNSIGNED 3)
+ (if (exact-integer? field)
+ (integer-syntaxer field 'UNSIGNED 3)
(let ((binding (cadr field))
(clauses (cddr field)))
(variable-width-expression-syntaxer
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.7 1989/08/28 18:33:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insutl.scm,v 1.8 1989/10/26 07:37:43 cph Rel $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
base-suppress index-suppress
base-displacement-size
base-displacement
- memory-indirection-type
+ indirection-type
outer-displacement-size
outer-displacement)
- (append-syntax!
- (EXTENSION-WORD (1 index-register-type)
- (3 index-register)
- (1 index-size)
- (2 factor SCALE-FACTOR)
- (1 #b1)
- (1 base-suppress)
- (1 index-suppress)
- (2 base-displacement-size)
- (1 #b0)
- (3 (case memory-indirection-type
- ((#F)
- #b000)
- ((PRE)
- outer-displacement-size)
- ((POST)
- (+ #b100 outer-displacement-size))
- (else
- (error "bad memory indirection-type"
- memory-indirection-type)))))
- (append-syntax!
- (output-displacement base-displacement-size base-displacement)
- (output-displacement outer-displacement-size outer-displacement))))
-
-(define (output-displacement size displacement)
- (case size
- ((1))
- ((2) (EXTENSION-WORD (16 displacement SIGNED)))
- ((3) (EXTENSION-WORD (32 displacement SIGNED)))))
+ (let ((output-displacement
+ (lambda (size displacement)
+ (case size
+ ((1) false)
+ ((2) (EXTENSION-WORD (16 displacement SIGNED)))
+ ((3) (EXTENSION-WORD (32 displacement SIGNED)))
+ (else (error "illegal displacement-size" size))))))
+ (apply
+ optimize-group
+ (let loop
+ ((items
+ (list
+ (EXTENSION-WORD
+ (1 index-register-type)
+ (3 index-register)
+ (1 index-size)
+ (2 factor SCALE-FACTOR)
+ (1 #b1)
+ (1 base-suppress)
+ (1 index-suppress)
+ (2 base-displacement-size)
+ (1 #b0)
+ (3 (case indirection-type
+ ((#F) #b000)
+ ((PRE) outer-displacement-size)
+ ((POST) (+ #b100 outer-displacement-size))
+ (else (error "illegal indirection-type" indirection-type)))))
+ (output-displacement base-displacement-size base-displacement)
+ (output-displacement outer-displacement-size outer-displacement))))
+ (if (null? items)
+ '()
+ (let ((rest (loop (cdr items))))
+ (if (car items)
+ (cons-syntax (car items) rest)
+ rest)))))))
\f
;;;; Common special cases
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.21 1989/08/28 18:33:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.22 1989/10/26 07:37:46 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(pseudo-register-offset register)))
(define (machine->machine-register source target)
- (cond ((float-register? source)
- (if (float-register? target)
- (INST (FMOVE ,source ,target))
- (error "Moving from floating point register to non-fp register")))
- ((float-register? target)
- (error "Moving from non-floating point register to fp register"))
- (else (INST (MOV L
- ,(register-reference source)
- ,(register-reference target))))))
+ (if (not (register-types-compatible? source target))
+ (error "Moving between incompatible register types" source target))
+ (if (float-register? source)
+ (INST (FMOVE ,(register-reference source)
+ ,(register-reference target)))
+ (INST (MOV L
+ ,(register-reference source)
+ ,(register-reference target)))))
(define (machine-register->memory source target)
(if (float-register? source)
- (INST (FMOVE X ,(register-reference source) ,target))
+ (INST (FMOVE D ,(register-reference source) ,target))
(INST (MOV L ,(register-reference source) ,target))))
(define (memory->machine-register source target)
(if (float-register? target)
- (INST (FMOVE X ,source ,(register-reference target)))
+ (INST (FMOVE D ,source ,(register-reference target)))
(INST (MOV L ,source ,(register-reference target)))))
(package (offset-reference byte-offset-reference)
(define-integrable (effective-address/address-register? ea)
(eq? (lap:ea-keyword ea) 'A))
+
+(define (effective-address/float-register? ea)
+ (memq ea '(FP0 FP1 FP2 FP3 FP4 FP5 FP6 FP7)))
\f
(define (standard-target-reference target)
;; Our preference for data registers here is a heuristic that works
((rtl:stack-push? target) (INST-EA (@-A 7)))
(else (error "STANDARD-TARGET->EA: Not a standard target" target))))
\f
+;;;; Machine Targets (actually, arithmetic targets)
+
+(define (reuse-and-load-machine-target! type target source operate-on-target)
+ (reuse-machine-target! type target
+ (lambda (target)
+ (operate-on-target (move-to-alias-register! source type target)))
+ (lambda (target)
+ (LAP
+ ,(if (eq? type 'FLOAT)
+ (let ((source (standard-register-reference source type false)))
+ (if (effective-address/float-register? source)
+ (INST (FMOVE ,source ,target))
+ (INST (FMOVE D ,source ,target))))
+ (INST (MOV L ,(standard-register-reference source type true)
+ ,target)))
+ ,@(operate-on-target target)))))
+
+(define (reuse-machine-target! type
+ target
+ operate-on-pseudo-target
+ operate-on-machine-target)
+ (let ((use-temporary
+ (lambda (target)
+ (let ((temp (reference-temporary-register! type)))
+ (LAP ,@(operate-on-machine-target temp)
+ ,(if (eq? type 'FLOAT)
+ (INST (FMOVE ,temp ,target))
+ (INST (MOV L ,temp ,target))))))))
+ (case (rtl:expression-type target)
+ ((REGISTER)
+ (let ((register (rtl:register-number target)))
+ (if (pseudo-register? register)
+ (operate-on-pseudo-target register)
+ (let ((target (register-reference register)))
+ (if (eq? type (register-type register))
+ (operate-on-machine-target target)
+ (use-temporary target))))))
+ ((OFFSET)
+ (use-temporary (offset->indirect-reference! target)))
+ (else
+ (error "Illegal machine target" target)))))
+
+(define (reuse-and-operate-on-machine-target! type target operate-on-target)
+ (reuse-machine-target! type target
+ (lambda (target)
+ (operate-on-target (reference-target-alias! target type)))
+ operate-on-target))
+
+(define (machine-operation-target? target)
+ (or (rtl:register? target)
+ (rtl:offset? target)))
+\f
+(define (two-arg-register-operation
+ operate commutative?
+ target-type source-reference alternate-source-reference
+ target source1 source2)
+ (let ((worst-case
+ (lambda (target source1 source2)
+ (LAP ,(if (eq? target-type 'FLOAT)
+ (INST (FMOVE ,source1 ,target))
+ (INST (MOV L ,source1 ,target)))
+ ,@(operate target source2)))))
+ (reuse-machine-target! target-type target
+ (lambda (target)
+ (reuse-pseudo-register-alias! source1 target-type
+ (lambda (alias)
+ (let ((source2 (if (= source1 source2)
+ (register-reference alias)
+ (source-reference source2))))
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target alias)
+ (operate (register-reference alias) source2)))
+ (lambda ()
+ (let ((new-target-alias!
+ (lambda ()
+ (let ((source1 (alternate-source-reference source1))
+ (source2 (source-reference source2)))
+ (delete-dead-registers!)
+ (worst-case (reference-target-alias! target target-type)
+ source1
+ source2)))))
+ (if commutative?
+ (reuse-pseudo-register-alias source2 target-type
+ (lambda (alias2)
+ (let ((source1 (source-reference source1)))
+ (delete-machine-register! alias2)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target alias2)
+ (operate (register-reference alias2) source1)))
+ new-target-alias!)
+ (new-target-alias!))))))
+ (lambda (target)
+ (worst-case target
+ (alternate-source-reference source1)
+ (source-reference source2))))))
+\f
;;;; Fixnum Operators
(define (signed-fixnum? n)
- (and (integer? n)
+ (and (exact-integer? n)
(>= n signed-fixnum/lower-limit)
(< n signed-fixnum/upper-limit)))
(define (unsigned-fixnum? n)
- (and (integer? n)
+ (and (exact-integer? n)
(not (negative? n))
(< n unsigned-fixnum/upper-limit)))
(if (not (unsigned-fixnum? n)) (error "Not a unsigned fixnum" n))
n)
-(define fixnum-1
+(define-integrable fixnum-1
(expt 2 scheme-type-width))
(define (load-fixnum-constant constant register-reference)
((GREATER-THAN-FIXNUM? POSITIVE-FIXNUM?) 'GT)
(else (error "FIXNUM-PREDICATE->CC: Unknown predicate" predicate))))
-(define-integrable (fixnum-2-args/commutative? operator)
+(define (fixnum-2-args/commutative? operator)
(memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM)))
\f
-(define (reuse-and-load-fixnum-target! target source operate-on-target)
- (reuse-fixnum-target! target
- (lambda (target)
- (operate-on-target (move-to-alias-register! source 'DATA target)))
- (lambda (target)
- (LAP (MOV L ,(standard-register-reference source 'DATA) ,target)
- ,@(operate-on-target target)))))
-
-(define (reuse-fixnum-target! target
- operate-on-pseudo-target
- operate-on-machine-target)
- (let ((use-temporary
- (lambda (target)
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP ,@(operate-on-machine-target temp)
- (MOV L ,temp ,target))))))
- (case (rtl:expression-type target)
- ((REGISTER)
- (let ((register (rtl:register-number target)))
- (if (pseudo-register? register)
- (operate-on-pseudo-target register)
- (let ((target (register-reference register)))
- (if (data-register? register)
- (operate-on-machine-target target)
- (use-temporary target))))))
- ((OFFSET)
- (use-temporary (offset->indirect-reference! target)))
- (else
- (error "REUSE-FIXNUM-TARGET!: Unknown fixnum target" target)))))
-
-(define (fixnum-operation-target? target)
- (or (rtl:register? target)
- (rtl:offset? target)))
-
(define (define-fixnum-method operator methods method)
(let ((entry (assq operator (cdr methods))))
(if entry
(define-integrable (fixnum-2-args/operate-constant operator)
(lookup-fixnum-method operator fixnum-methods/2-args-constant))
-\f
+
(define-fixnum-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
(lambda (reference)
(LAP (ADD L (& ,fixnum-1) ,reference))))
(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
(lambda (target source)
(if (equal? target source)
- (let ((new-source (reference-temporary-register! 'DATA)))
- ;;; I should add new-source as an alias for source, but I
- ;;; don't have a handle on the actual register here (I just
- ;;; have the register-reference). Maybe this should be
- ;;; moved into the rules.
- (LAP
- (MOV L ,source ,new-source)
- (AS R L (& ,scheme-type-width) ,target)
- (MUL S L ,new-source ,target)))
+ (if (even? scheme-type-width)
+ (LAP
+ (AS R L (& ,(quotient scheme-type-width 2)) ,target)
+ (MUL S L ,source ,target))
+ (LAP
+ (AS R L (& ,scheme-type-width) ,target)
+ (MUL S L ,source ,target)
+ (AS L L (& ,scheme-type-width) ,target)))
(LAP
(AS R L (& ,scheme-type-width) ,target)
(MUL S L ,source ,target)))))
(AS L L ,temp ,target)))
(LAP (AS L L (& ,power-of-2) ,target)))
(LAP (MUL S L (& ,n) ,target))))))))
-
+\f
(define (integer-log-base-2? n)
(let loop ((power 1) (exponent 0))
(cond ((< n power) false)
(lambda (target n)
(cond ((zero? n) (LAP))
(else (LAP (SUB L (& ,(* n fixnum-1)) ,target))))))
+
+(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
+ (lambda (target source)
+ (LAP
+ (DIV S L ,source ,target)
+ (AS L L (& ,scheme-type-width) ,target))))
+
+(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-constant
+ (lambda (target n)
+ (cond ((= n 1) (LAP))
+ ((= n -1) (LAP (NEG L ,target)))
+ (else
+ (let ((power-of-2 (integer-log-base-2? n)))
+ (if power-of-2
+ (if (> power-of-2 8)
+ (let ((temp (reference-temporary-register! 'DATA)))
+ (LAP (MOV L (& ,power-of-2) ,temp)
+ (AS R L ,temp ,target)))
+ (LAP (AS R L (& ,power-of-2) ,target)))
+ (LAP (DIV S L (& ,n) ,target))))))))
+
+(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args
+ (lambda (target source)
+ (let ((temp (reference-temporary-register! 'DATA)))
+ (LAP
+ (DIV S L ,source ,temp ,target)
+ (MOV L ,temp ,target)))))
+
+(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args-constant
+ (lambda (target n)
+ (if (or (= n 1) (= n -1))
+ (LAP (CLR L ,target))
+ (let ((power-of-2 (integer-log-base-2? n)))
+ (if power-of-2
+ (if (> power-of-2 8)
+ (let ((temp (reference-temporary-register! 'DATA)))
+ (LAP (MOV L (& ,power-of-2) ,temp)
+ (AS R L ,temp ,target)))
+ (LAP (AS R L (& ,power-of-2) ,target)))
+ (let ((temp (reference-temporary-register! 'DATA)))
+ (LAP
+ (DIV S L (& ,(* n fixnum-1)) ,temp ,target)
+ (MOV L ,temp ,target))))))))
\f
;;;; Flonum Operators
-(define (float-target-reference target)
- (delete-dead-registers!)
- (register-reference
- (or (register-alias target 'FLOAT)
- (allocate-alias-register! target 'FLOAT))))
-
(define (define-flonum-method operator methods method)
(let ((entry (assq operator (cdr methods))))
(if entry
(cdr (or (assq operator (cdr methods))
(error "Unknown operator" operator))))
-
(define flonum-methods/1-arg
(list 'FLONUM-METHODS/1-ARG))
(define-integrable (flonum-1-arg/operate operator)
(lookup-flonum-method operator flonum-methods/1-arg))
-;;; Notice the weird ,', syntax here. If LAP changes, this may also have to change.
+;;; Notice the weird ,', syntax here.
+;;; If LAP changes, this may also have to change.
(let-syntax
((define-flonum-operation
(macro (primitive-name instruction-name)
- `(define-flonum-method ',primitive-name flonum-methods/1-arg
- (lambda (source target)
- (LAP (,instruction-name ,',source ,',target)))))))
- (define-flonum-operation SINE-FLONUM FSIN)
- (define-flonum-operation COSINE-FLONUM FCOS)
- (define-flonum-operation ARCTAN-FLONUM FATAN)
- (define-flonum-operation EXP-FLONUM FETOX)
- (define-flonum-operation LN-FLONUM FLOGN)
- (define-flonum-operation SQRT-FLONUM FSQRT)
- (define-flonum-operation TRUNCATE-FLONUM FINT))
-
+ `(DEFINE-FLONUM-METHOD ',primitive-name FLONUM-METHODS/1-ARG
+ (LAMBDA (SOURCE TARGET)
+ (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
+ (LAP (,instruction-name ,',source ,',target))
+ (LAP (,instruction-name D ,',source ,',target))))))))
+ (define-flonum-operation flonum-negate fneg)
+ (define-flonum-operation flonum-abs fabs)
+ (define-flonum-operation flonum-sin fsin)
+ (define-flonum-operation flonum-cos fcos)
+ (define-flonum-operation flonum-tan ftan)
+ (define-flonum-operation flonum-asin fasin)
+ (define-flonum-operation flonum-acos facos)
+ (define-flonum-operation flonum-atan fatan)
+ (define-flonum-operation flonum-exp fetox)
+ (define-flonum-operation flonum-log flogn)
+ (define-flonum-operation flonum-sqrt fsqrt)
+ (define-flonum-operation flonum-round fint)
+ (define-flonum-operation flonum-truncate fintrz))
+\f
(define flonum-methods/2-args
(list 'FLONUM-METHODS/2-ARGS))
((define-flonum-operation
(macro (primitive-name instruction-name)
`(define-flonum-method ',primitive-name flonum-methods/2-args
- (lambda (source target)
+ (lambda (target source)
(LAP (,instruction-name ,',source ,',target)))))))
- (define-flonum-operation PLUS-FLONUM FADD)
- (define-flonum-operation MINUS-FLONUM FSUB)
- (define-flonum-operation MULTIPLY-FLONUM FMUL)
- (define-flonum-operation DIVIDE-FLONUM FDIV))
+ (define-flonum-operation flonum-add fadd)
+ (define-flonum-operation flonum-subtract fsub)
+ (define-flonum-operation flonum-multiply fmul)
+ (define-flonum-operation flonum-divide fdiv))
(define (invert-float-cc cc)
(cdr (or (assq cc
(MI . PL) (PL . MI)))
(error "INVERT-FLOAT-CC: Not a known CC" cc))))
-
(define (set-flonum-branches! cc)
(set-current-branches!
(lambda (label)
(define (flonum-predicate->cc predicate)
(case predicate
- ((EQUAL-FLONUM? ZERO-FLONUM?) 'EQ)
- ((LESS-THAN-FLONUM? NEGATIVE-FLONUM?) 'LT)
- ((GREATER-THAN-FLONUM? POSITIVE-FLONUM?) 'GT)
- (else (error "FLONUM-PREDICATE->CC: Unknown predicate" predicate))))\f
+ ((FLONUM-EQUAL? FLONUM-ZERO?) 'EQ)
+ ((FLONUM-LESS? FLONUM-NEGATIVE?) 'LT)
+ ((FLONUM-GREATER? FLONUM-POSITIVE?) 'GT)
+ (else (error "FLONUM-PREDICATE->CC: Unknown predicate" predicate))))
+
+(define (flonum-2-args/commutative? operator)
+ (memq operator '(FLONUM-ADD FLONUM-MULTIPLY)))
+\f
;;;; OBJECT->DATUM rules - Mhwu
;;; Similar to fixnum rules, but no sign extension
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.55 1989/09/25 21:45:36 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.56 1989/10/26 07:41:21 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
'((COMPILER MACROS)
(COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (Motorola MC68020)" 4 55 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (Motorola MC68020)" 4 56 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.26 1989/09/25 21:45:23 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.27 1989/10/26 07:37:51 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(ASSIGN (REGISTER (? target)) (REGISTER (? source)))
(QUALIFIER (machine-register? target))
(LAP (MOV L
- ,(standard-register-reference source false)
+ ,(standard-register-reference source false true)
,(register-reference target))))
(define-rule statement
(ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
(QUALIFIER (pseudo-register? target))
(convert-object/register->register target source address->fixnum))
-
+\f
(define (convert-object/offset->register target address offset conversion)
(let ((source (indirect-reference! address offset)))
(delete-dead-registers!)
(? offset)))))
(QUALIFIER (pseudo-register? target))
(convert-object/offset->register target address offset address->fixnum))
-\f
+
(define-rule statement
(ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
(QUALIFIER (pseudo-register? target))
(QUALIFIER (and (pseudo-register? target) (pseudo-register? datum)))
(let ((target (move-to-alias-register! datum 'DATA target)))
(LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target))))
-
+\f
(define-rule statement
(ASSIGN (REGISTER (? target)) (UNASSIGNED))
(QUALIFIER (pseudo-register? target))
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
(REGISTER (? r)))
(LAP (MOV L
- ,(standard-register-reference r false)
+ ,(standard-register-reference r false true)
,(indirect-reference! a n))))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? address)) (? offset))
(CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
(let ((target (indirect-reference! address offset)))
- (LAP (MOV L ,(standard-register-reference datum 'DATA) ,target)
+ (LAP (MOV L ,(standard-register-reference datum 'DATA true) ,target)
,(memory-set-type type target))))
(define-rule statement
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
(OFFSET (REGISTER (? a1)) (? n1)))
- (let ((source (indirect-reference! a1 n1)))
- (LAP (MOV L ,source ,(indirect-reference! a0 n0)))))
+ (if (and (= a0 a1) (= n0 n1))
+ (LAP)
+ (let ((source (indirect-reference! a1 n1)))
+ (LAP (MOV L ,source ,(indirect-reference! a0 n0))))))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r)))
(QUALIFIER (pseudo-word? r))
- (LAP (MOV L ,(standard-register-reference r false) (@A+ 5))))
+ (LAP (MOV L ,(standard-register-reference r false true) (@A+ 5))))
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r)))
(QUALIFIER (pseudo-float? r))
- (LAP (FMOVE D ,(float-register-reference r) (@A+ 5))))
+ (LAP (FMOVE D ,(machine-register-reference r 'FLOAT) (@A+ 5))))
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n)))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r)))
- (LAP (MOV L ,(standard-register-reference r false) (@-A 7))))
+ (LAP (MOV L ,(standard-register-reference r false true) (@-A 7))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
- (LAP (MOV L ,(standard-register-reference datum 'DATA) (@-A 7))
+ (LAP (MOV L ,(standard-register-reference datum 'DATA true) (@-A 7))
,(memory-set-type type (INST-EA (@A 7)))))
(define-rule statement
(LAP (PEA (@PCR ,(rtl-procedure/external-label (label->object label))))
,(memory-set-type type (INST-EA (@A 7)))))
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
+ (OFFSET-ADDRESS (REGISTER (? r)) (? n)))
+ (LAP (PEA ,(indirect-reference! r n))))
+
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n)))
(LAP (MOV L ,(indirect-reference! r n) (@-A 7))))
(define-rule statement
(ASSIGN (? target) (FIXNUM-1-ARG (? operator) (REGISTER (? source))))
- (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
- (reuse-and-load-fixnum-target! target
- source
- (fixnum-1-arg/operate operator)))
+ (QUALIFIER (and (machine-operation-target? target)
+ (pseudo-register? source)))
+ (reuse-and-load-machine-target! 'DATA
+ target
+ source
+ (fixnum-1-arg/operate operator)))
+
+(define-rule statement
+ (ASSIGN (? target)
+ (FIXNUM-2-ARGS (? operator)
+ (REGISTER (? source1))
+ (REGISTER (? source2))))
+ (QUALIFIER (and (machine-operation-target? target)
+ (pseudo-register? source1)
+ (pseudo-register? source2)))
+ (two-arg-register-operation (fixnum-2-args/operate operator)
+ (fixnum-2-args/commutative? operator)
+ 'DATA
+ (standard-fixnum-source operator)
+ (lambda (source)
+ (standard-register-reference source
+ 'DATA
+ true))
+ target
+ source1
+ source2))
(define-rule statement
(ASSIGN (? target)
(FIXNUM-2-ARGS (? operator)
(REGISTER (? source))
(OBJECT->FIXNUM (CONSTANT (? constant)))))
- (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
+ (QUALIFIER (and (machine-operation-target? target)
+ (pseudo-register? source)))
(fixnum-2-args/register*constant operator target source constant))
(define-rule statement
(FIXNUM-2-ARGS (? operator)
(OBJECT->FIXNUM (CONSTANT (? constant)))
(REGISTER (? source))))
- (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
+ (QUALIFIER (and (machine-operation-target? target)
+ (pseudo-register? source)))
(if (fixnum-2-args/commutative? operator)
(fixnum-2-args/register*constant operator target source constant)
(fixnum-2-args/constant*register operator target constant source)))
(define (fixnum-2-args/register*constant operator target source constant)
- (reuse-and-load-fixnum-target! target source
+ (reuse-and-load-machine-target! 'DATA target source
(lambda (target)
((fixnum-2-args/operate-constant operator) target constant))))
(define (fixnum-2-args/constant*register operator target constant source)
- (reuse-and-operate-on-fixnum-target! target
+ (reuse-and-operate-on-machine-target! 'DATA target
(lambda (target)
(LAP ,@(load-fixnum-constant constant target)
,@((fixnum-2-args/operate operator)
target
- (if (eq? operator 'MULTIPLY-FIXNUM)
- (standard-multiply-source source)
- (standard-register-reference source 'DATA)))))))
-
-(define (reuse-and-operate-on-fixnum-target! target operate-on-target)
- (reuse-fixnum-target! target
- (lambda (target)
- (operate-on-target (reference-target-alias! target 'DATA)))
- operate-on-target))
+ ((standard-fixnum-source operator) source))))))
+
+(define (standard-fixnum-source operator)
+ (let ((alternate-types?
+ (not (memq operator
+ '(MULTIPLY-FIXNUM FIXNUM-DIVIDE FIXNUM-REMAINDER)))))
+ (lambda (source)
+ (standard-register-reference source 'DATA alternate-types?))))
\f
;;; The maximum value for a shift constant is 8, so these rules can
;;; only be used when the type width is 6 bits or less.
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(OBJECT->FIXNUM (CONSTANT 4))
(OBJECT->FIXNUM (REGISTER (? source)))))
- (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
+ (QUALIFIER (and (machine-operation-target? target)
+ (pseudo-register? source)))
(convert-index->fixnum/register target source))
(define-rule statement
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(OBJECT->FIXNUM (REGISTER (? source)))
(OBJECT->FIXNUM (CONSTANT 4))))
- (QUALIFIER (and (fixnum-operation-target? target) (pseudo-register? source)))
+ (QUALIFIER (and (machine-operation-target? target)
+ (pseudo-register? source)))
(convert-index->fixnum/register target source))
(define-rule statement
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(OBJECT->FIXNUM (CONSTANT 4))
(OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))))
- (QUALIFIER (fixnum-operation-target? target))
+ (QUALIFIER (machine-operation-target? target))
(convert-index->fixnum/offset target r n))
(define-rule statement
(FIXNUM-2-ARGS MULTIPLY-FIXNUM
(OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
(OBJECT->FIXNUM (CONSTANT 4))))
- (QUALIFIER (fixnum-operation-target? target))
+ (QUALIFIER (machine-operation-target? target))
(convert-index->fixnum/offset target r n))
;;; end (IF (<= SCHEME-TYPE-WIDTH 6) ...)
;;; not in use.
(define (convert-index->fixnum/register target source)
- (reuse-and-load-fixnum-target! target source
+ (reuse-and-load-machine-target! 'DATA target source
(lambda (target)
(LAP (LS L L (& ,(+ scheme-type-width 2)) ,target)))))
(define (convert-index->fixnum/offset target address offset)
(let ((source (indirect-reference! address offset)))
- (reuse-and-operate-on-fixnum-target! target
+ (reuse-and-operate-on-machine-target! 'DATA target
(lambda (target)
(LAP (MOV L ,source ,target)
(LS L L (& ,(+ scheme-type-width 2)) ,target))))))\f
-(define-rule statement
- (ASSIGN (? target)
- (FIXNUM-2-ARGS (? operator)
- (REGISTER (? source1))
- (REGISTER (? source2))))
- (QUALIFIER (and (fixnum-operation-target? target)
- (pseudo-register? source1)
- (pseudo-register? source2)))
- (let ((worst-case
- (lambda (target source1 source2)
- (LAP (MOV L ,source1 ,target)
- ,@((fixnum-2-args/operate operator) target source2))))
- (source-reference
- (if (eq? operator 'MULTIPLY-FIXNUM)
- standard-multiply-source
- (lambda (source) (standard-register-reference source 'DATA)))))
- (reuse-fixnum-target! target
- (lambda (target)
- (reuse-pseudo-register-alias! source1 'DATA
- (lambda (alias)
- (let ((source2 (if (= source1 source2)
- (register-reference alias)
- (source-reference source2))))
- (delete-dead-registers!)
- (add-pseudo-register-alias! target alias)
- ((fixnum-2-args/operate operator) (register-reference alias)
- source2)))
- (lambda ()
- (let ((new-target-alias!
- (lambda ()
- (let ((source1
- (standard-register-reference source1 'DATA))
- (source2 (source-reference source2)))
- (delete-dead-registers!)
- (worst-case (reference-target-alias! target 'DATA)
- source1
- source2)))))
- (if (fixnum-2-args/commutative? operator)
- (reuse-pseudo-register-alias source2 'DATA
- (lambda (alias2)
- (let ((source1 (source-reference source1)))
- (delete-machine-register! alias2)
- (delete-dead-registers!)
- (add-pseudo-register-alias! target alias2)
- ((fixnum-2-args/operate operator)
- (register-reference alias2)
- source1)))
- new-target-alias!)
- (new-target-alias!))))))
- (lambda (target)
- (worst-case target
- (standard-register-reference source1 'DATA)
- (source-reference source2))))))
-
-(define (standard-multiply-source register)
- (let ((alias (register-alias register 'DATA)))
- (cond (alias
- (register-reference alias))
- ((register-saved-into-home? register)
- (pseudo-register-home register))
- (else
- (reference-alias-register! register 'DATA)))))
-\f
;;;; Flonum Operations
(define-rule statement
flonum-size
(INST-EA (@A+ 5)))
(FMOVE D
- ,(float-register-reference source)
+ ,(machine-register-reference source 'FLOAT)
(@A+ 5)))))
(define-rule statement
,(reference-target-alias! target 'FLOAT))))
(define-rule statement
- (ASSIGN (REGISTER (? target))
+ (ASSIGN (? target)
(FLONUM-1-ARG (? operator) (REGISTER (? source))))
- (QUALIFIER (and (pseudo-float? target) (pseudo-float? source)))
- (let ((source-reference (float-register-reference source)))
- (let ((target-reference (float-target-reference target)))
- (LAP ,@((flonum-1-arg/operate operator)
- source-reference
- target-reference)))))
+ (QUALIFIER (and (machine-operation-target? target)
+ (pseudo-float? source)))
+ (let ((operate-on-target
+ (lambda (target)
+ ((flonum-1-arg/operate operator)
+ (standard-register-reference source 'FLOAT false)
+ target))))
+ (reuse-machine-target! 'FLOAT target
+ (lambda (target)
+ (operate-on-target (reference-target-alias! target 'FLOAT)))
+ operate-on-target)))
(define-rule statement
- (ASSIGN (REGISTER (? target))
+ (ASSIGN (? target)
(FLONUM-2-ARGS (? operator)
(REGISTER (? source1))
(REGISTER (? source2))))
- (QUALIFIER (and (pseudo-float? target)
+ (QUALIFIER (and (machine-operation-target? target)
(pseudo-float? source1)
(pseudo-float? source2)))
- (let ((source1-reference (float-register-reference source1))
- (source2-reference (float-register-reference source2)))
- (let ((target-reference (float-target-reference target)))
- (LAP (FMOVE ,source1-reference ,target-reference)
- ,@((flonum-2-args/operate operator)
- source2-reference
- target-reference)))))\f
+ (let ((source-reference
+ (lambda (source) (standard-register-reference source 'FLOAT false))))
+ (two-arg-register-operation (flonum-2-args/operate operator)
+ (flonum-2-args/commutative? operator)
+ 'FLOAT
+ source-reference
+ source-reference
+ target
+ source1
+ source2)))
+\f
;;;; CHAR->ASCII/BYTE-OFFSET
(define (load-char-into-register type source target)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.9 1989/08/28 18:34:18 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.10 1989/10/26 07:37:56 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(let ((finish-1
(lambda (alias)
(finish (register-reference alias)
- (standard-register-reference register-2 'DATA)
+ (standard-register-reference register-2 'DATA true)
cc)))
(finish-2
(lambda (alias)
(finish (register-reference alias)
- (standard-register-reference register-1 'DATA)
+ (standard-register-reference register-1 'DATA true)
(invert-cc-noncommutative cc)))))
(let ((try-type
(lambda (type continue)
(finish-1 (load-alias-register! register-1 'DATA)))))))))))
(define (compare/register*memory register memory cc)
- (let ((reference (standard-register-reference register 'DATA)))
+ (let ((reference (standard-register-reference register 'DATA true)))
(if (effective-address/register? reference)
(begin
(set-standard-branches! cc)
(set-standard-branches! 'NE)
(LAP ,(test-non-pointer (ucode-type false)
0
- (standard-register-reference register false))))
+ (standard-register-reference register false true))))
(define-rule predicate
(TRUE-TEST (? memory))
(set-standard-branches! 'EQ)
(LAP ,(test-non-pointer (ucode-type unassigned)
0
- (standard-register-reference register 'DATA))))
+ (standard-register-reference register 'DATA true))))
(define-rule predicate
(UNASSIGNED-TEST (? memory))
(set-standard-branches! 'EQ)
(LAP ,(test-non-pointer-constant
constant
- (standard-register-reference register 'DATA))))
+ (standard-register-reference register 'DATA true))))
(compare/register*memory register
(INST-EA (@PCR ,(constant->label constant)))
'EQ)))
(eq-test/constant*memory constant
(predicate/memory-operand-reference memory)))
\f
-;;;; Fixnum Predicates
+;;;; Fixnum/Flonum Predicates
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
(QUALIFIER (pseudo-register? register))
(set-standard-branches! (fixnum-predicate->cc predicate))
- (test-fixnum (standard-register-reference register 'DATA)))
+ (test-fixnum (standard-register-reference register 'DATA true)))
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (? memory))
(define (fixnum-predicate/register*constant register constant cc)
(set-standard-branches! cc)
(guarantee-signed-fixnum constant)
- (let ((reference (standard-register-reference register 'DATA)))
+ (let ((reference (standard-register-reference register 'DATA true)))
(if (effective-address/register? reference)
(LAP (CMP L (& ,(* constant fixnum-1)) ,reference))
(LAP (CMPI L (& ,(* constant fixnum-1)) ,reference)))))
(predicate/memory-operand-reference memory)
constant
(invert-cc-noncommutative (fixnum-predicate->cc predicate))))
-\f
-;;;; Flonum Predicates
(define-rule predicate
(FLONUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
(QUALIFIER (pseudo-float? register))
(set-flonum-branches! (flonum-predicate->cc predicate))
- (LAP (FTST ,(float-register-reference register))))
+ (LAP (FTST ,(standard-register-reference register 'FLOAT false))))
(define-rule predicate
(FLONUM-PRED-2-ARGS (? predicate)
(REGISTER (? register2)))
(QUALIFIER (and (pseudo-float? register1) (pseudo-float? register2)))
(set-flonum-branches! (flonum-predicate->cc predicate))
- (LAP (FCMP ,(float-register-reference register2)
- ,(float-register-reference register1))))
\ No newline at end of file
+ (LAP (FCMP ,(standard-register-reference register2 'FLOAT false)
+ ,(standard-register-reference register1 'FLOAT false))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.17 1989/08/28 18:34:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.18 1989/10/26 07:38:00 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
environment-offset
free-ref-offset
n-sections)
- (LAP (MOV L (@PCR ,code-block-label) (D 0))
- (AND L ,mask-reference (D 0))
- (MOV L (D 0) (A 0))
- (LEA (@AO 0 ,environment-offset) (A 1))
- (MOV L ,reg:environment (@A 1))
- (LEA (@AO 0 ,free-ref-offset) (A 1))
- ,(load-dnw n-sections 0)
- (JSR ,entry:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))))
+ (let ((load-offset
+ (lambda (offset)
+ (if (<= -32768 offset 32767)
+ (INST (LEA (@AO 0 ,offset) (A 1)))
+ (INST (LEA (@AOF 0 E (,offset L) #F
+ ((D 0) L 1) Z
+ (0 N))
+ (A 1)))))))
+ (LAP (MOV L (@PCR ,code-block-label) (D 0))
+ (AND L ,mask-reference (D 0))
+ (MOV L (D 0) (A 0))
+ ,(load-offset environment-offset)
+ (MOV L ,reg:environment (@A 1))
+ ,(load-offset free-ref-offset)
+ ,(load-dnw n-sections 0)
+ (JSR ,entry:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label)))))
\f
(define (generate/constants-block constants references assignments uuo-links)
(let ((constant-info
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.6 1989/08/28 18:34:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.7 1989/10/26 07:38:05 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(define (assignment-call:cons-pointer entry environment name type datum)
(let ((set-environment (expression->machine-register! environment a0)))
- (let ((datum (standard-register-reference datum false)))
+ (let ((datum (standard-register-reference datum false true)))
(let ((clear-map (clear-map!)))
(LAP ,@set-environment
(MOV L ,datum ,reg:temp)
(CONS-POINTER (CONSTANT (? type))
(REGISTER (? datum))))
(let ((set-extension (expression->machine-register! extension a0)))
- (let ((datum (standard-register-reference datum false))) (let ((clear-map (clear-map!)))
+ (let ((datum (standard-register-reference datum false true)))
+ (let ((clear-map (clear-map!)))
(LAP ,@set-extension
(MOV L ,datum ,reg:temp)
,(memory-set-type type reg:temp)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 4.5 1989/07/25 12:37:46 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 4.6 1989/10/26 07:38:21 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
register-n-deaths
register-live-length
register-crosses-call?
- register-value-classes
- )
+ register-value-classes)
+
+(define (add-rgraph-bblock! rgraph bblock)
+ (set-rgraph-bblocks! rgraph (cons bblock (rgraph-bblocks rgraph))))
+
+(define (delete-rgraph-bblock! rgraph bblock)
+ (set-rgraph-bblocks! rgraph (delq! bblock (rgraph-bblocks rgraph))))
+
(define (add-rgraph-non-object-register! rgraph register)
(set-rgraph-non-object-registers!
rgraph
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 4.7 1989/04/15 18:06:41 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 4.8 1989/10/26 07:38:24 cph Rel $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
(define (make-pblock instructions)
(make-pnode pblock-tag instructions false false false false '() false false))
-(define-vector-slots rinst 0
- rtl
- dead-registers
- next)
-
-(define (make-rtl-instruction rtl)
- (vector rtl '() false))
-
(define-integrable (statement->srtl statement)
(snode->scfg (make-sblock (make-rtl-instruction statement))))
consequent-lap-generator
alternative-lap-generator)))))
\f
-(define-integrable (rinst-dead-register? rinst register)
- (memq register (rinst-dead-registers rinst)))
-
-(define (rinst-last rinst)
- (if (rinst-next rinst)
- (rinst-last (rinst-next rinst))
- rinst))
-
-(define (bblock-compress! bblock)
- (if (not (node-marked? bblock))
- (begin
- (node-mark! bblock)
- (if (sblock? bblock)
- (let ((next (snode-next bblock)))
- (if next
- (begin
- (if (null? (cdr (node-previous-edges next)))
- (begin
- (set-rinst-next!
- (rinst-last (bblock-instructions bblock))
- (bblock-instructions next))
- (set-bblock-instructions!
- next
- (bblock-instructions bblock))
- (snode-delete! bblock)))
- (bblock-compress! next))))
- (begin (let ((consequent (pnode-consequent bblock)))
- (if consequent
- (bblock-compress! consequent)))
- (let ((alternative (pnode-alternative bblock)))
- (if alternative
- (bblock-compress! alternative))))))))
+(define-integrable (bblock-reversed-instructions bblock)
+ (rinst-reversed (bblock-instructions bblock)))
+
+(define (bblock-compress! bblock limit-predicate)
+ (let ((walk-next?
+ (if limit-predicate
+ (lambda (next) (and next (not (limit-predicate next))))
+ (lambda (next) next))))
+ (let walk-bblock ((bblock bblock))
+ (if (not (node-marked? bblock))
+ (begin
+ (node-mark! bblock)
+ (if (sblock? bblock)
+ (let ((next (snode-next bblock)))
+ (if (walk-next? next)
+ (begin
+ (if (null? (cdr (node-previous-edges next)))
+ (begin
+ (set-rinst-next!
+ (rinst-last (bblock-instructions bblock))
+ (bblock-instructions next))
+ (set-bblock-instructions!
+ next
+ (bblock-instructions bblock))
+ (snode-delete! bblock)))
+ (walk-bblock next))))
+ (begin
+ (let ((consequent (pnode-consequent bblock)))
+ (if (walk-next? consequent)
+ (walk-bblock consequent)))
+ (let ((alternative (pnode-alternative bblock)))
+ (if (walk-next? alternative)
+ (walk-bblock alternative))))))))))
(define (bblock-walk-forward bblock procedure)
(let loop ((rinst (bblock-instructions bblock)))
(cfg-node-get pnode cfg/prefer-branch/tag))
(define cfg/prefer-branch/tag
- (intern "#[(compiler)cfg/prefer-branch]"))
\ No newline at end of file
+ (intern "#[(compiler)cfg/prefer-branch]"))
+
+;;;; RTL Instructions
+
+(define-vector-slots rinst 0
+ rtl
+ dead-registers
+ next)
+
+(define (make-rtl-instruction rtl)
+ (vector rtl '() false))
+
+(define-integrable (rinst-dead-register? rinst register)
+ (memq register (rinst-dead-registers rinst)))
+
+(define (rinst-last rinst)
+ (if (rinst-next rinst)
+ (rinst-last (rinst-next rinst))
+ rinst))
+
+(define (rinst-disconnect-previous! bblock rinst)
+ (let loop ((rinst* (bblock-instructions bblock)))
+ (if (eq? rinst (rinst-next rinst*))
+ (set-rinst-next! rinst* false)
+ (loop (rinst-next rinst*)))))
+
+(define (rinst-length rinst)
+ (let loop ((rinst rinst) (length 0))
+ (if rinst
+ (loop (rinst-next rinst) (1+ length))
+ length)))
+
+(define (rinst-reversed rinst)
+ (let loop ((rinst rinst) (result '()))
+ (if rinst
+ (loop (rinst-next rinst) (cons rinst result))
+ result)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.17 1989/07/25 12:37:32 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.18 1989/10/26 07:38:28 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
((or (rtl:machine-register-expression? locative)
(rtl:trivial-expression? expression))
(%make-assign locative expression))
+ ((and (or (rtl:register? locative)
+ (rtl:offset? expression))
+ (equal? locative expression))
+ (make-null-cfg))
(else
(let ((register (rtl:make-pseudo-register)))
(scfg*scfg->scfg! (assign-register register)
(%make-assign locative register)))))))
-
+\f
(define (rtl:make-eq-test expression-1 expression-2)
(expression-simplify-for-predicate expression-1
(lambda (expression-1)
(if (rtl:trivial-expression? expression)
(receiver expression)
(assign-to-temporary expression scfg-append! receiver)))))
- (let ((entry (assq (car expression) expression-methods)))
- (if entry
- (apply (cdr entry) receiver scfg-append! (cdr expression))
- (receiver expression)))))
+ (if (rtl:trivial-expression? expression)
+ (receiver expression)
+ (let ((entry (assq (car expression) expression-methods)))
+ (if entry
+ (apply (cdr entry) receiver scfg-append! (cdr expression))
+ (receiver expression))))))
(define (assign-to-temporary expression scfg-append! receiver)
(let ((pseudo (rtl:make-pseudo-register)))
(expression-simplify operand scfg-append!
(lambda (operand)
(receiver (rtl:make-fixnum-1-arg operator operand))))))
-\f
+
(define-expression-method 'GENERIC-BINARY
(lambda (receiver scfg-append! operator operand1 operand2)
(expression-simplify operand1 scfg-append!
(expression-simplify operand scfg-append!
(lambda (operand)
(receiver (rtl:make-generic-unary operator operand))))))
-\f(define-expression-method 'FLONUM-1-ARG
+
+(define-expression-method 'FLONUM-1-ARG
(lambda (receiver scfg-append! operator operand)
(expression-simplify operand scfg-append!
(lambda (s-operand)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.12 1989/07/25 12:37:17 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.13 1989/10/26 07:38:32 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
'(INVOCATION-PREFIX:DYNAMIC-LINK
INVOCATION-PREFIX:MOVE-FRAME-UP)))
-(define-integrable (rtl:trivial-expression? expression)
- (memq (rtl:expression-type expression)
- '(ASSIGNMENT-CACHE
- CONS-CLOSURE
- CONSTANT
- ENTRY:CONTINUATION
- ENTRY:PROCEDURE
- REGISTER
- UNASSIGNED
- VARIABLE-CACHE)))
+(define (rtl:trivial-expression? expression)
+ (case (rtl:expression-type expression)
+ ((ASSIGNMENT-CACHE
+ CONS-CLOSURE
+ CONSTANT
+ ENTRY:CONTINUATION
+ ENTRY:PROCEDURE
+ REGISTER
+ UNASSIGNED
+ VARIABLE-CACHE)
+ true)
+ ((OBJECT->FIXNUM OBJECT->UNSIGNED-FIXNUM)
+ (rtl:constant? (rtl:object->fixnum-expression expression)))
+ ((OBJECT->DATUM)
+ (let ((subexpression (rtl:object->datum-expression expression)))
+ (and (rtl:constant? subexpression)
+ (non-pointer-object? (rtl:constant-value subexpression)))))
+ ((OBJECT->TYPE)
+ (rtl:constant? (rtl:object->type-expression expression)))
+ (else
+ false)))
+
(define (rtl:non-object-valued-expression? expression)
(if (rtl:register? expression)
(register-contains-non-object? (rtl:register-number expression))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.9 1989/08/21 19:34:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.10 1989/10/26 07:38:35 cph Rel $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(node-mark! bblock)
(queue-continuations! bblock)
(if (and (not (bblock-label bblock))
- (let ((edges (node-previous-edges bblock)))
- (and (not (null? edges))
- (not (null? (cdr edges))))))
+ (node-previous>1? bblock))
(bblock-label! bblock))
(let ((kernel
(lambda ()
(let loop ((rinst (bblock-instructions bblock)))
(cond ((rinst-next rinst)
- (cons (rinst-rtl rinst)
- (loop (rinst-next rinst))))
+ (cons (rinst-rtl rinst) (loop (rinst-next rinst))))
((sblock? bblock)
(cons (rinst-rtl rinst)
(let ((next (snode-next bblock)))
(alternative (linearize-bblock an)))
`(,(rtl:make-jumpc-statement predicate clabel)
,@alternative
- ,@(if (node-marked? cn)
- '()
- (linearize-bblock cn))))))))))
+ ,@(if (node-marked? cn) '() (linearize-bblock cn))))))))))
(linearize-bblock bblock))
(define linearize-rtl
(make-linearizer bblock-linearize-rtl
- (lambda ()
- (let ((value (list false)))
- (cons value value))) (lambda (accumulator instructions)
+ (lambda () (let ((value (list false))) (cons value value)))
+ (lambda (accumulator instructions)
(set-cdr! (cdr accumulator) instructions)
(set-cdr! accumulator (last-pair instructions))
accumulator)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.6 1988/11/08 08:24:57 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.7 1989/10/26 07:38:39 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
-(define-integrable rtl:expression-type first)
-(define-integrable rtl:address-register second)
-(define-integrable rtl:address-number third)
-(define-integrable rtl:invocation-pushed second)
-(define-integrable rtl:invocation-continuation third)
-(define-integrable rtl:test-expression second)
+(define-integrable rtl:expression-type car)
+(define-integrable rtl:address-register cadr)
+(define-integrable rtl:address-number caddr)
+(define-integrable rtl:test-expression cadr)
+(define-integrable rtl:invocation-pushed cadr)
+(define-integrable rtl:invocation-continuation caddr)
+
+(define-integrable (rtl:set-invocation-continuation! rtl continuation)
+ (set-car! (cddr rtl) continuation))
(define (rtl:make-constant value)
(if (unassigned-reference-trap? value)
(rtl:make-unassigned)
(%make-constant value)))
-\f
+
;;;; Locatives
;;; Locatives are used as an intermediate form by the code generator
(define-integrable (rtl:interpreter-call-result:unbound?)
(rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNBOUND?))
-
\f
;;; "Pre-simplification" locative offsets
(quotient scheme-object-width 8))))
BYTE))
(else `(OFFSET ,locative ,byte-offset BYTE))))
+\f
+;;; Expressions that are used in the intermediate form.
+
+(define-integrable (rtl:make-address locative)
+ `(ADDRESS ,locative))
+
+(define-integrable (rtl:make-environment locative)
+ `(ENVIRONMENT ,locative))
+
+(define-integrable (rtl:make-cell-cons expression)
+ `(CELL-CONS ,expression))
+
+(define-integrable (rtl:make-fetch locative)
+ `(FETCH ,locative))
+
+(define-integrable (rtl:make-typed-cons:pair type car cdr)
+ `(TYPED-CONS:PAIR ,type ,car ,cdr))
+
+(define-integrable (rtl:make-typed-cons:vector type elements)
+ `(TYPED-CONS:VECTOR ,type ,@elements))
+
+(define-integrable (rtl:make-typed-cons:procedure label arg-info nvars)
+ `(TYPED-CONS:PROCEDURE ,label ,arg-info ,nvars))
+
+;;; Linearizer Support
+
+(define-integrable (rtl:make-jump-statement label)
+ `(JUMP ,label))
+
+(define-integrable (rtl:make-jumpc-statement predicate label)
+ `(JUMPC ,predicate ,label))
+
+(define-integrable (rtl:make-label-statement label)
+ `(LABEL ,label))
+
+(define-integrable (rtl:negate-predicate expression)
+ `(NOT ,expression))
+
+;;; Stack
+
+(define-integrable (stack-locative-offset locative offset)
+ (rtl:locative-offset locative (stack->memory-offset offset)))
+
+(define-integrable (stack-push-address)
+ (rtl:make-pre-increment (interpreter-stack-pointer)
+ (stack->memory-offset -1)))
+(define-integrable (stack-pop-address)
+ (rtl:make-post-increment (interpreter-stack-pointer)
+ (stack->memory-offset 1)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.2 1989/04/21 17:10:02 markf Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.3 1989/10/26 07:38:52 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(continuation/register continuation)
register:value)))
(find-variable-internal context variable
- (lambda (locative)
+ (lambda (variable locative)
(if-compiler
(if (variable-in-cell? variable)
(rtl:make-fetch locative)
locative)))
- (lambda (block locative)
+ (lambda (variable block locative)
(cond ((variable-in-known-location? context variable)
(if-compiler
(rtl:locative-offset locative
(define (find-closure-variable context variable)
(find-variable-internal context variable
- identity-procedure
- (lambda (block locative)
+ (lambda (variable locative)
+ variable
+ locative)
+ (lambda (variable block locative)
block locative
(error "Closure variable in IC frame" variable))))
(if (procedure/trivial-closure? rvalue)
(error "Trivial closure value encountered"))
(if-compiler
+ variable
(block-ancestor-or-self->locative
context
(procedure-block rvalue)
0
(procedure-closure-offset rvalue))))
- (let ((register (variable/register variable)))
- (if register
- (if-compiler (register-locative register))
- (find-block/variable context variable
- (lambda (offset-locative)
- (lambda (block locative)
- (if-compiler
- (offset-locative locative (variable-offset block variable)))))
- if-ic))))))\f
+ (let loop ((variable variable))
+ (let ((indirection (variable-indirection variable)))
+ (if indirection
+ (loop indirection)
+ (let ((register (variable/register variable)))
+ (if register
+ (if-compiler variable (register-locative register))
+ (find-block/variable context variable
+ (lambda (offset-locative)
+ (lambda (block locative)
+ (if-compiler
+ variable
+ (offset-locative
+ locative
+ (variable-offset block variable)))))
+ (lambda (block locative)
+ (if-ic variable block locative)))))))))))
+\f
(define (find-definition-variable context lvalue)
(find-block/variable context lvalue
(lambda (offset-locative)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.31 1989/09/05 22:34:52 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.32 1989/10/26 07:38:56 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(define (try-handler combination primitive entry)
(let ((operands (combination/operands combination)))
(and (primitive-arity-correct? primitive (length operands))
- (let ((result ((vector-ref entry 0) operands)))
- (and result
- (transmit-values result
- (lambda (generator indices)
- (make-inliner entry generator indices))))))))
+ (with-values (lambda () ((vector-ref entry 0) operands))
+ (lambda (generator indices internal-close-coding?)
+ (and generator
+ (make-inliner entry
+ generator
+ indices
+ internal-close-coding?)))))))
\f
;;;; Code Generator
(define (combination/inline combination)
- (let ((context (combination/context combination))
- (inliner (combination/inliner combination)))
- (generate/return* context
- (combination/continuation combination)
- (combination/continuation-push combination)
- (let ((handler (inliner/handler inliner))
- (generator (inliner/generator inliner))
- (expressions
- (map subproblem->expression
- (inliner/operands inliner))))
- (make-return-operand
- (lambda ()
- ((vector-ref handler 1) generator
- context
- expressions))
- (lambda (finish)
- ((vector-ref handler 2) generator
- context
- expressions
- finish))
- (lambda (finish)
- ((vector-ref handler 3) generator
- context
- expressions
- finish))
- false)))))
-
-(define (combination/inline/simple? combination)
- (not (memq (primitive-procedure-name
- (constant-value
- (rvalue-known-value (combination/operator combination))))
- non-simple-primitive-names)))
+ (let ((inliner (combination/inliner combination)))
+ (let ((finish
+ (lambda (context operand->expression)
+ (generate/return*
+ context
+ (combination/continuation combination)
+ (combination/continuation-push combination)
+ (let ((handler (inliner/handler inliner))
+ (generator (inliner/generator inliner))
+ (expressions
+ (map operand->expression (inliner/operands inliner))))
+ (make-return-operand (lambda ()
+ ((vector-ref handler 1) generator
+ combination
+ expressions))
+ (lambda (finish)
+ ((vector-ref handler 2) generator
+ combination
+ expressions
+ finish))
+ (lambda (finish)
+ ((vector-ref handler 3) generator
+ combination
+ expressions
+ finish))
+ false))))))
+ (if (and (inliner/internal-close-coding? inliner)
+ (combination/reduction? combination))
+ (let ((prefix (generate/invocation-prefix combination))
+ (invocation
+ (finish
+ ;; This value of context is a special kludge. See
+ ;; `generate/return*' for the details.
+ (length (inliner/operands inliner))
+ index->stack-reference)))
+ (if prefix
+ (scfg*scfg->scfg!
+ (prefix (combination/frame-size combination) 0)
+ invocation)
+ invocation))
+ (finish (combination/context combination) subproblem->expression)))))
(define (subproblem->expression subproblem)
(let ((rvalue (subproblem-rvalue subproblem)))
(rtl:make-fetch
(continuation*/register
(subproblem-continuation subproblem))))))))
+
+(define (index->stack-reference index)
+ (rtl:make-fetch
+ (stack-locative-offset (rtl:make-fetch register:stack-pointer) index)))
+
+(define-integrable (combination/reduction? combination)
+ (return-operator/reduction? (combination/continuation combination)))
\f
-(define (invoke/effect->effect generator context expressions)
- (generator context expressions false))
-
-(define (invoke/predicate->value generator context expressions finish)
- (generator context expressions
- (lambda (pcfg)
- (let ((temporary (rtl:make-pseudo-register)))
- ;; Force assignments to be made first.
- (let ((consequent
- (rtl:make-assignment temporary (rtl:make-constant true)))
- (alternative
- (rtl:make-assignment temporary (rtl:make-constant false))))
- (scfg*scfg->scfg!
- (pcfg*scfg->scfg! pcfg consequent alternative)
- (finish (rtl:make-fetch temporary))))))))
-
-(define (invoke/value->effect generator context expressions)
- generator context expressions
+(define (invoke/effect->effect generator combination expressions)
+ (generator combination expressions false))
+
+(define (invoke/effect->predicate generator combination expressions finish)
+ (generator combination expressions
+ (lambda (expression)
+ (finish (rtl:make-true-test expression)))))
+
+(define (invoke/effect->value generator combination expressions finish)
+ (generator combination expressions finish))
+
+(define (invoke/predicate->effect generator combination expressions)
+ generator combination expressions
+ (make-null-cfg))
+
+(define (invoke/predicate->predicate generator combination expressions finish)
+ (generator combination expressions finish))
+
+(define (invoke/predicate->value generator combination expressions finish)
+ (generator combination expressions (finish/predicate->value finish)))
+
+(define ((finish/predicate->value finish) pcfg)
+ (pcfg*scfg->scfg! pcfg
+ (finish (rtl:make-constant true))
+ (finish (rtl:make-constant false))))
+
+(define (invoke/value->effect generator combination expressions)
+ generator combination expressions
(make-null-cfg))
-(define (invoke/value->predicate generator context expressions finish)
- (generator context expressions
+(define (invoke/value->predicate generator combination expressions finish)
+ (generator combination expressions
(lambda (expression)
(finish (rtl:make-true-test expression)))))
-(define (invoke/value->value generator context expressions finish)
- (generator context expressions finish))
+(define (invoke/value->value generator combination expressions finish)
+ (generator combination expressions finish))
\f
;;;; Definers
(define define-open-coder/effect
(open-coder-definer invoke/effect->effect
- invoke/value->predicate
- invoke/value->value))
+ invoke/effect->predicate
+ invoke/effect->value))
(define define-open-coder/predicate
- (open-coder-definer invoke/value->effect
- invoke/value->value
+ (open-coder-definer invoke/predicate->effect
+ invoke/predicate->predicate
invoke/predicate->value))
+(define define-open-coder/generic-predicate
+ (open-coder-definer
+ invoke/predicate->effect
+ (lambda (generator combination expressions finish)
+ (generator combination expressions true finish))
+ (lambda (generator combination expressions finish)
+ (generator combination expressions false finish))))
+
(define define-open-coder/value
(open-coder-definer invoke/value->effect
invoke/value->predicate
invoke/value->value))
-
-(define (define-non-simple-primitive! name)
- (if (not (memq name non-simple-primitive-names))
- (set! non-simple-primitive-names (cons name non-simple-primitive-names)))
- unspecific)
-
-(define non-simple-primitive-names
- '())
\f
;;;; Operand Filters
-(define (simple-open-coder generator operand-indices)
+(define (simple-open-coder generator operand-indices internal-close-coding?)
(lambda (operands)
operands
- (return-2 generator operand-indices)))
+ (values generator operand-indices internal-close-coding?)))
(define (constant-filter predicate)
- (lambda (generator constant-index operand-indices)
+ (lambda (generator constant-index operand-indices internal-close-coding?)
(lambda (operands)
(let ((operand (rvalue-known-value (list-ref operands constant-index))))
- (and operand
- (rvalue/constant? operand)
- (let ((value (constant-value operand)))
- (and (predicate value)
- (return-2 (generator value) operand-indices))))))))
+ (if (and operand
+ (rvalue/constant? operand)
+ (predicate (constant-value operand)))
+ (values (generator (constant-value operand))
+ operand-indices
+ internal-close-coding?)
+ (values false false false))))))
(define filter/nonnegative-integer
- (constant-filter
- (lambda (value) (and (integer? value) (not (negative? value))))))
+ (constant-filter exact-nonnegative-integer?))
(define filter/positive-integer
(constant-filter
- (lambda (value) (and (integer? value) (positive? value)))))
+ (lambda (value) (and (exact-integer? value) (positive? value)))))
\f
;;;; Constraint Checkers
-(define (open-code:with-checks context checks non-error-cfg error-finish
+(define (open-code:with-checks combination checks non-error-cfg error-finish
primitive-name expressions)
(let ((checks (list-transform-negative checks cfg-null?)))
(if (null? checks)
;; it creates some unreachable code which we can't easily
;; remove from the output afterwards.
(let ((error-cfg
- (with-values (lambda () (generate-continuation-entry context))
- (lambda (label setup cleanup)
- (scfg-append!
- (generate-primitive primitive-name expressions setup label)
- cleanup
- (if error-finish
- (error-finish (rtl:make-fetch register:value))
- (make-null-cfg)))))))
+ (if (combination/reduction? combination)
+ (let ((scfg
+ (generate-primitive primitive-name '() false false)))
+ (make-scfg (cfg-entry-node scfg) '()))
+ (with-values
+ (lambda ()
+ (generate-continuation-entry
+ (combination/context combination)))
+ (lambda (label setup cleanup)
+ (scfg-append!
+ (generate-primitive primitive-name
+ expressions
+ setup
+ label)
+ cleanup
+ (if error-finish
+ (error-finish (rtl:make-fetch register:value))
+ (make-null-cfg))))))))
(let loop ((checks checks))
(if (null? checks)
non-error-cfg
(define (generate-primitive name argument-expressions
continuation-setup continuation-label)
(scfg*scfg->scfg!
- (let loop ((args argument-expressions))
- (if (null? args)
- (scfg*scfg->scfg! continuation-setup
- (rtl:make-push-return continuation-label))
- (load-temporary-register scfg*scfg->scfg! (car args)
- (lambda (temporary)
- (scfg*scfg->scfg! (loop (cdr args))
- (rtl:make-push temporary))))))
+ (if continuation-label
+ (let loop ((args argument-expressions))
+ (if (null? args)
+ (scfg*scfg->scfg! continuation-setup
+ (rtl:make-push-return continuation-label))
+ (load-temporary-register scfg*scfg->scfg! (car args)
+ (lambda (temporary)
+ (scfg*scfg->scfg! (loop (cdr args))
+ (rtl:make-push temporary))))))
+ (make-null-cfg))
(let ((primitive (make-primitive-procedure name true)))
((or (special-primitive-handler primitive)
rtl:make-invocation:primitive)
(define (indexed-memory-reference type length-expression index-locative)
(lambda (name value-type generator)
- (lambda (context expressions finish)
+ (lambda (combination expressions finish)
(let ((object (car expressions))
(index (cadr expressions)))
(open-code:with-checks
- context
+ combination
(cons*
(open-code:type-check object type)
(open-code:type-check index (ucode-type fixnum))
(rtl:make-assignment locative (rtl:make-char->ascii value)))
(define (assignment-finisher make-assignment make-fetch)
+ make-fetch ;ignore
(lambda (locative value finish)
(let ((assignment (make-assignment locative value)))
(if finish
+#|
(load-temporary-register scfg*scfg->scfg! (make-fetch locative)
(lambda (temporary)
(scfg*scfg->scfg! assignment (finish temporary))))
+|#
+ (scfg*scfg->scfg! assignment (finish (rtl:make-constant unspecific)))
assignment))))
(define finish-vector-assignment
(define-open-coder/predicate 'NULL?
(simple-open-coder
- (lambda (context expressions finish)
- context
+ (lambda (combination expressions finish)
+ combination
(finish (pcfg-invert (rtl:make-true-test (car expressions)))))
- '(0)))
+ '(0)
+ false))
(let ((open-code/type-test
(lambda (type)
- (lambda (context expressions finish)
- context
+ (lambda (combination expressions finish)
+ combination
(finish
(rtl:make-type-test (rtl:make-object->type (car expressions))
type))))))
(let ((simple-type-test
(lambda (name type)
(define-open-coder/predicate name
- (simple-open-coder (open-code/type-test type) '(0))))))
+ (simple-open-coder (open-code/type-test type) '(0) false)))))
(simple-type-test 'PAIR? (ucode-type pair))
(simple-type-test 'STRING? (ucode-type string))
(simple-type-test 'BIT-STRING? (ucode-type vector-1b)))
(define-open-coder/predicate 'OBJECT-TYPE?
- (filter/nonnegative-integer open-code/type-test 0 '(1))))
+ (filter/nonnegative-integer open-code/type-test 0 '(1) false)))
(define-open-coder/predicate 'EQ?
(simple-open-coder
- (lambda (context expressions finish)
- context
+ (lambda (combination expressions finish)
+ combination
(finish (rtl:make-eq-test (car expressions) (cadr expressions))))
- '(0 1)))
+ '(0 1)
+ false))
\f
(let ((open-code/pair-cons
(lambda (type)
- (lambda (context expressions finish)
- context
+ (lambda (combination expressions finish)
+ combination
(finish
(rtl:make-typed-cons:pair (rtl:make-constant type)
(car expressions)
(cadr expressions)))))))
(define-open-coder/value 'CONS
- (simple-open-coder (open-code/pair-cons (ucode-type pair)) '(0 1)))
+ (simple-open-coder (open-code/pair-cons (ucode-type pair)) '(0 1) false))
(define-open-coder/value 'SYSTEM-PAIR-CONS
- (filter/nonnegative-integer open-code/pair-cons 0 '(1 2))))
+ (filter/nonnegative-integer open-code/pair-cons 0 '(1 2) false)))
(define-open-coder/value 'VECTOR
(lambda (operands)
- (and (< (length operands) 32)
- (return-2 (lambda (context expressions finish)
- context
- (finish
- (rtl:make-typed-cons:vector
- (rtl:make-constant (ucode-type vector))
- expressions)))
- (all-operand-indices operands)))))
+ (if (< (length operands) 32)
+ (values (lambda (combination expressions finish)
+ combination
+ (finish
+ (rtl:make-typed-cons:vector
+ (rtl:make-constant (ucode-type vector))
+ expressions)))
+ (all-operand-indices operands)
+ false)
+ (values false false false))))
(define (all-operand-indices operands)
(let loop ((operands operands) (index 0))
(define-open-coder/value 'STRING-ALLOCATE
(simple-open-coder
- (lambda (context expressions finish)
+ (lambda (combination expressions finish)
(let ((length (car expressions)))
(open-code:with-checks
- context
+ combination
(list (open-code:nonnegative-check length))
(finish
(rtl:make-typed-cons:string
finish
'STRING-ALLOCATE
expressions)))
- '(0)))
+ '(0)
+ compiler:generate-range-checks?))
|#
\f
-(let ((make-fixed-ref
+(let ((user-ref
(lambda (name make-fetch type index)
- (lambda (context expressions finish)
+ (define-open-coder/value name
+ (simple-open-coder
+ (lambda (combination expressions finish)
+ (let ((expression (car expressions)))
+ (open-code:with-checks
+ combination
+ (list (open-code:type-check expression type))
+ (finish (make-fetch (rtl:locative-offset expression index)))
+ finish
+ name
+ expressions)))
+ '(0)
+ compiler:generate-type-checks?)))))
+ (user-ref 'CELL-CONTENTS rtl:make-fetch (ucode-type cell) 0)
+ (user-ref 'VECTOR-LENGTH rtl:length-fetch (ucode-type vector) 0)
+ (user-ref 'STRING-LENGTH rtl:length-fetch (ucode-type string) 1)
+ (user-ref 'BIT-STRING-LENGTH rtl:length-fetch (ucode-type vector-1b) 1)
+ (user-ref 'CAR rtl:make-fetch (ucode-type pair) 0)
+ (user-ref 'CDR rtl:make-fetch (ucode-type pair) 1))
+
+(let ((system-ref
+ (lambda (name make-fetch index)
+ (define-open-coder/value name
+ (simple-open-coder
+ (lambda (combination expressions finish)
+ combination
+ (finish
+ (make-fetch (rtl:locative-offset (car expressions) index))))
+ '(0)
+ false)))))
+ (system-ref 'SYSTEM-PAIR-CAR rtl:make-fetch 0)
+ (system-ref 'SYSTEM-PAIR-CDR rtl:make-fetch 1)
+ (system-ref 'SYSTEM-HUNK3-CXR0 rtl:make-fetch 0)
+ (system-ref 'SYSTEM-HUNK3-CXR1 rtl:make-fetch 1)
+ (system-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch 2))
+
+(let ((make-fixed-ref
+ (lambda (name index)
+ (lambda (combination expressions finish)
(let ((expression (car expressions)))
(open-code:with-checks
- context
- (if type (list (open-code:type-check expression type)) '())
- (finish (make-fetch (rtl:locative-offset expression index)))
+ combination
+ (list (open-code:type-check expression (ucode-type pair)))
+ (finish (rtl:make-fetch (rtl:locative-offset expression index)))
finish
name
- expressions)))))
- (standard-def
- (lambda (name fixed-ref)
- (define-open-coder/value name
- (simple-open-coder fixed-ref '(0))))))
- (let ((user-ref
- (lambda (name make-fetch type index)
- (standard-def name (make-fixed-ref name make-fetch type index)))))
- (user-ref 'CELL-CONTENTS rtl:make-fetch (ucode-type cell) 0)
- (user-ref 'VECTOR-LENGTH rtl:length-fetch (ucode-type vector) 0)
- (user-ref 'STRING-LENGTH rtl:length-fetch (ucode-type string) 1)
- (user-ref 'BIT-STRING-LENGTH rtl:length-fetch (ucode-type vector-1b) 1)
- (user-ref 'SYSTEM-PAIR-CAR rtl:make-fetch false 0)
- (user-ref 'SYSTEM-PAIR-CDR rtl:make-fetch false 1)
- (user-ref 'SYSTEM-HUNK3-CXR0 rtl:make-fetch false 0)
- (user-ref 'SYSTEM-HUNK3-CXR1 rtl:make-fetch false 1)
- (user-ref 'SYSTEM-HUNK3-CXR2 rtl:make-fetch false 2)
- (user-ref 'SYSTEM-VECTOR-SIZE rtl:vector-length-fetch false 0))
- (let ((car-ref (make-fixed-ref 'CAR rtl:make-fetch (ucode-type pair) 0))
- (cdr-ref (make-fixed-ref 'CDR rtl:make-fetch (ucode-type pair) 1)))
- (standard-def 'CAR car-ref)
- (standard-def 'CDR cdr-ref)
+ expressions))))))
+ (let ((car-ref (make-fixed-ref 'CAR 0))
+ (cdr-ref (make-fixed-ref 'CDR 1)))
(define-open-coder/value 'GENERAL-CAR-CDR
(filter/positive-integer
(lambda (pattern)
- (lambda (context expressions finish)
- context
- (finish
- (let loop ((pattern pattern) (expression (car expressions)))
- (if (= pattern 1)
- expression
- ((if (odd? pattern) car-ref cdr-ref)
- context
- (list expression)
- (lambda (expression)
- (loop (quotient pattern 2) expression))))))))
+ (if (= pattern 1)
+ (lambda (combination expressions finish)
+ combination
+ (finish (car expressions)))
+ (lambda (combination expressions finish)
+ (let loop ((pattern pattern)
+ (expression (car expressions)))
+ (let ((new-pattern (quotient pattern 2)))
+ ((if (odd? pattern) car-ref cdr-ref)
+ combination
+ (list expression)
+ (if (= new-pattern 1)
+ finish
+ (lambda (expression)
+ (loop new-pattern expression)))))))))
1
- '(0)))))
-
+ '(0)
+ compiler:generate-type-checks?))))
+\f
(for-each (lambda (name)
(define-open-coder/value name
(simple-open-coder
(lambda (locative expressions finish)
expressions
(finish (rtl:make-fetch locative))))
- '(0 1))))
+ '(0 1)
+ (or compiler:generate-type-checks?
+ compiler:generate-range-checks?))))
'(VECTOR-REF SYSTEM-VECTOR-REF))
-\f
+
;; For now SYSTEM-XXXX side effect procedures are considered
;; dangerous to the garbage collector's health. Some day we will
;; again be able to enable them.
(lambda (name type index)
(define-open-coder/effect name
(simple-open-coder
- (lambda (context expressions finish)
+ (lambda (combination expressions finish)
(let ((object (car expressions)))
(open-code:with-checks
- context
+ combination
(if type (list (open-code:type-check object type)) '())
(finish-vector-assignment (rtl:locative-offset object index)
(cadr expressions)
finish
name
expressions)))
- '(0 1))))))
+ '(0 1)
+ compiler:generate-type-checks?)))))
(fixed-assignment 'SET-CAR! (ucode-type pair) 0)
(fixed-assignment 'SET-CDR! (ucode-type pair) 1)
(fixed-assignment 'SET-CELL-CONTENTS! (ucode-type cell) 0)
(finish-vector-assignment locative
(caddr expressions)
finish)))
- '(0 1 2))))
+ '(0 1 2)
+ (or compiler:generate-type-checks?
+ compiler:generate-range-checks?))))
'(VECTOR-SET! #| SYSTEM-VECTOR-SET! |#))
\f
;;;; Character/String Primitives
(define-open-coder/value 'CHAR->INTEGER
(simple-open-coder
- (lambda (context expressions finish)
+ (lambda (combination expressions finish)
(let ((char (car expressions)))
(open-code:with-checks
- context
+ combination
(list (open-code:type-check char (ucode-type character)))
(finish
(rtl:make-cons-pointer
finish
'CHAR->INTEGER
expressions)))
- '(0)))
+ '(0)
+ compiler:generate-type-checks?))
(define-open-coder/value 'STRING-REF
(simple-open-coder
(lambda (locative expressions finish)
expressions
(finish (rtl:string-fetch locative))))
- '(0 1)))
+ '(0 1)
+ (or compiler:generate-type-checks?
+ compiler:generate-range-checks?)))
(define-open-coder/effect 'STRING-SET!
(simple-open-coder
(string-memory-reference 'STRING-SET! (ucode-type character)
(lambda (locative expressions finish)
(finish-string-assignment locative (caddr expressions) finish)))
- '(0 1 2)))
+ '(0 1 2)
+ (or compiler:generate-type-checks?
+ compiler:generate-range-checks?)))
\f
;;;; Fixnum Arithmetic
(for-each (lambda (fixnum-operator)
(define-open-coder/value fixnum-operator
(simple-open-coder
- (lambda (context expressions finish)
- context
+ (lambda (combination expressions finish)
+ combination
(finish
(rtl:make-fixnum->object
(rtl:make-fixnum-2-args
fixnum-operator
(rtl:make-object->fixnum (car expressions))
(rtl:make-object->fixnum (cadr expressions))))))
- '(0 1))))
+ '(0 1)
+ false)))
'(PLUS-FIXNUM
MINUS-FIXNUM
MULTIPLY-FIXNUM
(for-each (lambda (fixnum-operator)
(define-open-coder/value fixnum-operator
(simple-open-coder
- (lambda (context expressions finish)
- context
+ (lambda (combination expressions finish)
+ combination
(finish
(rtl:make-fixnum->object
(rtl:make-fixnum-1-arg
fixnum-operator
(rtl:make-object->fixnum (car expressions))))))
- '(0))))
+ '(0)
+ false)))
'(ONE-PLUS-FIXNUM MINUS-ONE-PLUS-FIXNUM))
(for-each (lambda (fixnum-pred)
(define-open-coder/predicate fixnum-pred
(simple-open-coder
- (lambda (context expressions finish)
- context
+ (lambda (combination expressions finish)
+ combination
(finish
(rtl:make-fixnum-pred-2-args
fixnum-pred
(rtl:make-object->fixnum (car expressions))
(rtl:make-object->fixnum (cadr expressions)))))
- '(0 1))))
+ '(0 1)
+ false)))
'(EQUAL-FIXNUM? LESS-THAN-FIXNUM? GREATER-THAN-FIXNUM?))
(for-each (lambda (fixnum-pred)
(define-open-coder/predicate fixnum-pred
(simple-open-coder
- (lambda (context expressions finish)
- context
+ (lambda (combination expressions finish)
+ combination
(finish
(rtl:make-fixnum-pred-1-arg
fixnum-pred
(rtl:make-object->fixnum (car expressions)))))
- '(0))))
+ '(0)
+ false)))
'(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?))
\f
;;; Floating Point Arithmetic
(lambda (flonum-operator)
(define-open-coder/value flonum-operator
(simple-open-coder
- (lambda (context expressions finish)
+ (lambda (combination expressions finish)
(let ((argument (car expressions)))
(open-code:with-checks
- context
+ combination
(list (open-code:type-check argument (ucode-type flonum)))
(finish (rtl:make-float->object
(rtl:make-flonum-1-arg
finish
flonum-operator
expressions)))
- '(0))))
- '(SINE-FLONUM COSINE-FLONUM ATAN-FLONUM EXP-FLONUM
- LN-FLONUM SQRT-FLONUM TRUNCATE-FLONUM))
+ '(0)
+ compiler:generate-type-checks?)))
+ '(FLONUM-NEGATE FLONUM-ABS FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN
+ FLONUM-ACOS FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-SQRT FLONUM-ROUND
+ FLONUM-TRUNCATE))
(for-each
(lambda (flonum-operator)
(define-open-coder/value flonum-operator
(simple-open-coder
- (lambda (context expressions finish)
+ (lambda (combination expressions finish)
(let ((arg1 (car expressions))
(arg2 (cadr expressions)))
(open-code:with-checks
- context
+ combination
(list (open-code:type-check arg1 (ucode-type flonum))
(open-code:type-check arg2 (ucode-type flonum)))
(finish
finish
flonum-operator
expressions)))
- '(0 1))))
- '(PLUS-FLONUM MINUS-FLONUM MULTIPLY-FLONUM DIVIDE-FLONUM))
-
+ '(0 1)
+ compiler:generate-type-checks?)))
+ '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE))
+\f
(for-each
(lambda (flonum-pred)
(define-open-coder/predicate flonum-pred
(simple-open-coder
- (lambda (context expressions finish)
+ (lambda (combination expressions finish)
(let ((argument (car expressions)))
(open-code:with-checks
- context
+ combination
(list (open-code:type-check argument (ucode-type flonum)))
(finish
(rtl:make-flonum-pred-1-arg
(finish (rtl:make-true-test expression)))
flonum-pred
expressions)))
- '(0))))
- '(ZERO-FLONUM? POSITIVE-FLONUM? NEGATIVE-FLONUM?))
+ '(0)
+ compiler:generate-type-checks?)))
+ '(FLONUM-ZERO? FLONUM-POSITIVE? FLONUM-NEGATIVE?))
(for-each
(lambda (flonum-pred)
(define-open-coder/predicate flonum-pred
(simple-open-coder
- (lambda (context expressions finish)
+ (lambda (combination expressions finish)
(let ((arg1 (car expressions))
(arg2 (cadr expressions)))
(open-code:with-checks
- context
+ combination
(list (open-code:type-check arg1 (ucode-type flonum))
(open-code:type-check arg2 (ucode-type flonum)))
(finish (rtl:make-flonum-pred-2-args
(finish (rtl:make-true-test expression)))
flonum-pred
expressions)))
- '(0 1))))
- '(EQUAL-FLONUM? LESS-THAN-FLONUM? GREATER-THAN-FLONUM?))
+ '(0 1)
+ compiler:generate-type-checks?)))
+ '(FLONUM-EQUAL? FLONUM-LESS? FLONUM-GREATER?))
+
+ ;; end COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC?
))
\f
;;; Generic arithmetic
-(define (generic-binary-generator generic-op is-pred?)
- (define-non-simple-primitive! generic-op)
- ((if is-pred? define-open-coder/predicate define-open-coder/value)
- generic-op
- (simple-open-coder
- (let ((fix-op (generic->fixnum-op generic-op)))
- (lambda (context expressions finish)
- (let ((op1 (car expressions))
- (op2 (cadr expressions))
- (give-it-up
- (generic-default generic-op is-pred?
- context expressions finish)))
- (if is-pred?
- (generate-binary-type-test (ucode-type fixnum) op1 op2
- give-it-up
- (lambda ()
- (finish
- (if (eq? fix-op 'EQUAL-FIXNUM?)
- ;; This produces better code.
- (rtl:make-eq-test op1 op2)
- (rtl:make-fixnum-pred-2-args
- fix-op
- (rtl:make-object->fixnum op1)
- (rtl:make-object->fixnum op2))))))
- (let ((give-it-up (give-it-up)))
- (generate-binary-type-test (ucode-type fixnum) op1 op2
- (lambda ()
- give-it-up)
- (lambda ()
- (load-temporary-register scfg*scfg->scfg!
- (rtl:make-fixnum-2-args
- fix-op
- (rtl:make-object->fixnum op1)
- (rtl:make-object->fixnum op2))
- (lambda (fix-temp)
- (pcfg*scfg->scfg!
- (pcfg/prefer-alternative! (rtl:make-overflow-test))
- give-it-up
- (finish (rtl:make-fixnum->object fix-temp))))))))))))
- '(0 1))))
+(define (generic-binary-operator generic-op)
+ (define-open-coder/value generic-op
+ (simple-open-coder
+ (let ((fix-op (generic->fixnum-op generic-op)))
+ (lambda (combination expressions finish)
+ (let ((op1 (car expressions))
+ (op2 (cadr expressions))
+ (give-it-up
+ (generic-default generic-op combination expressions
+ false finish)))
+ (let ((give-it-up (give-it-up)))
+ (generate-binary-type-test (ucode-type fixnum) op1 op2
+ (lambda ()
+ give-it-up)
+ (lambda ()
+ (load-temporary-register scfg*scfg->scfg!
+ (rtl:make-fixnum-2-args
+ fix-op
+ (rtl:make-object->fixnum op1)
+ (rtl:make-object->fixnum op2))
+ (lambda (fix-temp)
+ (pcfg*scfg->scfg!
+ (pcfg/prefer-alternative! (rtl:make-overflow-test))
+ give-it-up
+ (finish (rtl:make-fixnum->object fix-temp)))))))))))
+ '(0 1)
+ true)))
+
+(define (generic-binary-predicate generic-op)
+ (define-open-coder/generic-predicate generic-op
+ (simple-open-coder
+ (let ((fix-op (generic->fixnum-op generic-op)))
+ (lambda (combination expressions predicate? finish)
+ (let ((op1 (car expressions))
+ (op2 (cadr expressions)))
+ (generate-binary-type-test (ucode-type fixnum) op1 op2
+ (generic-default generic-op combination expressions predicate?
+ finish)
+ (lambda ()
+ ((if predicate? finish (finish/predicate->value finish))
+ (if (eq? fix-op 'EQUAL-FIXNUM?)
+ ;; This produces better code.
+ (rtl:make-eq-test op1 op2)
+ (rtl:make-fixnum-pred-2-args
+ fix-op
+ (rtl:make-object->fixnum op1)
+ (rtl:make-object->fixnum op2)))))))))
+ '(0 1)
+ true)))
(define (generate-binary-type-test type op1 op2 give-it-up do-it)
(generate-type-test type op1
(pcfg*scfg->scfg! test* (do-it) give-it-up)
give-it-up)))))))
\f
-(define (generic-unary-generator generic-op is-pred?)
- (define-non-simple-primitive! generic-op)
- ((if is-pred? define-open-coder/predicate define-open-coder/value)
- generic-op
- (simple-open-coder
- (let ((fix-op (generic->fixnum-op generic-op)))
- (lambda (context expressions finish)
- (let ((op (car expressions))
- (give-it-up
- (generic-default generic-op is-pred?
- context expressions finish)))
- (if is-pred?
- (generate-unary-type-test (ucode-type fixnum) op
- give-it-up
- (lambda ()
- (finish
- (rtl:make-fixnum-pred-1-arg
- fix-op
- (rtl:make-object->fixnum op)))))
- (let ((give-it-up (give-it-up)))
- (generate-unary-type-test (ucode-type fixnum) op
- (lambda ()
- give-it-up)
- (lambda ()
- (load-temporary-register scfg*scfg->scfg!
- (rtl:make-fixnum-1-arg
- fix-op
- (rtl:make-object->fixnum op))
- (lambda (fix-temp)
- (pcfg*scfg->scfg!
- (pcfg/prefer-alternative! (rtl:make-overflow-test))
- give-it-up
- (finish (rtl:make-fixnum->object fix-temp))))))))))))
- '(0))))
+(define (generic-unary-operator generic-op)
+ (define-open-coder/value generic-op
+ (simple-open-coder
+ (let ((fix-op (generic->fixnum-op generic-op)))
+ (lambda (combination expressions finish)
+ (let ((op (car expressions)))
+ (let ((give-it-up
+ ((generic-default generic-op combination expressions
+ false finish))))
+ (generate-unary-type-test (ucode-type fixnum) op
+ (lambda ()
+ give-it-up)
+ (lambda ()
+ (load-temporary-register scfg*scfg->scfg!
+ (rtl:make-fixnum-1-arg
+ fix-op
+ (rtl:make-object->fixnum op))
+ (lambda (fix-temp)
+ (pcfg*scfg->scfg!
+ (pcfg/prefer-alternative! (rtl:make-overflow-test))
+ give-it-up
+ (finish (rtl:make-fixnum->object fix-temp)))))))))))
+ '(0)
+ true)))
+
+(define (generic-unary-predicate generic-op)
+ (define-open-coder/generic-predicate generic-op
+ (simple-open-coder
+ (let ((fix-op (generic->fixnum-op generic-op)))
+ (lambda (combination expressions predicate? finish)
+ (let ((op (car expressions)))
+ (generate-unary-type-test (ucode-type fixnum) op
+ (generic-default generic-op combination expressions predicate?
+ finish)
+ (lambda ()
+ ((if predicate? finish (finish/predicate->value finish))
+ (rtl:make-fixnum-pred-1-arg
+ fix-op
+ (rtl:make-object->fixnum op))))))))
+ '(0)
+ true)))
(define (generate-unary-type-test type op give-it-up do-it)
(generate-type-test type op
(lambda (test)
(pcfg*scfg->scfg! test (do-it) (give-it-up)))))
\f
-(define (generic-default generic-op is-pred? context expressions finish)
+(define (generic-default generic-op combination expressions predicate? finish)
(lambda ()
- (with-values (lambda () (generate-continuation-entry context))
- (lambda (label setup cleanup)
- (scfg-append!
- (generate-primitive generic-op expressions setup label)
- cleanup
- (if is-pred?
- (finish (rtl:make-true-test (rtl:make-fetch register:value)))
- (expression-simplify-for-statement (rtl:make-fetch register:value)
- finish)))))))
+ (if (combination/reduction? combination)
+ (let ((scfg (generate-primitive generic-op '() false false)))
+ (make-scfg (cfg-entry-node scfg) '()))
+ (with-values
+ (lambda ()
+ (generate-continuation-entry (combination/context combination)))
+ (lambda (label setup cleanup)
+ (scfg-append!
+ (generate-primitive generic-op expressions setup label)
+ cleanup
+ (if predicate?
+ (finish (rtl:make-true-test (rtl:make-fetch register:value)))
+ (expression-simplify-for-statement
+ (rtl:make-fetch register:value)
+ finish))))))))
(define (generic->fixnum-op generic-op)
(case generic-op
- ((&+) 'PLUS-FIXNUM)
- ((&-) 'MINUS-FIXNUM)
- ((&*) 'MULTIPLY-FIXNUM)
- ((1+) 'ONE-PLUS-FIXNUM)
- ((-1+) 'MINUS-ONE-PLUS-FIXNUM)
- ((&<) 'LESS-THAN-FIXNUM?)
- ((&>) 'GREATER-THAN-FIXNUM?)
- ((&=) 'EQUAL-FIXNUM?)
- ((zero?) 'ZERO-FIXNUM?)
- ((positive?) 'POSITIVE-FIXNUM?)
- ((negative?) 'NEGATIVE-FIXNUM?)
+ ((integer-add &+) 'plus-fixnum)
+ ((integer-subtract &-) 'minus-fixnum)
+ ((integer-multiply &*) 'multiply-fixnum)
+ ((integer-quotient) 'fixnum-quotient)
+ ((integer-remainder) 'fixnum-remainder)
+ ((integer-add-1 1+) 'one-plus-fixnum)
+ ((integer-subtract-1 -1+) 'minus-one-plus-fixnum)
+ ((integer-negate) 'fixnum-negate)
+ ((integer-less? &<) 'less-than-fixnum?)
+ ((integer-greater? &>) 'greater-than-fixnum?)
+ ((integer-equal? &=) 'equal-fixnum?)
+ ((integer-zero? zero?) 'zero-fixnum?)
+ ((integer-positive? positive?) 'positive-fixnum?)
+ ((integer-negative? negative?) 'negative-fixnum?)
(else (error "Can't find corresponding fixnum op:" generic-op))))
-(define (generic->floatnum-op generic-op)
- (case generic-op
- ((&+) 'PLUS-FLOATNUM)
- ((&-) 'MINUS-FLOATNUM)
- ((&*) 'MULTIPLY-FLOATNUM)
- ((1+) 'ONE-PLUS-FLOATNUM)
- ((-1+) 'MINUS-ONE-PLUS-FLOATNUM)
- ((&<) 'LESS-THAN-FLOATNUM?)
- ((&>) 'GREATER-THAN-FLOATNUM?)
- ((&=) 'EQUAL-FLOATNUM?)
- ((zero?) 'ZERO-FLOATNUM?)
- ((positive?) 'POSITIVE-FLOATNUM?)
- ((negative?) 'NEGATIVE-FLOATNUM?)
- (else (error "Can't find corresponding floatnum op:" generic-op))))
-
(for-each (lambda (generic-op)
- (generic-binary-generator generic-op false))
- '(&+ &- &*))
+ (generic-binary-operator generic-op))
+ '(&+ &- &* integer-add integer-subtract integer-multiply))
(for-each (lambda (generic-op)
- (generic-binary-generator generic-op true))
- '(&= &< &>))
+ (generic-binary-predicate generic-op))
+ '(&= &< &> integer-equal? integer-less? integer-greater?))
(for-each (lambda (generic-op)
- (generic-unary-generator generic-op false))
- '(1+ -1+))
+ (generic-unary-operator generic-op))
+ '(1+ -1+ integer-add-1 integer-subtract-1))
(for-each (lambda (generic-op)
- (generic-unary-generator generic-op true))
- '(zero? positive? negative?))
\ No newline at end of file
+ (generic-unary-predicate generic-op))
+ '(zero? positive? negative?
+ integer-zero? integer-positive? integer-negative?))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.11 1989/06/16 09:14:08 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.12 1989/10/26 07:39:03 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(and (let ((callee (combination/model combination)))
(and callee
(rvalue/procedure? callee)
- (procedure/open-internal? callee)
- (internal-block/dynamic-link? (procedure-block callee)))) (if (return-operator/subproblem? (combination/continuation combination))
+ (block/dynamic-link? (procedure-block callee))))
+ (if (return-operator/subproblem? (combination/continuation combination))
link-prefix/subproblem
(let ((context (combination/context combination)))
(let ((popping-limit
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.12 1989/03/14 19:35:30 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.13 1989/10/26 07:39:08 cph Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
(define (generate/return return)
- (generate/return* (return/context return)
- (return/operator return)
- (application-continuation-push return)
- (trivial-return-operand (return/operand return))))
+ (let loop ((returns (return/equivalence-class return)))
+ (if (null? returns)
+ (generate/return* (return/context return)
+ (return/operator return)
+ (application-continuation-push return)
+ (trivial-return-operand (return/operand return)))
+ (let ((memoization (cfg-node-get (car returns) memoization-tag)))
+ (if (and memoization
+ (not (eq? memoization loop-memoization-marker)))
+ memoization
+ (loop (cdr returns)))))))
(define (generate/trivial-return context operator operand)
(generate/return* context operator false (trivial-return-operand operand)))
(finish (rtl:make-fetch register))))))
\f
(define (return-operator/pop-frames context operator extra)
- (let ((block (reference-context/block context))
- (pop-extra
- (lambda ()
+ (let ((pop-extra
+ (lambda (extra)
(if (zero? extra)
(make-null-cfg)
(rtl:make-assignment register:stack-pointer
(stack-locative-offset
(rtl:make-fetch register:stack-pointer)
extra)))))))
- (if (or (ic-block? block)
- (return-operator/subproblem? operator))
- (pop-extra)
- (let ((popping-limit (block-popping-limit block)))
- (cond ((not popping-limit)
- (scfg*scfg->scfg!
- (rtl:make-link->stack-pointer)
- (pop-extra)))
- ((and (eq? popping-limit (reference-context/block context))
- (zero? (block-frame-size popping-limit))
- (zero? (reference-context/offset context))
- (zero? extra))
- (make-null-cfg))
- (else
- (rtl:make-assignment register:stack-pointer
- (popping-limit/locative context
- popping-limit
- 0
- extra))))))))
\ No newline at end of file
+ (if (exact-integer? context)
+ ;; This kludge is used by open-coding of some primitives in
+ ;; reduction position. In that case, there is no frame (and
+ ;; therefore no context) because adjustments prior to the
+ ;; open-coding have eliminated it. So it is known that only
+ ;; the primitive's arguments are on the stack, and the return
+ ;; address appears directly above that.
+ (pop-extra (+ context extra))
+ (let ((block (reference-context/block context)))
+ (if (or (ic-block? block)
+ (return-operator/subproblem? operator))
+ (pop-extra extra)
+ (let ((popping-limit (block-popping-limit block)))
+ (cond ((not popping-limit)
+ (scfg*scfg->scfg!
+ (rtl:make-link->stack-pointer)
+ (pop-extra extra)))
+ ((and (eq? popping-limit block)
+ (zero? (block-frame-size popping-limit))
+ (zero? (reference-context/offset context))
+ (zero? extra))
+ (make-null-cfg))
+ (else
+ (rtl:make-assignment
+ register:stack-pointer
+ (popping-limit/locative context
+ popping-limit
+ 0
+ extra))))))))))
\ No newline at end of file
d3 1
a4 1
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.13 1988/12/30 07:11:06 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.14 1989/10/26 07:39:12 cph Exp $
#| -*-Scheme-*-
Copyright (c) 1988 Massachusetts Institute of Technology
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.13 1988/12/30 07:11:06 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.14 1989/10/26 07:39:12 cph Exp $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
(lambda (reference)
(let ((context (reference-context reference))
(safe? (reference-safe? reference)))
- (lambda ()
+ (lambda (lvalue)
(find-variable context lvalue
- (lambda (locative)
- (expression-value/simple (rtl:make-fetch locative)))
- (lambda (environment name)
- (expression-value/temporary
- (load-temporary-register scfg*scfg->scfg! environment
- (lambda (environment)
- (wrap-with-continuation-entry
- context
- (rtl:make-interpreter-call:lookup
- environment
- (intern-scode-variable!
- (reference-context/block context)
- name)
- safe?))))
- (rtl:interpreter-call-result:lookup)))
- (lambda (name)
- (if (memq 'IGNORE-REFERENCE-TRAPS
- (variable-declarations lvalue))
- (load-temporary-register values
- (rtl:make-variable-cache name)
- rtl:make-fetch)
- (generate/cached-reference context name safe?)))))))
- (cond ((not value) (perform-fetch))
+ (lambda (locative)
+ (expression-value/simple (rtl:make-fetch locative)))
+ (lambda (#| lvalue |#)
+ (find-variable/value context lvalue
+ expression-value/simple
+ (lambda (environment name)
+ (expression-value/temporary
+ (load-temporary-register scfg*scfg->scfg! environment
+ (lambda (environment)
+ (wrap-with-continuation-entry
+ context
+ (rtl:make-interpreter-call:lookup
+ environment
+ (intern-scode-variable!
+ (reference-context/block context)
+ name)
+ safe?))))
+ (rtl:interpreter-call-result:lookup)))
+ (lambda (name)
+ (rtl:make-variable-cache name)
+ rtl:make-fetch)
+ (load-temporary-register values
+ (rtl:make-variable-cache name)
+ (perform-fetch (or (variable-indirection lvalue) lvalue)))
lvalue))
|#
((not (rvalue/procedure? value))
(generate/rvalue* value))
- (else (perform-fetch)))))))
+ (generate/indirected-closure indirection value context
+ (perform-fetch lvalue)))))))
+ |#
+ (else
+ (perform-fetch #| lvalue |#)))))))
+\f
+(define (generate/cached-reference context name safe?)
+ (let ((result (rtl:make-pseudo-register)))
+ (values
+ (load-temporary-register scfg*scfg->scfg! (rtl:make-variable-cache name)
+ (lambda (cell)
+ (let ((reference (rtl:make-fetch cell)))
+ (let ((n2 (rtl:make-type-test (rtl:make-object->type reference)
+ (ucode-type reference-trap)))
+ (n3 (rtl:make-assignment result reference))
+ (n4
+ (wrap-with-continuation-entry
+ context
+ (rtl:make-interpreter-call:cache-reference cell safe?)))
+ (n5
+ (rtl:make-assignment
+ result
+ (rtl:interpreter-call-result:cache-reference))))
+ (pcfg-alternative-connect! n2 n3)
+ (scfg-next-connect! n4 n5)
+ (if safe?
+ (let ((n6 (rtl:make-unassigned-test reference))
+ ;; Make new copy of n3 to keep CSE happy.
+ ;; Otherwise control merge will confuse it.
+ (n7 (rtl:make-assignment result reference)))
+ (pcfg-consequent-connect! n2 n6)
+ (pcfg-consequent-connect! n6 n7)
+ (pcfg-alternative-connect! n6 n4)
+ (make-scfg (cfg-entry-node n2)
+ (hooks-union
+ (scfg-next-hooks n3)
+ (hooks-union (scfg-next-hooks n5)
+ (scfg-next-hooks n7)))))
+ (begin
+ (pcfg-consequent-connect! n2 n4)
+ (make-scfg (cfg-entry-node n2)
+ (hooks-union (scfg-next-hooks n3)
+ (scfg-next-hooks n5)))))))))
+ (rtl:make-fetch result))))
+\f
+(define-method-table-entry 'PROCEDURE rvalue-methods
+ (lambda (procedure)
+ (enqueue-procedure! procedure)
+ (case (procedure/type procedure)
+ (load-temporary-register
+ (lambda (assignment reference)
+ (values
+ (scfg*scfg->scfg!
+ assignment
+ (load-closure-environment procedure reference))
+ reference))
+ (make-non-trivial-closure-cons procedure)
+ identity-procedure))
+ (else
+ (expression-value/simple
+ (make-cons-closure-indirection procedure)))))
+ ((IC)
+ (make-ic-cons procedure))
+ ((OPEN-EXTERNAL OPEN-INTERNAL)
+ (if (not (procedure-virtual-closure? procedure))
+ (error "Reference to open procedure" procedure))
+ (expression-value/simple (make-trivial-closure-cons procedure)))
+(define (make-trivial-closure-cons procedure)
+ (enqueue-procedure! procedure)
+ (rtl:make-cons-pointer
+ (rtl:make-constant type-code:compiled-entry)
+ (rtl:make-entry:procedure (procedure-label procedure))))
+
+ (else
+ (error "Unknown procedure type" procedure)))))
+
+(define (make-ic-cons procedure)
+ ;; IC procedures have their entry points linked into their headers
+ ;; at load time by the linker.
+ (let ((header
+ (scode/make-lambda (procedure-name procedure)
+ (map variable-name
+ (procedure-required-arguments procedure))
+ (map variable-name (procedure-optional procedure))
+ (let ((rest (procedure-rest procedure)))
+ (and rest (variable-name rest)))
+ (map variable-name (procedure-names procedure))
+ '()
+ false)))
+ (let ((kernel
+ (rtl:make-constant (scode/procedure-type-code header))
+ (rtl:make-typed-cons:pair
+ (rtl:make-machine-constant
+ (scode/procedure-type-code header))
+ (rtl:make-constant header)
+ expression)))))
+ (set! *ic-procedure-headers*
+ (cons (cons header (procedure-label procedure))
+ *ic-procedure-headers*))
+ (let ((context (procedure-closure-context procedure)))
+ (if (reference? context)
+ (with-values (lambda () (generate/rvalue* context))
+ kernel)
+ ;; Is this right if the procedure is being closed
+ ;; inside another IC procedure?
+(define (make-non-trivial-closure-cons procedure)
+ (rtl:make-cons-pointer
+ (rtl:make-constant type-code:compiled-entry)
+ (with-values (lambda () (procedure-arity-encoding procedure))
+ (lambda (min max)
+ (rtl:make-cons-closure
+ (rtl:make-entry:procedure (procedure-label procedure))
+ min
+ max
+ (procedure-closure-size procedure))))))
+
+(define (load-closure-environment procedure closure-locative)
+ (define (load-closure-parent block force?)
+ (if (and (not force?)
+ (or (not block)
+ (not (ic-block/use-lookup? block))))
+ (make-null-cfg)
+ (rtl:make-assignment
+ (rtl:locative-offset closure-locative closure-block-first-offset)
+ (if (not (ic-block/use-lookup? block))
+ (rtl:make-constant false)
+ (let ((context (procedure-closure-context procedure)))
+ (if (not (reference-context? context))
+ (error "load-closure-environment: bad closure context"
+ procedure))
+ (if (ic-block? (reference-context/block context))
+ (rtl:make-fetch register:environment)
+ (closure-ic-locative context block)))))))
+ (enqueue-procedure! procedure)
+ (let ((block (procedure-closing-block procedure)))
+(define (make-non-trivial-closure-cons procedure block**)
+ (make-null-cfg))
+ ((ic-block? block)
+ (load-closure-parent block true))
+ ((closure-block? block)
+ (let ((context (procedure-closure-context procedure)))
+ ((ic-block? block)
+ (load-closure-parent block true))
+ ((closure-block? block)
+ (let loop
+ ((entries (block-closure-offsets block))
+ (code (load-closure-parent (block-parent block) false)))
+ (if (null? entries)
+ code
+ (reference-context/procedure context))
+ (loop (cdr entries)
+ (scfg*scfg->scfg!
+ (rtl:make-assignment
+ (rtl:locative-offset closure-locative
+ (cdar entries))
+ (let* ((variable (caar entries))
+ (value (lvalue-known-value variable)))
+ (cond
+ ;; Paranoia.
+ ((and value
+ (rvalue/procedure? value)
+ (procedure/trivial-or-virtual? value)
+ (error "known ignorable procedure"
+ value variable))
+ (make-trivial-closure-cons value))
+ ((eq? value
+ (rtl:make-fetch
+ (find-closure-variable context variable))))))
+ code))))))
+ (else
+ (error "Unknown block type" block))))) (find-closure-variable context variable)))))
+ code)))))
+ (error "Unknown block type" block))))))
+ (error "Unknown block type" block))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.20 1989/08/21 19:34:39 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.21 1989/10/26 07:39:15 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(with-new-node-marks
(lambda ()
(let ((initial-bblocks
- (map->eq-set edge-right-node (rgraph-initial-edges rgraph))))
+ (map->eq-set edge-right-node (rgraph-initial-edges rgraph)))
+ (protected-edges
+ (append! (map rtl-procedure/entry-edge *procedures*)
+ (map rtl-continuation/entry-edge *continuations*)
+ (map rtl-continuation/entry-edge *extra-continuations*))))
(let ((result '()))
(define (loop bblock)
(if (sblock? bblock)
(let ((bblock (edge-left-node edge)))
(if bblock
(not (node-marked? bblock))
- disallow-entries?))))))
+ (and disallow-entries?
+ (not (memq edge protected-edges)))))))))
(lambda (bblock)
(set-node-previous-edges!
bblock
(for-each loop initial-bblocks)
(for-each (delete-block-edges! false) initial-bblocks)
(for-each (delete-block-edges! true) result)
- (set-rgraph-bblocks! rgraph (append! initial-bblocks result)))))))
-\f
-(define (bblock-compress! bblock limit-predicate)
- ;; This improved compressor should replace the original in "rtlbase/rtlcfg".
- (let ((walk-next?
- (if limit-predicate
- (lambda (next) (and next (not (limit-predicate next))))
- (lambda (next) next))))
- (let walk-bblock ((bblock bblock))
- (if (not (node-marked? bblock))
- (begin
- (node-mark! bblock)
- (if (sblock? bblock)
- (let ((next (snode-next bblock)))
- (if (walk-next? next)
- (begin
- (if (null? (cdr (node-previous-edges next)))
- (begin
- (set-rinst-next!
- (rinst-last (bblock-instructions bblock))
- (bblock-instructions next))
- (set-bblock-instructions!
- next
- (bblock-instructions bblock))
- (snode-delete! bblock)))
- (walk-bblock next))))
- (begin
- (let ((consequent (pnode-consequent bblock)))
- (if (walk-next? consequent)
- (walk-bblock consequent)))
- (let ((alternative (pnode-alternative bblock)))
- (if (walk-next? alternative)
- (walk-bblock alternative))))))))))
\ No newline at end of file
+ (set-rgraph-bblocks! rgraph (append! initial-bblocks result)))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.11 1989/01/21 09:06:11 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.12 1989/10/26 07:39:27 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(define ((expression-inserter expression element hash in-memory?))
(or element
- (begin (if (rtl:register? expression)
- (set-register-expression! (rtl:register-number expression)
- expression)
- (mention-registers! expression))
- (let ((element* (hash-table-insert! hash expression false)))
- (set-element-in-memory?! element* in-memory?)
- (element-first-value element*)))))
+ (begin
+ (if (rtl:register? expression)
+ (set-register-expression! (rtl:register-number expression)
+ expression)
+ (mention-registers! expression))
+ (let ((element* (hash-table-insert! hash expression false)))
+ (set-element-in-memory?! element* in-memory?)
+ (element-first-value element*)))))
(define (expression-canonicalize expression)
(cond ((rtl:register? expression)
;; except the compiler's output, which is explicit.
(if (interpreter-stack-pointer? (rtl:offset-register expression))
(quantity-number (stack-reference-quantity expression))
- (begin (set! hash-arg-in-memory? true)
- (continue expression))))
+ (begin
+ (set! hash-arg-in-memory? true)
+ (continue expression))))
((BYTE-OFFSET)
(set! hash-arg-in-memory? true)
(continue expression))
(set! hash-arg-in-memory? true)
(set! do-not-record? true)
0)
- (else (continue expression))))))
+ (else
+ (continue expression))))))
(define (continue expression)
(rtl:reduce-subparts expression + 0 loop
(lambda (object)
- (cond ((integer? object) object)
+ (cond ((integer? object) (inexact->exact object))
((symbol? object) (symbol-hash object))
((string? object) (string-hash object))
(else (hash object))))))
;; the hash table as the destination of an assignment. ELEMENT is
;; the hash table element for the value being assigned to
;; EXPRESSION.
- (let ((class (element->class element))
- (register (rtl:register-number expression)))
+ (let ((register (rtl:register-number expression)))
(set-register-expression! register expression)
- (if class
- (let ((expression (element-expression class))
- (register-equivalence!
- (lambda (quantity)
- (set-register-quantity! register quantity)
- (let ((last (quantity-last-register quantity)))
- (cond ((not last)
- (set-quantity-first-register! quantity register)
- (set-register-next-equivalent! register false))
- (else
- (set-register-next-equivalent! last register)
- (set-register-previous-equivalent! register last))))
- (set-quantity-last-register! quantity register))))
- (cond ((rtl:register? expression)
- (register-equivalence!
- (get-register-quantity (rtl:register-number expression))))
- ((stack-reference? expression)
- (register-equivalence!
- (stack-reference-quantity expression))))))
- (set-element-in-memory?!
- (hash-table-insert! (expression-hash expression) expression class)
- false))
- unspecific)
+ (let ((quantity (get-element-quantity element)))
+ (if quantity
+ (begin
+ (set-register-quantity! register quantity)
+ (let ((last (quantity-last-register quantity)))
+ (cond ((not last)
+ (set-quantity-first-register! quantity register)
+ (set-register-next-equivalent! register false))
+ (else
+ (set-register-next-equivalent! last register)
+ (set-register-previous-equivalent! register last))))
+ (set-quantity-last-register! quantity register)))))
+ (set-element-in-memory?! (hash-table-insert! (expression-hash expression)
+ expression
+ (element->class element))
+ false))
(define (insert-stack-destination! expression element)
- (let ((class (element->class element)))
- (if class
- (let ((expression (element-expression class))
- (stash-quantity!
- (lambda (quantity)
- (set-stack-reference-quantity! expression quantity))))
- (cond ((rtl:register? expression)
- (stash-quantity!
- (get-register-quantity (rtl:register-number expression))))
- ((stack-reference? expression)
- (stash-quantity!
- (stack-reference-quantity expression))))))
- (set-element-in-memory?!
- (hash-table-insert! (expression-hash expression) expression class)
- false))
- unspecific)
+ (let ((quantity (get-element-quantity element)))
+ (if quantity
+ (set-stack-reference-quantity! expression quantity)))
+ (set-element-in-memory?! (hash-table-insert! (expression-hash expression)
+ expression
+ (element->class element))
+ false))
+
+(define (get-element-quantity element)
+ (let loop ((element (element->class element)))
+ (and element
+ (let ((expression (element-expression element)))
+ (cond ((rtl:register? expression)
+ (get-register-quantity (rtl:register-number expression)))
+ ((stack-reference? expression)
+ (stack-reference-quantity expression))
+ (else
+ (loop (element-next-value element))))))))
\f
(define (insert-memory-destination! expression element hash)
(let ((class (element->class element)))
;; In that case, there is no need to make an element at all.
(if (or class hash)
(set-element-in-memory?! (hash-table-insert! hash expression class)
- true)))
- unspecific)
+ true))))
(define (mention-registers! expression)
(if (rtl:register? expression)
(let ((register (rtl:register-number expression)))
(remove-invalid-references! register)
(set-register-in-table! register (register-tick register)))
- (rtl:for-each-subexpression expression mention-registers!))
- unspecific)
+ (rtl:for-each-subexpression expression mention-registers!)))
(define (remove-invalid-references! register)
;; If REGISTER is invalid, delete from the hash table all
;; Invalidate a register expression. These expressions are handled
;; specially for efficiency -- the register is marked invalid but we
;; delay searching the hash table for relevant expressions.
- (let ((hash (expression-hash expression)))
- (register-invalidate! (rtl:register-number expression))
- (hash-table-delete! hash (hash-table-lookup hash expression))))
+ (let ((register (rtl:register-number expression))
+ (hash (expression-hash expression)))
+ (register-invalidate! register)
+ ;; If we're invalidating the stack pointer, delete its entries
+ ;; immediately.
+ (if (interpreter-stack-pointer? expression)
+ (mention-registers! expression)
+ (hash-table-delete! hash (hash-table-lookup hash expression)))))
+
(define (register-invalidate! register)
(let ((next (register-next-equivalent register))
(previous (register-previous-equivalent register))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.8 1989/08/10 11:39:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.9 1989/10/26 07:39:32 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(set-element-previous-value! class element)
(let loop ((x element))
(if x
- (begin (set-element-first-value! x element)
- (loop (element-next-value x))))))
+ (begin
+ (set-element-first-value! x element)
+ (loop (element-next-value x))))))
(else
(set-element-first-value! element class)
(let loop ((previous class)
(set-element-next-value! previous next)
(let loop ((element next))
(if element
- (begin (set-element-first-value! element next)
- (loop (element-next-value element)))))))
+ (begin
+ (set-element-first-value! element next)
+ (loop (element-next-value element)))))))
(let ((next (element-next-hash element))
(previous (element-previous-hash element)))
(if next (set-element-previous-hash! next previous))
(if (< i (hash-table-size))
(let bucket-loop ((element (hash-table-ref i)))
(if element
- (begin (if (predicate element)
- (hash-table-delete! i element))
- (bucket-loop (element-next-hash element)))
+ (begin
+ (if (predicate element)
+ (hash-table-delete! i element))
+ (bucket-loop (element-next-hash element)))
(table-loop (1+ i))))))
unspecific)
(define (rtl:expression-cost expression)
- (case (rtl:expression-type expression)
- ((REGISTER) 1)
- ((CONSTANT) (rtl:constant-cost (rtl:constant-value expression)))
- (else
- (let loop ((parts (cdr expression)) (cost 2))
- (if (null? parts)
- cost
- (loop (cdr parts)
- (if (pair? (car parts))
- (+ cost (rtl:expression-cost (car parts)))
- cost)))))))\f
+ (let ((complex
+ (lambda ()
+ (let loop ((parts (cdr expression)) (cost 3))
+ (if (null? parts)
+ cost
+ (loop (cdr parts)
+ (if (pair? (car parts))
+ (+ cost (rtl:expression-cost (car parts)))
+ cost)))))))
+ (case (rtl:expression-type expression)
+ ((CONSTANT) (rtl:constant-cost (rtl:constant-value expression)))
+ ((REGISTER) 2)
+ ((OBJECT->FIXNUM)
+ (if (let ((subexpression (rtl:object->fixnum-expression expression)))
+ (and (rtl:constant? subexpression)
+ (let ((n (rtl:constant-value subexpression)))
+ (and (exact-integer? n)
+ (<= -128 n 127)))))
+ 1
+ (complex)))
+ (else
+ (complex)))))
+\f
(define (hash-table-copy table)
;; During this procedure, the `element-cost' slots of `table' are
;; reused as "broken hearts".
projects / mit-scheme.git / commitdiff