Improved disassembly output:
authorStephen Adams <edu/mit/csail/zurich/adams>
Fri, 10 Oct 1997 21:06:19 +0000 (21:06 +0000)
committerStephen Adams <edu/mit/csail/zurich/adams>
Fri, 10 Oct 1997 21:06:19 +0000 (21:06 +0000)
 - New comments to the right of LAP code, mostly the address of @pco
   branches so you can see where it is jumping.

 - correctly decodes the word field after a

(call (entry short-primitive-apply))

   rather than trying to disassemble the offset as instructions and
   getting out of sync with the subsequent instructions.

v7/src/compiler/machines/i386/dassm1.scm
v7/src/compiler/machines/i386/dassm2.scm

index 04023734c5ff063c49c1ba1010c03bdc66eeea0f..685ed41295ea4cdb8aa3018907397ddc84a004bb 100644 (file)
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: dassm1.scm,v 1.7 1997/07/15 16:05:24 adams Exp $
+$Id: dassm1.scm,v 1.8 1997/10/10 21:06:06 adams Exp $
 
-Copyright (c) 1992-1993 Massachusetts Institute of Technology
+Copyright (c) 1992-1997 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -131,17 +131,27 @@ MIT in each case. |#
 (define (disassembler/write-instruction-stream symbol-table instruction-stream)
   (fluid-let ((*unparser-radix* 16))
     (disassembler/for-each-instruction instruction-stream
-      (lambda (offset instruction)
-       (disassembler/write-instruction symbol-table
-                                       offset
-                                       (lambda () (display instruction)))))))
+      (lambda (offset instruction comment)
+       (disassembler/write-instruction
+        symbol-table
+        offset
+        (lambda ()
+          (if comment
+              (let ((s (with-output-to-string
+                         (lambda () (display instruction)))))
+                (if (< (string-length s) 40)
+                    (write-string (string-pad-right s 40))
+                    (write-string s))
+                (write-string "; ")
+                (display comment))
+              (write instruction))))))))
 
 (define (disassembler/for-each-instruction instruction-stream procedure)
   (let loop ((instruction-stream instruction-stream))
     (if (not (disassembler/instructions/null? instruction-stream))
        (disassembler/instructions/read instruction-stream
-         (lambda (offset instruction instruction-stream)
-           (procedure offset instruction)
+         (lambda (offset instruction comment instruction-stream)
+           (procedure offset instruction comment)
            (loop (instruction-stream)))))))
 \f
 (define (disassembler/write-constants-block block symbol-table)
index c4f51b49b4236a9aee297445e0d4157ea6c2034e..f58268227c942b89ff85cd9af2490992bae84fe3 100644 (file)
@@ -1,9 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/dassm2.scm,v 1.7 1992/08/19 03:18:54 jinx Exp $
-$MC68020-Header: /scheme/compiler/bobcat/RCS/dassm2.scm,v 4.18 1991/05/07 13:46:04 jinx Exp $
+$Id: dassm2.scm,v 1.8 1997/10/10 21:06:19 adams Exp $
 
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-1997 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -68,9 +67,10 @@ MIT in each case. |#
     (if (and end-offset (< offset end-offset))
        (disassemble-one-instruction
         block offset symbol-table state
-        (lambda (offset* instruction state)
+        (lambda (offset* instruction comment state)
           (make-instruction offset
                             instruction
+                            comment
                             (lambda () (loop offset* state)))))
        '())))
 
@@ -80,11 +80,13 @@ MIT in each case. |#
 (define (disassembler/instructions/read instruction-stream receiver)
   (receiver (instruction-offset instruction-stream)
            (instruction-instruction instruction-stream)
+           (instruction-comment instruction-stream)
            (instruction-next instruction-stream)))
 
 (define-structure (instruction (type vector))
   (offset false read-only true)
   (instruction false read-only true)
+  (comment false read-only true)
   (next false read-only true))
 
 (define *block)
@@ -107,21 +109,31 @@ MIT in each case. |#
                         (if label
                             `(BLOCK-OFFSET ,label)
                             `(WORD U ,word))
+                        #F
                         'INSTRUCTION)))
            ((external-label-marker? symbol-table offset state)
             (let ((word (next-unsigned-16-bit-word)))
               (receiver *current-offset
                         `(WORD U ,word)
+                        'ENTRY
                         'EXTERNAL-LABEL-OFFSET)))
+           ((eq? state 'PRIMITIVE-LONG-OFFSET)
+            (let ((offset (next-unsigned-32-bit-word)))
+              (receiver *current-offset
+                        `(LONG U ,offset)
+                        (+ offset *current-offset -4)
+                        'EXTERNAL-LABEL)))
            (else
             (let ((instruction (disassemble-next-instruction)))
               (if (or *valid? (not (eq? 'BYTE (car instruction))))
                   (receiver *current-offset
                             instruction
+                            (disassembler/guess-comment instruction state)
                             (disassembler/next-state instruction state))
                   (let ((inst `(BYTE U ,(caddr instruction))))
                     (receiver (1+ start-offset)
                               inst
+                              #F
                               (disassembler/next-state inst state))))))))))
 \f
 (define (disassembler/initial-state)
@@ -129,18 +141,33 @@ MIT in each case. |#
 
 (define (disassembler/next-state instruction state)
   state                                        ; ignored
-  (if (and disassembler/compiled-code-heuristics?
-          (or (memq (car instruction) '(JMP RET))
-              (and (eq? (car instruction) 'CALL)
-                   (let ((operand (cadr instruction)))
-                     (or (and (pair? operand)
-                              (eq? (car operand) 'ENTRY))
-                         (let ((entry
-                                (interpreter-register? operand)))
-                           (and entry
-                                (eq? (car entry) 'ENTRY))))))))
-      'EXTERNAL-LABEL
-      'INSTRUCTION))
+  (cond ((equal? instruction '(CALL (ENTRY SHORT-PRIMITIVE-APPLY)))
+        'PRIMITIVE-LONG-OFFSET)
+       ((and disassembler/compiled-code-heuristics?
+             (or (memq (car instruction) '(JMP RET))
+                 (and (eq? (car instruction) 'CALL)
+                      (let ((operand (cadr instruction)))
+                        (or (and (pair? operand)
+                                 (eq? (car operand) 'ENTRY))
+                            (let ((entry
+                                   (interpreter-register? operand)))
+                              (and entry
+                                   (eq? (car entry) 'ENTRY))))))))
+        'EXTERNAL-LABEL)
+       (else
+        'INSTRUCTION)))
+
+(define (disassembler/guess-comment instruction state)
+  state ; ignored
+  (let loop ((insn instruction))
+    (and (pair? insn)
+        (if (and (eq? (car insn) '@PCO)
+                 (pair? (cdr insn))
+                 (exact-integer? (cadr insn))
+                 (not (zero? (cadr insn))))
+            (+ (cadr insn) *current-offset)
+            (or (loop (car insn))
+                (loop (cdr insn)))))))
 
 (define (disassembler/lookup-symbol symbol-table offset)
   (and symbol-table