entry points that share the environment "frame".
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.13 1990/05/03 15:04:48 jinx Rel $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; Environment model data structures
+;;; package: (compiler)
(declare (usual-integrations))
\f
interned-variables ;alist of interned SCode variable objects
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)
+ (stack-link ;for stack block, adjacent block on stack
+ shared-block) ;for multi closures, the official block
+ (static-link? ;for stack block, true iff static link to parent
+ entry-number) ;for multi closures, entry number
+ (popping-limits ;for stack block (see continuation analysis)
+ grafted-blocks) ;for multi closures, list of blocks that share
popping-limit ;for stack block (see continuation analysis)
layout-frozen? ;used by frame reuse to tell parameter
;analysis not to alter this block's layout
(loop (block-parent block)
(+ n (block-frame-size block))))))
-(define (for-each-block-descendent! block procedure)
+(define (for-each-block-descendant! block procedure)
(let loop ((block block))
(procedure block)
(for-each loop (block-children block))))
(rvalue/procedure? procedure)
(procedure-target-block procedure))))
+#|
(define (disown-block-child! block child)
(set-block-children! block (delq! child (block-children block)))
- (set-block-disowned-children! block
- (cons child (block-disowned-children block)))
+ (if (eq? block (original-block-parent child))
+ (set-block-disowned-children! block
+ (cons child (block-disowned-children block))))
unspecific)
(define (own-block-child! block child)
(set-block-parent! child block)
(set-block-children! block (cons child (block-children block)))
- unspecific)
\ No newline at end of file
+ (if (eq? block (original-block-parent child))
+ (set-block-disowned-children! block
+ (delq! child (block-disowned-children block))))
+ unspecific)
+|#
+
+(define (transfer-block-child! child block block*)
+ ;; equivalent to
+ ;; (begin
+ ;; (disown-block-child! block child)
+ ;; (own-block-child! block* child))
+ ;; but faster.
+ (let ((original-parent (original-block-parent child)))
+ (set-block-children! block (delq! child (block-children block)))
+ (if (eq? block original-parent)
+ (set-block-disowned-children!
+ block
+ (cons child (block-disowned-children block))))
+ (set-block-parent! child block*)
+ (if block*
+ (begin
+ (set-block-children! block* (cons child (block-children block*)))
+ (if (eq? block* original-parent)
+ (set-block-disowned-children!
+ block*
+ (delq! child (block-disowned-children block*))))))))
+
+(define-integrable (block-number-of-entries block)
+ (block-entry-number block))
+
+(define (closure-block-entry-number block)
+ (if (eq? block (block-shared-block block))
+ 0
+ (block-entry-number block)))
+
+(define (closure-block-first-offset block)
+ (let ((block* (block-shared-block block)))
+ (closure-first-offset (block-entry-number block*)
+ (if (eq? block block*)
+ 0
+ (block-entry-number block)))))
+
+(define (block-nearest-closure-ancestor block)
+ (let loop ((block block) (last false))
+ (and block
+ (if (stack-block? block)
+ (loop (block-parent block) block)
+ (and (closure-block? block)
+ last)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.7 1990/01/22 23:44:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.8 1990/05/03 15:04:52 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Debugging Information
+;;; package: (compiler debugging-information)
(declare (usual-integrations))
\f
\f
(define (closure-block->dbg-block block)
(let ((parent (block-parent block))
+ (start-offset
+ (closure-object-first-offset
+ (block-entry-number (block-shared-block block))))
(offsets
(map (lambda (offset)
(cons (car offset)
- (- (cdr offset) closure-block-first-offset)))
+ (- (cdr offset)
+ (closure-block-first-offset block))))
(block-closure-offsets block))))
(let ((layout (make-layout (1+ (apply max (map cdr offsets))))))
(for-each (lambda (offset)
offsets)
(if (and parent (ic-block/use-lookup? parent))
(layout-set! layout 0 dbg-block-name/ic-parent))
- (make-dbg-block 'CLOSURE (block->dbg-block parent) false layout false))))
+ (make-dbg-block 'CLOSURE (block->dbg-block parent) false
+ (cons start-offset layout)
+ false))))
(define (ic-block->dbg-block block)
(make-dbg-block 'IC (block->dbg-block (block-parent block))
(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))
- (cond (integrated?
- (lvalue-known-value variable))
- (indirection
- (variable->dbg-variable indirection))
- (else
- false)))))
+ (make-dbg-variable
+ (variable-name variable)
+ (cond (integrated? 'INTEGRATED)
+ (indirection 'INDIRECTED)
+ ((variable-in-cell? variable) 'CELL)
+ (else 'NORMAL))
+ (cond (integrated?
+ (lvalue-known-value variable))
+ (indirection
+ ;; This currently does not examine whether it is a
+ ;; simple indirection, or a closure indirection.
+ ;; The value displayed will be incorrect if it
+ ;; is a closure indirection, but...
+ (variable->dbg-variable (car indirection)))
+ (else
+ false)))))
(if integrated?
(set! *integrated-variables*
(cons dbg-variable *integrated-variables*)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.17 1990/02/02 18:38:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.18 1990/05/03 15:04:56 jinx Exp $
Copyright (c) 1988, 1989, 1990 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]
+ indirection ;alias for this variable (variable . boolean) or #f
source-node ;virtual-return that initializes this variable, or #f
)
(and value
(or (rvalue/constant? value)
(and (rvalue/procedure? value)
- (procedure/virtually-open? value))))))
+ (procedure/virtually-open? value))
+ (lvalue-get lvalue 'INTEGRATED)))))
(define (variable-unused? variable)
(or (lvalue-integrated? variable)
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.16 1990/05/03 15:05:01 jinx Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; Procedure datatype
+;;; package: (compiler)
(declare (usual-integrations))
\f
label ;label to identify procedure entry point [symbol]
applications ;list of applications for which this is an operator
always-known-operator? ;always known operator of application? [boolean]
- closing-limit ;closing limit (see code)
+ closure-cons ;for closure, how it is to be consed.
closure-context ;for closure, where procedure is closed [block]
closure-offset ;for closure, offset of procedure in stack frame
register ;for continuation, argument register
closure-reasons ;reasons why a procedure is closed.
(variables ;variables which may be bound to this procedure (1)
side-effects) ;classes of side-effects performed by this procedure
- properties ;random bits of information [assq list]
+ alist ;random bits of information [assq list]
debugging-info ;[dbg-procedure or dbg-continuation]
)
(if (null? applications)
(set-procedure-always-known-operator?! procedure false))))
+(define (procedure-get procedure key)
+ (let ((entry (assq key (procedure-alist procedure))))
+ (and entry
+ (cdr entry))))
+
+(define (procedure-put! procedure key item)
+ (let ((entry (assq key (procedure-alist procedure))))
+ (if entry
+ (set-cdr! entry item)
+ (set-procedure-alist! procedure
+ (cons (cons key item) (procedure-alist procedure))))))
+
+(define (procedure-remove! procedure key)
+ (set-procedure-alist! procedure (del-assq! key (procedure-alist procedure))))
+
(define-integrable (procedure/simplified? procedure)
- (assq 'SIMPLIFIED (procedure-properties procedure)))
+ (procedure-get procedure 'SIMPLIFIED))
(define-integrable (procedure/trivial? procedure)
- (assq 'TRIVIAL (procedure-properties procedure)))
+ (procedure-get procedure 'TRIVIAL))
(define (procedure-inline-code? procedure)
(and (not (procedure-rest procedure))
(let loop ((reasons (procedure-closure-reasons procedure)))
(and (not (null? reasons))
(or (memq (caar reasons)
- '(PASSED-OUT ARGUMENT ASSIGNMENT APPLY-COMPATIBILITY))
+ '(PASSED-OUT ARGUMENT ASSIGNMENT
+ COMPATIBILITY APPLY-COMPATIBILITY))
(loop (cdr reasons))))))
(define (procedure-maybe-registerizable? procedure)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.14 1990/03/26 23:45:19 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.15 1990/05/03 15:05:05 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(define compiler:generate-range-checks? false)
(define compiler:generate-type-checks? false)
(define compiler:open-code-flonum-checks? false)
+(define compiler:use-multiclosures? true)
;; The switch COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC? is in machin.scm.
;;; Nary switches
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.14 1990/04/01 22:18:32 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.15 1990/05/03 15:09:03 jinx Rel $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; Environment Type Assignment
+;;; package: (compiler fg-optimizer setup-block-types)
(declare (usual-integrations))
\f
(define (block-type! block type)
(set-block-type! block type)
(for-each loop (block-children block)))
+
+ (loop root-block)
+ (if compiler:use-multiclosures?
+ (merge-closure-blocks! root-block)))
- (loop root-block))
+(define (merge-closure-blocks! root-block)
+ (define (loop block update?)
+ (enumeration-case block-type (block-type block)
+ ((STACK)
+ (let ((procedure (block-procedure block)))
+ (if (procedure/full-closure? procedure)
+ (let ((closure-block (block-parent block)))
+ (if (eq? closure-block (block-shared-block closure-block))
+ (or (attempt-child-graft block procedure update?)
+ (and update? (update-closure! procedure))))))
+ (examine-children block
+ (or (attempt-children-merge block procedure update?)
+ update?))))
+ ((IC CONTINUATION EXPRESSION)
+ (examine-children block update?))
+ (else
+ (error "Illegal block type" block))))
+
+ (define (examine-children block update?)
+ (for-each (lambda (child)
+ (loop child update?))
+ (original-block-children block)))
+
+ (loop root-block false))
+(define (original-block-children block)
+ (append (block-disowned-children block)
+ (list-transform-positive
+ (block-children block)
+ (lambda (block*)
+ (eq? block (original-block-parent block*))))))
+\f
(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 original-parent))
- (with-values
- (lambda ()
- (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)))
- (if previously-trivial?
- (if (not (procedure/trivial-closure? procedure))
- (error "trivial procedure becoming non-trivial" procedure))
- (if (procedure/trivial-closure? procedure)
- (warn "non-trivial procedure becoming trivial" 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)))))))
+ (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 original-parent))
+ (with-values
+ (lambda ()
+ (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-block closure-block?)
+ (transfer-block-child! block parent closure-block)
+ (set-procedure-closure-size!
+ procedure
+ (cond (closure-block?
+ (compute-closure-offsets! closure-block
+ (closure-first-offset 1 0)))
+ (closure-block 1)
+ (else 0)))))
+ (set-procedure-closure-cons! procedure '(NORMAL))
+ (if previously-trivial?
+ (if (not (procedure/trivial-closure? procedure))
+ (error "trivial procedure becoming non-trivial" procedure))
+ (if (procedure/trivial-closure? procedure)
+ (warn "non-trivial procedure becoming trivial"
+ procedure)))))))
+\f
+(define (attempt-child-graft block procedure update?)
+ (let ((block* (block-nearest-closure-ancestor
+ (procedure-target-block procedure))))
+ (and block*
+ (let ((closure-block (block-parent block))
+ (ancestor-block (block-shared-block (block-parent block*))))
+ (and (for-all?
+ (refilter-variables (block-bound-variables closure-block)
+ update? procedure)
+ (let ((bvars (block-bound-variables ancestor-block)))
+ (lambda (var)
+ (or (memq var bvars)
+ (let ((val (lvalue-known-value var)))
+ (and val
+ (if (rvalue/block? val)
+ (eq? val ancestor-block)
+ (and (rvalue/procedure? val)
+ (procedure/full-closure? val)
+ (eq? (block-shared-block
+ (procedure-closing-block val))
+ ancestor-block)))))))))
+ (graft-child! procedure ancestor-block closure-block))))))
+
+(define (graft-child! procedure ancestor-block closure-block)
+ (for-each
+ (lambda (var)
+ (if (and (lvalue-known-value var)
+ (not (variable-closed-over? var))
+ (let* ((sblock (block-nearest-closure-ancestor
+ (variable-block var)))
+ (cblock (and sblock (block-parent sblock))))
+ (and cblock
+ (eq? (block-shared-block cblock) ancestor-block))))
+ (lvalue-put! var 'INTEGRATED ancestor-block)))
+ (procedure-variables procedure))
+ (graft-block! '(DESCENDANT) ancestor-block closure-block procedure)
+ true)
+\f
+(define (update-closure! procedure)
+ (let ((closure-block (procedure-closing-block procedure)))
+ (if (not (eq? (block-shared-block closure-block) closure-block))
+ (error "update-closure!: Updating shared closure" procedure))
+ (let ((vars (refilter-variables (block-bound-variables closure-block)
+ true procedure)))
+ (set-block-bound-variables! closure-block vars)
+ (set-procedure-closure-size!
+ procedure
+ (compute-closure-offsets! closure-block
+ (closure-block-first-offset
+ closure-block))))))
+
+(define (refilter-variables bvars filter? procedure)
+ (if (not filter?)
+ bvars
+ (let loop ((vars (reverse bvars))
+ (real '())
+ (blocks '()))
+ (cond ((not (null? vars))
+ (let* ((var (car vars))
+ (ind (variable-indirection var)))
+ (if ind
+ (loop (cdr vars)
+ (if (memq (car ind) real)
+ real
+ (cons (car ind) real))
+ blocks)
+ (let ((val (lvalue-known-value var)))
+ (cond ((not val)
+ (loop (cdr vars)
+ (cons var real)
+ blocks))
+ ((rvalue/block? val)
+ ;; This should not be found since this is
+ ;; only the result of this procedure itself,
+ ;; or link-children!, and either way, it
+ ;; should not be called after that point.
+ (error "refilter-variables: Block found"
+ procedure))
+ #|
+ ;; This doesn't work because these variables
+ ;; have not been indirected, so the eventual
+ ;; lookup will fail.
+ ;; We need to think about whether they can be
+ ;; indirected always.
+ ((and (rvalue/procedure? val)
+ (procedure/closure? val))
+ (let ((block
+ (block-shared-block
+ (procedure-closing-block val))))
+ (if (memq block blocks)
+ (loop (cdr vars)
+ real
+ blocks)
+ (loop (cdr vars)
+ (cons var real)
+ (cons block blocks)))))
+ |#
+ (else
+ (loop (cdr vars)
+ (cons var real)
+ blocks)))))))
+ ((null? real)
+ ;; Only non-trivial closures passed here.
+ (error "refilter-variables: becoming trivial!" procedure))
+ (else real)))))
+\f
+(define (attempt-children-merge block procedure update?)
+ (let ((closure-children
+ (list-transform-positive
+ (original-block-children block)
+ (lambda (block*)
+ (let ((procedure* (block-procedure block*)))
+ (and procedure*
+ (procedure/full-closure? procedure*)))))))
+ (and (not (null? closure-children))
+ (list-split
+ closure-children
+ (lambda (block*)
+ (procedure-get (block-procedure block*) 'UNCONDITIONAL))
+ (lambda (unconditional conditional)
+ (and (not (null? unconditional))
+ (or (not (null? conditional))
+ (not (null? (cdr unconditional))))
+ (merge-children! block procedure
+ unconditional conditional
+ update?)))))))
+
+(define (merge-children! block procedure unconditional conditional update?)
+ (let ((ic-parent
+ (let ((block
+ (list-search-positive unconditional
+ (lambda (block*)
+ (block-parent (block-parent block*))))))
+ (and block
+ (block-parent (block-parent block)))))
+ (closed-over-variables
+ (refilter-variables
+ (reduce-right eq-set-union
+ '()
+ (map (lambda (block*)
+ (block-bound-variables (block-parent block*)))
+ unconditional))
+ update? (block-procedure (car unconditional)))))
+ (let loop ((conditional conditional)
+ (block-closed (reverse unconditional)))
+ (cond ((not (null? conditional))
+ (loop (cdr conditional)
+ (let* ((block* (car conditional))
+ (closure-block (block-parent block*)))
+ (if (and (or (not (block-parent closure-block))
+ ic-parent)
+ (for-all?
+ (refilter-variables
+ (block-bound-variables closure-block)
+ update? (block-procedure block*))
+ (lambda (var)
+ (or (lvalue-implicit? var unconditional)
+ (let ((ind (variable-indirection var)))
+ (memq (if ind
+ (car ind)
+ var)
+ closed-over-variables))))))
+ (cons (car conditional) block-closed)
+ block-closed))))
+ ((null? (cdr block-closed))
+ false)
+ (else
+ (link-children! block procedure (reverse block-closed)
+ ic-parent closed-over-variables))))))
+\f
+(define closure-redirection-tag (intern "#[closure-redirection]"))
+
+(define (link-children! block procedure block-closed ic-parent variables)
+ ;; Possible improvement: the real free variables may be references
+ ;; to closure ancestors. At this point, all of them can be merged
+ ;; with the ancestor parent! This should be pretty rare, but...
+ (list-split
+ variables
+ (lambda (var)
+ (lvalue-implicit? var block-closed))
+ (lambda (removable real)
+ (if (and (null? real) (not ic-parent))
+ (error "link-children!: Trivial multiclosure" block-closed variables))
+ (let ((letrec-names (procedure-names procedure))
+ (indirection-var (make-variable block closure-redirection-tag))
+ (shared-block
+ (make-closure-block
+ ic-parent
+ (reduce-right eq-set-union
+ '()
+ (map (lambda (block*)
+ (block-free-variables (block-parent block*)))
+ block-closed))
+ real
+ '())))
+ (set-variable-closed-over?! indirection-var true)
+ (let ((cache (list shared-block)))
+ (set-lvalue-initial-values! indirection-var cache)
+ (set-lvalue-values-cache! indirection-var cache)
+ (set-lvalue-known-value! indirection-var shared-block))
+ ;; what follows is a kludge to communicate with
+ ;; rtlgen/rgproc.scm
+ (set-procedure-names! procedure
+ (cons indirection-var letrec-names))
+ (set-procedure-values! procedure
+ (cons shared-block (procedure-values procedure)))
+ (set-block-bound-variables! block
+ (append (block-bound-variables block)
+ (list indirection-var)))
+ (set-block-entry-number! shared-block 0)
+ (for-each
+ (let ((pair `(INDIRECTED . ,indirection-var)))
+ (lambda (block)
+ (graft-block! pair shared-block
+ (block-parent block) (block-procedure block))))
+ block-closed)
+ (let ((pair (cons indirection-var true)))
+ (for-each
+ (lambda (removable)
+ (if (not (memq removable letrec-names))
+ (error "link-children!: non-letrec removable" removable))
+ (set-variable-indirection! removable pair))
+ removable)
+ (for-each
+ (lambda (name)
+ (if (not (variable-indirection name))
+ (let ((proc (lvalue-known-closure name)))
+ (if (and proc
+ (eq? (block-shared-block
+ (procedure-closing-block proc))
+ shared-block))
+ (set-variable-indirection! name pair)))))
+ letrec-names)
+ true)))))
+\f
+(define (graft-block! how-consed block block* procedure*)
+ (if (or (closure-procedure-needs-external-descriptor? procedure*)
+ ;; Known lexpr closures are invoked through apply.
+ (procedure-rest procedure*))
+ (let ((entry (block-entry-number block)))
+ (if (zero? entry)
+ (set-block-procedure! block procedure*))
+ (set-block-entry-number! block (1+ entry))
+ (set-block-entry-number! block* entry))
+ (set-block-entry-number! block* 0))
+ (let ((parent (block-parent block))
+ (parent* (block-parent block*)))
+ (cond ((not parent*)
+ (if parent
+ (set-block-parent! block* parent)))
+ ((not parent)
+ (set-block-parent! block parent*)
+ (for-each (lambda (block**)
+ (set-block-parent! block** parent*))
+ (block-grafted-blocks block)))
+ ((not (eq? parent parent*))
+ (error "graft-block!: Differing parents" block block*))))
+ (set-procedure-closure-cons! procedure* how-consed)
+ (set-block-shared-block! block* block)
+ ;; Note that the list of grafted blocks are in decreasing entry
+ ;; number order, except for those that have 0 as their entry number
+ ;; (and thus don't need entries). This is used to advantage in
+ ;; make-non-trivial-closure-cons in rtlgen/rgrval.scm .
+ (let ((new-grafts (cons block* (block-grafted-blocks block))))
+ (set-block-grafted-blocks! block new-grafts)
+ (for-each (let ((bvars (block-bound-variables block)))
+ (lambda (block*)
+ (set-block-bound-variables! block* bvars)
+ (let ((size
+ (compute-closure-offsets!
+ block*
+ (closure-block-first-offset block*))))
+ (if (not (null? (block-children block*)))
+ (set-procedure-closure-size!
+ (block-procedure (car (block-children block*)))
+ size)))))
+ (cons block new-grafts))))
+\f
+;;; Utilities that should live elsewhere
+
+(define (indirection-block-procedure block)
+ (or (block-procedure block)
+ (if (null? (block-grafted-blocks block))
+ (error "indirection-block-procedure: Bad indirection block" block)
+ (block-procedure
+ (car (block-children
+ (car (block-grafted-blocks block))))))))
+
+(define (lvalue-implicit? var blocks)
+ (let ((val (lvalue-known-value var)))
+ (and val
+ (rvalue/procedure? val)
+ (memq (procedure-block val) blocks))))
+
+(define (lvalue-known-closure var)
+ (let ((val (lvalue-known-value var)))
+ (and val
+ (rvalue/procedure? val)
+ (procedure/full-closure? val)
+ val)))
+
+(define-integrable (procedure/full-closure? proc)
+ (and (procedure/closure? proc)
+ (not (procedure/trivial-closure? proc))))
+
+(define (list-split list predicate recvr)
+ (let split ((list list)
+ (recvr recvr))
+ (if (not (pair? list))
+ (recvr '() '())
+ (let ((next (car list)))
+ (split (cdr list)
+ (if (predicate next)
+ (lambda (win lose)
+ (recvr (cons next win) lose))
+ (lambda (win lose)
+ (recvr win (cons next lose)))))))))
\f
(define (find-closure-bindings block free-variables bound-variables
variables-nontransitively-free)
(if (or (not block) (ic-block? block))
(let ((grandparent (and (not (null? free-variables)) block)))
(if (null? bound-variables)
- (values grandparent (if grandparent 1 0))
- (make-closure-block grandparent
- free-variables
- bound-variables
- variables-nontransitively-free)))
+ (values grandparent false)
+ (values
+ (make-closure-block grandparent
+ free-variables
+ bound-variables
+ variables-nontransitively-free)
+ true)))
(with-values
(lambda ()
(filter-bound-variables (block-bound-variables block)
free-variables
bound-variables))))
-;; Note: The use of closure-block-first-offset below implies that
-;; closure frames are not shared between different closures.
-;; This may have to change if we ever do simultaneous closing of multiple
-;; procedures sharing structure.
-
(define (make-closure-block parent free-variables bound-variables
variables-nontransitively-free)
(let ((block (make-block parent 'CLOSURE)))
(set-block-variables-nontransitively-free!
block
variables-nontransitively-free)
- (do ((variables (block-bound-variables block) (cdr variables))
- (size (if (and parent (ic-block/use-lookup? parent)) 1 0) (1+ size))
- (table '()
- (cons (cons (car variables)
- (+ closure-block-first-offset size))
- table)))
- ((null? variables)
- (set-block-closure-offsets! block table)
- (values block size))
- (if (lvalue-integrated? (car variables))
- (error "make-closure-block: integrated lvalue" (car variables))))))
+ (set-block-shared-block! block block)
+ (set-block-entry-number! block 1)
+ (set-block-grafted-blocks! block '())
+ block))
+
+(define (compute-closure-offsets! block offset)
+ (if block
+ (let ((parent (block-parent block)))
+ (do ((variables (block-bound-variables block) (cdr variables))
+ (size (if (and parent (ic-block/use-lookup? parent)) 1 0)
+ (1+ size))
+ (table '()
+ (cons (cons (car variables) (+ offset size))
+ table)))
+ ((null? variables)
+ (set-block-closure-offsets! block table)
+ size)
+ (if (lvalue-integrated? (car variables))
+ (error "compute-closure-offsets!: integrated lvalue"
+ (car variables)))))
+ 0))
\f
+;;;; Reference contexts in which procedures are closed.
+;;; Needed to determine the access paths of free variables to close over.
+
(define (setup-closure-contexts! expression procedures)
(with-new-node-marks
(lambda ()
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.14 1990/04/01 22:23:16 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.15 1990/05/03 15:09:07 jinx Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Closure Analysis
+;;; package: (compiler fg-optimizer closure-analysis)
(declare (usual-integrations))
\f
;; is an ancestor if free variables captured by `block*' are needed.
(define (process-descendant block)
- (for-each-block-descendent!
+ (for-each-block-descendant!
block
(lambda (block*)
(for-each process-disowned (block-disowned-children block*)))))
constraints))
(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)))))
+ (transfer-block-child! block (block-parent block) new-parent))
\f
;;;; Utilities
;; envopt has an identical definition commented out.
(define (for-each-callee! block action)
- (for-each-block-descendent! block
+ (for-each-block-descendant! block
(lambda (block*)
(for-each (lambda (application)
(for-each (lambda (value)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/envopt.scm,v 1.6 1990/04/01 22:19:41 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/envopt.scm,v 1.7 1990/05/03 15:09:12 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Procedure environment optimization
+;;; package: (compiler fg-optimizer environment-optimization)
(declare (usual-integrations))
\f
;; world (which is ultimately functional).
(define (for-each-callee! block procedure)
- (for-each-block-descendent! block
+ (for-each-block-descendant! block
(lambda (block*)
(for-each (lambda (application)
(for-each (lambda (value)
;; invocation block.
(set-procedure-target-block! procedure parent)
(if (not (eq? parent target-block))
- (begin
- (disown-block-child! parent block)
- (own-block-child! target-block block)))))
+ (transfer-block-child! block parent target-block))))
#|
(define (choose-target-block! procedure)
(lambda (application)
(eq? (application-block application)
parent)))))))
- (begin
- (disown-block-child! parent block)
- (own-block-child! target-block block)))
+ (transfer-block-child! block parent target-block))
unspecific))
|#
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.6 1988/12/12 21:51:52 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.7 1990/05/03 15:09:17 jinx Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; Compute FG Node Offsets
+;;; package: (compiler fg-optimizer compute-node-offsets)
(declare (usual-integrations))
\f
+(define *grafted-procedures*)
(define *procedure-queue*)
(define *procedures*)
(define (compute-node-offsets root-expression)
(fluid-let ((*procedure-queue* (make-queue))
+ (*grafted-procedures* '())
(*procedures* '()))
(with-new-node-marks
(lambda ()
(walk-node (expression-entry-node root-expression) 0)
(queue-map!/unsafe *procedure-queue*
- (lambda (procedure)
- (if (procedure-continuation? procedure)
- (walk-next (continuation/entry-node procedure)
- (if (eq? (continuation/type procedure)
- continuation-type/push)
- (1+ (continuation/offset procedure))
- (continuation/offset procedure)))
- (begin
- (for-each
- (lambda (value)
- (if (and (rvalue/procedure? value)
- (not (procedure-continuation? value)))
- (let ((context (procedure-closure-context value)))
- (if (reference-context? context)
- (update-reference-context/offset! context 0))))
- (walk-rvalue value 0))
- (procedure-values procedure))
- (walk-next (procedure-entry-node procedure) 0)))))))))
+ (lambda (procedure)
+ (if (procedure-continuation? procedure)
+ (walk-next (continuation/entry-node procedure)
+ (if (eq? (continuation/type procedure)
+ continuation-type/push)
+ (1+ (continuation/offset procedure))
+ (continuation/offset procedure)))
+ (begin
+ (for-each
+ (lambda (value)
+ (cond ((and (rvalue/procedure? value)
+ (not (procedure-continuation? value)))
+ (let ((context (procedure-closure-context value)))
+ (if (reference-context? context)
+ (update-reference-context/offset! context 0)))
+ (walk-rvalue value 0))
+ ((rvalue/block? value)
+ (enqueue-grafted-procedures! value))
+ (else
+ (walk-rvalue value 0))))
+ (procedure-values procedure))
+ (walk-next (procedure-entry-node procedure) 0)))))
+ ;; This is a kludge. If the procedure hasn't been encountered
+ ;; elsewhere, tag it as closed when the letrec was done.
+ (for-each
+ (lambda (procedure)
+ (let ((context (procedure-closure-context procedure)))
+ (if (not (reference-context/offset context))
+ (set-reference-context/offset! context 0))))
+ *grafted-procedures*)))))
+
+(define (enqueue-grafted-procedures! block)
+ (let ((procs (map (lambda (block)
+ (block-procedure (car (block-children block))))
+ (block-grafted-blocks block))))
+ (set! *grafted-procedures* (append procs *grafted-procedures*))
+ (for-each maybe-enqueue-procedure! procs)))
(define (walk-rvalue rvalue offset)
(if (and (rvalue/procedure? rvalue)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/sideff.scm,v 1.6 1990/03/21 02:11:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/sideff.scm,v 1.7 1990/05/03 15:09:20 jinx Rel $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Side effect analysis
+;;; package: (compiler fg-optimizer)
(declare (usual-integrations))
\f
r/lvalue))
\f
(define (procedure/trivial! procedure kind)
- (let ((place (assq 'TRIVIAL (procedure-properties procedure))))
- (cond ((not place)
- (set-procedure-properties!
- procedure
- (cons `(TRIVIAL ,kind) (procedure-properties procedure))))
- ((not (memq kind (cdr place)))
- (set-cdr! place (cons kind (cdr place)))))))
+ (let ((kinds (procedure-get procedure 'TRIVIAL)))
+ (cond ((or (not kinds) (null? kinds))
+ (procedure-put! procedure 'TRIVIAL (list kind)))
+ ((not (memq kind kinds))
+ (procedure-put! procedure 'TRIVIAL (cons kind kinds))))))
(define (simplify-procedure! procedure r/lvalue)
- (let ((place (assq 'SIMPLIFIED (procedure-properties procedure))))
- (if place
- (error "procedure/trivial!: Already simplified" procedure))
- (set-procedure-properties! procedure
- (cons `(SIMPLIFIED ,r/lvalue)
- (procedure-properties procedure))))
;; **** Kludge! `make-application' requires that a block be given,
;; rather than a context, because this is how "fggen" builds things.
;; So we must pass the block and then clobber it after.
+ (if (procedure-get procedure 'SIMPLIFIED)
+ (error "procedure/trivial!: Already simplified" procedure))
+ (procedure-put! procedure 'SIMPLIFIED r/lvalue)
(let ((block (procedure-block procedure)))
(let ((context (make-reference-context block)))
(let ((application
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/subfre.scm,v 1.4 1990/01/18 22:44:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/subfre.scm,v 1.5 1990/05/03 15:09:24 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Subproblem Free Variables
+;;; package: (compiler fg-optimizer subproblem-free-variables)
(declare (usual-integrations))
\f
(with-analysis-state
(lambda ()
(for-each (lambda (parallel)
- (for-each (lambda (subproblem)
- (set-subproblem-free-variables! subproblem 'UNKNOWN))
- (parallel-subproblems parallel)))
+ (for-each
+ (lambda (subproblem)
+ (set-subproblem-free-variables! subproblem 'UNKNOWN))
+ (parallel-subproblems parallel)))
parallels)
(for-each (lambda (parallel)
(for-each walk-subproblem (parallel-subproblems parallel)))
(else
free))))
+(define (walk-procedure proc)
+ (define (default)
+ ;; This should be OK for open procedures, but perhaps
+ ;; we should look at the closure block for closures.
+ (list-transform-negative
+ (block-free-variables (procedure-block proc))
+ lvalue-integrated?))
+
+ (if (or (not (procedure/closure? proc))
+ (procedure/trivial-closure? proc))
+ (default)
+ (let ((how (procedure-closure-cons proc)))
+ (case (car how)
+ ((NORMAL)
+ (default))
+ ((DESCENDANT)
+ ;; This will automatically imply saving the ancestor
+ ;; for stack overwrites since that is how the free
+ ;; variables will be obtained.
+ ;; Is this really true?
+ ;; What if some of them are in registers?
+ ;; What if it is a descendant of an indirected procedure?
+ (default))
+ ((INDIRECTED)
+ ;; In reality, only the indirection variable or the default
+ ;; set is needed, depending on where the reference occurs.
+ ;; This is always safe, however.
+ (cons (cdr how) (default)))
+ (else
+ (error "walk-procedure: Unknown closure method" proc))))))
+
(define (walk-operator rvalue)
(enumeration-case rvalue-type (tagged-vector/index rvalue)
((REFERENCE) (walk-lvalue (reference-lvalue rvalue) walk-operator))
((PROCEDURE)
(if (procedure-continuation? rvalue)
(walk-next (continuation/entry-node rvalue) '())
- (map-union (lambda (procedure)
- (list-transform-negative
- (block-free-variables (procedure-block procedure))
- lvalue-integrated?))
+ (map-union walk-procedure
(eq-set-union (list rvalue)
(procedure-callees rvalue)))))
(else '())))
((PROCEDURE)
(if (procedure-continuation? rvalue)
(walk-next (continuation/entry-node rvalue) '())
- (list-transform-negative
- (block-free-variables (procedure-block rvalue))
- lvalue-integrated?)))
+ (walk-procedure rvalue)))
(else '())))
(define (walk-lvalue lvalue walk-rvalue)
(eq-set-adjoin lvalue (walk-rvalue value)))
(if (and (variable? lvalue)
(variable-indirection lvalue))
- (walk-lvalue (variable-indirection lvalue) walk-rvalue)
+ (walk-lvalue (car (variable-indirection lvalue))
+ walk-rvalue)
(list lvalue)))))
\f
(define *nodes*)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/varind.scm,v 1.3 1989/11/02 08:08:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/varind.scm,v 1.4 1990/05/03 15:09:28 jinx Rel $
-Copyright (c) 1989 Massachusetts Institute of Technology
+Copyright (c) 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; Variable Indirections
+;;; package: (compiler fg-optimizer variable-indirection)
(declare (usual-integrations))
\f
lvalues))))
(define (initialize-variable-indirection! variable)
- (if (not (lvalue-marked? variable))
+ (if (and (not (lvalue-marked? variable))
+ (not (variable-indirection variable)))
(begin
(lvalue-mark! variable)
(let ((block (variable-block variable)))
(begin
(initialize-variable-indirection! possibility)
(or (variable-indirection possibility)
- possibility))))))
+ (cons possibility false)))))))
(if indirection
- (begin
+ (let ((indirection-variable (car indirection)))
(set-variable-indirection! variable indirection)
(let ((variables
(block-variables-nontransitively-free block)))
- (if (not (memq indirection variables))
+ (if (not (memq indirection-variable variables))
(set-block-variables-nontransitively-free!
block
- (cons indirection variables))))
- (let ((block* (variable-block indirection)))
+ (cons indirection-variable variables))))
+ (let ((block* (variable-block indirection-variable)))
(let loop ((block block))
(let ((variables (block-free-variables block)))
- (if (not (memq indirection variables))
+ (if (not (memq indirection-variable variables))
(begin
(set-block-free-variables!
block
- (cons indirection variables))
+ (cons indirection-variable variables))
(let ((parent (block-parent block)))
(if (not (eq? parent block*))
(loop parent))))))))))))))))
\ 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.29 1990/03/26 23:45:05 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.30 1990/05/03 15:16:59 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
compiler:show-phases?
compiler:show-procedures?
compiler:show-subphases?
- compiler:show-time-reports?))
+ compiler:show-time-reports?
+ compiler:use-multiclosures?))
\f
(define-package (compiler reference-contexts)
(files "base/refctx")
(parent (compiler fg-optimizer))
(export (compiler top-level)
setup-block-types!
- setup-closure-contexts!))
+ setup-closure-contexts!)
+ (export (compiler)
+ indirection-block-procedure))
(define-package (compiler fg-optimizer simplicity-analysis)
(files "fgopt/simple")
(export (compiler rtl-generator)
generate/rvalue
load-closure-environment
+ make-cons-closure-indirection
+ make-cons-closure-redirection
+ make-closure-redirection
make-ic-cons
make-non-trivial-closure-cons
- make-trivial-closure-cons))
+ make-trivial-closure-cons
+ redirect-closure))
(define-package (compiler rtl-generator generate/combination)
(files "rtlgen/rgcomb")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.16 1989/12/11 06:16:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.17 1990/05/03 15:17:04 jinx Rel $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; 68000 Disassembler: Top Level
+;;; package: (compiler disassembler)
(declare (usual-integrations))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.26 1990/02/02 18:39:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.27 1990/05/03 15:17:08 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Compiler File Dependencies
+;;; package: (compiler declarations)
(declare (usual-integrations))
\f
(source-node/declarations node)))))
filenames))
- (let ((front-end-base
+ (let* ((front-end-base
(filename/append "base"
"blocks" "cfg1" "cfg2" "cfg3"
"contin" "ctypes" "enumer" "lvalue"
"rtlty2"))
(cse-base
(filename/append "rtlopt"
- "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr"))
+ "rcse1" "rcseht" "rcserq" "rcsesr"))
+ (cse-all
+ (append (filename/append "rtlopt"
+ "rcse2" "rcseep")
+ cse-base))
(instruction-base
(filename/append "machines/bobcat" "assmd" "machin"))
(lapgen-base
(append bobcat-base front-end-base rtl-base))
(file-dependency/integration/join
- (append cse-base
+ (append cse-all
(filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
"rerite" "rinvex" "rlife" "rtlcsm")
(filename/append "machines/bobcat" "rulrew"))
(append bobcat-base rtl-base))
- (file-dependency/integration/join cse-base cse-base)
+ (file-dependency/integration/join cse-all cse-base)
(file-dependency/integration/join
(filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.31 1990/04/01 22:26:01 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.32 1990/05/03 15:17:14 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; RTL Rules for 68020. Part 1
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(define (increment-machine-register register n)
(let ((target (register-reference register)))
- (case n
- ((0) (LAP))
- ((1 2) (LAP (ADDQ L (& ,(* 4 n)) ,target)))
- ((-1 -2) (LAP (SUBQ L (& ,(* -4 n)) ,target)))
- (else
- (if (< register 8)
- (LAP (ADD L (& ,(* 4 n)) ,target))
- (LAP (LEA (@AO ,(- register 8) ,(* 4 n)) ,target)))))))
+ (cond ((zero? n) (LAP))
+ ((<= 1 n 8) (LAP (ADDQ L (& ,n) ,target)))
+ ((>= -1 n -8) (LAP (SUBQ L (& ,n) ,target)))
+ ((not (< register 8))
+ (LAP (LEA (@AO ,(- register 8) ,n) ,target)))
+ ((<= -128 n 127)
+ (let ((temp (reference-temporary-register! 'DATA)))
+ (LAP (MOVEQ (& ,n) ,temp)
+ (ADD L ,temp ,target))))
+ (else
+ (LAP (ADD L (& ,n) ,target))))))
(define (load-constant constant target)
(if (non-pointer-object? constant)
(load-non-pointer-constant constant target)
- (INST (MOV L
- (@PCR ,(constant->label constant))
- ,target))))
+ (LAP (MOV L
+ (@PCR ,(constant->label constant))
+ ,target))))
(define (load-non-pointer-constant constant target)
(load-non-pointer (object-type constant)
(define (load-machine-constant n target)
(cond ((and (zero? n)
(effective-address/data&alterable? target))
- (INST (CLR L ,target)))
- ((and (<= -128 n 127)
- (effective-address/data-register? target))
- (INST (MOVEQ (& ,n) ,target)))
+ (LAP (CLR L ,target)))
+ ((not (effective-address/data-register? target))
+ (LAP (MOV UL (& ,n) ,target)))
+ ((<= -128 n 127)
+ (LAP (MOVEQ (& ,n) ,target)))
(else
- (INST (MOV UL (& ,n) ,target)))))
+ (find-zero-bits n
+ (lambda (zero-bits datum)
+ (cond ((> datum 127)
+ (LAP (MOV UL (& ,n) ,target)))
+ ((<= zero-bits 16)
+ (LAP (MOVEQ (& ,datum) ,target)
+ (LS L L (& ,zero-bits) ,target)))
+ (else
+ ;; This is useful for type-code or-masks.
+ ;; It should be extended to handle and-masks.
+ (LAP (MOVEQ (& ,datum) ,target)
+ (RO R L (& ,(- 32 zero-bits)) ,target)))))))))
+
+(define (find-zero-bits n receiver)
+ (let loop ((bits 0) (n n))
+ (let ((result (integer-divide n 2)))
+ (if (zero? (integer-divide-remainder result))
+ (loop (1+ bits)
+ (integer-divide-quotient result))
+ (receiver bits n)))))
(define (memory-set-type type target)
(if (= 8 scheme-type-width)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.21 1990/04/01 22:28:28 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.22 1990/05/03 15:17:20 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Machine Model for 68020
+;;; package: (compiler)
(declare (usual-integrations))
\f
(define-integrable (stack->memory-offset offset) offset)
(define-integrable ic-block-first-parameter-offset 2)
-(define-integrable closure-block-first-offset 2)
+
+;; This must return a word based offset.
+;; On the 68k, to save space, entries can be at 2 mod 4 addresses,
+;; which makes this impossible if the closure object used for
+;; referencing points to arbitrary entries. Instead, all closure
+;; entry points bump to the canonical entry point, which is always
+;; longword aligned.
+;; On other machines (word aligned), it may be easier to bump back
+;; to each entry point, and the entry number `entry' would be part
+;; of the computation.
+
+(define (closure-first-offset nentries entry)
+ entry ; ignored
+ (if (zero? nentries)
+ 1
+ (quotient (+ (+ 3 1) (* 5 (- nentries 1))) 2)))
+
+;; This is from the start of the complete closure object,
+;; viewed as a vector, and including the header word.
+
+(define (closure-object-first-offset nentries)
+ (case nentries
+ ((0) 1)
+ ((1) 4)
+ (else
+ (quotient (+ 5 (* 5 nentries)) 2))))
+
+;; Bump from one entry point to another.
+
+(define (closure-entry-distance nentries entry entry*)
+ nentries ; ignored
+ (* 10 (- entry* entry)))
+
+;; Bump to the canonical entry point.
+
+(define (closure-environment-adjustment nentries entry)
+ (declare (integrate-operator closure-entry-distance))
+ (closure-entry-distance nentries entry 0))
(define-integrable d0 0)
(define-integrable d1 1)
ENTRY:CONTINUATION
ASSIGNMENT-CACHE
VARIABLE-CACHE
- OFFSET-ADDRESS)
+ OFFSET-ADDRESS
+ BYTE-OFFSET-ADDRESS)
3)
((CONS-POINTER)
(and (rtl:machine-constant? (rtl:cons-pointer-type expression))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.72 1990/04/03 04:50:08 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.73 1990/05/03 15:17:24 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
'((COMPILER MACROS)
(COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (Motorola MC68020)" 4 72 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (Motorola MC68020)" 4 73 '()))
\ 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.32 1990/01/18 22:43:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.33 1990/05/03 15:17:28 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; LAP Generation Rules: Data Transfers
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(define-rule statement
(ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))
- (load-static-link target source n false))
+ (load-static-link target source (* 4 n) false))
(define-rule statement
;; This is an intermediate rule -- not intended to produce code.
(ASSIGN (REGISTER (? target))
(CONS-POINTER (MACHINE-CONSTANT (? type))
(OFFSET-ADDRESS (REGISTER (? source)) (? n))))
- (load-static-link target source n
+ (load-static-link target source (* 4 n)
(lambda (target)
(LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))))
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n)))
+ (load-static-link target source n false))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (load-static-link target source n
+ (lambda (target)
+ (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))))
+\f
(define (load-static-link target source n suffix)
(if (and (zero? n) (not suffix))
(assign-register->register target source)
(let ((non-reusable
- (if (not suffix)
- (lambda ()
- (let ((source (allocate-indirection-register! source)))
- (delete-dead-registers!)
- (let ((target (allocate-alias-register! target 'ADDRESS)))
- (if (eqv? source target)
- (increment-machine-register target n)
- (LAP (LEA ,(offset-reference source n)
- ,(register-reference target)))))))
- (lambda ()
- (let ((source (indirect-reference! source n)))
- (delete-dead-registers!)
- (let ((temp (reference-temporary-register! 'ADDRESS)))
- (let ((target (reference-target-alias! target 'DATA)))
- (LAP (LEA ,source ,temp)
- (MOV L ,temp ,target)
- ,@(suffix target)))))))))
+ (cond ((not suffix)
+ (lambda ()
+ (let ((source (allocate-indirection-register! source)))
+ (delete-dead-registers!)
+ (let ((target (allocate-alias-register! target
+ 'ADDRESS)))
+ (if (eqv? source target)
+ (increment-machine-register target n)
+ (LAP (LEA ,(byte-offset-reference source n)
+ ,(register-reference target))))))))
+ ((<= -128 n 127)
+ (lambda ()
+ (let ((source (register-reference source)))
+ (delete-dead-registers!)
+ (let ((target (reference-target-alias! target 'DATA)))
+ (LAP (MOVEQ (& ,n) ,target)
+ (ADD L ,source ,target))))))
+ (else
+ (lambda ()
+ (let ((source (indirect-byte-reference! source n)))
+ (delete-dead-registers!)
+ (let ((temp (reference-temporary-register! 'ADDRESS)))
+ (let ((target (reference-target-alias! target
+ 'DATA)))
+ (LAP (LEA ,source ,temp)
+ (MOV L ,temp ,target)
+ ,@(suffix target))))))))))
(if (machine-register? source)
(non-reusable)
(reuse-pseudo-register-alias! source 'DATA
(define-rule statement
(ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- (LAP ,(load-constant source (standard-target-reference target))))
+ (load-constant source (standard-target-reference target)))
(define-rule statement
(ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n)))
- (LAP ,(load-machine-constant n (standard-target-reference target))))
+ (load-machine-constant n (standard-target-reference target)))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
- (LAP ,(load-non-pointer type datum (standard-target-reference target))))
+ (load-non-pointer type datum (standard-target-reference target)))
(define-rule statement
(ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
(delete-dead-registers!)
(let ((target (reference-target-alias! target 'DATA)))
(if (non-pointer-object? constant)
- (LAP ,(load-non-pointer 0 (careful-object-datum constant) target))
- (LAP ,(load-constant constant target)
+ (load-non-pointer 0 (careful-object-datum constant) target)
+ (LAP ,@(load-constant constant target)
,@(conversion target)))))
(define-rule statement
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
(CONSTANT (? object)))
- (LAP ,(load-constant object (indirect-reference! a n))))
+ (load-constant object (indirect-reference! a n)))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
- (LAP ,(load-non-pointer type datum (indirect-reference! a n))))
+ (load-non-pointer type datum (indirect-reference! a n)))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r)))
(MOV L ,temp ,target)
,(memory-set-type type target))))
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+ (let ((temp (reference-temporary-register! 'ADDRESS))
+ (target (indirect-reference! address offset)))
+ (LAP (LEA ,(indirect-byte-reference! source n) ,temp)
+ (MOV L ,temp ,target)
+ ,(memory-set-type type target))))
+\f
+;; Common case that can be done cheaply:
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+ (BYTE-OFFSET-ADDRESS (OFFSET (REGISTER (? address)) (? offset))
+ (? n)))
+ (if (zero? n)
+ (LAP)
+ (let ((target (indirect-byte-reference! address offset)))
+ (cond ((<= 1 n 8)
+ (LAP (ADDQ L (& ,n) ,target)))
+ ((<= -8 n -1)
+ (LAP (SUBQ L (& ,(- n)) ,target)))
+ ((<= -128 n 127)
+ (let ((temp (reference-temporary-register! 'DATA)))
+ (LAP (MOVEQ (& ,n) ,temp)
+ (ADD L ,temp ,target))))
+ (else
+ (LAP (ADD L (& ,n) ,target)))))))
+
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? address)) (? offset))
(CONS-POINTER (MACHINE-CONSTANT (? type))
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1) (CONSTANT (? object)))
- (LAP ,(load-constant object (INST-EA (@A+ 5)))))
+ (load-constant object (INST-EA (@A+ 5))))
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
- (LAP ,(load-non-pointer type datum (INST-EA (@A+ 5)))))
+ (load-non-pointer type datum (INST-EA (@A+ 5))))
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r)))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONSTANT (? object)))
- (LAP ,(load-constant object (INST-EA (@-A 7)))))
+ (load-constant object (INST-EA (@-A 7))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
- (LAP ,(load-non-pointer type datum (INST-EA (@-A 7)))))
+ (load-non-pointer type datum (INST-EA (@-A 7))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(LAP (PEA ,(indirect-reference! r n))
,(memory-set-type type (INST-EA (@A 7)))))
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? r)) (? n))))
+ (LAP (PEA ,(indirect-byte-reference! r n))
+ ,(memory-set-type type (INST-EA (@A 7)))))
+
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n)))
(LAP (MOV L ,(indirect-reference! r n) (@-A 7))))
(let ((target (reference-target-alias! target 'DATA)))
(LAP (MOV L (A 5) ,target)
(OR L (& ,(make-non-pointer-literal (ucode-type flonum) 0)) ,target)
- ,(load-non-pointer (ucode-type manifest-nm-vector)
- flonum-size
- (INST-EA (@A+ 5)))
+ ,@(load-non-pointer (ucode-type manifest-nm-vector)
+ flonum-size
+ (INST-EA (@A+ 5)))
(FMOVE D ,source (@A+ 5))))))
(define-rule statement
(define (load-char-into-register type source target)
(delete-dead-registers!)
(let ((target (reference-target-alias! target 'DATA)))
- (LAP ,(load-non-pointer type 0 target)
+ (LAP ,@(load-non-pointer type 0 target)
(MOV B ,source ,target))))
(define-rule statement
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.23 1990/01/18 22:44:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.24 1990/05/03 15:17:33 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(delete-dead-registers!)
(LAP ,@set-environment
,@(clear-map!)
- ,(load-constant name (INST-EA (D 2)))
+ ,@(load-constant name (INST-EA (D 2)))
,(load-dnl frame-size 3)
,@(invoke-interface code:compiler-lookup-apply))))
(cond ((zero? how-far)
(LAP))
((zero? frame-size)
- (increment-machine-register 15 how-far))
+ (increment-machine-register 15 (* 4 how-far)))
((= frame-size 1)
(LAP (MOV L (@A+ 7) ,(offset-reference a7 (-1+ how-far)))
- ,@(increment-machine-register 15 (-1+ how-far))))
+ ,@(increment-machine-register 15 (* 4 (-1+ how-far)))))
((= frame-size 2)
(if (= how-far 1)
(LAP (MOV L (@AO 7 4) (@AO 7 8))
,(offset-reference a7 (-1+ how-far)))))))
(LAP ,(i)
,(i)
- ,@(increment-machine-register 15 (- how-far 2))))))
+ ,@(increment-machine-register 15 (* 4 (- how-far 2)))))))
(else
(generate/move-frame-up frame-size (offset-reference a7 offset))))))
(define internal-entry-code-word
(make-code-word #xff #xfe))
+(define (frame-size->code-word offset)
+ (cond ((not offset)
+ (make-code-word #xff #xfc))
+ ((< offset #x2000)
+ ;; This uses up through (#xff #xdf).
+ (let ((qr (integer-divide offset #x80)))
+ (make-code-word (+ #x80 (integer-divide-remainder qr))
+ (+ #x80 (integer-divide-quotient qr)))))
+ (else
+ (error "Unable to encode continuation offset" offset))))
+
(define (continuation-code-word label)
- (let ((offset
- (if label
- (rtl-continuation/next-continuation-offset (label->object label))
- 0)))
- (cond ((not offset)
- (make-code-word #xff #xfc))
- ((< offset #x2000)
- ;; This uses up through (#xff #xdf).
- (let ((qr (integer-divide offset #x80)))
- (make-code-word (+ #x80 (integer-divide-remainder qr))
- (+ #x80 (integer-divide-quotient qr)))))
- (else
- (error "Unable to encode continuation offset" offset)))))
+ (frame-size->code-word
+ (if label
+ (rtl-continuation/next-continuation-offset (label->object label))
+ 0)))
\f
;;;; Procedure headers
entry:compiler-interrupt-procedure)))
\f
;;;; Closures. These two statements are intertwined:
+;;; Note: If the closure is a multiclosure, the closure object on the
+;;; stack corresponds to the first (official) entry point.
+;;; Thus on entry and interrupt it must be bumped around.
-(define magic-closure-constant
- (- (make-non-pointer-literal (ucode-type compiled-entry) 0) 6))
+(define (make-magic-closure-constant entry)
+ (- (make-non-pointer-literal (ucode-type compiled-entry) 0)
+ (+ (* entry 10) 6)))
(define-rule statement
- (CLOSURE-HEADER (? internal-label))
+ (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+ nentries ; ignored
(let ((procedure (label->object internal-label)))
(let ((gc-label (generate-label))
(external-label (rtl-procedure/external-label procedure)))
- (LAP (LABEL ,gc-label)
- (JMP ,entry:compiler-interrupt-closure)
- ,@(make-external-label internal-entry-code-word external-label)
- (ADD UL (& ,magic-closure-constant) (@A 7))
- (LABEL ,internal-label)
- (CMP L ,reg:compiled-memtop (A 5))
- (B GE B (@PCR ,gc-label))))))
+ (if (zero? nentries)
+ (LAP (EQUATE ,external-label ,internal-label)
+ ,@(simple-procedure-header internal-entry-code-word
+ internal-label
+ entry:compiler-interrupt-procedure))
+ (LAP (LABEL ,gc-label)
+ ,@(let ((distance (* 10 entry)))
+ (cond ((zero? distance)
+ (LAP))
+ ((< distance 128)
+ (LAP (MOVEQ (& ,distance) (D 0))
+ (ADD L (D 0) (@A 7))))
+ (else
+ (LAP (ADD L (& ,distance) (@A 7))))))
+ (JMP ,entry:compiler-interrupt-closure)
+ ,@(make-external-label internal-entry-code-word
+ external-label)
+ (ADD UL (& ,(make-magic-closure-constant entry)) (@A 7))
+ (LABEL ,internal-label)
+ (CMP L ,reg:compiled-memtop (A 5))
+ (B GE B (@PCR ,gc-label)))))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
(? min) (? max) (? size)))
- (generate/cons-closure (reference-target-alias! target 'DATA)
+ (generate/cons-closure (reference-target-alias! target 'ADDRESS)
false procedure-label min max size))
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? size))))
- (generate/cons-closure (reference-target-alias! target 'DATA)
- type procedure-label min max size))
-
-(define-rule statement
- (ASSIGN (? target)
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? size))))
- (QUALIFIER (standard-target-expression? target))
- (let ((temporary (reference-temporary-register! 'DATA)))
- (LAP ,@(generate/cons-closure temporary type procedure-label min max size)
- (MOV L ,temporary ,(standard-target-expression->ea target)))))
-
(define (generate/cons-closure target type procedure-label min max size)
(let ((temporary (reference-temporary-register! 'ADDRESS)))
(LAP (LEA (@PCR ,(rtl-procedure/external-label
(label->object procedure-label)))
,temporary)
- ,(load-non-pointer (ucode-type manifest-closure)
- (+ 3 size)
- (INST-EA (@A+ 5)))
+ ,@(load-non-pointer (ucode-type manifest-closure)
+ (+ 3 size)
+ (INST-EA (@A+ 5)))
(MOV UL
(& ,(+ (* (make-procedure-code-word min max) #x10000) 8))
(@A+ 5))
(MOV UW (& #x4eb9) (@A+ 5)) ; (JSR (L <entry>))
(MOV L ,temporary (@A+ 5))
(CLR W (@A+ 5))
- ,@(increment-machine-register 13 size))))
+ ,@(increment-machine-register 13 (* 4 size)))))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
+ (let ((target (reference-target-alias! target 'ADDRESS)))
+ (case nentries
+ ((0)
+ (LAP (MOV L (A 5) ,target)
+ ,@(load-non-pointer (ucode-type manifest-vector)
+ size
+ (INST-EA (@A+ 5)))
+ ,@(increment-machine-register 13 (* 4 size))))
+ ((1)
+ (let ((entry (vector-ref entries 0)))
+ (generate/cons-closure target false
+ (car entry) (cadr entry) (caddr entry)
+ size)))
+ (else
+ (generate/cons-multiclosure target nentries size
+ (vector->list entries))))))
+
+(define (generate/cons-multiclosure target nentries size entries)
+ (let ((total-size (+ size
+ (quotient (+ 3 (* 5 nentries))
+ 2)))
+ (temp1 (reference-temporary-register! 'ADDRESS))
+ (temp2 (reference-temporary-register! 'DATA)))
+
+ (define (generate-entries entries offset first?)
+ (if (null? entries)
+ (LAP)
+ (let ((entry (car entries)))
+ (LAP (MOV UL (& ,(+ (* (make-procedure-code-word (cadr entry)
+ (caddr entry))
+ #x10000)
+ offset))
+ (@A+ 5))
+ ,@(if first?
+ (LAP (MOV L (A 5) ,target))
+ (LAP))
+ (LEA (@PCR ,(rtl-procedure/external-label
+ (label->object (car entry))))
+ ,temp1)
+ (MOV W ,temp2 (@A+ 5)) ; (JSR (L <entry>))
+ (MOV L ,temp1 (@A+ 5))
+ ,@(generate-entries (cdr entries)
+ (+ 10 offset)
+ false)))))
+
+ (LAP ,@(load-non-pointer (ucode-type manifest-closure)
+ total-size
+ (INST-EA (@A+ 5)))
+ (MOV UL (& ,(* nentries #x10000)) (@A+ 5))
+ (MOV UW (& #x4eb9) ,temp2)
+ ,@(generate-entries entries
+ (if (= nentries 1)
+ 8
+ 12)
+ true)
+ ,@(if (odd? nentries)
+ (LAP (CLR W (@A+ 5)))
+ (LAP))
+ ,@(increment-machine-register 13 (* 4 size)))))
\f
;;;; Entry Header
;;; This is invoked by the top level of the LAP generator.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.11 1990/01/20 07:26:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.12 1990/05/03 15:17:38 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(load-machine-register! (rtl:register-number expression) register))
((CONSTANT)
(LAP ,@(clear-registers! register)
- ,(load-constant (rtl:constant-value expression) target)))
+ ,@(load-constant (rtl:constant-value expression) target)))
((CONS-POINTER)
(LAP ,@(clear-registers! register)
- ,(load-non-pointer (rtl:machine-constant-value
- (rtl:cons-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-pointer-datum expression))
- target)))
+ ,@(load-non-pointer (rtl:machine-constant-value
+ (rtl:cons-pointer-type expression))
+ (rtl:machine-constant-value
+ (rtl:cons-pointer-datum expression))
+ target)))
((OFFSET)
(let ((source-reference (offset->indirect-reference! expression)))
(LAP ,@(clear-registers! register)
(let ((clear-map (clear-map!)))
(LAP ,@set-environment
,@clear-map
- ,(load-constant name (INST-EA (D 3)))
+ ,@(load-constant name (INST-EA (D 3)))
,@(invoke-interface-jsr code)))))
\f
(define-rule statement
(LAP ,@set-environment
,@set-value
,@clear-map
- ,(load-constant name (INST-EA (D 3)))
+ ,@(load-constant name (INST-EA (D 3)))
,@(invoke-interface-jsr code))))))
(define-rule statement
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rulrew.scm,v 1.2 1990/04/03 04:52:22 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rulrew.scm,v 1.3 1990/05/03 15:17:42 jinx Rel $
Copyright (c) 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; RTL Rewrite Rules
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(define-rule rewriting
(OBJECT->DATUM (REGISTER (? source register-known-value)))
(QUALIFIER (rtl:constant-non-pointer? source))
- (rtl:make-machine-constant (careful-object-datum (rtl:constant-value source))))
+ (rtl:make-machine-constant
+ (careful-object-datum (rtl:constant-value source))))
(define (rtl:constant-non-pointer? expression)
(and (rtl:constant? expression)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.20 1990/01/18 22:45:15 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.21 1990/05/03 15:10:19 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Register Transfer Language: Complex Constructors
+;;; package: (compiler)
(declare (usual-integrations))
\f
(lambda (element)
(loop (cdr elements*)
(cons element simplified-elements)))))))))))
-
+\f
(define-expression-method 'TYPED-CONS:PROCEDURE
- ;; A NOP for simplification
- (lambda (receiver scfg-append! type entry min max size)
- scfg-append!
- (receiver (rtl:make-typed-cons:procedure type entry min max size))))
+ (lambda (receiver scfg-append! entry)
+ (expression-simplify
+ entry scfg-append!
+ (lambda (entry)
+ (receiver (rtl:make-cons-pointer
+ (rtl:make-machine-constant type-code:compiled-entry)
+ entry))))))
+
+(define-expression-method 'BYTE-OFFSET-ADDRESS
+ (lambda (receiver scfg-append! base number)
+ (expression-simplify
+ base scfg-append!
+ (lambda (base)
+ (receiver (rtl:make-byte-offset-address base number))))))
+
+;; NOPs for simplification
+
+(define-expression-method 'ENTRY:CONTINUATION
+ (lambda (receiver scfg-append! label)
+ scfg-append! ; unused
+ (receiver (rtl:make-entry:continuation label))))
+
+(define-expression-method 'ENTRY:PROCEDURE
+ (lambda (receiver scfg-append! label)
+ scfg-append! ; unused
+ (receiver (rtl:make-entry:procedure label))))
+
+(define-expression-method 'CONS-CLOSURE
+ (lambda (receiver scfg-append! entry min max size)
+ scfg-append! ; unused
+ (receiver (rtl:make-cons-closure entry min max size))))
+
+(define-expression-method 'CONS-MULTICLOSURE
+ (lambda (receiver scfg-append! nentries size entries)
+ scfg-append! ; unused
+ (receiver (rtl:make-cons-multiclosure nentries size entries))))
\f
(define (object-selector make-object-selector)
(lambda (receiver scfg-append! expression)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.15 1990/01/18 22:45:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.16 1990/05/03 15:10:27 jinx Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Register Transfer Language: Expression Operations
+;;; package: (compiler)
(declare (usual-integrations))
\f
((REGISTER)
(register-value-class (rtl:register-number expression)))
((CONS-POINTER CONSTANT FIXNUM->OBJECT FLOAT->OBJECT GENERIC-BINARY
- GENERIC-UNARY OFFSET POST-INCREMENT PRE-INCREMENT)
+ GENERIC-UNARY OFFSET POST-INCREMENT PRE-INCREMENT
+ ;; This is a lie, but it is the only way in which it is
+ ;; used now! It should be moved to value-class=address,
+ ;; and a cast type introduced to handle current usage.
+ BYTE-OFFSET-ADDRESS)
value-class=object)
- ((ASSIGNMENT-CACHE FIXNUM->ADDRESS OBJECT->ADDRESS OFFSET-ADDRESS
- VARIABLE-CACHE)
+ ((FIXNUM->ADDRESS OBJECT->ADDRESS
+ OFFSET-ADDRESS
+ ASSIGNMENT-CACHE VARIABLE-CACHE
+ CONS-CLOSURE CONS-MULTICLOSURE
+ ENTRY:CONTINUATION ENTRY:PROCEDURE)
value-class=address)
((MACHINE-CONSTANT)
value-class=immediate)
((BYTE-OFFSET CHAR->ASCII)
value-class=ascii)
- ((CONS-CLOSURE ENTRY:CONTINUATION ENTRY:PROCEDURE OBJECT->DATUM)
+ ((OBJECT->DATUM)
value-class=datum)
((ADDRESS->FIXNUM FIXNUM-1-ARG FIXNUM-2-ARGS OBJECT->FIXNUM
OBJECT->UNSIGNED-FIXNUM)
(memq (rtl:expression-type expression)
'(ASSIGNMENT-CACHE
CONS-CLOSURE
+ CONS-MULTICLOSURE
CONSTANT
ENTRY:CONTINUATION
ENTRY:PROCEDURE
MACHINE-CONSTANT
VARIABLE-CACHE)
true)
- ((CHAR->ASCII
+ ((BYTE-OFFSET-ADDRESS
+ CHAR->ASCII
CONS-POINTER
FIXNUM-1-ARG
FIXNUM-2-ARGS
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.16 1990/01/18 22:45:49 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.17 1990/05/03 15:10:31 jinx Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Register Transfer Language Type Definitions
+;;; package: (compiler)
(declare (usual-integrations))
\f
(define-rtl-expression entry:procedure rtl: procedure)
;;; Allocating a closure object (returns its address)
-(define-rtl-expression cons-closure rtl: procedure min max size)
+(define-rtl-expression cons-closure rtl: entry min max size)
+;;; Allocating a multi-closure object
+;;; (returns the address of first entry point)
+(define-rtl-expression cons-multiclosure rtl: nentries size entries)
;;; Cache addresses
(define-rtl-expression assignment-cache rtl: name)
;;; Add a constant offset to an address
(define-rtl-expression offset-address rtl: base number)
+(define-rtl-expression byte-offset-address rtl: base number)
;;; A machine constant (an integer, usually unsigned)
(define-rtl-expression machine-constant rtl: value)
(define-rtl-statement ic-procedure-header rtl: procedure)
(define-rtl-statement open-procedure-header rtl: procedure)
(define-rtl-statement procedure-header rtl: procedure min max)
-(define-rtl-statement closure-header rtl: procedure)
+(define-rtl-statement closure-header rtl: procedure nentries entry)
(define-rtl-statement interpreter-call:access % environment name)
(define-rtl-statement interpreter-call:define % environment name value)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.8 1990/01/18 22:45:53 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.9 1990/05/03 15:10:34 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Register Transfer Language Type Definitions
+;;; package: (compiler)
(declare (usual-integrations))
\f
(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))
+(define-integrable (rtl:make-typed-cons:procedure entry)
+ `(TYPED-CONS:PROCEDURE ,entry))
;;; Linearizer Support
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.10 1988/12/12 21:52:15 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.11 1990/05/03 15:11:36 jinx Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; RTL Generation: Environment Locatives
+;;; package: (compiler rtl-generator find-block)
(declare (usual-integrations))
\f
'TRIVIAL-CLOSURE-BOGUS-LOCATIVE)
(define (closure-block/parent-locative block context locative)
- block context
+ context
(rtl:make-fetch
- (rtl:locative-offset locative closure-block-first-offset)))
+ (rtl:locative-offset locative
+ (closure-block-first-offset block))))
(define (stack-block/parent-of-dummy-closure-locative block context locative)
(closure-block/parent-locative
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.4 1990/03/28 06:11:14 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.5 1990/05/03 15:11:40 jinx Rel $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; RTL Generation: Variable Locatives
+;;; package: (compiler rtl-generator)
(declare (usual-integrations))
\f
-(define (find-variable context variable if-compiler if-ic if-cached)
- (if (variable/value-variable? variable)
- (if-compiler
- (let ((continuation (reference-context/procedure context)))
- (if (continuation/ever-known-operator? continuation)
- (continuation/register continuation)
- register:value)))
- (find-variable-internal context variable
- (lambda (variable locative)
- (if-compiler
- (if (variable-in-cell? variable)
- (rtl:make-fetch locative)
- locative)))
- (lambda (variable block locative)
- (cond ((variable-in-known-location? context variable)
- (if-compiler
- (rtl:locative-offset locative
- (variable-offset block variable))))
- ((ic-block/use-lookup? block)
- (if-ic locative (variable-name variable)))
- (else
- (if-cached (variable-name variable))))))))
+(define-integrable (find-variable/locative context variable
+ if-compiler if-ic if-cached)
+ (find-variable false context variable if-compiler if-ic if-cached))
+
+(define-integrable (find-variable/value context variable
+ if-compiler if-ic if-cached)
+ (find-variable true context variable if-compiler if-ic if-cached))
+
+(define-integrable (find-variable/value/simple context variable message)
+ (find-variable/value context variable
+ identity-procedure
+ (lambda (environment name)
+ environment ; ignored
+ (error message name))
+ (lambda (name)
+ (error message name))))
(define (find-known-variable context variable)
- (find-variable context variable identity-procedure
- (lambda (environment name)
- environment
- (error "Known variable found in IC frame" name))
- (lambda (name)
- (error "Known variable found in IC frame" name))))
+ (find-variable/value/simple
+ context variable
+ "find-known-variable: Known variable found in IC frame"))
(define (find-closure-variable context variable)
(find-variable-internal context variable
+ identity-procedure
(lambda (variable locative)
- variable
- locative)
+ variable ; ignored
+ (rtl:make-fetch locative))
(lambda (variable block locative)
block locative
(error "Closure variable in IC frame" variable))))
locative)
(lambda (variable block locative)
block locative
- (error "Stack overwrite slot in IC frame" variable))))
+ (error "Stack overwrite slot in IC frame" variable))))
+
+(define (find-variable get-value? context variable if-compiler if-ic if-cached)
+ (let ((if-locative
+ (if get-value?
+ (lambda (locative)
+ (if-compiler (rtl:make-fetch locative)))
+ if-compiler)))
+ (if (variable/value-variable? variable)
+ (if-locative
+ (let ((continuation (reference-context/procedure context)))
+ (if (continuation/ever-known-operator? continuation)
+ (continuation/register continuation)
+ register:value)))
+ (find-variable-internal context variable
+ (and get-value? if-compiler)
+ (lambda (variable locative)
+ (if-locative
+ (if (variable-in-cell? variable)
+ (rtl:make-fetch locative)
+ locative)))
+ (lambda (variable block locative)
+ (cond ((variable-in-known-location? context variable)
+ (if-locative
+ (rtl:locative-offset locative
+ (variable-offset block variable))))
+ ((ic-block/use-lookup? block)
+ (if-ic locative (variable-name variable)))
+ (else
+ (if-cached (variable-name variable)))))))))
\f
-(define (find-variable-internal context variable if-compiler if-ic)
- (let ((rvalue (lvalue-known-value variable)))
- (if (and rvalue
- (rvalue/procedure? rvalue)
- (procedure/closure? rvalue)
- (block-ancestor-or-self? (reference-context/block context)
- (procedure-block rvalue)))
- (begin
- ;; This is just for paranoia.
- (if (procedure/trivial-closure? rvalue)
- (error "Trivial closure value encountered"))
- (if-compiler
- variable
- (block-ancestor-or-self->locative
- context
- (procedure-block rvalue)
- 0
- (procedure-closure-offset rvalue))))
- (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-variable-no-tricks context variable
- if-compiler if-ic)))))))))
+(define (find-variable-internal context variable if-value if-locative if-ic)
+ (define (loop variable)
+ (let ((indirection (variable-indirection variable)))
+ (cond ((not indirection)
+ (let ((register (variable/register variable)))
+ (if register
+ (if-locative variable (register-locative register))
+ (find-variable-no-tricks context variable
+ if-locative if-ic))))
+ ((not (cdr indirection))
+ (loop (car indirection)))
+ (else
+ (error "find-variable-internal: Indirection not for value"
+ variable)))))
+ (let ((rvalue (lvalue-known-value variable)))
+ (cond ((or (not if-value)
+ (not rvalue))
+ (loop variable))
+ ((rvalue/block? rvalue)
+ (let* ((sblock (block-nearest-closure-ancestor
+ (reference-context/block context)))
+ (cblock (and sblock (block-parent sblock))))
+ (if (and cblock (eq? rvalue (block-shared-block cblock)))
+ (if-value
+ (redirect-closure context
+ sblock
+ (block-procedure sblock)
+ (indirection-block-procedure rvalue)))
+ (loop variable))))
+ ((not (rvalue/procedure? rvalue))
+ (loop variable))
+ ((procedure/trivial-or-virtual? rvalue)
+ (if-value (make-trivial-closure-cons rvalue)))
+ ((not (procedure/closure? rvalue))
+ (error "find-variable-internal: Reference to open procedure"
+ context variable)
+ (loop variable))
+ (else
+ (let ((nearest-closure (block-nearest-closure-ancestor
+ (reference-context/block context)))
+ (closing-block (procedure-closing-block rvalue)))
+ (if (and nearest-closure
+ (eq? (block-shared-block closing-block)
+ (block-shared-block
+ (block-parent nearest-closure))))
+ (if-value
+ (redirect-closure context
+ nearest-closure
+ (block-procedure nearest-closure)
+ rvalue))
+ (let ((indirection (variable-indirection variable)))
+ (cond ((not indirection)
+ (loop variable))
+ ((not (cdr indirection))
+ (loop (car indirection)))
+ (else
+ (let ((source (car indirection)))
+ ;; Should not be indirected.
+ (find-variable-no-tricks
+ context source
+ (lambda (variable locative)
+ variable ; ignored
+ (if-value (make-closure-redirection
+ (rtl:make-fetch locative)
+ (indirection-block-procedure
+ (lvalue-known-value source))
+ rvalue)))
+ (lambda (new-variable block locative)
+ new-variable block locative ; ignored
+ (error "find-variable-internal: Bad indirection"
+ variable)))))))))))))
+\f
(define (find-variable-no-tricks context variable if-compiler if-ic)
(find-block/variable context variable
(lambda (offset-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)
((IC) if-ic)
(else (error "Illegal result type" block)))
block locative))))
-
+\f
(define (nearest-ic-block-expression context)
(with-values
(lambda ()
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.36 1990/04/03 06:01:54 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.37 1990/05/03 15:11:44 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; RTL Generation: Inline Combinations
+;;; package: (compiler rtl-generator combination/inline)
(declare (usual-integrations))
\f
((and (rvalue/reference? rvalue)
(not (variable/value-variable? (reference-lvalue rvalue)))
(reference-to-known-location? rvalue))
- (rtl:make-fetch
- (find-known-variable (reference-context rvalue)
- (reference-lvalue rvalue))))
+ (find-known-variable (reference-context rvalue)
+ (reference-lvalue rvalue)))
(else
(rtl:make-fetch
(continuation*/register
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.14 1989/12/05 20:17:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.15 1990/05/03 15:11:50 jinx Rel $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; RTL Generation: Combinations
+;;; package: (compiler rtl-generator generate/combination)
(declare (usual-integrations))
\f
(case (procedure/type model)
((OPEN-EXTERNAL OPEN-INTERNAL) invocation/jump)
((CLOSURE TRIVIAL-CLOSURE)
- ;; *** For the time being, known lexpr closures are
- ;; invoked through apply. This makes the code
- ;; simpler and probably does not matter much. ***
+ ;; Known lexpr closures are invoked through apply.
+ ;; This makes the code simpler and probably does
+ ;; not matter much.
(if (procedure-rest model)
invocation/apply
invocation/jump))
(generate/procedure-entry/inline callee))
(else
(enqueue-procedure! callee)
- (if (not (procedure-rest callee))
- (rtl:make-invocation:jump
- frame-size
- continuation
- (procedure-label callee))
- (let* ((callee-block (procedure-block callee))
- (core
- (lambda (frame-size)
- (rtl:make-invocation:lexpr
- (if (stack-block/static-link? callee-block)
- (-1+ frame-size)
- frame-size)
- continuation
- (procedure-label callee)))))
- (if (not (block/dynamic-link? callee-block))
- (core frame-size)
- (scfg*scfg->scfg!
- (rtl:make-push-link)
- (core (1+ frame-size)))))))))))
+ (let ((trivial-call
+ (lambda ()
+ (rtl:make-invocation:jump
+ frame-size
+ continuation
+ (procedure-label callee)))))
+ (cond ((procedure-rest callee)
+ ;; Note that callee can't be a closure because of
+ ;; the dispatch in generate/combination!
+ (let* ((callee-block (procedure-block callee))
+ (core
+ (lambda (frame-size)
+ (rtl:make-invocation:lexpr
+ (if (stack-block/static-link? callee-block)
+ (-1+ frame-size)
+ frame-size)
+ continuation
+ (procedure-label callee)))))
+ (if (not (block/dynamic-link? callee-block))
+ (core frame-size)
+ (scfg*scfg->scfg!
+ (rtl:make-push-link)
+ (core (1+ frame-size))))))
+ ((and (procedure/closure? callee)
+ (not (procedure/trivial-closure? callee)))
+ (let* ((block (procedure-closing-block callee))
+ (block* (block-shared-block block)))
+ (if (eq? block block*)
+ (trivial-call)
+ (invocation/adjust-closure-prefix block block*
+ (trivial-call)))))
+ (else
+ (trivial-call)))))))))
+(define (invocation/adjust-closure-prefix block block* call-code)
+ (let ((distance (closure-environment-adjustment
+ (block-number-of-entries block*)
+ (closure-block-entry-number block))))
+ (if (zero? distance)
+ call-code
+ (let ((locative
+ (rtl:make-offset (rtl:make-fetch (interpreter-stack-pointer))
+ (stack->memory-offset 0))))
+ (scfg*scfg->scfg!
+ (rtl:make-assignment
+ locative
+ (rtl:make-byte-offset-address (rtl:make-fetch locative)
+ distance))
+ call-code)))))
+\f
(define (invocation/apply model operator frame-size continuation prefix)
model operator ; ignored
(invocation/apply* frame-size 0 continuation prefix))
(invocation/apply* frame-size 0 continuation prefix)
(let ((context (reference-context operator))
(variable (reference-lvalue operator)))
- (find-variable context variable
- (lambda (locative)
+ (find-variable/value context variable
+ (lambda (expression)
(scfg*scfg->scfg!
- (rtl:make-push (rtl:make-fetch locative))
+ (rtl:make-push expression)
(invocation/apply* (1+ frame-size) 1 continuation prefix)))
(lambda (environment name)
(invocation/lookup frame-size
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.11 1990/04/01 22:24:35 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.12 1990/05/03 15:11:55 jinx Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; RTL Generation: Procedure Headers
+;;; package: (compiler rtl-generator generate/procedure-header)
(declare (usual-integrations))
\f
(error "Inlining a real closure!" procedure))
(make-null-cfg))
((procedure/closure? procedure)
- (cond ((not (procedure/trivial-closure? procedure))
- (rtl:make-closure-header (procedure-label procedure)))
- ((or (procedure-rest procedure)
+ (let ((needs-entry?
+ (or (procedure-rest procedure)
(closure-procedure-needs-external-descriptor?
- procedure))
- (with-values
- (lambda () (procedure-arity-encoding procedure))
- (lambda (min max)
- (rtl:make-procedure-header
- (procedure-label procedure)
- min max))))
- (else
- ;; It's not an open procedure but it looks like one
- ;; at the rtl level.
- (rtl:make-open-procedure-header
- (procedure-label procedure)))))
+ procedure))))
+ (cond ((not (procedure/trivial-closure? procedure))
+ (let* ((block (procedure-closing-block procedure))
+ (nentries (block-entry-number
+ (block-shared-block block))))
+ (if (or (not needs-entry?) (zero? nentries))
+ ;; It's not an open procedure but it looks like
+ ;; one at the rtl level.
+ (rtl:make-open-procedure-header
+ (procedure-label procedure))
+ (rtl:make-closure-header
+ (procedure-label procedure)
+ nentries
+ (closure-block-entry-number block)))))
+ (needs-entry?
+ (with-values
+ (lambda () (procedure-arity-encoding procedure))
+ (lambda (min max)
+ (rtl:make-procedure-header
+ (procedure-label procedure)
+ min max))))
+ (else
+ ;; It's not an open procedure but it looks like one
+ ;; at the rtl level.
+ (rtl:make-open-procedure-header
+ (procedure-label procedure))))))
((procedure-rest procedure)
(with-values (lambda () (procedure-arity-encoding procedure))
(lambda (min max)
(if rest
(cellify-variable rest)
(make-null-cfg)))
- (scfg*->scfg!
- (map (lambda (name value)
- (if (and (procedure? value)
- (not (procedure/trivial-or-virtual? value)))
- (letrec-close context name value)
- (make-null-cfg)))
- names values))))))
-\f
+ (scfg*->scfg! (map (lambda (name value)
+ (close-binding context name value))
+ names values))))))
+
(define (setup-bindings names values pushes)
(if (null? names)
(scfg*->scfg! pushes)
(setup-bindings (cdr names)
(cdr values)
- (letrec-value (car values)
+ (letrec-value (car names) (car values)
(lambda (scfg expression)
(cons (scfg*scfg->scfg!
scfg
(rtl:make-push (if (variable-in-cell? variable)
(rtl:make-cell-cons value)
value)))
-
-(define (letrec-value value recvr)
+\f
+(define (letrec-value name value recvr)
(cond ((constant? value)
(recvr (make-null-cfg)
(rtl:make-constant (constant-value value))))
(enqueue-procedure! value)
(case (procedure/type value)
((CLOSURE)
- (recvr (make-null-cfg)
- (make-non-trivial-closure-cons value)))
+ (let ((closing-block (procedure-closing-block value)))
+ (recvr
+ (make-null-cfg)
+ (if (eq? closing-block (block-shared-block closing-block))
+ (make-non-trivial-closure-cons value false)
+ (let ((how (procedure-closure-cons value)))
+ (cond ((or (not (eq? (car how) 'INDIRECTED))
+ (not (eq? (variable-block (cdr how))
+ (variable-block name))))
+ (make-cons-closure-redirection value))
+ ((not (variable-in-cell? name))
+ (error "letrec-value: Non-indirected shared sibling!"
+ value))
+ (else
+ (rtl:make-constant
+ (make-unassigned-reference-trap)))))))))
((IC)
(with-values (lambda () (make-ic-cons value 'USE-ENV)) recvr))
((TRIVIAL-CLOSURE)
(error "Letrec value is open procedure" value))
(else
(error "Unknown procedure type" value))))
+ ((block? value)
+ (for-each
+ (lambda (block*)
+ (enqueue-procedure!
+ (block-procedure (car (block-children block*)))))
+ (block-grafted-blocks value))
+ (recvr (make-null-cfg)
+ (make-non-trivial-closure-cons
+ (indirection-block-procedure value)
+ value)))
(else
(error "Unknown letrec binding value" value))))
+\f
+(define (close-binding context name value)
+ (cond ((block? value)
+ (letrec-close context name
+ (indirection-block-procedure value)))
+ ((and (procedure? value)
+ (not (procedure/trivial-or-virtual? value)))
+ (let ((closing-block (procedure-closing-block value)))
+ (if (eq? closing-block (block-shared-block closing-block))
+ (letrec-close context name value)
+ (let ((how (procedure-closure-cons value)))
+ (cond ((or (not (eq? (car how) 'INDIRECTED))
+ (not (eq? (variable-block (cdr how))
+ (variable-block name))))
+ (make-null-cfg))
+ ((not (variable-in-cell? name))
+ (error "close-binding: Non-indirected shared sibling!"
+ value))
+ (else
+ (find-variable/locative
+ context name
+ (lambda (locative)
+ (rtl:make-assignment
+ locative
+ (make-cons-closure-indirection value)))
+ (lambda (environment name)
+ environment
+ (error "close-binding: IC letrec name" name))
+ (lambda (name)
+ (error "close-binding: cached letrec name"
+ name)))))))))
+ (else
+ (make-null-cfg))))
(define (letrec-close context variable value)
(load-closure-environment
value
- (find-variable context
- variable
- rtl:make-fetch
- (lambda (nearest-ic-locative name)
- nearest-ic-locative name ;; ignored
- (error "Missing closure variable" variable))
- (lambda (name)
- name ;; ignored
- (error "Missing closure variable" variable)))))
\ No newline at end of file
+ (find-variable/value/simple
+ context variable
+ "letrec-close: Missing closure variable")
+ context))
\ 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.15 1990/01/18 22:47:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.16 1990/05/03 15:11:58 jinx Exp $
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.15 1990/01/18 22:47:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.16 1990/05/03 15:11:58 jinx Exp $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
there shall be no use of the name of the Massachusetts Institute of
Technology nor of any adaptation thereof in any advertising,
promotional, or sales literature without prior written consent from
+MIT in each case. |#
;;;; RTL Generation: RValues
;;; package: (compiler rtl-generator generate/rvalue)
(define-method-table-entry 'REFERENCE rvalue-methods
(lambda (reference)
(let ((context (reference-context reference))
+ (lvalue (reference-lvalue reference))
(safe? (reference-safe? reference)))
- (lambda (lvalue)
- (find-variable context lvalue
- (lambda (locative)
- (expression-value/simple (rtl:make-fetch locative)))
+ (let ((value (lvalue-known-value lvalue))
+ #| (indirection (variable-indirection lvalue)) |#
+ (perform-fetch
(lambda (#| lvalue |#)
(find-variable/value context lvalue
expression-value/simple
safe?))))
(rtl:interpreter-call-result:lookup)))
(lambda (name)
- (rtl:make-variable-cache name)
- rtl:make-fetch)
+ (if (memq 'IGNORE-REFERENCE-TRAPS
+ (variable-declarations lvalue))
(load-temporary-register values
(rtl:make-variable-cache name)
- (perform-fetch (or (variable-indirection lvalue) lvalue)))
+ rtl:make-fetch)
+ (generate/cached-reference context name safe?)))))))
+ (cond ((not value)
+ #|
+ (if (and indirection (cdr indirection))
+ (error "reference: Unknown mapped indirection"
lvalue))
|#
+ (perform-fetch #| (if indirection (car indirection) lvalue) |#))
((not (rvalue/procedure? value))
(generate/rvalue* value))
+ #|
+ ((procedure/trivial-or-virtual? value)
+ (expression-value/simple (make-trivial-closure-cons value)))
+ ((and indirection (cdr indirection))
(generate/indirected-closure indirection value context
- (perform-fetch lvalue)))))))
+ reference))
|#
(else
(perform-fetch #| lvalue |#)))))))
(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))
+ ((TRIVIAL-CLOSURE)
+ (expression-value/simple (make-trivial-closure-cons procedure)))
+ ((CLOSURE)
+ (case (car (procedure-closure-cons procedure))
+ ((NORMAL)
+ (load-temporary-register
+ (lambda (assignment reference)
+ (values
+ (scfg*scfg->scfg!
+ assignment
+ (load-closure-environment procedure reference false))
+ reference))
+ (make-non-trivial-closure-cons procedure false)
+ identity-procedure))
+ ((DESCENDANT)
+ (expression-value/simple
+ (make-cons-closure-redirection procedure)))
(else
(expression-value/simple
(make-cons-closure-indirection procedure)))))
(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-machine-constant type-code:compiled-entry)
- (rtl:make-entry:procedure (procedure-label procedure))))
-
(else
(error "Unknown procedure type" procedure)))))
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-machine-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)))))))
+ (kernel (make-null-cfg)
+ (rtl:make-fetch register:environment)))))))
+\f
+(define (make-trivial-closure-cons procedure)
(enqueue-procedure! procedure)
- (let ((block (procedure-closing-block procedure)))
+ (rtl:make-typed-cons:procedure
+ (rtl:make-entry:procedure (procedure-label procedure))))
+
+(define (make-cons-closure-indirection procedure)
+ (let* ((context (procedure-closure-context procedure))
+ (variable (cdr (procedure-closure-cons procedure))))
+ (make-closure-redirection
+ (find-variable/value/simple
+ context variable
+ "make-cons-closure-indirection: Unavailable indirection variable")
+ (indirection-block-procedure
+ (block-shared-block (procedure-closing-block procedure)))
+ procedure)))
+
+(define (make-cons-closure-redirection procedure)
+ (let* ((context (procedure-closure-context procedure))
+ (block (stack-block/external-ancestor
+ (reference-context/block context))))
+ (redirect-closure context
+ block
+ (block-procedure block)
+ procedure)))
+
+(define (redirect-closure context block* procedure* procedure)
+ (make-closure-redirection
+ (rtl:make-fetch (block-ancestor-or-self->locative
+ context block* 0
+ (procedure-closure-offset procedure*)))
+ procedure*
+ procedure))
+
+(define (make-closure-redirection expression procedure procedure*)
+ (enqueue-procedure! procedure*)
+ (let ((block (procedure-closing-block procedure))
+ (block* (procedure-closing-block procedure*)))
+ (let* ((block** (block-shared-block block)))
+ (if (not (eq? (block-shared-block block*) block**))
+ (error "make-closure-redirection: non-shared redirection"
+ procedure procedure*))
+ (let ((nentries (block-number-of-entries block**))
+ (entry (closure-block-entry-number block))
+ (entry* (closure-block-entry-number block*)))
+ (let ((distance
+ (- (closure-entry-distance nentries entry entry*)
+ (closure-environment-adjustment nentries entry))))
+ (if (zero? distance)
+ expression
+ ;; This is cheaper than the obvious thing with object->address,
+ ;; etc.
+ (rtl:make-byte-offset-address expression distance)))))))
+\f
(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)))
+ (let* ((block (procedure-closing-block procedure))
+ (block* (or block** block)))
+ (cond ((not block)
+ (error "make-non-trivial-closure-cons: Consing trivial closure"
+ procedure))
+ ((not (eq? (block-shared-block block) block*))
+ (error "make-non-trivial-closure-cons: Non-canonical closure"
+ procedure))
+ ((= (block-entry-number block*) 1)
+ ;; Single entry point. This could use the multiclosure case
+ ;; below, but this is simpler.
+ (with-values (lambda () (procedure-arity-encoding procedure))
+ (lambda (min max)
+ (rtl:make-typed-cons:procedure
+ (rtl:make-cons-closure
+ (rtl:make-entry:procedure (procedure-label procedure))
+ min
+ max
+ (procedure-closure-size procedure))))))
+ ((= (block-entry-number block*) 0)
+ ;; No entry point (used for environment only)
+ (rtl:make-cons-pointer
+ (rtl:make-machine-constant (ucode-type vector))
+ (rtl:make-cons-multiclosure 0
+ (procedure-closure-size procedure)
+ '#())))
+ (else
+ ;; Multiple entry points
+ (let* ((procedures
+ (let ((children
+ ;; This depends on the order of entries established
+ ;; by graft-block! in fgopt/blktyp.scm .
+ (reverse
+ (map (lambda (block)
+ (block-procedure
+ (car (block-children block))))
+ (list-transform-negative
+ (block-grafted-blocks block*)
+ (lambda (block)
+ (zero? (block-entry-number block))))))))
+ ;; Official entry point.
+ (cons procedure children)))
+ (entries
+ (map (lambda (proc)
+ (with-values
+ (lambda () (procedure-arity-encoding proc))
+ (lambda (min max)
+ (list (procedure-label proc) min max))))
+ procedures)))
+ (if (not (= (length entries) (block-entry-number block*)))
+ (error "make-non-trivial-closure-cons: disappearing entries"
+ procedure))
+ (rtl:make-typed-cons:procedure
+ (rtl:make-cons-multiclosure (block-entry-number block*)
+ (procedure-closure-size procedure)
+ (list->vector entries))))))))
+\f
+(define (load-closure-environment procedure closure-locative context*)
+ (let ((context (or context* (procedure-closure-context procedure))))
+ (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 block))
+ (if (not (ic-block/use-lookup? block))
+ (rtl:make-constant false)
+ (begin
+ (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)))))))
+
+ (let ((block (procedure-closing-block procedure)))
+ (cond ((not block)
+ (make-null-cfg))
((ic-block? block)
(load-closure-parent block true))
((closure-block? block)
value variable))
(make-trivial-closure-cons value))
((eq? value
+ (else
(rtl:make-fetch
- (find-closure-variable context variable))))))
- code))))))
- (else
- (error "Unknown block type" block))))) (find-closure-variable context variable)))))
+ (block-closure-locative context)))
+ (else
+ (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/rgstmt.scm,v 4.14 1990/03/28 06:11:39 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.15 1990/05/03 15:12:04 jinx Rel $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; RTL Generation: Statements
+;;; package: (compiler rtl-generator)
(declare (usual-integrations))
\f
(make-null-cfg)
(generate/rvalue rvalue scfg*scfg->scfg!
(lambda (expression)
- (find-variable context lvalue
+ (find-variable/locative context lvalue
(lambda (locative)
(rtl:make-assignment locative expression))
(lambda (environment name)
(let ((value (lvalue-known-value lvalue)))
(cond ((not value)
(pcfg*scfg->scfg!
- (find-variable context lvalue
- (lambda (locative)
- (rtl:make-unassigned-test (rtl:make-fetch locative)))
+ (find-variable/value context lvalue
+ rtl:make-unassigned-test
(lambda (environment name)
(scfg*pcfg->pcfg!
(load-temporary-register scfg*scfg->scfg! environment
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rdflow.scm,v 1.1 1990/01/18 22:49:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rdflow.scm,v 1.2 1990/05/03 15:22:24 jinx Rel $
Copyright (c) 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; RTL Dataflow Analysis
+;;; package: (compiler rtl-optimizer rtl-dataflow-analysis)
(declare (usual-integrations))
\f
(let ((target (get-rnode address)))
(if (rtl:pseudo-register-expression? expression)
(rnode/connect! target (get-rnode expression))
- (let ((values (rnode/initial-values target)))
- (if (not (there-exists? values
- (lambda (value)
- (rtl:expression=? expression value))))
- (set-rnode/initial-values!
- target
- (cons expression values)))))))))))
+ (add-rnode/initial-value! target expression))))))
+ (let loop ((rtl rtl))
+ (rtl:for-each-subexpression rtl
+ (lambda (expression)
+ (if (rtl:volatile-expression? expression)
+ (if (or (rtl:post-increment? expression)
+ (rtl:pre-increment? expression))
+ (add-rnode/initial-value!
+ (get-rnode (rtl:address-register expression))
+ expression)
+ (error "Unknown volatile expression" expression))
+ (loop expression)))))))
+
+(define (add-rnode/initial-value! target expression)
+ (let ((values (rnode/initial-values target)))
+ (if (not (there-exists? values
+ (lambda (value)
+ (rtl:expression=? expression value))))
+ (set-rnode/initial-values! target
+ (cons expression values)))))
(define (rnode/connect! target source)
(if (not (memq source (rnode/backward-links target)))
(lambda (rnode)
(let ((expression (initial-known-value (rnode/classified-values rnode))))
(set-rnode/known-value! rnode expression)
- (if (not (eq? expression 'UNDETERMINED))
+ (if (not (memq expression '(UNDETERMINED #F)))
(set-rnode/classified-values! rnode '())))))
(let loop ()
(let ((new-constant? false))
\f
(define (initial-known-value values)
(and (not (null? values))
+ (not (there-exists? values
+ (lambda (value)
+ (rtl:volatile-expression? (cdr value)))))
(let loop ((value (car values)) (rest (cdr values)))
(cond ((eq? (car value) 'SUBSTITUTABLE-REGISTERS) 'UNDETERMINED)
((null? rest) (values-unique-expression values))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.3 1990/01/18 22:48:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rinvex.scm,v 1.4 1990/05/03 15:22:29 jinx Rel $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; RTL Invertible Expression Elimination
+;;; package: (compiler rtl-optimizer invertible-expression-elimination)
(declare (usual-integrations))
\f
unspecific)
\f
(define (expression-update! get-expression set-expression! object)
+ ;; Note: The following code may cause pseudo register copies to be
+ ;; generated since it would have to propagate some of the
+ ;; simplifications, and then delete the now-unused registers.
+ ;; This is not worth it since the previous register is likely to be
+ ;; dead at this point, so the lap-level register allocator will
+ ;; reuse the alias achieving the effect of the deletion. Ultimately
+ ;; the expression invertibility code should be integrated into the
+ ;; CSE and this register deletion would happen there.
(set-expression!
object
(let loop ((expression (get-expression object)))
(optimize-expression (rtl:map-subexpressions expression loop))))))
(define (optimize-expression expression)
- (let ((type (rtl:expression-type expression))
- (try-unary-fold
- (lambda (types)
- (let loop ((types types)
- (expression (cadr expression)))
- (if (null? types)
- expression
- (let ((subexpression
- (canonicalize-subexpression expression)))
- (and (eq? (car types) (rtl:expression-type subexpression))
- (loop (cdr types)
- (cadr subexpression)))))))))
- (let next-inversion ((unary-inversions unary-inversions))
- (if (null? unary-inversions)
- expression
- (let ((first-inversion (car unary-inversions)))
- (or (and (eq? type (caar first-inversion))
- (try-unary-fold (append (cdar first-inversion)
- (cdr first-inversion))))
- (and (eq? type (cadr first-inversion))
- (try-unary-fold (append (cddr first-inversion)
- (car first-inversion))))
- (next-inversion (cdr unary-inversions))))))))
-
-(define unary-inversions
- '(((OBJECT->FIXNUM) . (FIXNUM->OBJECT))
- ((OBJECT->UNSIGNED-FIXNUM) . (FIXNUM->OBJECT))
- ((ADDRESS->FIXNUM) . (FIXNUM->ADDRESS))
- ((@ADDRESS->FLOAT OBJECT->ADDRESS) . (FLOAT->OBJECT))))
+ (define (try-identity identity)
+ (let ((in-domain? (car identity))
+ (matching-operation (cadr identity)))
+ (let loop ((operations (cddr identity))
+ (subexpression ((cadr matching-operation) expression)))
+ (if (null? operations)
+ (and (valid-subexpression? subexpression)
+ (in-domain? (rtl:expression-value-class subexpression))
+ subexpression)
+ (let ((subexpression (canonicalize-subexpression subexpression)))
+ (and (eq? (caar operations) (rtl:expression-type subexpression))
+ (loop (cdr operations)
+ ((cadar operations) subexpression))))))))
+
+ (let loop ((rules (list-transform-positive
+ identities
+ (let ((type (rtl:expression-type expression)))
+ (lambda (identity)
+ (eq? type (car (cadr identity))))))))
+
+ (cond ((null? rules) expression)
+ ((try-identity (car rules)) => optimize-expression)
+ (else (loop (cdr rules))))))
+
+(define identities
+ ;; Each entry is composed of a value class and a sequence
+ ;; of operations whose composition is the identity for that
+ ;; value class.
+ ;; Each operation is described by the operator and the selector for
+ ;; the relevant operand.
+ `((,value-class=value? (OBJECT->FIXNUM ,rtl:object->fixnum-expression)
+ (FIXNUM->OBJECT ,rtl:fixnum->object-expression))
+ (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression)
+ (OBJECT->FIXNUM ,rtl:object->fixnum-expression))
+ (,value-class=value? (OBJECT->UNSIGNED-FIXNUM
+ ,rtl:object->unsigned-fixnum-expression)
+ (FIXNUM->OBJECT ,rtl:fixnum->object-expression))
+ (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression)
+ (OBJECT->UNSIGNED-FIXNUM
+ ,rtl:object->unsigned-fixnum-expression))
+ (,value-class=value? (FIXNUM->ADDRESS ,rtl:fixnum->address-expression)
+ (ADDRESS->FIXNUM ,rtl:address->fixnum-expression))
+ (,value-class=value? (ADDRESS->FIXNUM ,rtl:address->fixnum-expression)
+ (FIXNUM->ADDRESS ,rtl:fixnum->address-expression))
+ (,value-class=value? (@ADDRESS->FLOAT ,rtl:@address->float-expression)
+ (OBJECT->ADDRESS ,rtl:object->address-expression)
+ (FLOAT->OBJECT ,rtl:float->object-expression))
+ (,value-class=value? (FLOAT->OBJECT ,rtl:float->object-expression)
+ (@ADDRESS->FLOAT ,rtl:@address->float-expression)
+ (OBJECT->ADDRESS ,rtl:object->address-expression))
+ #|
+ ;; This one, although true, is useless.
+ (,value-class=value? (OBJECT->ADDRESS ,rtl:object->address-expression)
+ (FLOAT->OBJECT ,rtl:float->object-expression)
+ (@ADDRESS->FLOAT ,rtl:@address->float-expression))
+ |#
+ (,value-class=address? (OBJECT->ADDRESS ,rtl:object->address-expression)
+ (CONS-POINTER ,rtl:cons-pointer-datum))
+ (,value-class=datum? (OBJECT->DATUM ,rtl:object->datum-expression)
+ (CONS-POINTER ,rtl:cons-pointer-datum))
+ ;; Perhaps this should be value-class=type
+ (,value-class=immediate? (OBJECT->TYPE ,rtl:object->type-expression)
+ (CONS-POINTER ,rtl:cons-pointer-type))))
+\f
+(define (valid-subexpression? expression)
+ ;; Machine registers not allowed because they are volatile.
+ ;; Ideally at this point we could introduce a copy to the
+ ;; value of the machine register required, but it is too late
+ ;; to do this. Perhaps always copying machine registers out
+ ;; before using them would make this win.
+ (or (not (rtl:register? expression))
+ (rtl:pseudo-register-expression? expression)))
(define (canonicalize-subexpression expression)
(or (and (rtl:pseudo-register-expression? expression)
projects / mit-scheme.git / commitdiff