#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.5 1987/08/28 21:54:15 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.6 1988/03/14 20:44:59 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(register-type? register type)
(pseudo-register-alias *register-map* type register)))
+(define-integrable (is-alias-for-register? potential-alias register)
+ (is-pseudo-register-alias? *register-map* potential-alias register))
+
(define-integrable (register-alias register type)
(maybe-need-register! (pseudo-register-alias *register-map* type register)))
(define ((register-type-predicate type) register)
(register-type? register type))
+(define-integrable (same-register? reg1 reg2)
+ (= reg1 reg2))
+
(define-integrable (dead-register? register)
(memv register *dead-registers*))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 4.1 1987/12/30 06:53:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 4.2 1988/03/14 20:45:17 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define free-assignment-label (->label assq *interned-assignments*))
- (define free-uuo-link-label (->label assq *interned-uuo-links*))
;; End of let-syntax
)
+;; This one is different because a different uuo-link is used for different
+;; numbers of arguments.
+
+(define (free-uuo-link-label name frame-size)
+ (let ((entry (assq name *interned-uuo-links*)))
+ (if entry
+ (let ((place (assv frame-size (cdr entry))))
+ (if place
+ (cdr place)
+ (let ((label (allocate-constant-label)))
+ (set-cdr! entry
+ (cons (cons frame-size label)
+ (cdr entry)))
+ label)))
+ (let ((label (allocate-constant-label)))
+ (set! *interned-uuo-links*
+ (cons (list name (cons frame-size label))
+ *interned-uuo-links*))
+ label))))
+
(define-integrable (set-current-branches! consequent alternative)
(set-pblock-consequent-lap-generator! *current-bblock* consequent)
(set-pblock-alternative-lap-generator! *current-bblock* alternative))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.1 1987/12/30 06:53:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.2 1988/03/14 20:45:30 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(list-search-positive (map-entry-aliases entry)
(register-type-predicate type)))))
+(define (is-pseudo-register-alias? map maybe-alias register)
+ (let ((entry (map-entries:find-home map register)))
+ (and entry
+ (list-search-positive (map-entry-aliases entry)
+ (lambda (alias)
+ (same-register? maybe-alias alias))))))
+
(define (save-machine-register map register receiver)
(let ((entry (map-entries:find-alias map register)))
(if (and entry
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.3 1988/01/02 15:17:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.4 1988/03/14 20:48:00 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(scode/make-combination compiled-error-procedure
(cons message irritants))))))
+;; For now
+
+(define (compile-recursively expression block)
+ (error "compile-recursively: invoked!" expression))
+
+(define (compile-recursively? block)
+ false)
+
(define (generate/in-package block continuation expression)
- (warn "IN-PACKAGE not supported; body will be interpreted" expression)
- (scode/in-package-components expression
- (lambda (environment expression)
- (generate/combination
- block
- continuation
- (scode/make-combination (ucode-primitive scode-eval)
- (list (scode/make-quotation expression)
- environment))))))
+ (let ((recursive? (compile-recursively? block)))
+ (if (not recursive?)
+ (warn "dynamic IN-PACKAGE not supported; body will be interpreted"
+ expression))
+ (scode/in-package-components expression
+ (lambda (environment expression)
+ (generate/combination
+ block
+ continuation
+ (scode/make-combination
+ (ucode-primitive scode-eval)
+ (list (if recursive?
+ (scode/make-constant
+ (compile-recursively expression false))
+ (scode/make-quotation expression))
+ environment)))))))
(define (generate/quotation block continuation expression)
(generate/combination
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.2 1987/12/30 06:43:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.3 1988/03/14 20:51:26 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(let ((procedure (block-procedure block))
(parent (block-parent block)))
(set-procedure-closure-block! procedure parent)
- (set-block-parent!
- block
- ((find-closure-bindings parent)
- (list-transform-negative (block-free-variables block)
- (lambda (lvalue)
- (eq? (lvalue-known-value lvalue) procedure)))
- '()))
+ (((find-closure-bindings
+ (lambda (closure-frame-block size)
+ (set-block-parent! block closure-frame-block)
+ (set-procedure-closure-size! procedure size)))
+ parent)
+ (list-transform-negative (block-free-variables block)
+ (lambda (lvalue)
+ (eq? (lvalue-known-value lvalue) procedure)))
+ '())
(set-block-children! parent (delq! block (block-children parent)))
(set-block-disowned-children!
parent
(cons block (block-disowned-children parent)))))
\f
-(define (find-closure-bindings block)
- (lambda (free-variables bound-variables)
- (if (or (not block) (ic-block? block))
- (let ((grandparent (and (not (null? free-variables)) block)))
- (if (null? bound-variables)
- grandparent
- (make-closure-block grandparent
- free-variables
- bound-variables
- (and block (block-procedure block)))))
- (transmit-values
- (filter-bound-variables (block-bound-variables block)
+(define (find-closure-bindings receiver)
+ (define (find-internal block)
+ (lambda (free-variables bound-variables)
+ (if (or (not block) (ic-block? block))
+ (let ((grandparent (and (not (null? free-variables)) block)))
+ (if (null? bound-variables)
+ (receiver grandparent (if grandparent 1 0))
+ (make-closure-block receiver
+ grandparent
free-variables
- bound-variables)
- (find-closure-bindings (block-parent block))))))
+ bound-variables
+ (and block (block-procedure block)))))
+ (transmit-values
+ (filter-bound-variables (block-bound-variables block)
+ free-variables
+ bound-variables)
+ (find-internal (block-parent block))))))
+ find-internal)
(define (filter-bound-variables bindings free-variables bound-variables)
(cond ((null? bindings)
free-variables
bound-variables))))
-(define (make-closure-block parent free-variables bound-variables frame)
- (let ((block (make-block parent 'CLOSURE)))
+;; 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 recvr parent free-variables bound-variables frame)
+ (let ((block (make-block parent 'CLOSURE))
+ (extra (if (and parent (ic-block/use-lookup? parent)) 1 0)))
(set-block-free-variables! block free-variables)
(set-block-bound-variables! block bound-variables)
(set-block-frame! block
(and frame
(rvalue/procedure? frame)
(procedure-name frame)))
- (set-block-closure-offsets!
- block
- (let loop
- ((variables (block-bound-variables block))
- (offset (if (and parent (ic-block/use-lookup? parent)) 2 1)))
- (cond ((null? variables) '())
- ((lvalue-integrated? (car variables))
- (loop (cdr variables) offset))
- (else
- (cons (cons (car variables) offset)
- (loop (cdr variables) (1+ offset)))))))
- block))
+ (let loop ((variables (block-bound-variables block))
+ (offset (+ closure-block-first-offset extra))
+ (table '())
+ (size extra))
+ (cond ((null? variables)
+ (set-block-closure-offsets! block table)
+ (recvr block size))
+ ((lvalue-integrated? (car variables))
+ (loop (cdr variables) offset table size))
+ (else
+ (loop (cdr variables)
+ (1+ offset)
+ (cons (cons (car variables) offset)
+ table)
+ (1+ size)))))))
)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.3 1987/12/31 08:51:44 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.4 1988/03/14 20:51:42 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
((rvalue/procedure? callee)
(case (procedure/type callee)
((OPEN-EXTERNAL OPEN-INTERNAL) continuation-type/effect)
- ((CLOSURE) continuation-type/push)
+ ((CLOSURE)
+ (if (procedure/trivial-closure? callee)
+ continuation-type/effect
+ continuation-type/push))
((IC) continuation-type/apply)
(else (error "Unknown procedure type" callee))))
(else
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.4 1988/01/02 19:12:14 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.5 1988/03/14 20:53:19 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (find-variable-internal block variable offset if-compiler if-ic)
(let ((rvalue (lvalue-known-value variable)))
- (if (and rvalue
- (rvalue/procedure? rvalue)
- (procedure/closure? rvalue)
- (block-ancestor-or-self? block (procedure-block rvalue)))
- (if-compiler
- (stack-locative-offset
- (block-ancestor-or-self->locative block
- (procedure-block rvalue)
- offset)
- (procedure-closure-offset rvalue)))
- (find-block/variable block variable offset
- (lambda (offset-locative)
- (lambda (block locative)
- (if-compiler
- (offset-locative locative (variable-offset block variable)))))
- if-ic))))
+ (cond ((not
+ (and rvalue
+ (rvalue/procedure? rvalue)
+ (procedure/closure? rvalue)
+ (block-ancestor-or-self? block (procedure-block rvalue))))
+ (find-block/variable block variable offset
+ (lambda (offset-locative)
+ (lambda (block locative)
+ (if-compiler
+ (offset-locative locative (variable-offset block variable)))))
+ if-ic))
+ ((procedure/trivial-closure? rvalue)
+ (if-compiler (make-trivial-closure-cons rvalue)))
+ (else
+ (if-compiler
+ (stack-locative-offset
+ (block-ancestor-or-self->locative block
+ (procedure-block rvalue)
+ offset)
+ (procedure-closure-offset rvalue)))))))
\f
(define (find-definition-variable block lvalue offset)
(find-block/variable block lvalue offset
(define (find-block/parent-procedure block)
(enumeration-case block-type (block-type block)
((STACK)
- (if (procedure/closure? (block-procedure block))
- stack-block/closure-parent-locative
- (let ((parent (block-parent block)))
- (if parent
- (enumeration-case block-type (block-type parent)
- ((STACK) internal-block/parent-locative)
- ((IC) stack-block/static-link-locative)
- ((CLOSURE) (error "Closure parent of open procedure" block))
- (else (error "Illegal procedure parent" parent)))
- (error "Block has no parent" block)))))
+ (let ((parent (block-parent block)))
+ (cond ((not (procedure/closure? (block-procedure block)))
+ (if parent
+ (enumeration-case block-type (block-type parent)
+ ((STACK) internal-block/parent-locative)
+ ((IC) stack-block/static-link-locative)
+ ((CLOSURE) (error "Closure parent of open procedure" block))
+ (else (error "Illegal procedure parent" parent)))
+ (error "Block has no parent" block)))
+ ((procedure/trivial-closure? (block-procedure block))
+ trivial-closure/bogus-locative)
+ ((not parent)
+ (error "Block has no parent" block))
+ (else
+ (enumeration-case
+ block-type (block-type parent)
+ ((STACK) (error "Closure has a stack parent" block))
+ ((IC) stack-block/parent-of-dummy-closure-locative)
+ ((CLOSURE) stack-block/closure-parent-locative)
+ (else (error "Illegal procedure parent" parent)))))))
((CLOSURE) closure-block/parent-locative)
((CONTINUATION) continuation-block/parent-locative)
(else (error "Illegal parent block type" block))))
(define (stack-block/closure-parent-locative block locative)
(rtl:make-fetch
- (rtl:locative-offset
- (rtl:make-fetch
- (stack-locative-offset
- locative
- (procedure-closure-offset (block-procedure block))))
- 1)))
+ (stack-locative-offset
+ locative
+ (procedure-closure-offset (block-procedure block)))))
+
+;; This value should make anyone trying to look at it crash.
+
+(define (trivial-closure/bogus-locative block locative)
+ 'TRIVIAL-CLOSURE-BOGUS-LOCATIVE)
(define (closure-block/parent-locative block locative)
- (rtl:make-fetch (rtl:locative-offset locative 1)))
+ (rtl:make-fetch
+ (rtl:locative-offset locative
+ closure-block-first-offset)))
+
+(define (stack-block/parent-of-dummy-closure-locative block locative)
+ (closure-block/parent-locative
+ block
+ (stack-block/closure-parent-locative block locative)))
)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.3 1988/01/02 17:24:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.4 1988/03/14 20:53:42 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(case (procedure/type callee)
((OPEN-EXTERNAL) (finish invocation/jump true))
((OPEN-INTERNAL) (finish invocation/jump false))
- ((CLOSURE) (finish invocation/jump true))
+ ((CLOSURE)
+ ;; *** For the time being, known lexpr closures are invoked through
+ ;; apply. This makes the code simpler and probably does not matter
+ ;; much. ***
+ (if (procedure-rest callee)
+ (finish invocation/apply true)
+ (finish invocation/jump true)))
((IC) (finish invocation/ic true))
(else (error "Unknown procedure type" callee))))
(else
(define (invocation/cache-reference offset frame-size continuation prefix name)
(let* ((temp (rtl:make-pseudo-register))
(cell (rtl:make-fetch temp))
- (contents (rtl:make-fetch cell)))
- (let ((n1 (rtl:make-assignment temp (rtl:make-variable-cache name)))
- (n2
+ (contents (rtl:make-fetch cell))
+ (n1 (rtl:make-assignment temp (rtl:make-variable-cache name))))
+ ;; n1 MUST be bound before the rest. It flags temp as a
+ ;; register that contains an address.
+ (let ((n2
(rtl:make-type-test (rtl:make-object->type contents)
(ucode-type reference-trap)))
(n3
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.1 1987/12/04 20:31:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.2 1988/03/14 20:54:09 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(scfg*scfg->scfg!
(if inline?
(make-null-cfg)
- (rtl:make-procedure-heap-check (procedure-label procedure)))
+ (rtl:make-ic-procedure-header (procedure-label procedure)))
(setup-ic-frame procedure))
(scfg*scfg->scfg!
- (cond ((or (procedure-rest procedure)
- (and (procedure/closure? procedure)
- (not (null? (procedure-optional procedure)))))
- (rtl:make-setup-lexpr (procedure-label procedure)))
+ (cond ((procedure/closure? procedure)
+ (if (procedure/trivial-closure? procedure)
+ (with-procedure-arity-encoding
+ procedure
+ (lambda (min max)
+ (rtl:make-procedure-header (procedure-label procedure)
+ min max)))
+ (rtl:make-closure-header (procedure-label procedure))))
(inline?
(make-null-cfg))
+ ((procedure-rest procedure)
+ (with-procedure-arity-encoding
+ procedure
+ (lambda (min max)
+ (rtl:make-procedure-header (procedure-label procedure)
+ min max))))
(else
- (rtl:make-procedure-heap-check (procedure-label procedure))))
+ (rtl:make-open-procedure-header (procedure-label procedure))))
(setup-stack-frame procedure)))
body))
(map (lambda (name value)
(if (and (procedure? value)
(procedure/closure? value)
- (procedure-closing-block value))
+ (not (procedure/trivial-closure? value)))
(letrec-close block name value)
(make-null-cfg)))
names values))))))
(scfg*->scfg! pushes)
(setup-bindings (cdr names)
(cdr values)
- (cons (make-auxiliary-push (car names)
- (letrec-value (car values)))
- pushes))))
+ (letrec-value (car values)
+ (lambda (scfg expression)
+ (cons (scfg*scfg->scfg!
+ scfg
+ (make-auxiliary-push (car names) expression))
+ pushes))))))
(define (make-auxiliary-push variable value)
(rtl:make-push (if (variable-in-cell? variable)
(rtl:make-cell-cons value)
value)))
-(define (letrec-value value)
+(define (letrec-value value recvr)
(cond ((constant? value)
- (rtl:make-constant (constant-value value)))
+ (recvr (make-null-cfg)
+ (rtl:make-constant (constant-value value))))
((procedure? value)
(enqueue-procedure! value)
(case (procedure/type value)
((CLOSURE)
- (make-closure-cons value (rtl:make-constant '())))
+ (if (procedure/trivial-closure? value)
+ (recvr (make-null-cfg)
+ (make-trivial-closure-cons value))
+ (recvr (make-non-trivial-closure-cons value)
+ (rtl:interpreter-call-result:enclose))))
((IC)
- (make-ic-cons value))
+ (recvr (make-null-cfg)
+ (make-ic-cons value)))
((OPEN-EXTERNAL OPEN-INTERNAL)
(error "Letrec value is open procedure" value))
(else
(error "Unknown letrec binding value" value))))
(define (letrec-close block variable value)
- (transmit-values (make-closure-environment value 0)
- (lambda (prefix environment)
- (scfg*scfg->scfg! prefix
- (rtl:make-assignment
- (closure-procedure-environment-locative
- (find-variable block variable 0
- (lambda (locative) locative)
- (lambda (nearest-ic-locative name)
- (error "Missing closure variable" variable))
- (lambda (name)
- (error "Missing closure variable" variable))))
- environment)))))
-
-(define-integrable (closure-procedure-environment-locative locative)
- (rtl:locative-offset (rtl:make-fetch locative) 1))
+ (load-closure-environment
+ value 0
+ (find-variable block variable 0
+ rtl:make-fetch
+ (lambda (nearest-ic-locative name)
+ (error "Missing closure variable" variable))
+ (lambda (name)
+ (error "Missing closure variable" variable)))))
;;; end GENERATE/PROCEDURE-HEADER
)
\ 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.3 1987/12/30 09:10:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.4 1988/03/14 20:54:28 jinx Exp $
#| -*-Scheme-*-
Copyright (c) 1987 Massachusetts Institute of Technology
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.3 1987/12/30 09:10:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.4 1988/03/14 20:54:28 jinx Exp $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
;;;; RTL Generation: RValues
;;; package: (compiler rtl-generator generate/rvalue)
-(package (generate/rvalue make-closure-environment)
+(package (generate/rvalue load-closure-environment)
(define-export (generate/rvalue operand offset scfg*cfg->cfg! generator)
(transmit-values (generate/rvalue* operand offset)
(let ((block (reference-block reference))
(define-method-table-entry 'REFERENCE rvalue-methods
(lambda (reference)
- (let ((value (lvalue-known-value lvalue)))
- (if (and value (not (rvalue/procedure? value)))
- (generate/rvalue* value offset)
- (find-variable block lvalue offset
- (lambda (locative)
- (expression-value/simple (rtl:make-fetch locative)))
- (lambda (environment name)
- (expression-value/temporary
- (rtl:make-interpreter-call:lookup
- environment
- (intern-scode-variable! block name)
- safe?)
- (rtl:interpreter-call-result:lookup)))
- (lambda (name)
- (generate/cached-reference name safe?))))))))
+ (let ((context (reference-context reference))
+ (safe? (reference-safe? reference)))
+ (lambda ()
+ (find-variable block lvalue offset
+ (lambda (locative)
+ (expression-value/simple (rtl:make-fetch locative)))
+ (lambda (environment name)
+ (expression-value/temporary
+ (rtl:make-interpreter-call:lookup
+ environment
+ (intern-scode-variable! block name)
+ safe?)
+ (rtl:interpreter-call-result:lookup)))
+ (lambda (name)
+ (generate/cached-reference name safe?))))))
+ (cond ((not value) (perform-fetch))
+ lvalue))
+ (generate/rvalue* value offset))
+ ((and (procedure/closure? value)
+ (procedure/trivial-closure? value))
+ (generate/rvalue* value))
+ (else (perform-fetch)))))))
\f
(define (generate/cached-reference name safe?)
(let ((temp (rtl:make-pseudo-register))
(result (rtl:make-pseudo-register)))
(return-2
- (let ((cell (rtl:make-fetch temp)))
- (let ((reference (rtl:make-fetch cell)))
- (let ((n1 (rtl:make-assignment temp (rtl:make-variable-cache name)))
- (n2 (rtl:make-type-test (rtl:make-object->type reference)
- (ucode-type reference-trap)))
- (n3 (rtl:make-assignment result reference))
- (n4 (rtl:make-interpreter-call:cache-reference cell safe?))
- (n5
- (rtl:make-assignment
- result
- (rtl:interpreter-call-result:cache-reference))))
- (scfg-next-connect! n1 n2)
- (pcfg-alternative-connect! n2 n3)
- (scfg-next-connect! n4 n5)
- (if safe?
- (let ((n6 (rtl:make-unassigned-test reference))
- ;; Make new copy of n3 to keep CSE happy.
- ;; Otherwise control merge will confuse it.
- (n7 (rtl:make-assignment result reference)))
- (pcfg-consequent-connect! n2 n6)
- (pcfg-consequent-connect! n6 n7)
- (pcfg-alternative-connect! n6 n4)
- (make-scfg (cfg-entry-node n1)
- (hooks-union (scfg-next-hooks n3)
- (hooks-union (scfg-next-hooks n5)
- (scfg-next-hooks n7)))))
- (begin
- (pcfg-consequent-connect! n2 n4)
- (make-scfg (cfg-entry-node n1)
- (hooks-union (scfg-next-hooks n3)
- (scfg-next-hooks n5))))))))
+ (let* ((cell (rtl:make-fetch temp))
+ (reference (rtl:make-fetch cell))
+ (n1 (rtl:make-assignment temp (rtl:make-variable-cache name))))
+ ;; n1 MUST be bound before the rest. It flags temp as a
+ ;; register that contains an address.
+ (let ((n2 (rtl:make-type-test (rtl:make-object->type reference)
+ (ucode-type reference-trap)))
+ (n3 (rtl:make-assignment result reference))
+ (n4 (rtl:make-interpreter-call:cache-reference cell safe?))
+ (n5
+ (rtl:make-assignment
+ result
+ (rtl:interpreter-call-result:cache-reference))))
+ (scfg-next-connect! n1 n2)
+ (pcfg-alternative-connect! n2 n3)
+ (scfg-next-connect! n4 n5)
+ (if safe?
+ (let ((n6 (rtl:make-unassigned-test reference))
+ ;; Make new copy of n3 to keep CSE happy.
+ ;; Otherwise control merge will confuse it.
+ (n7 (rtl:make-assignment result reference)))
+ (pcfg-consequent-connect! n2 n6)
+ (pcfg-consequent-connect! n6 n7)
+ (pcfg-alternative-connect! n6 n4)
+ (make-scfg (cfg-entry-node n1)
+ (hooks-union (scfg-next-hooks n3)
+ (hooks-union (scfg-next-hooks n5)
+ (scfg-next-hooks n7)))))
+ (begin
+ (pcfg-consequent-connect! n2 n4)
+ (make-scfg (cfg-entry-node n1)
+ (hooks-union (scfg-next-hooks n3)
+ (scfg-next-hooks n5)))))))
(make-scfg (cfg-entry-node n2)
(hooks-union (scfg-next-hooks n3)
(scfg-next-hooks n5)))))))))
\f
(define-method-table-entry 'PROCEDURE rvalue-methods
(case (procedure/type procedure)
- (expression-value/transform (make-closure-environment procedure offset)
- (lambda (environment)
- (make-closure-cons procedure environment))))
+ (if (procedure/trivial-closure? procedure)
+ (expression-value/simple (make-trivial-closure-cons procedure))
+ (let ((register (rtl:make-pseudo-register)))
+ (return-2
+ (scfg*scfg->scfg!
+ (make-non-trivial-closure-cons procedure)
+ (scfg*scfg->scfg!
+ (rtl:make-assignment register
+ (rtl:interpreter-call-result:enclose))
+ (load-closure-environment procedure offset
+ (rtl:make-fetch register))))
+ (rtl:make-fetch register)))))
(else
(expression-value/simple (make-ic-cons procedure)))
(make-cons-closure-indirection procedure)))))
(if (not (procedure-virtual-closure? procedure))
(error "Reference to open procedure" procedure))
;; inside another IC procedure?
-(define-export (make-closure-environment procedure offset)
+(define-export (load-closure-environment procedure offset closure-locative)
(let ((block (procedure-closing-block procedure)))
(define (make-non-trivial-closure-cons procedure block**)
- (expression-value/simple (rtl:make-constant false)))
+ (make-null-cfg))
((ic-block? block)
- (expression-value/simple
+ (rtl:make-assignment
+ (rtl:locative-offset closure-locative closure-block-first-offset)
(if (ic-block/use-lookup? block)
(let ((closure-block (procedure-closure-block procedure)))
(if (ic-block? closure-block)
(closure-ic-locative closure-block block offset)))
(rtl:make-constant false))))
((closure-block? block)
- (let ((closure-block (procedure-closure-block procedure))
- (entries (block-closure-offsets block)))
- (define (loop entries offset)
+ (let ((closure-block (procedure-closure-block procedure)))
+ (define (loop entries code)
(let loop
- '()
- (cons (rtl:make-push
- (rtl:make-fetch
- (let ((variable (caar entries)))
- (if (eq? (lvalue-known-value variable)
- (block-procedure closure-block))
- (block-closure-locative closure-block offset)
- (find-closure-variable closure-block
- variable
- offset)))))
- (loop (cdr entries) (-1+ offset)))))
-
- (let ((pushes
- (let ((offset (+ offset (length entries))))
- (let ((parent (block-parent block))
- (pushes (loop entries (-1+ offset))))
- (if (and parent (ic-block/use-lookup? parent))
- (cons (rtl:make-push
- (closure-ic-locative closure-block
- parent
- offset))
- pushes)
- pushes)))))
- (expression-value/temporary
- (scfg*->scfg!
- (reverse!
- (cons (rtl:make-interpreter-call:enclose (length pushes))
- pushes)))
- (rtl:interpreter-call-result:enclose)))))
+ ((entries (block-closure-offsets block))
+ (code (load-closure-parent (block-parent block) false)))
+ (if (null? entries)
+ code
+ (reference-context/procedure context))
+ (loop (cdr entries)
+ (scfg*scfg->scfg!
+ (rtl:make-assignment
+ (cond ;; This is a waste. It should be integrated.
+ ((and value
+ (rvalue/procedure? value)
+ (procedure/closure? value)
+ (procedure/trivial-closure? value))
+ (make-trivial-closure-cons value))
+ ((not (eq? value (block-procedure
+ closure-block)))
+ (rtl:make-fetch
+ (find-closure-variable closure-block
+ variable
+ offset)))
+ (else
+ (rtl:make-fetch
+ (block-closure-locative closure-block
+ offset))))))
+ code))))
+
+ (loop
+ (block-closure-offsets block)
+ (if (let ((parent (block-parent block)))
+ (and parent (ic-block/use-lookup? parent)))
+ (rtl:make-assignment
+ (rtl:locative-offset closure-locative
+ closure-block-first-offset)
+ (if (ic-block? closure-block)
+ (rtl:make-fetch register:environment)
+ (closure-ic-locative closure-block block offset)))
+ (make-null-cfg)))))
(else
(error "Unknown block type" block)))))
;; inside another IC procedure?
(rtl:make-fetch register:environment))))
-(define (make-closure-cons procedure environment)
- (rtl:make-typed-cons:pair
- (rtl:make-constant type-code:compiled-procedure)
- (rtl:make-entry:procedure (procedure-label procedure))
- environment)) (find-closure-variable context variable)))))
+(define (make-trivial-closure-cons procedure)
+ (rtl:make-cons-pointer
+ (rtl:make-constant type-code:compiled-entry)
+ (rtl:make-entry:procedure (procedure-label procedure))))
+
+(define (make-non-trivial-closure-cons procedure)
+ (with-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 (with-procedure-arity-encoding procedure receiver)
+ (let* ((min
+ (+ (if (procedure/closure? procedure) 1 0)
+ (length (procedure-required-arguments procedure))))
+ (max (+ min (length (procedure-optional procedure)))))
+ (receiver min
+ (if (procedure-rest procedure)
+ (- (1+ max))
+ max)))) (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.2 1987/12/30 07:10:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.3 1988/03/14 20:55:03 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(generate/cached-assignment name expression))))))))
(define (generate/cached-assignment name value)
- (let ((temp (rtl:make-pseudo-register)))
- (let ((cell (rtl:make-fetch temp)))
- (let ((contents (rtl:make-fetch cell)))
- (let ((n1 (rtl:make-assignment temp (rtl:make-assignment-cache name)))
- (n2 (rtl:make-type-test (rtl:make-object->type contents)
- (ucode-type reference-trap)))
- (n3 (rtl:make-unassigned-test contents))
- (n4 (rtl:make-assignment cell value))
- (n5 (rtl:make-interpreter-call:cache-assignment cell value))
- ;; Copy prevents premature control merge which confuses CSE
- (n6 (rtl:make-assignment cell value)))
- (scfg-next-connect! n1 n2)
- (pcfg-consequent-connect! n2 n3)
- (pcfg-alternative-connect! n2 n4)
- (pcfg-consequent-connect! n3 n6)
- (pcfg-alternative-connect! n3 n5)
- (make-scfg (cfg-entry-node n1)
- (hooks-union (scfg-next-hooks n4)
- (hooks-union (scfg-next-hooks n5)
- (scfg-next-hooks n6)))))))))
+ (let* ((temp (rtl:make-pseudo-register))
+ (cell (rtl:make-fetch temp))
+ (contents (rtl:make-fetch cell))
+ (n1 (rtl:make-assignment temp (rtl:make-assignment-cache name))))
+ ;; n1 MUST be bound before the rest. It flags temp as a
+ ;; register that contains an address.
+ (let ((n2 (rtl:make-type-test (rtl:make-object->type contents)
+ (ucode-type reference-trap)))
+ (n3 (rtl:make-unassigned-test contents))
+ (n4 (rtl:make-assignment cell value))
+ (n5 (rtl:make-interpreter-call:cache-assignment cell value))
+ ;; Copy prevents premature control merge which confuses CSE
+ (n6 (rtl:make-assignment cell value)))
+ (scfg-next-connect! n1 n2)
+ (pcfg-consequent-connect! n2 n3)
+ (pcfg-alternative-connect! n2 n4)
+ (pcfg-consequent-connect! n3 n6)
+ (pcfg-alternative-connect! n3 n5)
+ (make-scfg (cfg-entry-node n1)
+ (hooks-union (scfg-next-hooks n4)
+ (hooks-union (scfg-next-hooks n5)
+ (scfg-next-hooks n6)))))))
(define (generate/definition definition)
(let ((block (definition-block definition))
(generate/node alternative))))))
(define (generate/cached-unassigned? name)
- (let ((temp (rtl:make-pseudo-register)))
- (let ((cell (rtl:make-fetch temp)))
- (let ((reference (rtl:make-fetch cell)))
- (let ((n1 (rtl:make-assignment temp (rtl:make-variable-cache name)))
- (n2 (rtl:make-type-test (rtl:make-object->type reference)
- (ucode-type reference-trap)))
- (n3 (rtl:make-unassigned-test reference))
- (n4 (rtl:make-interpreter-call:cache-unassigned? cell))
- (n5
- (rtl:make-true-test
- (rtl:interpreter-call-result:cache-unassigned?))))
- (scfg-next-connect! n1 n2)
- (pcfg-consequent-connect! n2 n3)
- (pcfg-alternative-connect! n3 n4)
- (scfg-next-connect! n4 n5)
- (make-pcfg (cfg-entry-node n1)
- (hooks-union (pcfg-consequent-hooks n3)
- (pcfg-consequent-hooks n5))
- (hooks-union (pcfg-alternative-hooks n2)
- (pcfg-alternative-hooks n5))))))))
\ No newline at end of file
+ (let* ((temp (rtl:make-pseudo-register))
+ (cell (rtl:make-fetch temp))
+ (reference (rtl:make-fetch cell))
+ (n1 (rtl:make-assignment temp (rtl:make-variable-cache name))))
+ ;; n1 MUST be bound before the rest. It flags temp as a
+ ;; register that contains an address.
+ (let ((n2 (rtl:make-type-test (rtl:make-object->type reference)
+ (ucode-type reference-trap)))
+ (n3 (rtl:make-unassigned-test reference))
+ (n4 (rtl:make-interpreter-call:cache-unassigned? cell))
+ (n5
+ (rtl:make-true-test
+ (rtl:interpreter-call-result:cache-unassigned?))))
+ (scfg-next-connect! n1 n2)
+ (pcfg-consequent-connect! n2 n3)
+ (pcfg-alternative-connect! n3 n4)
+ (scfg-next-connect! n4 n5)
+ (make-pcfg (cfg-entry-node n1)
+ (hooks-union (pcfg-consequent-hooks n3)
+ (pcfg-consequent-hooks n5))
+ (hooks-union (pcfg-alternative-hooks n2)
+ (pcfg-alternative-hooks n5))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.3 1988/02/17 19:12:51 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.4 1988/03/14 20:55:24 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(scfg-append!
(if (continuation/avoid-check? continuation)
(rtl:make-continuation-entry label)
- (rtl:make-continuation-heap-check label))
+ (rtl:make-continuation-header label))
(generate/continuation-entry/ic-block continuation)
(if (block/dynamic-link?
(continuation/closing-block continuation))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.5 1988/02/17 19:14:05 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.6 1988/03/14 20:58:41 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
'DONE)
(define-cse-method 'POP-RETURN method/noop)
-(define-cse-method 'PROCEDURE-HEAP-CHECK method/noop)
-(define-cse-method 'CONTINUATION-HEAP-CHECK method/noop)
+
(define-cse-method 'CONTINUATION-ENTRY method/noop)
+(define-cse-method 'CONTINUATION-HEADER method/noop)
+(define-cse-method 'IC-PROCEDURE-HEADER method/noop)
+(define-cse-method 'OPEN-PROCEDURE-HEADER method/noop)
+(define-cse-method 'PROCEDURE-HEADER method/noop)
+(define-cse-method 'CLOSURE-HEADER method/noop)
+
(define-cse-method 'INVOCATION:APPLY method/noop)
(define-cse-method 'INVOCATION:JUMP method/noop)
(define-cse-method 'INVOCATION:LEXPR method/noop)
+(define-cse-method 'INVOCATION:UUO-LINK method/noop)
(define-cse-method 'INVOCATION:PRIMITIVE method/noop)
(define-cse-method 'INVOCATION:SPECIAL-PRIMITIVE method/noop)
-(define-cse-method 'INVOCATION:UUO-LINK method/noop)
-
-(define-cse-method 'INTERPRETER-CALL:ENCLOSE
- (lambda (statement)
- (let ((n (rtl:interpreter-call:enclose-size statement)))
- (stack-region-invalidate! 0 n)
- (stack-pointer-adjust! n))
- (expression-invalidate! (interpreter-register:enclose))))
(define-cse-method 'INVOCATION:CACHE-REFERENCE
(lambda (statement)
rtl:set-invocation:lookup-environment!
statement
trivial-action)))
-\f
-(define-cse-method 'SETUP-LEXPR
- (lambda (statement)
- (stack-invalidate!)
- (stack-pointer-invalidate!)))
+(define-cse-method 'CONS-CLOSURE
+ (lambda (statement)
+ (expression-invalidate! (interpreter-register:enclose))))
+\f
(define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP
(lambda (statement)
(expression-replace! rtl:invocation-prefix:move-frame-up-locative
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.3 1987/12/31 07:01:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.4 1988/03/14 20:59:05 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(memq (rtl:expression-type expression)
'(OBJECT->ADDRESS OBJECT->DATUM
OBJECT->TYPE
- OFFSET-ADDRESS)))))))
+ OFFSET-ADDRESS
+ VARIABLE-CACHE
+ ASSIGNMENT-CACHE)))))))
(define (element-address-varies? element)
(and (element-in-memory? element)
projects / mit-scheme.git / commitdiff