introduced in runtime system version 14.31.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.9 1988/12/16 16:19:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.10 1988/12/30 07:11:57 cph Exp $
Copyright (c) 1987, 1988 Massachusetts Institute of Technology
;; the procedure is being "demoted" from first-class to closure.
(set-procedure-closure-context! procedure
(make-reference-context parent))
- (((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)
- (or (lvalue-integrated? lvalue)
- ;; Some of this is redundant
- (let ((value (lvalue-known-value lvalue)))
- (and value
- (or (eq? value procedure)
- (and (rvalue/procedure? value)
- (procedure/trivial-or-virtual? value)))))
- (begin
- (set-variable-closed-over?! lvalue true)
- false))))
- '())
+ (with-values
+ (lambda ()
+ (find-closure-bindings
+ parent
+ (list-transform-negative (block-free-variables block)
+ (lambda (lvalue)
+ (or (lvalue-integrated? lvalue)
+ ;; Some of this is redundant
+ (let ((value (lvalue-known-value lvalue)))
+ (and value
+ (or (eq? value procedure)
+ (and (rvalue/procedure? value)
+ (procedure/trivial-or-virtual? value)))))
+ (begin
+ (set-variable-closed-over?! lvalue true)
+ false))))
+ '()))
+ (lambda (closure-frame-block size)
+ (set-block-parent! block closure-frame-block)
+ (set-procedure-closure-size! procedure size)))
(let ((new (procedure/trivial-closure? procedure)))
(if (or (and previously-trivial? (not new))
(and (not previously-trivial?) new))
procedure))))
(disown-block-child! current-parent block)))
\f
-(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
+(define (find-closure-bindings block free-variables bound-variables)
+ (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)))
+ (with-values
+ (lambda ()
+ (filter-bound-variables (block-bound-variables block)
free-variables
- bound-variables
- (and block (block-procedure block)))))
- (with-values
- (lambda ()
- (filter-bound-variables (block-bound-variables block)
- free-variables
- bound-variables))
- (find-internal (original-block-parent block))))))
- find-internal)
+ bound-variables))
+ (lambda (free-variables bound-variables)
+ (find-closure-bindings (original-block-parent block)
+ free-variables
+ bound-variables)))))
(define (filter-bound-variables bindings free-variables bound-variables)
(cond ((null? bindings)
;; 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)))
+(define (make-closure-block parent free-variables bound-variables)
+ (let ((block (make-block parent 'CLOSURE)))
(set-block-free-variables! block free-variables)
(set-block-bound-variables! block bound-variables)
- (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))
- (error "make-closure-block: Found integrated lvalue"
- (car variables))
- (loop (cdr variables) offset table size))
- (else
- (loop (cdr variables)
- (1+ offset)
- (cons (cons (car variables) offset)
- table)
- (1+ size)))))))
+ (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))))))
\f
(define (setup-closure-contexts! expression procedures)
(with-new-node-marks
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.24 1988/12/14 00:01:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.25 1988/12/30 07:10:49 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
;;;; Code Generator
(define (combination/inline combination)
- (generate/return* (combination/context combination)
- (combination/continuation combination)
- (combination/continuation-push combination)
- (let ((inliner (combination/inliner combination)))
+ (let ((context (combination/context combination))
+ (inliner (combination/inliner combination)))
+ (generate/return* context
+ (combination/continuation combination)
+ (combination/continuation-push combination)
(let ((handler (inliner/handler inliner))
(generator (inliner/generator inliner))
(expressions
(inliner/operands inliner))))
(make-return-operand
(lambda ()
- ((vector-ref handler 1) generator expressions))
+ ((vector-ref handler 1) generator
+ context
+ expressions))
(lambda (finish)
((vector-ref handler 2) generator
+ context
expressions
finish))
(lambda (finish)
((vector-ref handler 3) generator
+ context
expressions
finish))
false)))))
(continuation*/register
(subproblem-continuation subproblem))))))))
\f
-(define (invoke/effect->effect generator expressions)
- (generator expressions false))
+(define (invoke/effect->effect generator context expressions)
+ (generator context expressions false))
-(define (invoke/predicate->value generator expressions finish)
- (generator expressions
+(define (invoke/predicate->value generator context expressions finish)
+ (generator context expressions
(lambda (pcfg)
(let ((temporary (rtl:make-pseudo-register)))
;; Force assignments to be made first.
(pcfg*scfg->scfg! pcfg consequent alternative)
(finish (rtl:make-fetch temporary))))))))
-(define (invoke/value->effect generator expressions)
- generator expressions
+(define (invoke/value->effect generator context expressions)
+ generator context expressions
(make-null-cfg))
-(define (invoke/value->predicate generator expressions finish)
- (generator expressions
+(define (invoke/value->predicate generator context expressions finish)
+ (generator context expressions
(lambda (expression)
(finish (rtl:make-true-test expression)))))
-(define (invoke/value->value generator expressions finish)
- (generator expressions finish))
+(define (invoke/value->value generator context expressions finish)
+ (generator context expressions finish))
\f
;;;; Definers
(define-integrable (make-invocation operator operands)
`(,operator ,@operands))
-(define (open-code:with-checks checks non-error-cfg error-finish
+(define (open-code:with-checks context checks non-error-cfg error-finish
prim-invocation)
(let ((checks (list-transform-negative checks cfg-null?)))
(if (null? checks)
;; it creates some unreachable code which we can't easily
;; remove from the output afterwards.
(let ((error-cfg
- (let ((continuation-entry (generate-continuation-entry)))
- (scfg-append!
- (generate-primitive
- (car prim-invocation)
- (cdr prim-invocation)
- (rtl:continuation-entry-continuation
- (rinst-rtl
- (bblock-instructions
- (cfg-entry-node continuation-entry)))))
- continuation-entry
- (if error-finish
- (error-finish (rtl:make-fetch register:value))
- (make-null-cfg))))))
+ (with-values (lambda () (generate-continuation-entry context))
+ (lambda (label setup cleanup)
+ (scfg-append!
+ setup
+ (generate-primitive (car prim-invocation)
+ (cdr prim-invocation)
+ label)
+ cleanup
+ (if error-finish
+ (error-finish (rtl:make-fetch register:value))
+ (make-null-cfg)))))))
(let loop ((checks checks))
(if (null? checks)
non-error-cfg
identity-procedure)
(make-null-cfg)))
\f
-(define (generate-continuation-entry)
- (let* ((label (generate-label))
- (rtl (rtl:make-continuation-entry label))
- (rtl-continuation
- (make-rtl-continuation *current-rgraph* label (cfg-entry-edge rtl))))
- (set! *extra-continuations* (cons rtl-continuation *extra-continuations*))
- rtl))
-
(define (generate-primitive name arg-list continuation-label)
(scfg*scfg->scfg!
(let loop ((args arg-list))
(define-open-coder/predicate 'NULL?
(lambda (operands)
operands
- (return-2 (lambda (expressions finish)
+ (return-2 (lambda (context expressions finish)
+ context
(finish (pcfg-invert (rtl:make-true-test (car expressions)))))
'(0))))
(let ((open-code/type-test
(lambda (type)
- (lambda (expressions finish)
+ (lambda (context expressions finish)
+ context
(finish
(rtl:make-type-test (rtl:make-object->type (car expressions))
type))))))
(return-2 (open-code/type-test type) '(1)))))))
(let ((open-code/eq-test
- (lambda (expressions finish)
+ (lambda (context expressions finish)
+ context
(finish (rtl:make-eq-test (car expressions) (cadr expressions))))))
(define-open-coder/predicate 'EQ?
(lambda (operands)
\f
(let ((open-code/pair-cons
(lambda (type)
- (lambda (expressions finish)
+ (lambda (context expressions finish)
+ context
(finish
(rtl:make-typed-cons:pair (rtl:make-constant type)
(car expressions)
(define-open-coder/value 'VECTOR
(lambda (operands)
(and (< (length operands) 32)
- (return-2 (lambda (expressions finish)
+ (return-2 (lambda (context expressions finish)
+ context
(finish
(rtl:make-typed-cons:vector
(rtl:make-constant (ucode-type vector))
\f
(let ((open-code/memory-length
(lambda (index)
- (lambda (expressions finish)
+ (lambda (context expressions finish)
+ context
(finish
(rtl:make-cons-pointer
(rtl:make-constant (ucode-type fixnum))
finish))
\f
(let* ((open-code/memory-ref
- (lambda (index)
- (lambda (expressions finish)
- (finish
- (rtl:make-fetch
- (rtl:locative-offset (car expressions) index))))))
+ (lambda (expressions finish index)
+ (finish
+ (rtl:make-fetch
+ (rtl:locative-offset (car expressions) index)))))
(open-code/vector-ref
(lambda (name)
- (lambda (expressions finish)
+ (lambda (context expressions finish)
(let ((vector (car expressions))
(index (cadr expressions)))
(open-code:with-checks
+ context
(list
(open-code:type-check vector 'VECTOR)
(open-code:type-check index 'FIXNUM)
vector
index
(lambda (memory-locative)
- ((open-code/memory-ref 1)
- (list memory-locative)
- finish)))
+ (open-code/memory-ref (list memory-locative) finish 1)))
finish
(make-invocation name expressions))))))
(open-code/constant-vector-ref
(lambda (name index)
- (lambda (expressions finish)
+ (lambda (context expressions finish)
(let ((vector (car expressions)))
(open-code:with-checks
+ context
(list
(open-code:type-check vector 'VECTOR)
(open-code:limit-check
(rtl:make-constant index)
(rtl:make-fetch (rtl:locative-offset vector 0))))
- ((open-code/memory-ref (1+ index)) expressions finish)
+ (open-code/memory-ref expressions finish (1+ index))
finish
(make-invocation name expressions)))))))
(let ((define/ref
(define-open-coder/value name
(lambda (operands)
operands
- (return-2 (open-code/memory-ref index) '(0)))))))
+ (return-2 (lambda (context expressions finish)
+ context
+ (open-code/memory-ref expressions finish index))
+ '(0)))))))
(define/ref '(CAR SYSTEM-PAIR-CAR CELL-CONTENTS SYSTEM-HUNK3-CXR0) 0)
(define/ref '(CDR SYSTEM-PAIR-CDR SYSTEM-HUNK3-CXR1) 1)
(define/ref 'SYSTEM-HUNK3-CXR2 2))
\f
(let ((open-code/general-car-cdr
(lambda (pattern)
- (lambda (expressions finish)
+ (lambda (context expressions finish)
+ context
(finish
(let loop ((pattern pattern) (expression (car expressions)))
(if (= pattern 1)
(return-2 (open-code/general-car-cdr pattern) '(0)))))))
\f
(let* ((open-code/memory-assignment
- (lambda (index)
- (lambda (expressions finish)
- (let* ((locative (rtl:locative-offset (car expressions) index))
- (assignment
- (rtl:make-assignment locative
- (car (last-pair expressions)))))
- (if finish
- (load-temporary-register scfg*scfg->scfg!
- (rtl:make-fetch locative)
- (lambda (temporary)
- (scfg*scfg->scfg! assignment (finish temporary))))
- assignment)))))
+ (lambda (expressions finish index)
+ (let* ((locative (rtl:locative-offset (car expressions) index))
+ (assignment
+ (rtl:make-assignment locative
+ (car (last-pair expressions)))))
+ (if finish
+ (load-temporary-register scfg*scfg->scfg!
+ (rtl:make-fetch locative)
+ (lambda (temporary)
+ (scfg*scfg->scfg! assignment (finish temporary))))
+ assignment))))
(open-code/vector-set
(lambda (name)
- (lambda (expressions finish)
+ (lambda (context expressions finish)
(let ((vector (car expressions))
(index (cadr expressions))
(newval-list (cddr expressions)))
(open-code:with-checks
+ context
(list
(open-code:type-check vector 'VECTOR)
(open-code:type-check index 'FIXNUM)
vector
index
(lambda (memory-locative)
- ((open-code/memory-assignment 1)
+ (open-code/memory-assignment
(cons memory-locative newval-list)
- finish)))
+ finish
+ 1)))
finish
(make-invocation name expressions))))))
(open-code/constant-vector-set
(lambda (name index)
- (lambda (expressions finish)
+ (lambda (context expressions finish)
(let ((vector (car expressions)))
(open-code:with-checks
+ context
(list
(open-code:type-check vector 'VECTOR)
(open-code:limit-check
(rtl:make-constant index)
(rtl:make-fetch (rtl:locative-offset vector 0))))
- ((open-code/memory-assignment index) expressions finish)
+ (open-code/memory-assignment expressions finish index)
finish
(make-invocation name expressions)))))))
(define-open-coder/effect name
(lambda (operands)
operands
- (return-2 (open-code/memory-assignment index) '(0 1)))))))
+ (return-2
+ (lambda (context expressions finish)
+ context
+ (open-code/memory-assignment expressions finish index))
+ '(0 1)))))))
(define/set! '(SET-CAR!
SET-CELL-CONTENTS!
#| SYSTEM-PAIR-SET-CAR! |#
(lambda (operands)
operands
(return-2
- (lambda (expressions finish)
+ (lambda (context expressions finish)
+ context
(finish
(rtl:make-fixnum->object
(rtl:make-fixnum-2-args
(lambda (operand)
operand
(return-2
- (lambda (expressions finish)
+ (lambda (context expressions finish)
+ context
(finish
(rtl:make-fixnum->object
(rtl:make-fixnum-1-arg
(lambda (operands)
operands
(return-2
- (lambda (expressions finish)
+ (lambda (context expressions finish)
+ context
(finish
(rtl:make-fixnum-pred-2-args
fixnum-pred
(lambda (operand)
operand
(return-2
- (lambda (expressions finish)
+ (lambda (context expressions finish)
+ context
(finish
(rtl:make-fixnum-pred-1-arg
fixnum-pred
\f
;;; Generic arithmetic
-(define (generate-generic-binary expression finish is-pred?)
- (let ((continuation-entry (generate-continuation-entry))
- (generic-op (rtl:generic-binary-operator expression))
+(define (generate-generic-binary context expression finish is-pred?)
+ (let ((generic-op (rtl:generic-binary-operator expression))
(fix-op
(generic->fixnum-op (rtl:generic-binary-operator expression)))
(op1 (rtl:generic-binary-operand-1 expression))
(op2 (rtl:generic-binary-operand-2 expression)))
(let ((give-it-up
(lambda ()
- (scfg-append!
- (generate-primitive
- generic-op
- (cddr expression)
- (rtl:continuation-entry-continuation
- (rinst-rtl
- (bblock-instructions
- (cfg-entry-node continuation-entry)))))
- continuation-entry
- (if is-pred?
- (finish
- (rtl:make-true-test (rtl:make-fetch register:value)))
- (expression-simplify-for-statement
- (rtl:make-fetch register:value)
- finish))))))
+ (with-values (lambda () (generate-continuation-entry context))
+ (lambda (label setup cleanup)
+ (scfg-append!
+ setup
+ (generate-primitive generic-op (cddr expression) label)
+ cleanup
+ (if is-pred?
+ (finish
+ (rtl:make-true-test (rtl:make-fetch register:value)))
+ (expression-simplify-for-statement
+ (rtl:make-fetch register:value)
+ finish))))))))
(if is-pred?
(generate-binary-type-test 'FIXNUM op1 op2
give-it-up
(pcfg*scfg->scfg! test* (do-it) give-it-up)
give-it-up)))))))
\f
-(define (generate-generic-unary expression finish is-pred?)
- (let ((continuation-entry (generate-continuation-entry))
- (generic-op (rtl:generic-unary-operator expression))
+(define (generate-generic-unary context expression finish is-pred?)
+ (let ((generic-op (rtl:generic-unary-operator expression))
(fix-op
(generic->fixnum-op (rtl:generic-unary-operator expression)))
(op (rtl:generic-unary-operand expression)))
(let ((give-it-up
(lambda ()
- (scfg-append!
- (generate-primitive
- generic-op
- (cddr expression)
- (rtl:continuation-entry-continuation
- (rinst-rtl
- (bblock-instructions
- (cfg-entry-node continuation-entry)))))
- continuation-entry
- (if is-pred?
- (finish
- (rtl:make-true-test (rtl:make-fetch register:value)))
- (expression-simplify-for-statement
- (rtl:make-fetch register:value)
- finish))))))
+ (with-values (lambda () (generate-continuation-entry context))
+ (lambda (label setup cleanup)
+ (scfg-append!
+ setup
+ (generate-primitive generic-op (cddr expression) label)
+ cleanup
+ (if is-pred?
+ (finish
+ (rtl:make-true-test (rtl:make-fetch register:value)))
+ (expression-simplify-for-statement
+ (rtl:make-fetch register:value)
+ finish))))))))
(if is-pred?
(generate-unary-type-test 'FIXNUM op
give-it-up
(lambda (operands)
operands
(return-2
- (lambda (expressions finish)
+ (lambda (context expressions finish)
(generate-generic-binary
+ context
(rtl:make-generic-binary generic-op
(car expressions)
(cadr expressions))
(for-each (lambda (generic-op)
(define-open-coder/value generic-op
- (lambda (operand)
- operand
+ (lambda (operands)
+ operands
(return-2
- (lambda (expression finish)
+ (lambda (context expressions finish)
(generate-generic-unary
- (rtl:make-generic-unary generic-op (car expression))
+ context
+ (rtl:make-generic-unary generic-op (car expressions))
finish
false))
'(0)))))
(lambda (operands)
operands
(return-2
- (lambda (expressions finish)
+ (lambda (context expressions finish)
(generate-generic-binary
+ context
(rtl:make-generic-binary generic-op
(car expressions)
(cadr expressions))
(for-each (lambda (generic-op)
(define-open-coder/predicate generic-op
- (lambda (operand)
- operand
+ (lambda (operands)
+ operands
(return-2
- (lambda (expression finish)
+ (lambda (context expressions finish)
(generate-generic-unary
- (rtl:make-generic-unary generic-op (car expression))
+ context
+ (rtl:make-generic-unary generic-op (car expressions))
finish
true))
'(0)))))
(define-open-coder/value character->fixnum
(lambda (operand)
operand
- (return-2 (lambda (expressions finish)
+ (return-2 (lambda (context expressions finish)
+ context
(finish
(rtl:make-cons-pointer
(rtl:make-constant (ucode-type fixnum))
(filter/nonnegative-integer (cadr operands)
(lambda (index)
(return-2
- (lambda (expressions finish)
+ (lambda (context expressions finish)
(let ((string (car expressions)))
(open-code:with-checks
+ context
(list
(open-code:type-check string 'STRING)
(open-code:limit-check
(filter/nonnegative-integer (cadr operands)
(lambda (index)
(return-2
- (lambda (expressions finish)
+ (lambda (context expressions finish)
(let ((string (car expressions))
(value (caddr expressions)))
(open-code:with-checks
+ context
(list
(open-code:type-check string 'STRING)
(open-code:limit-check
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.6 1988/12/12 21:52:40 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.7 1988/12/30 07:11:01 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(package (generate/procedure-header)
-
-(define-export (generate/procedure-header procedure body inline?)
+(define (generate/procedure-header procedure body inline?)
(scfg*scfg->scfg!
- (if (procedure/ic? procedure)
- (scfg*scfg->scfg!
- (if inline?
- (make-null-cfg)
- (rtl:make-ic-procedure-header (procedure-label procedure)))
- (setup-ic-frame procedure))
- (scfg*scfg->scfg!
- (cond (inline?
- ;; Paranoia
- (if (not (procedure/virtually-open? procedure))
- (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)
- (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-rest procedure)
- (with-values (lambda () (procedure-arity-encoding procedure))
- (lambda (min max)
- (rtl:make-procedure-header (procedure-label procedure)
- min max))))
- (else
- (rtl:make-open-procedure-header (procedure-label procedure))))
- (setup-stack-frame procedure)))
+ (let ((context (make-reference-context (procedure-block procedure))))
+ (set-reference-context/offset! context 0)
+ (if (procedure/ic? procedure)
+ (scfg*scfg->scfg!
+ (if inline?
+ (make-null-cfg)
+ (rtl:make-ic-procedure-header (procedure-label procedure)))
+ (setup-ic-frame procedure context))
+ (scfg*scfg->scfg!
+ (cond (inline?
+ ;; Paranoia
+ (if (not (procedure/virtually-open? procedure))
+ (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)
+ (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-rest procedure)
+ (with-values (lambda () (procedure-arity-encoding procedure))
+ (lambda (min max)
+ (rtl:make-procedure-header (procedure-label procedure)
+ min max))))
+ (else
+ (rtl:make-open-procedure-header (procedure-label procedure))))
+ (setup-stack-frame procedure context))))
body))
-
-(define (setup-ic-frame procedure)
+\f
+(define (setup-ic-frame procedure context)
(scfg*->scfg!
(map (let ((block (procedure-block procedure)))
(lambda (name value)
- (generate/rvalue value 0 scfg*scfg->scfg!
+ (generate/rvalue value scfg*scfg->scfg!
(lambda (expression)
- (rtl:make-interpreter-call:set!
- (rtl:make-fetch register:environment)
- (intern-scode-variable! block (variable-name name))
- expression)))))
+ (load-temporary-register scfg*scfg->scfg! expression
+ (lambda (expression)
+ (wrap-with-continuation-entry
+ context
+ (rtl:make-interpreter-call:set!
+ (rtl:make-fetch register:environment)
+ (intern-scode-variable! block (variable-name name))
+ expression))))))))
(procedure-names procedure)
(procedure-values procedure))))
-\f
-(define (setup-stack-frame procedure)
+
+(define (setup-stack-frame procedure context)
(let ((block (procedure-block procedure)))
(define (cellify-variables variables)
(scfg*->scfg! (map cellify-variable variables)))
(cellify-variable rest)
(make-null-cfg)))
(scfg*->scfg!
- (map (let ((context (make-reference-context block)))
- (set-reference-context/offset! context 0)
- (lambda (name value)
- (if (and (procedure? value)
- (not (procedure/trivial-or-virtual? value)))
- (letrec-close context name value)
- (make-null-cfg))))
+ (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
(define (setup-bindings names values pushes)
(error "Missing closure variable" variable))
(lambda (name)
name ;; ignored
- (error "Missing closure variable" variable)))))
-
-;;; end GENERATE/PROCEDURE-HEADER
-)
\ No newline at end of file
+ (error "Missing closure variable" variable)))))
\ 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.12 1988/12/12 21:52:46 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.13 1988/12/30 07:11:06 cph Rel $
#| -*-Scheme-*-
Copyright (c) 1988 Massachusetts Institute of Technology
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.12 1988/12/12 21:52:46 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.13 1988/12/30 07:11:06 cph Rel $
Copyright (c) 1988, 1990 Massachusetts Institute of Technology
(expression-value/simple (rtl:make-fetch locative)))
(lambda (environment name)
(expression-value/temporary
- (rtl:make-interpreter-call:lookup
- environment
- (intern-scode-variable! (reference-context/block context)
- name)
- safe?)
+ (load-temporary-register scfg*scfg->scfg! environment
+ (lambda (environment)
+ (wrap-with-continuation-entry
+ context
+ (rtl:make-interpreter-call:lookup
+ environment
+ (intern-scode-variable!
+ (reference-context/block context)
+ name)
+ safe?))))
(rtl:interpreter-call-result:lookup)))
(lambda (name)
(if (memq 'IGNORE-REFERENCE-TRAPS
(load-temporary-register values
(rtl:make-variable-cache name)
rtl:make-fetch)
- (generate/cached-reference name safe?)))))))
+ (generate/cached-reference context name safe?)))))))
(cond ((not value) (perform-fetch))
lvalue))
|#
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.9 1988/12/12 21:52:53 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.10 1988/12/30 07:11:11 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(lambda (locative)
(rtl:make-assignment locative expression))
(lambda (environment name)
- (rtl:make-interpreter-call:set!
- environment
- (intern-scode-variable! (reference-context/block context)
- name)
- expression))
+ (load-temporary-register scfg*scfg->scfg! environment
+ (lambda (environment)
+ (load-temporary-register scfg*scfg->scfg! expression
+ (lambda (expression)
+ (wrap-with-continuation-entry
+ context
+ (rtl:make-interpreter-call:set!
+ environment
+ (intern-scode-variable!
+ (reference-context/block context)
+ name)
+ expression)))))))
(lambda (name)
(if (memq 'IGNORE-ASSIGNMENT-TRAPS
(variable-declarations lvalue))
(rtl:make-assignment-cache name)
(lambda (cell)
(rtl:make-assignment cell expression)))
- (generate/cached-assignment name expression)))))))))
+ (generate/cached-assignment context
+ name
+ expression)))))))))
-(define (generate/cached-assignment name value)
+(define (generate/cached-assignment context name value)
(load-temporary-register scfg*scfg->scfg!
(rtl:make-assignment-cache name)
(lambda (cell)
(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))
+ (n5
+ (load-temporary-register scfg*scfg->scfg! value
+ (lambda (value)
+ (wrap-with-continuation-entry
+ context
+ (rtl:make-interpreter-call:cache-assignment cell value)))))
;; Copy prevents premature control merge which confuses CSE
(n6 (rtl:make-assignment cell value)))
(pcfg-consequent-connect! n2 n3)
(lambda (expression)
(with-values (lambda () (find-definition-variable context lvalue))
(lambda (environment name)
- (rtl:make-interpreter-call:define environment
- name
- expression)))))))
+ (load-temporary-register scfg*scfg->scfg! environment
+ (lambda (environment)
+ (load-temporary-register scfg*scfg->scfg! expression
+ (lambda (expression)
+ (wrap-with-continuation-entry
+ context
+ (rtl:make-interpreter-call:define environment
+ name
+ expression))))))))))))
\f
;;;; Virtual Returns
(receiver setup (generator (rtl:make-fetch temporary))))))
(define (generate/continuation-cons continuation)
- (let ((closing-block (continuation/closing-block continuation)))
- (scfg-append!
- (if (ic-block? closing-block)
- (rtl:make-push (rtl:make-fetch register:environment))
- (make-null-cfg))
- (if (block/dynamic-link? closing-block)
- (rtl:make-push-link)
- (make-null-cfg))
- (if (continuation/always-known-operator? continuation)
- (make-null-cfg)
- (begin
- (enqueue-continuation! continuation)
+ (let ((extra
+ (push-continuation-extra (continuation/closing-block continuation))))
+ (if (continuation/always-known-operator? continuation)
+ extra
+ (begin
+ (enqueue-continuation! continuation)
+ (scfg*scfg->scfg!
+ extra
(rtl:make-push-return (continuation/label continuation)))))))
\f
(define (generate/pop pop)
consequent)))
(define (generate/unassigned-test rvalue consequent alternative)
- (let ((lvalue (unassigned-test-lvalue rvalue)))
+ (let ((context (unassigned-test-context rvalue))
+ (lvalue (unassigned-test-lvalue rvalue)))
(let ((value (lvalue-known-value lvalue)))
(cond ((not value)
(pcfg*scfg->scfg!
- (find-variable (unassigned-test-context rvalue) lvalue
+ (find-variable context lvalue
(lambda (locative)
(rtl:make-unassigned-test (rtl:make-fetch locative)))
(lambda (environment name)
(scfg*pcfg->pcfg!
- (rtl:make-interpreter-call:unassigned? environment name)
+ (load-temporary-register scfg*scfg->scfg! environment
+ (lambda (environment)
+ (wrap-with-continuation-entry
+ context
+ (rtl:make-interpreter-call:unassigned? environment
+ name))))
(rtl:make-true-test
(rtl:interpreter-call-result:unassigned?))))
- generate/cached-unassigned?)
+ (lambda (name)
+ (generate/cached-unassigned? context name)))
(generate/node consequent)
(generate/node alternative)))
((and (rvalue/constant? value)
(else
(generate/node alternative))))))
-(define (generate/cached-unassigned? name)
+(define (generate/cached-unassigned? context name)
(load-temporary-register scfg*pcfg->pcfg!
(rtl:make-variable-cache name)
(lambda (cell)
(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))
+ (n4
+ (wrap-with-continuation-entry
+ context
+ (rtl:make-interpreter-call:cache-unassigned? cell)))
(n5
(rtl:make-true-test
(rtl:interpreter-call-result:cache-unassigned?))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.14 1988/12/16 13:37:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.15 1988/12/30 07:11:17 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(error "Illegal continuation type" continuation)))
(generate/node node)))))
(lambda (rgraph entry-edge)
- (make-rtl-continuation rgraph
- label
- entry-edge
- (continuation/debugging-info continuation))))))
+ (make-rtl-continuation
+ rgraph
+ label
+ entry-edge
+ (continuation/next-continuation-offset
+ (continuation/closing-block continuation)
+ (continuation/offset continuation))
+ (continuation/debugging-info continuation))))))
+\f
+(define (wrap-with-continuation-entry context scfg)
+ (with-values (lambda () (generate-continuation-entry context))
+ (lambda (label setup cleanup)
+ label
+ (scfg-append! setup scfg cleanup))))
+
+(define (generate-continuation-entry context)
+ (let ((label (generate-label))
+ (closing-block (reference-context/block context)))
+ (let ((setup (push-continuation-extra closing-block))
+ (cleanup
+ (scfg*scfg->scfg!
+ (rtl:make-continuation-entry label)
+ (pop-continuation-extra closing-block))))
+ (set! *extra-continuations*
+ (cons (make-rtl-continuation
+ *current-rgraph*
+ label
+ (cfg-entry-edge cleanup)
+ (continuation/next-continuation-offset
+ closing-block
+ (reference-context/offset context))
+ (generated-dbg-continuation context label))
+ *extra-continuations*))
+ (values label setup cleanup))))
+
+(define (continuation/next-continuation-offset block offset)
+ (if (stack-block? block)
+ (let ((popping-limit (block-popping-limit block)))
+ (and popping-limit
+ (let loop ((block block) (offset offset))
+ (let ((offset (+ offset (block-frame-size block))))
+ (if (eq? block popping-limit)
+ offset
+ (loop (block-parent block) offset)))))) offset))
(define (generate/continuation-entry/pop-extra continuation)
- (let ((block (continuation/closing-block continuation)))
- (scfg*scfg->scfg!
- (if (ic-block? block)
- (rtl:make-pop register:environment)
- (make-null-cfg))
- (if (block/dynamic-link? block)
- (rtl:make-pop-link)
- (make-null-cfg)))))
+ (pop-continuation-extra (continuation/closing-block continuation)))
+
+(define (push-continuation-extra closing-block)
+ (cond ((ic-block? closing-block)
+ (rtl:make-push (rtl:make-fetch register:environment)))
+ ((and (stack-block? closing-block)
+ (stack-block/dynamic-link? closing-block))
+ (rtl:make-push-link))
+ (else
+ (make-null-cfg))))
+
+(define (pop-continuation-extra closing-block)
+ (cond ((ic-block? closing-block)
+ (rtl:make-pop register:environment))
+ ((and (stack-block? closing-block)
+ (stack-block/dynamic-link? closing-block))
+ (rtl:make-pop-link))
+ (else
+ (make-null-cfg))))
\f
(define (generate/node node)
(let ((memoization (cfg-node-get node memoization-tag)))
projects / mit-scheme.git / commitdiff