#| -*-Scheme-*-
-$Id: infnew.scm,v 1.4 1995/02/28 01:17:31 adams Exp $
+$Id: infnew.scm,v 1.5 1995/07/14 01:00:34 adams Exp $
Copyright (c) 1988-1994 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (info-generation-phase-1 expression procedures)
- (fluid-let ((*integrated-variables* '()))
- (set-expression-debugging-info!
- expression
- (make-dbg-expression (block->dbg-block (expression-block expression))
- (expression-label expression)))
- (for-each
- (lambda (procedure)
- (if (procedure-continuation? procedure)
- (set-continuation/debugging-info!
- procedure
- (let ((block (block->dbg-block (continuation/block procedure))))
- (let ((continuation
- (make-dbg-continuation
- block
- (continuation/label procedure)
- (enumeration/index->name continuation-types
- (continuation/type procedure))
- (continuation/offset procedure)
- (continuation/debugging-info procedure))))
- (set-dbg-block/procedure! block continuation)
- continuation)))
- (set-procedure-debugging-info!
- procedure
- (let ((block (block->dbg-block (procedure-block procedure))))
- (let ((procedure
- (make-dbg-procedure
- block
- (procedure-label procedure)
- (procedure/type procedure)
- (procedure-name procedure)
- (map variable->dbg-variable
- (cdr (procedure-original-required procedure)))
- (map variable->dbg-variable
- (procedure-original-optional procedure))
- (let ((rest (procedure-original-rest procedure)))
- (and rest (variable->dbg-variable rest)))
- (map variable->dbg-variable (procedure-names procedure))
- (procedure-debugging-info procedure))))
- (set-dbg-block/procedure! block procedure)
- procedure)))))
- procedures)
- (for-each process-integrated-variable! *integrated-variables*)))
-
-(define (generated-dbg-continuation context label)
- (let ((block
- (make-dbg-block/continuation (reference-context/block context)
- false)))
- (let ((continuation
- (make-dbg-continuation block
- label
- 'GENERATED
- (reference-context/offset context)
- false)))
- (set-dbg-block/procedure! block continuation)
- continuation)))
-\f
-(define (block->dbg-block block)
- (and block
- (or (block-debugging-info block)
- (let ((dbg-block
- (enumeration-case block-type (block-type block)
- ((STACK) (stack-block->dbg-block block))
- ((CONTINUATION) (continuation-block->dbg-block block))
- ((CLOSURE) (closure-block->dbg-block block))
- ((IC) (ic-block->dbg-block block))
- (else
- (error "BLOCK->DBG-BLOCK: Illegal block type" block)))))
- (set-block-debugging-info! block dbg-block)
- dbg-block))))
-
-(define (stack-block->dbg-block block)
- (let ((parent (block-parent block))
- (frame-size (block-frame-size block))
- (procedure (block-procedure block)))
- (let ((layout (make-layout frame-size)))
- (for-each (lambda (variable)
- (if (not (continuation-variable? variable))
- (layout-set! layout
- (variable-normal-offset variable)
- (variable->dbg-variable variable))))
- (block-bound-variables block))
- (if (procedure/closure? procedure)
- (if (closure-procedure-needs-operator? procedure)
- (layout-set! layout
- (procedure-closure-offset procedure)
- dbg-block-name/normal-closure))
- (if (stack-block/static-link? block)
- (layout-set! layout
- (-1+ frame-size)
- dbg-block-name/static-link)))
- (make-dbg-block 'STACK
- (block->dbg-block parent)
- (if (procedure/closure? procedure)
- (block->dbg-block
- (reference-context/block
- (procedure-closure-context procedure)))
- (block->dbg-block
- (procedure-target-block procedure)))
- layout
- (block->dbg-block (block-stack-link block))))))
-
-(define (continuation-block->dbg-block block)
- (make-dbg-block/continuation
- (block-parent block)
- (continuation/always-known-operator? (block-procedure block))))
-
-(define (make-dbg-block/continuation parent always-known?)
- (let ((dbg-parent (block->dbg-block parent)))
- (make-dbg-block
- 'CONTINUATION
- dbg-parent
- false
- (let ((names
- (append (if always-known?
- '()
- (list dbg-block-name/return-address))
- (if (block/dynamic-link? parent)
- (list dbg-block-name/dynamic-link)
- '())
- (if (ic-block? parent)
- (list dbg-block-name/ic-parent)
- '()))))
- (let ((layout (make-layout (length names))))
- (do ((names names (cdr names))
- (index 0 (1+ index)))
- ((null? names))
- (layout-set! layout index (car names)))
- layout))
- dbg-parent)))
-\f
-(define (closure-block->dbg-block block)
- (let ((parent (block-parent block))
- (start-offset
- (closure-object-first-offset
- (block-entry-number (block-shared-block block))))
- (offsets
- (map (lambda (offset)
- (cons (car offset)
- (- (cdr offset)
- (closure-block-first-offset block))))
- (block-closure-offsets block))))
- (let ((layout (make-layout (1+ (apply max (map cdr offsets))))))
- (for-each (lambda (offset)
- (layout-set! layout
- (cdr offset)
- (variable->dbg-variable (car offset))))
- offsets)
- (if (and parent (ic-block/use-lookup? parent))
- (layout-set! layout 0 dbg-block-name/ic-parent))
- (make-dbg-block 'CLOSURE (block->dbg-block parent) false
- (cons start-offset layout)
- false))))
-
-(define (ic-block->dbg-block block)
- (make-dbg-block 'IC (block->dbg-block (block-parent block))
- false false false))
-
-(define-integrable (make-layout length)
- (make-vector length false))
-
-(define (layout-set! layout index name)
- (let ((name* (vector-ref layout index)))
- (if name* (error "LAYOUT-SET!: reusing layout slot" name* name)))
- (vector-set! layout index name)
- unspecific)
-
-(define *integrated-variables*)
-
-(define (variable->dbg-variable variable)
- (or (lvalue-get variable dbg-variable-tag)
- (let ((integrated? (lvalue-integrated? variable))
- (indirection (variable-indirection variable)))
- (let ((dbg-variable
- (make-dbg-variable
- (variable-name variable)
- (cond (integrated? 'INTEGRATED)
- (indirection 'INDIRECTED)
- ((variable-in-cell? variable) 'CELL)
- (else 'NORMAL))
- (cond (integrated?
- (lvalue-known-value variable))
- (indirection
- ;; This currently does not examine whether it is a
- ;; simple indirection, or a closure indirection.
- ;; The value displayed will be incorrect if it
- ;; is a closure indirection, but...
- (variable->dbg-variable (car indirection)))
- (else
- false)))))
- (if integrated?
- (set! *integrated-variables*
- (cons dbg-variable *integrated-variables*)))
- (lvalue-put! variable dbg-variable-tag dbg-variable)
- dbg-variable))))
-
-(define dbg-variable-tag
- "dbg-variable-tag")
-
-(define (process-integrated-variable! variable)
- (set-dbg-variable/value!
- variable
- (let ((rvalue (dbg-variable/value variable)))
- (cond ((rvalue/constant? rvalue) (constant-value rvalue))
- ((rvalue/procedure? rvalue) (procedure-debugging-info rvalue))
- (else (error "Illegal variable value" rvalue))))))
-\f
(define (info-generation-phase-2 expression procedures continuations)
+ ;; (values expression prcoedures continuations)
(define (debug-info selector object)
(or (selector object)
(begin
(and expression (debug-info rtl-expr/debugging-info expression))
(list-transform-negative
(map (lambda (procedure)
- (let ((info
- (debug-info rtl-procedure/debugging-info procedure)))
+ (let ((info (debug-info rtl-procedure/debugging-info procedure)))
(and info
- (set-dbg-procedure/external-label!
- info
- (rtl-procedure/%external-label procedure))
+ ;;(set-dbg-procedure/external-label!
+ ;; info
+ ;; (rtl-procedure/%external-label procedure))
info)))
procedures)
false?)
false?)))
(define (info-generation-phase-3 expression procedures continuations
- label-bindings external-labels)
+ label-bindings external-labels
+ constant-offset-map)
(let ((label-bindings (labels->dbg-labels label-bindings))
- (no-datum '(NO-DATUM)))
- (let ((labels (make-string-hash-table)))
- (for-each (lambda (label-binding)
- (for-each (lambda (key)
- (let ((datum
- (hash-table/get labels key no-datum)))
- (if (not (eq? datum no-datum))
- (error "Redefining label:" key datum)))
- (hash-table/put! labels
- key
- (cdr label-binding)))
- (car label-binding)))
- label-bindings)
- (let ((map-label/fail
- (lambda (label)
- (let ((key (system-pair-car label)))
- (let ((datum (hash-table/get labels key no-datum)))
- (if (eq? datum no-datum)
- (error "Missing label:" key))
- datum))))
- (map-label/false
- (lambda (label)
- (hash-table/get labels (system-pair-car label) #f))))
- (for-each (lambda (label)
- (set-dbg-label/external?! (map-label/fail label) true))
- external-labels)
- (if expression
- (set-dbg-expression/label!
- expression
- (map-label/fail (dbg-expression/label expression))))
- (for-each
- (lambda (procedure)
- (let* ((internal-label (dbg-procedure/label procedure))
- (mapped-label (map-label/false internal-label)))
- (set-dbg-procedure/label! procedure mapped-label)
- (cond ((dbg-procedure/external-label procedure)
- => (lambda (label)
- (set-dbg-procedure/external-label!
- procedure
- (map-label/fail label))))
- ((not mapped-label)
- (error "Missing label" internal-label)))))
- procedures)
- (for-each
- (lambda (continuation)
- (set-dbg-continuation/label!
- continuation
- (map-label/fail (dbg-continuation/label continuation))))
- continuations)))
+ (no-datum '(NO-DATUM))
+ (labels (make-string-hash-table))
+ (blocks-seen (make-eq-hash-table)))
+ (define (initialize-label label-binding)
+ (for-each (lambda (key)
+ (let ((datum (hash-table/get labels key no-datum)))
+ (if (not (eq? datum no-datum))
+ (error "Redefining label:" key datum)))
+ (hash-table/put! labels key (cdr label-binding)))
+ (car label-binding)))
+ (define (map-label/fail label)
+ (let ((key (system-pair-car label)))
+ (let ((datum (hash-table/get labels key no-datum)))
+ (if (eq? datum no-datum)
+ (error "Missing label:" key))
+ datum)))
+ (define (map-label/false label)
+ (hash-table/get labels (system-pair-car label) #f))
+
+ (define (map-block block)
+ ;; Rewrite path elements that are defined in terms of the compiled code
+ ;; block - i.e. things which are labels or constants in the
+ ;; constants block.
+ (if (new-dbg-block? block)
+ (begin
+ (map-block (new-dbg-block/parent block))
+ (for-each-vector-element (new-dbg-block/variables block)
+ (lambda (var)
+ (define (map-path! path)
+ (cond ((not (pair? path)))
+ ((and (eq? (caar path) 'CC-ENTRY)
+ (symbol? (cdar path)))
+ (let ((label (map-label/fail (cdr (car path)))))
+ (if (dbg-label/external? label)
+ (set-cdr! (car path) (dbg-label/offset label))
+ (set-new-dbg-variable/path! var #F)))
+ (map-path! (cdr path)))
+ ((and (eq? (caar path) 'INTEGRATED)
+ (not (interned-symbol? (cdar path)))
+ (constant-offset-map (cdar path)))
+ => (lambda (offset)
+ (set-car! path (cons 'CONSTANT-BLOCK offset))
+ (map-path! (cdr path))))
+ (else (map-path! (cdr path)))))
+ (if (new-dbg-variable? var)
+ (map-path! (new-dbg-variable/path var))))))))
+ (for-each initialize-label label-bindings)
+ (for-each (lambda (label)
+ (set-dbg-label/external?! (map-label/fail label) true))
+ external-labels)
+ (if expression
+ (set-dbg-expression/label!
+ expression
+ (map-label/fail (dbg-expression/label expression))))
+ (for-each
+ (lambda (procedure)
+ (let* ((internal-label (new-dbg-procedure/label procedure))
+ (mapped-label (map-label/false internal-label)))
+ (set-new-dbg-procedure/label! procedure mapped-label)
+ (cond ;;((dbg-procedure/external-label procedure)
+ ;; => (lambda (label)
+ ;; (set-dbg-procedure/external-label!
+ ;; procedure
+ ;; (map-label/fail label))))
+ ((not mapped-label)
+ (error "Missing label" internal-label)))
+ (map-block (new-dbg-procedure/block procedure))))
+ procedures)
+ (for-each
+ (lambda (continuation)
+ (set-dbg-continuation/label!
+ continuation
+ (map-label/fail (dbg-continuation/label continuation)))
+ (map-block (dbg-continuation/block continuation)))
+ continuations)
(make-dbg-info
expression
- (list->vector (sort procedures dbg-procedure<?))
+ (list->vector (sort procedures new-dbg-procedure<?))
(list->vector (sort continuations dbg-continuation<?))
(list->vector (map cdr label-bindings)))))
\f
projects / mit-scheme.git / commitdiff