From: Stephen Adams Date: Fri, 4 Aug 1995 19:48:50 +0000 (+0000) Subject: DBG-REDUCE now stored %stack-closure-ref (and also %read-closure-ref) X-Git-Tag: 20090517-FFI~6069 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1271aacdc1e6c2d2b4d77499796f999707b6848c;p=mit-scheme.git DBG-REDUCE now stored %stack-closure-ref (and also %read-closure-ref) expressions in a compact form as this is the dominant expression kind. CLOSCONV generates these expressions directly, and DBG-INFO/REMEMBER converts others. STACKOPT is modified to update the stack frame ordering and INDEXIFY leaves them alone (the call to vectro-index occurs in DBG info generation). --- diff --git a/v8/src/compiler/midend/closconv.scm b/v8/src/compiler/midend/closconv.scm index 0d74b3c24..7651fcc13 100644 --- a/v8/src/compiler/midend/closconv.scm +++ b/v8/src/compiler/midend/closconv.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: closconv.scm,v 1.8 1995/07/04 19:20:29 adams Exp $ +$Id: closconv.scm,v 1.9 1995/08/04 19:47:20 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -562,6 +562,9 @@ MIT in each case. |# (QUOTE ,closed-over-names) (QUOTE ,name)) (QUOTE ,name))) + (define (dbg-reference-expression) + (dbg/make-closure-ref %closure-ref + closure-name closed-over-names name)) (define (self-reference-expression) `(LOOKUP ,closure-name)) (define (rewrite-self-reference! ref) @@ -572,7 +575,7 @@ MIT in each case. |# (dbg-info/remember name (if (eq? binding self-binding) (self-reference-expression) - (reference-expression))) + (dbg-reference-expression))) (for-each (if (eq? (car free-ref) self-binding) rewrite-self-reference! diff --git a/v8/src/compiler/midend/dbgred.scm b/v8/src/compiler/midend/dbgred.scm index adcd7f2d8..c1317eff1 100644 --- a/v8/src/compiler/midend/dbgred.scm +++ b/v8/src/compiler/midend/dbgred.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: dbgred.scm,v 1.11 1995/08/03 23:28:21 adams Exp $ +$Id: dbgred.scm,v 1.12 1995/08/04 19:48:50 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -196,7 +196,7 @@ reachable. (let ((edge (dbg-red/node/add-edge! node `(CC-ENTRY . ,name)))) (dbg-red/edge/statically-available! edge)) - (internal-warning "Node absent" node))))) + (internal-warning "Node absent" name))))) bindings)) (define-dbg-reducer IF (pred conseq alt) @@ -424,11 +424,15 @@ reachable. (let walk ((expr expr)) (cond ((symbol? expr) (add-reference! expr)) - ((not (pair? expr)) unspecific) ((LOOKUP/? expr) (add-reference! (lookup/name expr))) ((QUOTE/? expr) unspecific) + ((dbg/stack-closure-ref? expr) + (walk (vector-ref expr 1))) + ((dbg/heap-closure-ref? expr) + (walk (vector-ref expr 1))) ((CALL/? expr) (for-each walk (call/operands expr))) + ((not (pair? expr)) unspecific) (else ;;(pp expr) unspecific)))) @@ -524,6 +528,7 @@ reachable. (define dbg-red/reconstruct-path (lambda (item graph env) + (define (reconstruct-name item) (cond ((dbg-reduce/env/lookup env item) => (lambda (offset-or-name) @@ -577,22 +582,20 @@ reachable. `((INTEGRATED . ,(quote/text expr))))) ((LOOKUP/? expr) (reconstruct-name (lookup/name expr))) ((symbol? expr) (reconstruct-name expr)) - ((CALL/%stack-closure-ref? expr) - (let ((frame (call/%stack-closure-ref/closure expr)) - (offset (call/%stack-closure-ref/offset expr))) - (and (LOOKUP/? frame) - (QUOTE/? offset) - (eq? (lookup/name frame) (dbg-reduce/env/frame-name env)) - (list (dbgred/STACK (quote/text offset)))))) - ((CALL/%heap-closure-ref? expr) - (let ((closure (call/%heap-closure-ref/closure expr)) - (offset (call/%heap-closure-ref/offset expr))) - (let ((closure-path (reconstruct-expression closure))) - (and closure-path - (QUOTE/? offset) - (cons (dbgred/CLOSURE (+ (quote/text offset) - (rtlgen/closure-first-offset))) - closure-path))))) + ((dbg/stack-closure-ref? expr) + (let ((frame (vector-ref expr 1)) + (offset + (vector-index (vector-ref expr 2) (vector-ref expr 3)))) + (and (eq? frame (dbg-reduce/env/frame-name env)) + (list (dbgred/STACK offset))))) + ((dbg/heap-closure-ref? expr) + (let ((closure-path (reconstruct-expression (vector-ref expr 1))) + (offset + (vector-index (vector-ref expr 2) (vector-ref expr 3)))) + (and closure-path + (cons (dbgred/CLOSURE (+ offset + (rtlgen/closure-first-offset))) + closure-path)))) ((CALL/%multicell-ref? expr) (let ((cell-path (reconstruct-expression (call/%multicell-ref/cell expr))) @@ -605,6 +608,9 @@ reachable. (vector-index (quote/text layout) (quote/text name))) cell-path)))) + ((or (CALL/%stack-closure-ref? expr) + (CALL/%heap-closure-ref? expr)) + (internal-error "DBG expression should have been compressed" expr)) ((and (pair? expr) (eq? (car expr) 'CC-ENTRY)) (list expr)) @@ -720,30 +726,71 @@ reachable. ;; tracking of representation and naming changes for generating debugging ;; info. +;; Compact representation of closure reference expressions + +(define (dbg/make-closure-ref op closure elements-vector name) + (vector op closure elements-vector name)) + +(define (dbg/stack-closure-ref? thing) + (and (vector? thing) + (eq? (vector-ref thing 0) %stack-closure-ref))) + +(define (dbg/heap-closure-ref? thing) + (and (vector? thing) + (eq? (vector-ref thing 0) %heap-closure-ref))) + +(define (dbg-red/compress-expression form) + (define (compress-closure-ref op) + ;; (CALL '%*-closure-ref '#F 'name) + (let* ((closure (dbg-red/compress-expression (fourth form))) + (ix-expr (fifth form)) + (name (quote/text (sixth form)))) + (vector op closure (if (QUOTE/? ix-expr) + (quote/text ix-expr) + (quote/text (CALL/%vector-index/vector ix-expr))) + name))) + + (define (compress-ordinary-call form) + (let ((exprs* (map dbg-red/compress-expression (call/operands form)))) + (if (there-exists? exprs* false?) + #F + `(CALL ,(call/operator form) ,(call/continuation form) ,@exprs*)))) + + (cond ((QUOTE/? form) form) + ((symbol? form) form) + ((LOOKUP/? form) (lookup/name form)) + ((and (CALL/? form) + (QUOTE/? (call/operator form))) + (let ((op (quote/text (call/operator form)))) + (cond ((or (eq? op %stack-closure-ref) + (eq? op %heap-closure-ref)) + (compress-closure-ref op)) + ((hash-table/get *dbg-forbidden-operators* op #F) #F) + (else + (compress-ordinary-call form))))) + (else #F))) + (define *dbg-rewrites*) (define (dbg-info/make-rewrites) (cons 'HEAD '())) -(define (dbg-info/remember from to) - - (let ((to (if (LOOKUP/? to) (lookup/name to) to))) - (define (good) - (set-cdr! *dbg-rewrites* - (cons (vector from to) (cdr *dbg-rewrites*)))) - - (cond ((eq? from to)) - ((CALL/? to) - (if (QUOTE/? (call/operator to)) - (let ((op (quote/text (call/operator to)))) - (cond ((hash-table/get *dbg-forbidden-operators* op #F)) - ((hash-table/get dbg-reduce/equivalent-operators op #F) - (good)) - ((primitive-procedure? op)) - (else ; a fakeprim - (good)))))) - ((continuation-variable? from)) - (else (good))))) +(define (dbg-info/remember from to*) + (define (good to) + (set-cdr! *dbg-rewrites* + (cons (vector from to) (cdr *dbg-rewrites*)))) + (cond ((continuation-variable? from)) + ((dbg/stack-closure-ref? to*) (good to*)) + ((dbg/heap-closure-ref? to*) (good to*)) + (else + (let ((to (dbg-red/compress-expression to*))) + (cond ((eq? from to)) + ((false? to) + #|(fluid-let ((*unparser-list-breadth-limit* 7) + (*unparser-list-depth-limit* 6)) + (pp `(reject ,from ,to*)))|#) + (else (good to))))))) + (define *dbg-forbidden-operators* (make-eq-hash-table)) diff --git a/v8/src/compiler/midend/indexify.scm b/v8/src/compiler/midend/indexify.scm index 79c60d517..3c45682f6 100644 --- a/v8/src/compiler/midend/indexify.scm +++ b/v8/src/compiler/midend/indexify.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: indexify.scm,v 1.4 1995/06/15 18:01:55 adams Exp $ +$Id: indexify.scm,v 1.5 1995/08/04 19:46:23 adams Exp $ -Copyright (c) 1994 Massachusetts Institute of Technology +Copyright (c) 1994-1995 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -127,12 +127,17 @@ MIT in each case. |# (define (indexify/do-dbg-info!) (define (rewrite-indexifies! expr) - (cond ((QUOTE/? expr)) + (cond ((dbg/stack-closure-ref? expr) + (rewrite-indexifies! (vector-ref expr 1))) + ((dbg/heap-closure-ref? expr) + (rewrite-indexifies! (vector-ref expr 1))) + ((QUOTE/? expr)) ((LOOKUP/? expr)) ((and (CALL/? expr) (QUOTE/? (call/operator expr)) (eq? %vector-index (quote/text (call/operator expr))) (for-all? (call/cont-and-operands expr) QUOTE/?)) + (internal-error "%vector-index found in DBG info") (let ((rands (call/operands expr))) (form/rewrite! expr `(QUOTE ,(vector-index (QUOTE/text (first rands)) diff --git a/v8/src/compiler/midend/stackopt.scm b/v8/src/compiler/midend/stackopt.scm index 846b7be26..7fc189add 100644 --- a/v8/src/compiler/midend/stackopt.scm +++ b/v8/src/compiler/midend/stackopt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: stackopt.scm,v 1.11 1995/08/03 00:17:40 adams Exp $ +$Id: stackopt.scm,v 1.12 1995/08/04 19:45:23 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -119,7 +119,10 @@ End of Big Note A |# (define (stackopt/top-level program) - (stackopt/expr false program)) + (fluid-let ((stackopt/dbg-refs (stackopt/get-dbg-refs))) + (stackopt/expr false program))) + +(define stackopt/dbg-refs) ; table from frame name to dbg info references (define-macro (define-stack-optimizer keyword bindings . body) (let ((proc-name (symbol-append 'STACKOPT/ keyword))) @@ -369,6 +372,7 @@ End of Big Note A |# ;;Following test wrong: (lambda () (subproblem) (lambda (a1 ... a100) ...)) ;;(if state ;; (internal-error "Model exists at non-continuation lambda!" state)) + state (let* ((frame-vector (cadr (assq stackopt/?frame-vector match-result))) (frame-name (cadr (assq stackopt/?frame-name match-result))) (model (stackopt/model/make #F (vector-copy frame-vector) frame-name @@ -524,16 +528,28 @@ End of Big Note A |# ,(call/%make-stack-closure/vector form) ,@values*)))))) +(define (stackopt/get-dbg-refs) + (let ((info (make-eq-hash-table))) + (define (walk expr) + (cond ((dbg/stack-closure-ref? expr) + (let ((frame-var (vector-ref expr 1))) + (hash-table/put! + info + frame-var + (cons expr + (hash-table/get info frame-var '()))))) + ((dbg/heap-closure-ref? expr) + (walk (vector-ref expr 1))) + ((CALL/? expr) + (for-each walk (call/operands expr))) + (else unspecific))) + (dbg-info/for-all-dbg-expressions! walk) + info)) + (define (stackopt/rewrite-dbg-frames! frame-var new-vector) - (dbg-info/for-all-dbg-expressions! - (lambda (expr) - (if (and (call/%stack-closure-ref? expr) - (eq? (lookup/name (call/%stack-closure-ref/closure expr)) - frame-var)) - (let* ((ix-expr (call/%stack-closure-ref/offset expr)) - (quoted-vector (call/%vector-index/vector ix-expr))) - (form/rewrite! quoted-vector - `(QUOTE ,new-vector))))))) + (for-each (lambda (ref) + (vector-set! ref 2 new-vector)) + (hash-table/get stackopt/dbg-refs frame-var '()))) (define (stackopt/rearrange! model wired) (define (arrange-locally! model)