From: Chris Hanson Date: Fri, 30 Dec 1988 07:05:28 +0000 (+0000) Subject: Flesh out debugging information. This goes along with changes X-Git-Tag: 20090517-FFI~12313 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=51dba257c435d89927a1ef91cef624fddde24e29;p=mit-scheme.git Flesh out debugging information. This goes along with changes introduced in runtime system version 14.31. --- diff --git a/v7/src/compiler/base/infnew.scm b/v7/src/compiler/base/infnew.scm index 665d0d8a9..e0c4afe57 100644 --- a/v7/src/compiler/base/infnew.scm +++ b/v7/src/compiler/base/infnew.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.2 1988/04/15 02:08:43 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/infnew.scm,v 4.3 1988/12/30 07:02:35 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -32,48 +32,287 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Debugging information output. +;;;; Debugging Information (declare (usual-integrations)) -(define (generation-phase2 label-bindings external-labels) - (make-compiler-info - '() - '() - (list->vector - (sort (map (lambda (association) - (make-label-info - (symbol->string (car association)) - (cdr association) - (let loop ((external-labels external-labels)) - (cond ((null? external-labels) false) - ((eq? (car association) (car external-labels)) true) - (else (loop (cdr external-labels))))))) - label-bindings) - (lambda (x y) - (< (label-info-offset x) (label-info-offset y))))))) - -(define (generate-vector top-level selector others) - (let* ((last (length others)) - (v (make-vector (1+ last) '()))) - (vector-set! v 0 top-level) - (let loop ((l others)) - (if (null? l) - v - (let ((desc (car l))) - (vector-set! v (car desc) (selector desc)) - (loop (cdr l))))))) - -(define (generate-top-level-info top-level others) - (if (null? others) - top-level - (generate-vector top-level cadr others))) - -(define (generate-top-level-object top-level others) - (if (null? others) - top-level - (scode/make-comment - (list compiler-entries-tag - (generate-vector (compiled-code-address->block top-level) - caddr others)) - top-level))) \ No newline at end of file +(define (info-generation-phase-1 expression procedures) + (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)))) + (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) + (symbol->string (procedure-name procedure)) + (map variable->dbg-name + (cdr (procedure-required procedure))) + (map variable->dbg-name (procedure-optional procedure)) + (let ((rest (procedure-rest procedure))) + (and rest (variable->dbg-name rest))) + (map variable->dbg-name (procedure-names procedure))))) + (set-dbg-block/procedure! block procedure) + procedure))))) + procedures)) + +(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-name 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) + 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 + (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))) + +(define (closure-block->dbg-block block) + (let ((parent (block-parent block)) + (offsets + (map (lambda (offset) + (cons (car offset) + (- (cdr offset) closure-block-first-offset))) + (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-name (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) layout false)))) + +(define (ic-block->dbg-block block) + (make-dbg-block 'IC (block->dbg-block (block-parent block)) 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-integrable (variable->dbg-name variable) + (symbol->dbg-name (variable-name variable))) + +(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)))) + (set-dbg-block/procedure! block continuation) + continuation))) + +(define (info-generation-phase-2 expression procedures continuations) + (let ((debug-info + (lambda (selector object) + (or (selector object) + (error "Missing debugging info" object))))) + (values + (debug-info rtl-expr/debugging-info expression) + (map (lambda (procedure) + (let ((info (debug-info rtl-procedure/debugging-info procedure))) + (set-dbg-procedure/external-label! + info + (rtl-procedure/%external-label procedure)) + info)) + procedures) + (map (lambda (continuation) + (debug-info rtl-continuation/debugging-info continuation)) + continuations)))) + +(define (info-generation-phase-3 expression procedures continuations + label-bindings external-labels) + (let ((dbg-labels (labels->dbg-labels label-bindings))) + (let ((labels (make-btree))) + (for-each (lambda (dbg-label) + (for-each (lambda (name) + (btree-insert! labels stringvector (sort procedures dbg-procedurevector (sort continuations dbg-continuationvector dbg-labels)))) + +(define (labels->dbg-labels label-bindings) + (let ((dbg-labels + (let ((labels (make-btree))) + (for-each + (lambda (binding) + (let ((name (system-pair-car (car binding)))) + (btree-insert! labels < dbg-label/offset (cdr binding) + (lambda (offset) + (make-dbg-label name offset)) + (lambda (dbg-label) + (set-dbg-label/names! + dbg-label + (cons name (dbg-label/names dbg-label)))) + (lambda (dbg-label) + dbg-label + unspecific)))) + label-bindings) + (btree-fringe labels)))) + (for-each (lambda (dbg-label) + (set-dbg-label/name! + dbg-label + (choose-distinguished-label (dbg-label/names dbg-label)))) + dbg-labels) + dbg-labels)) + +(define (choose-distinguished-label names) + (if (null? (cdr names)) + (car names) + (let ((distinguished + (list-transform-negative names + (lambda (name) + (or (standard-name? name "label") + (standard-name? name "end-label")))))) + (cond ((null? distinguished) + (min-suffix names)) + ((null? (cdr distinguished)) + (car distinguished)) + (else + (min-suffix distinguished)))))) + +(define (min-suffix names) + (let ((suffix-number + (lambda (name) + (let ((index (string-find-previous-char name #\-))) + (if (not index) + (error "Illegal label name" name)) + (let ((suffix (string-tail name (1+ index)))) + (let ((result (string->number suffix))) + (if (not result) + (error "Illegal label suffix" suffix)) + result)))))) + (car (sort names (lambda (x y) (< (suffix-number x) (suffix-number y))))))) + +(define (standard-name? string prefix) + (let ((index (string-match-forward-ci string prefix)) + (end (string-length string))) + (and (= index (string-length prefix)) + (>= (- end index) 2) + (char=? #\- (string-ref string index)) + (let loop ((index (1+ index))) + (or (= index end) + (and (char-numeric? (string-ref string index)) + (loop (1+ index)))))))) \ No newline at end of file diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index 755abdee8..9a70de92f 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.13 1988/12/13 13:02:39 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.14 1988/12/30 07:02:55 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -56,6 +56,9 @@ MIT in each case. |# (define *rtl-continuations*) (define *rtl-graphs*) (define label->object) +(define *dbg-expression*) +(define *dbg-procedures*) +(define *dbg-continuations*) ;;; These variable names mistakenly use the format "compiler:..." ;;; instead of the correct format, which is "*...*". Fix it sometime. @@ -87,7 +90,6 @@ MIT in each case. |# (set! *lvalues*) (set! *applications*) (set! *parallels*) - ;; (set! *assignments*) (set! *ic-procedure-headers*) (set! *root-expression*) (set! *root-block*) @@ -96,6 +98,9 @@ MIT in each case. |# (set! *rtl-continuations*) (set! *rtl-graphs*) (set! label->object) + (set! *dbg-expression*) + (set! *dbg-procedures*) + (set! *dbg-continuations*) (set! *machine-register-map*) (set! compiler:external-labels) (set! compiler:label-bindings) @@ -117,7 +122,6 @@ MIT in each case. |# (*lvalues*) (*applications*) (*parallels*) - ;; (*assignments*) (*ic-procedure-headers*) (*root-expression*) (*root-block*)) @@ -126,6 +130,9 @@ MIT in each case. |# (*rtl-continuations*) (*rtl-graphs*) (label->object) + (*dbg-expression*) + (*dbg-procedures*) + (*dbg-continuations*) (*machine-register-map*) (compiler:external-labels) (compiler:label-bindings) @@ -141,15 +148,27 @@ MIT in each case. |# (fluid-let ((compiler:process-time 0) (compiler:real-time 0)) (compiler:reset!) - (let* ((topl (thunk)) - (value - (generate-top-level-object topl *recursive-compilation-results*))) + (let ((value + (let ((expression (thunk))) + (let ((others (recursive-compilation-results))) + (if (null? others) + expression + (scode/make-comment + (make-dbg-info-vector + (list->vector + (cons (compiled-code-address->block expression) + (map (lambda (other) (vector-ref other 2)) + others)))) + expression)))))) (if (not compiler:preserve-data-structures?) (compiler:reset!)) (compiler-time-report "Total compilation time" compiler:process-time compiler:real-time) value))) + +(define (recursive-compilation-results) + (sort *recursive-compilation-results* (lambda (x y) (< (car x) (car y))))) ;;;; The file compiler, its usual mode. @@ -380,9 +399,12 @@ MIT in each case. |# (write-string " (real time)")) (define-macro (last-reference name) - `(IF COMPILER:PRESERVE-DATA-STRUCTURES? - ,name - (SET! ,name))) + (let ((x (generate-uninterned-symbol))) + `(IF COMPILER:PRESERVE-DATA-STRUCTURES? + ,name + (LET ((,x ,name)) + (SET! ,name) + ,x)))) (define (phase/fg-generation) (compiler-superphase "Flow Graph Generation" @@ -406,14 +428,13 @@ MIT in each case. |# (set! *lvalues* '()) (set! *applications* '()) (set! *parallels* '()) - ;; (set! *assignments* '()) (set! *root-expression* (construct-graph (last-reference *scode*))) (set! *root-block* (expression-block *root-expression*)) (if (or (null? *expressions*) (not (null? (cdr *expressions*)))) (error "Multiple expressions")) (set! *expressions*)))) - + (define (phase/fg-optimization) (compiler-superphase "Flow Graph Optimization" (lambda () @@ -433,6 +454,7 @@ MIT in each case. |# (phase/subproblem-ordering) (phase/connectivity-analysis) (phase/compute-node-offsets) + (phase/info-generation-1) (phase/fg-optimization-cleanup)))) (define (phase/simulate-application) @@ -462,8 +484,8 @@ MIT in each case. |# (define (phase/environment-optimization) (compiler-subphase "Environment Optimization" - (lambda () - (optimize-environments! *procedures*)))) + (lambda () + (optimize-environments! *procedures*)))) (define (phase/identify-closure-limits) (compiler-subphase "Closure Limit Identification" @@ -477,16 +499,14 @@ MIT in each case. |# (setup-closure-contexts! *root-expression* *procedures*)))) (define (phase/compute-call-graph) - (compiler-subphase - "Call Graph Computation" - (lambda () - (compute-call-graph! *procedures*)))) + (compiler-subphase "Call Graph Computation" + (lambda () + (compute-call-graph! *procedures*)))) (define (phase/side-effect-analysis) - (compiler-subphase - "Side Effect Analysis" - (lambda () - (side-effect-analysis *procedures* *applications*)))) + (compiler-subphase "Side Effect Analysis" + (lambda () + (side-effect-analysis *procedures* *applications*)))) (define (phase/continuation-analysis) (compiler-subphase "Continuation Analysis" @@ -524,6 +544,11 @@ MIT in each case. |# (lambda () (compute-node-offsets *root-expression*)))) +(define (phase/info-generation-1) + (compiler-subphase "Debugging Information Initialization" + (lambda () + (info-generation-phase-1 *root-expression* *procedures*)))) + (define (phase/fg-optimization-cleanup) (compiler-subphase "Flow Graph Optimization Cleanup" (lambda () @@ -535,7 +560,6 @@ MIT in each case. |# (set! *lvalues*) (set! *applications*) (set! *parallels*) - ;; (set! *assignments*) (set! *root-block*)))))) (define (phase/rtl-generation) @@ -658,6 +682,15 @@ MIT in each case. |# (linearize-bits *rtl-expression* *rtl-procedures* *rtl-continuations*))) + (with-values + (lambda () + (info-generation-phase-2 *rtl-expression* + *rtl-procedures* + *rtl-continuations*)) + (lambda (expression procedures continuations) + (set! *dbg-expression* expression) + (set! *dbg-procedures* procedures) + (set! *dbg-continuations* continuations))) (if (not compiler:preserve-data-structures?) (begin (set! label->object) (set! *rtl-expression*) @@ -668,49 +701,51 @@ MIT in each case. |# (define (phase/assemble) (compiler-phase "Assembly" (lambda () - (if compiler:preserve-data-structures? - (assemble compiler:block-label compiler:bits phase/assemble-finish) - (assemble (set! compiler:block-label) - (set! compiler:bits) - phase/assemble-finish))))) - -(define (phase/assemble-finish count code-vector labels bindings linkage-info) - linkage-info ;; ignored - (set! compiler:code-vector code-vector) - (set! compiler:entry-points labels) - (set! compiler:label-bindings bindings) - (newline) - (display " Branch tensioning done in ") - (write (1+ count)) - (if (zero? count) - (display " iteration.") - (display " iterations."))) + (assemble (last-reference compiler:block-label) + (last-reference compiler:bits) + (lambda (count code-vector labels bindings linkage-info) + linkage-info ; ignored + (set! compiler:code-vector code-vector) + (set! compiler:entry-points labels) + (set! compiler:label-bindings bindings) + (newline) + (display " Branch tensioning done in ") + (write (1+ count)) + (if (zero? count) + (display " iteration.") + (display " iterations."))))))) (define (phase/info-generation-2 pathname) (compiler-phase "Debugging Information Generation" - (lambda () - (let ((info - (generation-phase2 compiler:label-bindings - (last-reference compiler:external-labels)))) - - (if (eq? pathname true) ; recursive compilation - (begin - (set! *recursive-compilation-results* - (cons (list *recursive-compilation-number* - info - compiler:code-vector) - *recursive-compilation-results*)) - (set-compiled-code-block/debugging-info! - compiler:code-vector - (cons (pathname->string *info-output-pathname*) - *recursive-compilation-number*))) - (begin - (fasdump - (generate-top-level-info info *recursive-compilation-results*) - pathname) - (set-compiled-code-block/debugging-info! - compiler:code-vector - (pathname->string pathname)))))))) + (lambda () + (set-compiled-code-block/debugging-info! + compiler:code-vector + (let ((info + (info-generation-phase-3 + (last-reference *dbg-expression*) + (last-reference *dbg-procedures*) + (last-reference *dbg-continuations*) + compiler:label-bindings + (last-reference compiler:external-labels)))) + (if (eq? pathname true) ; recursive compilation + (begin + (set! *recursive-compilation-results* + (cons (vector *recursive-compilation-number* + info + compiler:code-vector) + *recursive-compilation-results*)) + (cons (pathname->string *info-output-pathname*) + *recursive-compilation-number*)) + (begin + (fasdump (let ((others (recursive-compilation-results))) + (if (null? others) + info + (list->vector + (cons info + (map (lambda (other) (vector-ref other 1)) + others))))) + pathname) + (pathname->string pathname)))))))) (define (phase/link) (compiler-phase "Linkification" diff --git a/v7/src/compiler/machines/bobcat/compiler.pkg b/v7/src/compiler/machines/bobcat/compiler.pkg index a2d0bbf4a..71f01eecc 100644 --- a/v7/src/compiler/machines/bobcat/compiler.pkg +++ b/v7/src/compiler/machines/bobcat/compiler.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.15 1988/12/19 20:23:55 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.16 1988/12/30 07:01:53 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -71,11 +71,6 @@ MIT in each case. |# "rtlbase/rtlobj" ;RTL: CFG objects "rtlbase/regset" ;RTL: register sets - #| - ;;; Now in runtime system (I hope) ~JRM - "base/infutl" ;utilities for info generation, shared - |# - "back/insseq" ;LAP instruction sequences ) (parent ()) @@ -113,6 +108,16 @@ MIT in each case. |# reference-context? set-reference-context/offset!)) +(define-package (compiler balanced-binary-tree) + (files "base/btree") + (parent (compiler)) + (export (compiler) + btree-delete! + btree-fringe + btree-insert! + btree-lookup + make-btree)) + (define-package (compiler macros) (files "base/macros") (parent ()) @@ -158,7 +163,9 @@ MIT in each case. |# (export (compiler debug) *root-expression* *rtl-procedures* - *rtl-graphs*)) + *rtl-graphs*) + (import (runtime compiler-info) + make-dbg-info-vector)) (define-package (compiler debug) (files "base/debug") @@ -208,7 +215,65 @@ MIT in each case. |# make-database-transformer make-symbol-transformer make-bit-mask-transformer)) - + +(define-package (compiler debugging-information) + (files "base/infnew") + (parent (compiler)) + (export (compiler top-level) + info-generation-phase-1 + info-generation-phase-2 + info-generation-phase-3) + (export (compiler rtl-generator) + generated-dbg-continuation) + (import (runtime compiler-info) + make-dbg-info + + make-dbg-expression + dbg-expression/block + dbg-expression/label + set-dbg-expression/label! + + make-dbg-procedure + dbg-procedure/block + dbg-procedure/label + set-dbg-procedure/label! + dbg-procedure/name + dbg-procedure/required + dbg-procedure/optional + dbg-procedure/rest + dbg-procedure/auxiliary + dbg-procedure/external-label + set-dbg-procedure/external-label! + dbg-proceduredbg-name + )) + (define-package (compiler fg-generator) (files "fggen/canon" ;SCode canonicalizer "fggen/fggen" ;SCode->flow-graph converter @@ -218,7 +283,7 @@ MIT in each case. |# (export (compiler top-level) canonicalize/top-level construct-graph)) - + (define-package (compiler fg-optimizer) (files "fgopt/outer" ;outer analysis "fgopt/operan" ;operator analysis @@ -255,7 +320,7 @@ MIT in each case. |# (files "fgopt/offset") (parent (compiler fg-optimizer)) (export (compiler top-level) compute-node-offsets)) - + (define-package (compiler fg-optimizer connectivity-analysis) (files "fgopt/conect") (parent (compiler fg-optimizer)) @@ -302,7 +367,6 @@ MIT in each case. |# (define-package (compiler rtl-generator) (files "rtlgen/rtlgen" ;RTL generator - "rtlgen/rgproc" ;procedure headers "rtlgen/rgstmt" ;statements "rtlgen/fndvar" ;find variables "machines/bobcat/rgspcm" ;special close-coded primitives @@ -320,19 +384,21 @@ MIT in each case. |# (import (compiler top-level) label->object)) +(define-package (compiler rtl-generator generate/procedure-header) + (files "rtlgen/rgproc") + (parent (compiler rtl-generator)) + (export (compiler rtl-generator) generate/procedure-header)) + (define-package (compiler rtl-generator combination/inline) (files "rtlgen/opncod") (parent (compiler rtl-generator)) - (export (compiler rtl-generator) - combination/inline) - (export (compiler top-level) - open-coding-analysis)) + (export (compiler rtl-generator) combination/inline) + (export (compiler top-level) open-coding-analysis)) (define-package (compiler rtl-generator find-block) (files "rtlgen/fndblk") (parent (compiler rtl-generator)) - (export (compiler rtl-generator) - find-block)) + (export (compiler rtl-generator) find-block)) (define-package (compiler rtl-generator generate/rvalue) (files "rtlgen/rgrval") @@ -389,16 +455,6 @@ MIT in each case. |# (files "rtlopt/rdeath") (parent (compiler rtl-optimizer)) (export (compiler top-level) code-compression)) - -(define-package (compiler debugging-information) - (files "base/infnew") - (parent (compiler)) - (export (compiler top-level) - generate-top-level-info - generate-top-level-object - generation-phase2) - (import (runtime compiler-info) - compiler-entries-tag)) (define-package (compiler lap-syntaxer) (files "back/lapgn1" ;LAP generator @@ -469,4 +525,9 @@ MIT in each case. |# compiler:write-lap-file compiler:disassemble) (import (runtime compiler-info) - compiler-entries-tag)) \ No newline at end of file + compiled-code-block/dbg-info + dbg-info-vector/items dbg-info-vector? + dbg-info/labels + dbg-label/external? + dbg-label/name + dbg-labels/find-offset)) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/dassm1.scm b/v7/src/compiler/machines/bobcat/dassm1.scm index 8cd01b8d3..95848b3c1 100644 --- a/v7/src/compiler/machines/bobcat/dassm1.scm +++ b/v7/src/compiler/machines/bobcat/dassm1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.9 1988/11/05 22:21:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.10 1988/12/30 07:05:04 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -68,41 +68,27 @@ MIT in each case. |# object (lambda (text expression) expression ;; ignored - (if (and (pair? text) - (eq? (car text) compiler-entries-tag) - (vector? (cadr text))) - (for-each disassembler/write-compiled-code-block - (vector->list (cadr text)) - (if (false? info) - (make-list (vector-length (cadr text)) - false) - (vector->list info))) + (if (dbg-info-vector? text) + (let ((items (dbg-info-vector/items text))) + (for-each disassembler/write-compiled-code-block + (vector->list items) + (if (false? info) + (make-list (vector-length items) false) + (vector->list info)))) (error "compiler:write-lap-file : Not a compiled file" (pathname-new-type pathname "com")))))))))))) (define disassembler/base-address) (define (compiler:disassemble entry) - (define (do-it the-block) - (compiler-info/with-on-demand-loading ;force compiler info loading - (lambda () - (compiled-code-block->compiler-info the-block - (lambda (info) - (fluid-let ((disassembler/write-offsets? true) - (disassembler/write-addresses? true) - (disassembler/base-address (object-datum the-block))) - (newline) - (newline) - (disassembler/write-compiled-code-block the-block info))) - (lambda () (error "No compiler info for entry" entry)))))) - - (compiled-entry->block-and-offset entry - (lambda (block offset) offset (do-it block)) - (lambda (manifest-block manifest-offset block offset) - manifest-block manifest-offset offset - (write-string "Writing MANIFEST-CLOSURE") - (do-it block)) - (lambda () (error "Cannot disassemble entry" entry)))) + (let ((block (compiled-entry/block entry))) + (let ((info (compiled-code-block/dbg-info block))) + (fluid-let ((disassembler/write-offsets? true) + (disassembler/write-addresses? true) + (disassembler/base-address (object-datum block))) + (newline) + (newline) + (disassembler/write-compiled-code-block block info))))) ;;; Operations exported from the disassembler package @@ -125,8 +111,7 @@ MIT in each case. |# (write-string "]")) (define (disassembler/write-compiled-code-block block info #!optional page?) - (let ((symbol-table (compiler-info/symbol-table info))) - (if (or (default-object? page?) page?) + (let ((symbol-table (dbg-info/labels info))) (if (or (default-object? page?) page?) (begin (write-char #\page) (newline))) @@ -285,12 +270,12 @@ MIT in each case. |# (define (disassembler/write-instruction symbol-table offset write-instruction) (if symbol-table - (sorted-vector/for-each symbol-table offset - (lambda (label) - (write-char #\Tab) - (write-string (string-downcase (label-info-name label))) - (write-char #\:) - (newline)))) + (let ((label (dbg-labels/find-offset symbol-table offset))) + (if label + (begin + (write-char #\Tab) + (write-string (string-downcase (dbg-label/name label))) (write-char #\:) + (newline))))) (if disassembler/write-addresses? (begin diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm index 3a79639d1..ac2f5e078 100644 --- a/v7/src/compiler/machines/bobcat/dassm2.scm +++ b/v7/src/compiler/machines/bobcat/dassm2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.11 1988/12/12 22:11:35 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.12 1988/12/30 07:05:13 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -173,15 +173,15 @@ MIT in each case. |# (set! disassembler/lookup-symbol (lambda (symbol-table offset) (and symbol-table - (let ((label (sorted-vector/find-element symbol-table offset))) + (let ((label (dbg-labels/find-offset symbol-table offset))) (and label - (label-info-name label)))))) + (dbg-label/name label)))))) (define (external-label-marker? symbol-table offset state) (if symbol-table - (sorted-vector/there-exists? symbol-table - (+ offset 4) - label-info-external?) + (let ((label (dbg-labels/find-offset symbol-table (+ offset 4)))) + (and label + (dbg-label/external? label))) (and *block (not (eq? state 'INSTRUCTION)) (let loop ((offset (+ offset 4))) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 3096db428..7b956d7f8 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.35 1988/12/19 20:56:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.36 1988/12/30 07:03:38 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -41,4 +41,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar" 4 35 '())) \ No newline at end of file +(add-system! (make-system "Liar" 4 36 '())) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm index 3ac298dc9..762f2e076 100644 --- a/v7/src/compiler/machines/bobcat/rules3.scm +++ b/v7/src/compiler/machines/bobcat/rules3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.14 1988/11/08 12:36:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.15 1988/12/30 07:05:20 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -289,16 +289,13 @@ MIT in each case. |# (+ (* #x100 min) max)) (define (make-procedure-code-word min max) - (define (coerce val) - (cond ((and (not (negative? val)) - (< val 128)) - val) - ((and (negative? val) - (> val -128)) - (+ 256 val)) - (else - (error "make-procedure-code-word: Bad value" val)))) - (make-code-word (coerce min) (coerce max))) + ;; The "min" byte must be less than #x80; the "max" byte may not + ;; equal #x80 but can take on any other value. + (if (or (negative? min) (>= min #x80)) + (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min)) + (if (>= (abs max) #x80) + (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max)) + (make-code-word min (if (negative? max) (+ #x100 max) max))) (define expression-code-word (make-code-word #xff #xff)) @@ -306,10 +303,20 @@ MIT in each case. |# (define internal-entry-code-word (make-code-word #xff #xfe)) -;; This is the same until information is encoded in them - -(define continuation-code-word - (make-code-word #x80 #x80)) +(define (continuation-code-word label) + (let ((offset + (if label + (rtl-continuation/next-continuation-offset (label->object label)) + 0))) + (cond ((not offset) + (make-code-word #xff #xfc)) + ((< offset #x2000) + ;; This uses up through (#xff #xdf). + (let ((qr (integer-divide offset #x80))) + (make-code-word (+ #x80 (integer-divide-remainder qr)) + (+ #x80 (integer-divide-quotient qr))))) + (else + (error "Unable to encode continuation offset" offset))))) ;;;; Procedure headers @@ -337,12 +344,12 @@ MIT in each case. |# (define-rule statement (CONTINUATION-ENTRY (? internal-label)) - (make-external-label continuation-code-word + (make-external-label (continuation-code-word internal-label) internal-label)) (define-rule statement (CONTINUATION-HEADER (? internal-label)) - (simple-procedure-header continuation-code-word + (simple-procedure-header (continuation-code-word internal-label) internal-label entry:compiler-interrupt-continuation)) @@ -498,7 +505,7 @@ MIT in each case. |# (if (null? assignments) 0 1)) 0) (JSR ,entry:compiler-link) - ,@(make-external-label continuation-code-word + ,@(make-external-label (continuation-code-word false) (generate-label)))))))))) ;;; Local Variables: *** diff --git a/v7/src/compiler/machines/bobcat/rules4.scm b/v7/src/compiler/machines/bobcat/rules4.scm index 75e5cd556..5d2b23e95 100644 --- a/v7/src/compiler/machines/bobcat/rules4.scm +++ b/v7/src/compiler/machines/bobcat/rules4.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.4 1988/08/29 22:56:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.5 1988/12/30 07:05:28 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -61,8 +61,7 @@ MIT in each case. |# (LAP ,@set-environment ,@clear-map ,(load-constant name (INST-EA (A 1))) - (JSR ,entry) - ,@(make-external-label continuation-code-word (generate-label)))))) + (JSR ,entry))))) (define-rule statement (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value)) @@ -82,9 +81,7 @@ MIT in each case. |# ,@set-value ,@clear-map ,(load-constant name (INST-EA (A 1))) - (JSR ,entry) - ,@(make-external-label continuation-code-word - (generate-label))))))) + (JSR ,entry)))))) (define-rule statement (INTERPRETER-CALL:DEFINE (? environment) (? name) @@ -110,9 +107,7 @@ MIT in each case. |# ,@clear-map (MOV L ,reg:temp (A 2)) ,(load-constant name (INST-EA (A 1))) - (JSR ,entry) - ,@(make-external-label continuation-code-word - (generate-label))))))) + (JSR ,entry)))))) (define-rule statement (INTERPRETER-CALL:DEFINE (? environment) (? name) @@ -136,8 +131,7 @@ MIT in each case. |# (MOV B (& ,type) (@A 7)) (MOV L (@A+ 7) (A 2)) ,(load-constant name (INST-EA (A 1))) - (JSR ,entry) - ,@(make-external-label continuation-code-word (generate-label))))) + (JSR ,entry)))) (define-rule statement (INTERPRETER-CALL:CACHE-REFERENCE (? extension) (? safe?)) @@ -147,8 +141,7 @@ MIT in each case. |# ,@clear-map (JSR ,(if safe? entry:compiler-safe-reference-trap - entry:compiler-reference-trap)) - ,@(make-external-label continuation-code-word (generate-label)))))) + entry:compiler-reference-trap)))))) (define-rule statement (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) (? value)) @@ -159,9 +152,7 @@ MIT in each case. |# (LAP ,@set-extension ,@set-value ,@clear-map - (JSR ,entry:compiler-assignment-trap) - ,@(make-external-label continuation-code-word - (generate-label))))))) + (JSR ,entry:compiler-assignment-trap)))))) (define-rule statement (INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) @@ -174,9 +165,7 @@ MIT in each case. |# (MOV B (& ,type) ,reg:temp) ,@clear-map (MOV L ,reg:temp (A 1)) - (JSR ,entry:compiler-assignment-trap) - ,@(make-external-label continuation-code-word - (generate-label))))))) + (JSR ,entry:compiler-assignment-trap)))))) (define-rule statement (INTERPRETER-CALL:CACHE-ASSIGNMENT @@ -188,8 +177,7 @@ MIT in each case. |# ,@(clear-map!) (PEA (@PCR ,(rtl-procedure/external-label (label->object label)))) (MOV B (& ,type) (@A 7)) (MOV L (@A+ 7) (A 1)) - (JSR ,entry:compiler-assignment-trap) - ,@(make-external-label continuation-code-word (generate-label))))) + (JSR ,entry:compiler-assignment-trap)))) (define-rule statement (INTERPRETER-CALL:CACHE-UNASSIGNED? (? extension)) @@ -197,5 +185,4 @@ MIT in each case. |# (let ((clear-map (clear-map!))) (LAP ,@set-extension ,@clear-map - (JSR ,entry:compiler-unassigned?-trap) - ,@(make-external-label continuation-code-word (generate-label)))))) \ No newline at end of file + (JSR ,entry:compiler-unassigned?-trap))))) \ No newline at end of file