make the accessors/mutators architecture independent.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.15 1989/11/21 00:00:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.16 1990/04/21 16:26:26 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
(equal? (car x) (car y))
(directory-prefix? (cdr x) (cdr y)))))
\f
+(define-integrable (dbg-block/layout-first-offset block)
+ (let ((layout (dbg-block/layout block)))
+ (and (pair? layout) (car layout))))
+
+(define-integrable (dbg-block/layout-vector block)
+ (let ((layout (dbg-block/layout block)))
+ (if (pair? layout)
+ (cdr layout)
+ layout)))
+
(define (dbg-block/dynamic-link-index block)
- (vector-find-next-element (dbg-block/layout block)
+ (vector-find-next-element (dbg-block/layout-vector block)
dbg-block-name/dynamic-link))
(define (dbg-block/ic-parent-index block)
- (vector-find-next-element (dbg-block/layout block)
+ (vector-find-next-element (dbg-block/layout-vector block)
dbg-block-name/ic-parent))
(define (dbg-block/normal-closure-index block)
- (vector-find-next-element (dbg-block/layout block)
+ (vector-find-next-element (dbg-block/layout-vector block)
dbg-block-name/normal-closure))
(define (dbg-block/return-address-index block)
- (vector-find-next-element (dbg-block/layout block)
+ (vector-find-next-element (dbg-block/layout-vector block)
dbg-block-name/return-address))
(define (dbg-block/static-link-index block)
- (vector-find-next-element (dbg-block/layout block)
+ (vector-find-next-element (dbg-block/layout-vector block)
dbg-block-name/static-link))
(define (dbg-block/find-name block name)
- (let ((layout (dbg-block/layout block)))
+ (let ((layout (dbg-block/layout-vector block)))
(let ((end (vector-length layout)))
(let loop ((index 0))
(and (< index end)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.65 1990/04/12 21:53:41 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.66 1990/04/21 16:26:47 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
dbg-block/find-name
dbg-block/ic-parent-index
dbg-block/layout
+ dbg-block/layout-first-offset
+ dbg-block/layout-vector
dbg-block/normal-closure-index
dbg-block/original-parent
dbg-block/parent
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.11 1989/08/15 13:20:30 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.12 1990/04/21 16:26:13 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
(error "Stack address out of range" address start-offset))
index))
-(define-integrable (compiled-closure/ref closure index)
- ;; 68020 specific -- must be rewritten in compiler interface.
- ((ucode-primitive primitive-object-ref 2) closure (+ 2 index)))
-
-(define-integrable (compiled-closure/set! closure index value)
- ;; 68020 specific -- must be rewritten in compiler interface.
- ((ucode-primitive primitive-object-set! 3) closure (+ 2 index) value)
+;; In the following two procedures, offset can be #f to support
+;; old-style 68020 closures. When offset is not #f, it works on all
+;; architectures.
+
+(define (compiled-closure/ref closure index offset)
+ (if (not offset)
+ ((ucode-primitive primitive-object-ref 2) closure (+ 2 index))
+ ((ucode-primitive primitive-object-ref 2)
+ ((ucode-primitive compiled-code-address->block 1)
+ closure)
+ (+ index offset))))
+
+(define-integrable (compiled-closure/set! closure index offset value)
+ (if (not offset)
+ ((ucode-primitive primitive-object-set! 3) closure (+ 2 index) value)
+ ((ucode-primitive primitive-object-set! 3)
+ ((ucode-primitive compiled-code-address->block 1)
+ closure)
+ (+ index offset)
+ value))
unspecific)
\f
;;;; Compiled Code Blocks
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.15 1989/10/27 07:19:51 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.16 1990/04/21 16:25:12 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
(let ((parent (dbg-block/parent block)))
(case (dbg-block/type parent)
((STACK)
- (make-stack-ccenv parent
- frame
- (+ (dbg-continuation/offset continuation)
- (vector-length (dbg-block/layout block)))))
+ (make-stack-ccenv
+ parent
+ frame
+ (+ (dbg-continuation/offset continuation)
+ (vector-length (dbg-block/layout-vector block)))))
((IC)
(let ((index (dbg-block/ic-parent-index block)))
(if index
(frame (stack-ccenv/frame environment))
(index
(+ (stack-ccenv/start-index environment)
- (vector-length (dbg-block/layout block)))))
+ (vector-length (dbg-block/layout-vector block)))))
(let ((stack-link (dbg-block/stack-link block)))
(cond ((not stack-link)
(with-values
(else
(loop stack-link
frame
- (+ (vector-length (dbg-block/layout stack-link))
+ (+ (vector-length
+ (dbg-block/layout-vector stack-link))
(case (dbg-block/type stack-link)
((STACK)
0)
(define (stack-ccenv/bound-names environment)
(map dbg-variable/name
(list-transform-positive
- (vector->list (dbg-block/layout (stack-ccenv/block environment)))
+ (vector->list
+ (dbg-block/layout-vector (stack-ccenv/block environment)))
dbg-variable?)))
(define (stack-ccenv/bound? environment name)
(map dbg-variable/name
(list-transform-positive
(vector->list
- (dbg-block/layout (closure-ccenv/stack-block environment)))
+ (dbg-block/layout-vector (closure-ccenv/stack-block environment)))
(lambda (variable)
(and (dbg-variable? variable)
(closure-ccenv/variable-bound? environment variable))))))
(and index
(closure-ccenv/variable-bound?
environment
- (vector-ref (dbg-block/layout block) index))))))
+ (vector-ref (dbg-block/layout-vector block) index))))))
(define (closure-ccenv/variable-bound? environment variable)
(or (eq? (dbg-variable/type variable) 'INTEGRATED)
(vector-find-next-element
- (dbg-block/layout (closure-ccenv/closure-block environment))
+ (dbg-block/layout-vector (closure-ccenv/closure-block environment))
variable)))
(define (closure-ccenv/lookup environment name)
(closure-ccenv/get-value environment)
value))
\f
+(define-integrable (closure/get-value closure closure-block index)
+ (compiled-closure/ref closure
+ index
+ (dbg-block/layout-first-offset closure-block)))
+
(define (closure-ccenv/get-value environment)
(lambda (index)
- (compiled-closure/ref (closure-ccenv/closure environment) index)))
+ (closure/get-value (closure-ccenv/closure environment)
+ (closure-ccenv/closure-block environment)
+ index)))
(define (closure-ccenv/has-parent? environment)
(let ((stack-block (closure-ccenv/stack-block environment)))
(guarantee-ic-environment
(let ((index (dbg-block/ic-parent-index closure-block)))
(if index
- (compiled-closure/ref closure index)
+ (closure/get-value closure closure-block index)
(compiled-code-block/environment
(compiled-entry/block closure))))))
(else
\f
(define (lookup-dbg-variable block name get-value)
(let loop ((name name))
- (let ((index (dbg-block/find-name block name)))
- (let ((variable (vector-ref (dbg-block/layout block) index)))
- (case (dbg-variable/type variable)
- ((NORMAL)
- (get-value index))
- ((CELL)
- (let ((value (get-value index)))
- (if (not (cell? value))
- (error "Value of variable should be in cell" variable value))
- (cell-contents value)))
- ((INTEGRATED)
- (dbg-variable/value variable))
- ((INDIRECTED)
- (loop (dbg-variable/name (dbg-variable/value variable))))
- (else
- (error "Unknown variable type" variable)))))))
+ (let* ((index (dbg-block/find-name block name))
+ (variable (vector-ref (dbg-block/layout-vector block) index)))
+ (case (dbg-variable/type variable)
+ ((NORMAL)
+ (get-value index))
+ ((CELL)
+ (let ((value (get-value index)))
+ (if (not (cell? value))
+ (error "Value of variable should be in cell" variable value))
+ (cell-contents value)))
+ ((INTEGRATED)
+ (dbg-variable/value variable))
+ ((INDIRECTED)
+ (loop (dbg-variable/name (dbg-variable/value variable))))
+ (else
+ (error "Unknown variable type" variable))))))
(define (assignable-dbg-variable? block name)
(eq? 'CELL
(dbg-variable/type
- (vector-ref (dbg-block/layout block)
+ (vector-ref (dbg-block/layout-vector block)
(dbg-block/find-name block name)))))
(define (assign-dbg-variable! block name get-value value)
- (let ((index (dbg-block/find-name block name)))
- (let ((variable (vector-ref (dbg-block/layout block) index)))
- (case (dbg-variable/type variable)
- ((CELL)
- (let ((cell (get-value index)))
- (if (not (cell? cell))
- (error "Value of variable should be in cell" name cell))
- (set-cell-contents! cell value)
- unspecific))
- ((NORMAL INTEGRATED INDIRECTED)
- (error "Variable cannot be side-effected" variable))
- (else
- (error "Unknown variable type" variable))))))
+ (let ((index (dbg-block/find-name block name))
+ (variable (vector-ref (dbg-block/layout-vector block) index)))
+ (case (dbg-variable/type variable)
+ ((CELL)
+ (let ((cell (get-value index)))
+ (if (not (cell? cell))
+ (error "Value of variable should be in cell" name cell))
+ (set-cell-contents! cell value)
+ unspecific))
+ ((NORMAL INTEGRATED INDIRECTED)
+ (error "Variable cannot be side-effected" variable))
+ (else
+ (error "Unknown variable type" variable)))))
(define (dbg-block/name block)
(let ((procedure (dbg-block/procedure block)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.15 1989/11/21 00:00:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.16 1990/04/21 16:26:26 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
(equal? (car x) (car y))
(directory-prefix? (cdr x) (cdr y)))))
\f
+(define-integrable (dbg-block/layout-first-offset block)
+ (let ((layout (dbg-block/layout block)))
+ (and (pair? layout) (car layout))))
+
+(define-integrable (dbg-block/layout-vector block)
+ (let ((layout (dbg-block/layout block)))
+ (if (pair? layout)
+ (cdr layout)
+ layout)))
+
(define (dbg-block/dynamic-link-index block)
- (vector-find-next-element (dbg-block/layout block)
+ (vector-find-next-element (dbg-block/layout-vector block)
dbg-block-name/dynamic-link))
(define (dbg-block/ic-parent-index block)
- (vector-find-next-element (dbg-block/layout block)
+ (vector-find-next-element (dbg-block/layout-vector block)
dbg-block-name/ic-parent))
(define (dbg-block/normal-closure-index block)
- (vector-find-next-element (dbg-block/layout block)
+ (vector-find-next-element (dbg-block/layout-vector block)
dbg-block-name/normal-closure))
(define (dbg-block/return-address-index block)
- (vector-find-next-element (dbg-block/layout block)
+ (vector-find-next-element (dbg-block/layout-vector block)
dbg-block-name/return-address))
(define (dbg-block/static-link-index block)
- (vector-find-next-element (dbg-block/layout block)
+ (vector-find-next-element (dbg-block/layout-vector block)
dbg-block-name/static-link))
(define (dbg-block/find-name block name)
- (let ((layout (dbg-block/layout block)))
+ (let ((layout (dbg-block/layout-vector block)))
(let ((end (vector-length layout)))
(let loop ((index 0))
(and (< index end)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.65 1990/04/12 21:53:41 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.66 1990/04/21 16:26:47 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
dbg-block/find-name
dbg-block/ic-parent-index
dbg-block/layout
+ dbg-block/layout-first-offset
+ dbg-block/layout-vector
dbg-block/normal-closure-index
dbg-block/original-parent
dbg-block/parent
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.15 1989/10/27 07:19:51 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.16 1990/04/21 16:25:12 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
(let ((parent (dbg-block/parent block)))
(case (dbg-block/type parent)
((STACK)
- (make-stack-ccenv parent
- frame
- (+ (dbg-continuation/offset continuation)
- (vector-length (dbg-block/layout block)))))
+ (make-stack-ccenv
+ parent
+ frame
+ (+ (dbg-continuation/offset continuation)
+ (vector-length (dbg-block/layout-vector block)))))
((IC)
(let ((index (dbg-block/ic-parent-index block)))
(if index
(frame (stack-ccenv/frame environment))
(index
(+ (stack-ccenv/start-index environment)
- (vector-length (dbg-block/layout block)))))
+ (vector-length (dbg-block/layout-vector block)))))
(let ((stack-link (dbg-block/stack-link block)))
(cond ((not stack-link)
(with-values
(else
(loop stack-link
frame
- (+ (vector-length (dbg-block/layout stack-link))
+ (+ (vector-length
+ (dbg-block/layout-vector stack-link))
(case (dbg-block/type stack-link)
((STACK)
0)
(define (stack-ccenv/bound-names environment)
(map dbg-variable/name
(list-transform-positive
- (vector->list (dbg-block/layout (stack-ccenv/block environment)))
+ (vector->list
+ (dbg-block/layout-vector (stack-ccenv/block environment)))
dbg-variable?)))
(define (stack-ccenv/bound? environment name)
(map dbg-variable/name
(list-transform-positive
(vector->list
- (dbg-block/layout (closure-ccenv/stack-block environment)))
+ (dbg-block/layout-vector (closure-ccenv/stack-block environment)))
(lambda (variable)
(and (dbg-variable? variable)
(closure-ccenv/variable-bound? environment variable))))))
(and index
(closure-ccenv/variable-bound?
environment
- (vector-ref (dbg-block/layout block) index))))))
+ (vector-ref (dbg-block/layout-vector block) index))))))
(define (closure-ccenv/variable-bound? environment variable)
(or (eq? (dbg-variable/type variable) 'INTEGRATED)
(vector-find-next-element
- (dbg-block/layout (closure-ccenv/closure-block environment))
+ (dbg-block/layout-vector (closure-ccenv/closure-block environment))
variable)))
(define (closure-ccenv/lookup environment name)
(closure-ccenv/get-value environment)
value))
\f
+(define-integrable (closure/get-value closure closure-block index)
+ (compiled-closure/ref closure
+ index
+ (dbg-block/layout-first-offset closure-block)))
+
(define (closure-ccenv/get-value environment)
(lambda (index)
- (compiled-closure/ref (closure-ccenv/closure environment) index)))
+ (closure/get-value (closure-ccenv/closure environment)
+ (closure-ccenv/closure-block environment)
+ index)))
(define (closure-ccenv/has-parent? environment)
(let ((stack-block (closure-ccenv/stack-block environment)))
(guarantee-ic-environment
(let ((index (dbg-block/ic-parent-index closure-block)))
(if index
- (compiled-closure/ref closure index)
+ (closure/get-value closure closure-block index)
(compiled-code-block/environment
(compiled-entry/block closure))))))
(else
\f
(define (lookup-dbg-variable block name get-value)
(let loop ((name name))
- (let ((index (dbg-block/find-name block name)))
- (let ((variable (vector-ref (dbg-block/layout block) index)))
- (case (dbg-variable/type variable)
- ((NORMAL)
- (get-value index))
- ((CELL)
- (let ((value (get-value index)))
- (if (not (cell? value))
- (error "Value of variable should be in cell" variable value))
- (cell-contents value)))
- ((INTEGRATED)
- (dbg-variable/value variable))
- ((INDIRECTED)
- (loop (dbg-variable/name (dbg-variable/value variable))))
- (else
- (error "Unknown variable type" variable)))))))
+ (let* ((index (dbg-block/find-name block name))
+ (variable (vector-ref (dbg-block/layout-vector block) index)))
+ (case (dbg-variable/type variable)
+ ((NORMAL)
+ (get-value index))
+ ((CELL)
+ (let ((value (get-value index)))
+ (if (not (cell? value))
+ (error "Value of variable should be in cell" variable value))
+ (cell-contents value)))
+ ((INTEGRATED)
+ (dbg-variable/value variable))
+ ((INDIRECTED)
+ (loop (dbg-variable/name (dbg-variable/value variable))))
+ (else
+ (error "Unknown variable type" variable))))))
(define (assignable-dbg-variable? block name)
(eq? 'CELL
(dbg-variable/type
- (vector-ref (dbg-block/layout block)
+ (vector-ref (dbg-block/layout-vector block)
(dbg-block/find-name block name)))))
(define (assign-dbg-variable! block name get-value value)
- (let ((index (dbg-block/find-name block name)))
- (let ((variable (vector-ref (dbg-block/layout block) index)))
- (case (dbg-variable/type variable)
- ((CELL)
- (let ((cell (get-value index)))
- (if (not (cell? cell))
- (error "Value of variable should be in cell" name cell))
- (set-cell-contents! cell value)
- unspecific))
- ((NORMAL INTEGRATED INDIRECTED)
- (error "Variable cannot be side-effected" variable))
- (else
- (error "Unknown variable type" variable))))))
+ (let ((index (dbg-block/find-name block name))
+ (variable (vector-ref (dbg-block/layout-vector block) index)))
+ (case (dbg-variable/type variable)
+ ((CELL)
+ (let ((cell (get-value index)))
+ (if (not (cell? cell))
+ (error "Value of variable should be in cell" name cell))
+ (set-cell-contents! cell value)
+ unspecific))
+ ((NORMAL INTEGRATED INDIRECTED)
+ (error "Variable cannot be side-effected" variable))
+ (else
+ (error "Unknown variable type" variable)))))
(define (dbg-block/name block)
(let ((procedure (dbg-block/procedure block)))