home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / machines / spectrum / dassm1.scm < prev    next >
Text File  |  1999-01-02  |  9KB  |  276 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: dassm1.scm,v 4.19 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Disassembler: User Level
  23. ;;; package: (compiler disassembler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;; Flags that control disassembler behavior
  28.  
  29. (define disassembler/symbolize-output? true)
  30. (define disassembler/compiled-code-heuristics? true)
  31. (define disassembler/write-offsets? true)
  32. (define disassembler/write-addresses? false)
  33.  
  34. ;;;; Top level entries
  35.  
  36. (define (compiler:write-lap-file filename #!optional symbol-table?)
  37.   (let ((pathname (->pathname filename))
  38.     (symbol-table?
  39.      (if (default-object? symbol-table?) true symbol-table?)))
  40.     (with-output-to-file (pathname-new-type pathname "lap")
  41.       (lambda ()
  42.     (let ((com-file (pathname-new-type pathname "com")))
  43.       (let ((object (fasload com-file)))
  44.         (if (compiled-code-address? object)
  45.         (let ((block (compiled-code-address->block object)))
  46.           (disassembler/write-compiled-code-block
  47.            block
  48.            (compiled-code-block/dbg-info block symbol-table?)))
  49.         (begin
  50.           (if (not
  51.                (and (scode/comment? object)
  52.                 (dbg-info-vector? (scode/comment-text object))))
  53.               (error "Not a compiled file" com-file))
  54.           (let ((blocks
  55.              (vector->list
  56.               (dbg-info-vector/blocks-vector
  57.                (scode/comment-text object)))))
  58.             (if (not (null? blocks))
  59.             (do ((blocks blocks (cdr blocks)))
  60.                 ((null? blocks) unspecific)
  61.               (disassembler/write-compiled-code-block
  62.                (car blocks)
  63.                (compiled-code-block/dbg-info (car blocks)
  64.                              symbol-table?))
  65.               (if (not (null? (cdr blocks)))
  66.                   (begin
  67.                 (write-char #\page)
  68.                 (newline))))))))))))))
  69.  
  70. (define disassembler/base-address)
  71.  
  72. (define (compiler:disassemble entry)
  73.   (let ((block (compiled-entry/block entry)))
  74.     (let ((info (compiled-code-block/dbg-info block true)))
  75.       (fluid-let ((disassembler/write-offsets? true)
  76.           (disassembler/write-addresses? true)
  77.           (disassembler/base-address (object-datum block)))
  78.     (newline)
  79.     (newline)
  80.     (disassembler/write-compiled-code-block block info)))))
  81.  
  82. (define (disassembler/write-compiled-code-block block info)
  83.   (let ((symbol-table (and info (dbg-info/labels info))))
  84.     (write-string "Disassembly of ")
  85.     (write block)
  86.     (let loop ((info (compiled-code-block/debugging-info block)))
  87.       (cond ((string? info)
  88.          (write-string " (")
  89.          (write-string info)
  90.          (write-string ")"))
  91.         ((not (pair? info)))
  92.         ((vector? (car info))
  93.          (loop (cdr info)))
  94.         (else
  95.            (write-string " (Block ")
  96.            (write (cdr info))
  97.            (write-string " in ")
  98.            (write-string (car info))
  99.            (write-string ")"))))
  100.     (write-string ":\n")
  101.     (write-string "Code:\n\n")
  102.     (disassembler/write-instruction-stream
  103.      symbol-table
  104.      (disassembler/instructions/compiled-code-block block symbol-table))
  105.     (write-string "\nConstants:\n\n")
  106.     (disassembler/write-constants-block block symbol-table)
  107.     (newline)))
  108.  
  109. (define (disassembler/instructions/compiled-code-block block symbol-table)
  110.   (disassembler/instructions block
  111.                  (compiled-code-block/code-start block)
  112.                  (compiled-code-block/code-end block)
  113.                  symbol-table))
  114.  
  115. (define (disassembler/instructions/address start-address end-address)
  116.   (disassembler/instructions false start-address end-address false))
  117.  
  118. (define (disassembler/write-instruction-stream symbol-table instruction-stream)
  119.   (fluid-let ((*unparser-radix* 16))
  120.     (disassembler/for-each-instruction instruction-stream
  121.       (lambda (offset instruction)
  122.     (disassembler/write-instruction symbol-table
  123.                     offset
  124.                     (lambda () (display instruction)))))))
  125.  
  126. (define (disassembler/for-each-instruction instruction-stream procedure)
  127.   (let loop ((instruction-stream instruction-stream))
  128.     (if (not (disassembler/instructions/null? instruction-stream))
  129.     (disassembler/instructions/read instruction-stream
  130.       (lambda (offset instruction instruction-stream)
  131.         (procedure offset instruction)
  132.         (loop (instruction-stream)))))))
  133.  
  134. (define (disassembler/write-constants-block block symbol-table)
  135.   (fluid-let ((*unparser-radix* 16))
  136.     (let ((end (system-vector-length block)))
  137.       (let loop ((index (compiled-code-block/constants-start block)))
  138.     (cond ((not (< index end)) 'DONE)
  139.           ((object-type?
  140.         (let-syntax ((ucode-type
  141.                   (macro (name) (microcode-type name))))
  142.           (ucode-type linkage-section))
  143.         (system-vector-ref block index))
  144.            (loop (disassembler/write-linkage-section block
  145.                              symbol-table
  146.                              index)))
  147.           (else
  148.            (disassembler/write-instruction
  149.         symbol-table
  150.         (compiled-code-block/index->offset index)
  151.         (lambda ()
  152.           (write-constant block
  153.                   symbol-table
  154.                   (system-vector-ref block index))))
  155.            (loop (1+ index))))))))
  156.  
  157. (define (write-constant block symbol-table constant)
  158.   (write-string (cdr (write-to-string constant 60)))
  159.   (cond ((lambda? constant)
  160.      (let ((expression (lambda-body constant)))
  161.        (if (and (compiled-code-address? expression)
  162.             (eq? (compiled-code-address->block expression) block))
  163.            (begin
  164.          (write-string "  (")
  165.          (let ((offset (compiled-code-address->offset expression)))
  166.            (let ((label
  167.               (disassembler/lookup-symbol symbol-table offset)))
  168.              (if label
  169.              (write-string label)
  170.              (write offset))))
  171.          (write-string ")")))))
  172.     ((compiled-code-address? constant)
  173.      (write-string "  (offset ")
  174.      (write (compiled-code-address->offset constant))
  175.      (write-string " in ")
  176.      (write (compiled-code-address->block constant))
  177.      (write-string ")"))
  178.     (else false)))
  179.  
  180. (define (disassembler/write-linkage-section block symbol-table index)
  181.   (let* ((field (object-datum (system-vector-ref block index)))
  182.      (descriptor (integer-divide field #x10000)))
  183.     (let ((kind (integer-divide-quotient descriptor))
  184.       (length (integer-divide-remainder descriptor)))
  185.  
  186.       (define (write-caches offset size writer)
  187.     (let loop ((index (1+ (+ offset index)))
  188.            (how-many (quotient (- length offset) size)))
  189.       (if (zero? how-many)
  190.           'DONE
  191.           (begin
  192.         (disassembler/write-instruction
  193.          symbol-table
  194.          (compiled-code-block/index->offset index)
  195.          (lambda ()
  196.            (writer block index)))
  197.         (loop (+ size index) (-1+ how-many))))))
  198.  
  199.       (disassembler/write-instruction
  200.        symbol-table
  201.        (compiled-code-block/index->offset index)
  202.        (lambda ()
  203.      (write-string "#[LINKAGE-SECTION ")
  204.      (write field)
  205.      (write-string "]")))
  206.        (case kind
  207.      ((0 3)
  208.       (write-caches
  209.        compiled-code-block/procedure-cache-offset
  210.        compiled-code-block/objects-per-procedure-cache
  211.        disassembler/write-procedure-cache))
  212.      ((1)
  213.       (write-caches
  214.        0
  215.        compiled-code-block/objects-per-variable-cache
  216.       (lambda (block index)
  217.         (disassembler/write-variable-cache "Reference" block index))))
  218.      ((2)
  219.       (write-caches
  220.        0
  221.        compiled-code-block/objects-per-variable-cache
  222.       (lambda (block index)
  223.         (disassembler/write-variable-cache "Assignment" block index))))
  224.      (else
  225.       (error "disassembler/write-linkage-section: Unknown section kind"
  226.          kind)))
  227.       (1+ (+ index length)))))
  228.  
  229. (define-integrable (variable-cache-name cache)
  230.   ((ucode-primitive primitive-object-ref 2) cache 1))
  231.  
  232. (define (disassembler/write-variable-cache kind block index)
  233.   (write-string kind)
  234.   (write-string " cache to ")
  235.   (write (variable-cache-name (disassembler/read-variable-cache block index))))
  236.  
  237. (define (disassembler/write-procedure-cache block index)
  238.   (let ((result (disassembler/read-procedure-cache block index)))
  239.     (write (vector-ref result 2))
  240.     (write-string " argument procedure cache to ")
  241.     (case (vector-ref result 0)
  242.       ((COMPILED INTERPRETED)
  243.        (write (vector-ref result 1)))
  244.       ((VARIABLE)
  245.        (write-string "variable ")
  246.        (write (vector-ref result 1)))
  247.       (else
  248.        (error "disassembler/write-procedure-cache: Unknown cache kind"
  249.           (vector-ref result 0))))))
  250.  
  251. (define (disassembler/write-instruction symbol-table offset write-instruction)
  252.   (if symbol-table
  253.       (let ((label (dbg-labels/find-offset symbol-table offset)))
  254.     (if label
  255.         (begin
  256.           (write-char #\Tab)
  257.           (write-string (dbg-label/name label))
  258.           (write-char #\:)
  259.           (newline)))))
  260.  
  261.   (if disassembler/write-addresses?
  262.       (begin
  263.     (write-string
  264.      (number->string (+ offset disassembler/base-address) 16))
  265.     (write-char #\Tab)))
  266.   
  267.   (if disassembler/write-offsets?
  268.       (begin
  269.     (write-string (number->string offset 16))
  270.     (write-char #\Tab)))
  271.  
  272.   (if symbol-table
  273.       (write-string "    "))
  274.   (write-instruction)
  275.   (newline))
  276.