From aba10969386f26e0c7aaf9ed8c954ff8d3755642 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Fri, 4 Nov 1988 02:26:07 +0000 Subject: [PATCH] Rename disassembler/write-compiled-entry to compiler:disassemble, export it to the global package, and add some cleverness about printing linkage sections. --- v7/src/compiler/machines/bobcat/compiler.pkg | 5 +- v7/src/compiler/machines/bobcat/dassm1.scm | 114 +++++++++++++++++-- v7/src/compiler/machines/bobcat/dassm2.scm | 78 ++++++++++++- 3 files changed, 179 insertions(+), 18 deletions(-) diff --git a/v7/src/compiler/machines/bobcat/compiler.pkg b/v7/src/compiler/machines/bobcat/compiler.pkg index 501a24391..c2325f3db 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.8 1988/11/01 04:43:57 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.9 1988/11/04 02:26:07 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -337,6 +337,7 @@ MIT in each case. |# "machines/bobcat/dassm3") (parent (compiler)) (export () - compiler:write-lap-file) + compiler:write-lap-file + compiler:disassemble) (import (runtime compiler-info) compiler-entries-tag)) \ 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 cf1384926..99b8c5ca2 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.7 1988/07/16 21:47:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.8 1988/11/04 02:24:12 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -82,7 +82,7 @@ MIT in each case. |# (define disassembler/base-address) -(define (disassembler/write-compiled-entry entry) +(define (compiler:disassemble entry) (define (do-it the-block) (compiler-info/with-on-demand-loading ;force compiler info loading (lambda () @@ -110,6 +110,10 @@ MIT in each case. |# (define disassembler/instructions/null?) (define disassembler/instructions/read) (define disassembler/lookup-symbol) +(define disassembler/read-variable-cache) +(define disassembler/read-procedure-cache) +(define compiled-code-block/objects-per-procedure-cache) +(define compiled-code-block/objects-per-variable-cache) (define (write-block block) (write-string "#[COMPILED-CODE-BLOCK ") @@ -173,16 +177,22 @@ MIT in each case. |# (fluid-let ((*unparser-radix* 16)) (let ((end (system-vector-length block))) (let loop ((index (compiled-code-block/constants-start block))) - (if (< index end) - (begin - (disassembler/write-instruction - symbol-table - (compiled-code-block/index->offset index) - (lambda () - (write-constant block - symbol-table - (system-vector-ref block index)))) - (loop (1+ index)))))))) + (cond ((not (< index end)) 'DONE) + ((object-type? + (let-syntax ((ucode-type + (macro (name) (microcode-type name)))) + (ucode-type linkage-section)) + (system-vector-ref block index)) + (loop (disassembler/write-linkage-section block symbol-table index))) + (else + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-constant block + symbol-table + (system-vector-ref block index)))) + (loop (1+ index)))))))) (define (write-constant block symbol-table constant) (write-string (cdr (write-to-string constant 60))) @@ -207,6 +217,86 @@ MIT in each case. |# (write-string ")")) (else false))) +(define (disassembler/write-linkage-section block symbol-table index) + (define (write-caches index size how-many writer) + (let loop ((index index) (how-many how-many)) + (if (zero? how-many) + 'DONE + (begin + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (writer block index))) + (loop (+ size index) (-1+ how-many)))))) + + (let* ((field (object-datum (system-vector-ref block index))) + (descriptor (integer-divide field #x10000))) + (let ((kind (integer-divide-quotient descriptor)) + (length (integer-divide-remainder descriptor))) + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-string "#[LINKAGE-SECTION ") + (write field) + (write-string "]"))) + (case kind + ((0) + (write-caches (1+ index) + compiled-code-block/objects-per-procedure-cache + (quotient length compiled-code-block/objects-per-procedure-cache) + disassembler/write-procedure-cache)) + ((1) + (write-caches (1+ index) + compiled-code-block/objects-per-variable-cache + (quotient length compiled-code-block/objects-per-variable-cache) + (lambda (block index) + (disassembler/write-variable-cache + "Reference" + block + index)))) + ((2) + (write-caches (1+ index) + compiler/variable-cache-size + (quotient length compiler/variable-cache-size) + (lambda (block index) + (disassembler/write-variable-cache + "Assignment" + block + index)))) + (else + (error "disassembler/write-linkage-section: Unknown section kind" + kind))) + (1+ (+ index length))))) + +(define (variable-cache-name cache) + (let-syntax ((ucode-primitive + (macro (name arity) + (make-primitive-procedure name arity)))) + ((ucode-primitive primitive-object-ref 2) + cache + 1))) + +(define (disassembler/write-variable-cache kind block index) + (write-string kind) + (write-string " cache to ") + (write (variable-cache-name (disassembler/read-variable-cache block index)))) + +(define (disassembler/write-procedure-cache block index) + (let ((result (disassembler/read-procedure-cache block index))) + (write (vector-ref result 2)) + (write-string " argument procedure cache to ") + (case (vector-ref result 0) + ((COMPILED INTERPRETED) + (write (vector-ref result 1))) + ((VARIABLE) + (write-string "variable ") + (write (vector-ref result 1))) + (else + (error "disassembler/write-procedure-cache: Unknown cache kind" + (vector-ref result 0)))))) + (define (disassembler/write-instruction symbol-table offset write-instruction) (if symbol-table (sorted-vector/for-each symbol-table offset diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm index 5d3c70db4..8e8654c2d 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.8 1988/11/01 04:56:26 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.9 1988/11/04 02:24:53 jinx Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -37,7 +37,60 @@ MIT in each case. |# (declare (usual-integrations)) (set! compiled-code-block/bytes-per-object 4) - +(set! compiled-code-block/objects-per-procedure-cache 2) +(set! compiled-code-block/objects-per-variable-cache 1) + +(set! disassembler/read-variable-cache + (lambda (block index) + (let-syntax ((ucode-type + (macro (name) (microcode-type name))) + (ucode-primitive + (macro (name arity) + (make-primitive-procedure name arity)))) + ((ucode-primitive primitive-object-set-type 2) + (ucode-type quad) + (system-vector-ref block index))))) + +(set! disassembler/read-procedure-cache + (lambda (block index) + (fluid-let ((*block block)) + (let* ((offset (compiled-code-block/index->offset index))) + (let ((opcode (read-unsigned-integer offset 16)) + (arity (read-unsigned-integer (+ offset 6) 16))) + (case opcode + ((#x4ef9) ; JMP .L + (vector 'COMPILED + (read-procedure (+ offset 2)) + arity)) + ((#x4eb9) ; JSR .L + (let* ((new-block + (compiled-code-address->block + (read-procedure (+ offset 2)))) + (offset + (fluid-let ((*block new-block)) + (read-unsigned-integer 14 16)))) + (case offset + ((#xf6) ; lookup + (vector 'VARIABLE + (variable-cache-name + (system-vector-ref new-block 3)) + arity)) + ((#xfc) ; interpreted + (vector 'INTERPRETED + (system-vector-ref new-block 3) + arity)) + ((#x102) ; arity + (vector 'COMPILED + (system-vector-ref new-block 3) + arity)) + (else + (error + "disassembler/read-procedure-cache: Unknown offset" + offset block index))))) + (else + (error "disassembler/read-procedure-cache: Unknown opcode" + opcode block index)))))))) + (set! disassembler/instructions (lambda (block start-offset end-offset symbol-table) (let loop ((offset start-offset) (state (disassembler/initial-state))) @@ -140,12 +193,29 @@ MIT in each case. |# (define (make-dc wl bit-string) `(DC ,wl ,(bit-string->unsigned-integer bit-string))) +(define (read-procedure offset) + (with-absolutely-no-interrupts + (lambda () + (let-syntax ((ucode-type + (macro (name) (microcode-type name))) + (ucode-primitive + (macro (name arity) + (make-primitive-procedure name arity)))) + ((ucode-primitive primitive-object-set-type 2) + (ucode-type compiled-entry) + ((ucode-primitive make-non-pointer-object 1) + (read-unsigned-integer offset 32))))))) + +(define (read-unsigned-integer offset size) + (bit-string->unsigned-integer (read-bits offset size))) + (define (read-bits offset size-in-bits) - (let ((word (bit-string-allocate size-in-bits))) + (let ((word (bit-string-allocate size-in-bits)) + (bit-offset (* offset addressing-granularity))) (with-absolutely-no-interrupts (lambda () (if *block - (read-bits! *block (* offset addressing-granularity) word) + (read-bits! *block bit-offset word) (read-bits! offset 0 word)))) word)) -- 2.25.1