From: Guillermo J. Rozas Date: Sat, 21 Apr 1990 16:26:47 +0000 (+0000) Subject: New information in closure dbg blocks to accomodate multiclosures and X-Git-Tag: 20090517-FFI~11421 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3ebde78c48fb4b29173c7bb9c517388651bd5a27;p=mit-scheme.git New information in closure dbg blocks to accomodate multiclosures and make the accessors/mutators architecture independent. --- diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm index 0ab0a2b49..4ca2cc1a0 100644 --- a/v7/src/runtime/infutl.scm +++ b/v7/src/runtime/infutl.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -269,28 +269,38 @@ MIT in each case. |# (equal? (car x) (car y)) (directory-prefix? (cdr x) (cdr y))))) +(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) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index fa9f817f7..76eb17840 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -234,6 +234,8 @@ MIT in each case. |# 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 diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm index a8fbd3566..af1511c2d 100644 --- a/v7/src/runtime/udata.scm +++ b/v7/src/runtime/udata.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -145,13 +145,26 @@ MIT in each case. |# (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) ;;;; Compiled Code Blocks diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index d7234c8ea..921e68b5a 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -286,10 +286,11 @@ MIT in each case. |# (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 @@ -329,7 +330,7 @@ MIT in each case. |# (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 @@ -347,7 +348,8 @@ MIT in each case. |# (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) @@ -399,7 +401,8 @@ MIT in each case. |# (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) @@ -468,7 +471,7 @@ MIT in each case. |# (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)))))) @@ -479,12 +482,12 @@ MIT in each case. |# (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) @@ -501,9 +504,16 @@ MIT in each case. |# (closure-ccenv/get-value environment) value)) +(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))) @@ -530,7 +540,7 @@ MIT in each case. |# (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 @@ -541,43 +551,43 @@ MIT in each case. |# (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))) diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm index a98a5d1e7..259938c7d 100644 --- a/v8/src/runtime/infutl.scm +++ b/v8/src/runtime/infutl.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -269,28 +269,38 @@ MIT in each case. |# (equal? (car x) (car y)) (directory-prefix? (cdr x) (cdr y))))) +(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) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 6f11d52f3..3e1f712d1 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -234,6 +234,8 @@ MIT in each case. |# 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 diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm index 9c5eaa5d8..faeaee161 100644 --- a/v8/src/runtime/uenvir.scm +++ b/v8/src/runtime/uenvir.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -286,10 +286,11 @@ MIT in each case. |# (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 @@ -329,7 +330,7 @@ MIT in each case. |# (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 @@ -347,7 +348,8 @@ MIT in each case. |# (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) @@ -399,7 +401,8 @@ MIT in each case. |# (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) @@ -468,7 +471,7 @@ MIT in each case. |# (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)))))) @@ -479,12 +482,12 @@ MIT in each case. |# (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) @@ -501,9 +504,16 @@ MIT in each case. |# (closure-ccenv/get-value environment) value)) +(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))) @@ -530,7 +540,7 @@ MIT in each case. |# (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 @@ -541,43 +551,43 @@ MIT in each case. |# (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)))