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 / i386 / dassm2.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  340 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: dassm2.scm,v 1.9 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1992-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. ;;;; Intel i386 Disassembler: Top Level
  23. ;;; package: (compiler disassembler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (disassembler/read-variable-cache block index)
  28.   (let-syntax ((ucode-type
  29.         (macro (name) (microcode-type name)))
  30.            (ucode-primitive
  31.         (macro (name arity)
  32.           (make-primitive-procedure name arity))))
  33.     ((ucode-primitive primitive-object-set-type 2)
  34.      (ucode-type quad)
  35.      (system-vector-ref block index))))
  36.  
  37. (define (disassembler/read-procedure-cache block index)
  38.   (fluid-let ((*block block))
  39.     (let* ((offset (compiled-code-block/index->offset index)))
  40.       (let ((opcode (read-unsigned-integer (+ offset 3) 8))
  41.         (arity (read-unsigned-integer offset 16)))
  42.     (case opcode
  43.       ((#xe9)            ; (JMP (@PCR label))
  44.        ;; This should learn how to decode the new trampolines.
  45.        (vector 'COMPILED
  46.            (read-procedure (+ offset 4))
  47.            arity))
  48.       (else
  49.        (error "disassembler/read-procedure-cache: Unknown opcode"
  50.           opcode block index)))))))
  51.  
  52. (define (disassembler/instructions block start-offset end-offset symbol-table)
  53.   (let loop ((offset start-offset) (state (disassembler/initial-state)))
  54.     (if (and end-offset (< offset end-offset))
  55.     (disassemble-one-instruction
  56.      block offset symbol-table state
  57.      (lambda (offset* instruction comment state)
  58.        (make-instruction offset
  59.                  instruction
  60.                  comment
  61.                  (lambda () (loop offset* state)))))
  62.     '())))
  63.  
  64. (define-integrable (disassembler/instructions/null? obj)
  65.   (null? obj))
  66.  
  67. (define (disassembler/instructions/read instruction-stream receiver)
  68.   (receiver (instruction-offset instruction-stream)
  69.         (instruction-instruction instruction-stream)
  70.         (instruction-comment instruction-stream)
  71.         (instruction-next instruction-stream)))
  72.  
  73. (define-structure (instruction (type vector))
  74.   (offset false read-only true)
  75.   (instruction false read-only true)
  76.   (comment false read-only true)
  77.   (next false read-only true))
  78.  
  79. (define *block)
  80. (define *current-offset)
  81. (define *symbol-table)
  82. (define *valid?)
  83.  
  84. (define (disassemble-one-instruction block offset symbol-table state receiver)
  85.   (fluid-let ((*block block)
  86.           (*current-offset offset)
  87.           (*symbol-table symbol-table)
  88.           (*valid? true))
  89.     (let ((start-offset *current-offset))
  90.       ;; External label markers come in two parts:
  91.       ;; An entry type descriptor, and a gc offset.
  92.       (cond ((eq? state 'EXTERNAL-LABEL-OFFSET)
  93.          (let* ((word (next-unsigned-16-bit-word))
  94.             (label (find-label *current-offset)))
  95.            (receiver *current-offset
  96.              (if label
  97.                  `(BLOCK-OFFSET ,label)
  98.                  `(WORD U ,word))
  99.              #F
  100.              'INSTRUCTION)))
  101.         ((external-label-marker? symbol-table offset state)
  102.          (let ((word (next-unsigned-16-bit-word)))
  103.            (receiver *current-offset
  104.              `(WORD U ,word)
  105.              'ENTRY
  106.              'EXTERNAL-LABEL-OFFSET)))
  107.         ((eq? state 'PRIMITIVE-LONG-OFFSET)
  108.          (let ((offset (next-unsigned-32-bit-word)))
  109.            (receiver *current-offset
  110.              `(LONG U ,offset)
  111.              (+ offset *current-offset -4)
  112.              'EXTERNAL-LABEL)))
  113.         (else
  114.          (let ((instruction (disassemble-next-instruction)))
  115.            (if (or *valid? (not (eq? 'BYTE (car instruction))))
  116.            (receiver *current-offset
  117.                  instruction
  118.                  (disassembler/guess-comment instruction state)
  119.                  (disassembler/next-state instruction state))
  120.            (let ((inst `(BYTE U ,(caddr instruction))))
  121.              (receiver (1+ start-offset)
  122.                    inst
  123.                    #F
  124.                    (disassembler/next-state inst state))))))))))
  125.  
  126. (define (disassembler/initial-state)
  127.   'INSTRUCTION-NEXT)
  128.  
  129. (define (disassembler/next-state instruction state)
  130.   state                    ; ignored
  131.   (cond ((equal? instruction '(CALL (ENTRY SHORT-PRIMITIVE-APPLY)))
  132.      'PRIMITIVE-LONG-OFFSET)
  133.     ((and disassembler/compiled-code-heuristics?
  134.           (or (memq (car instruction) '(JMP RET))
  135.           (and (eq? (car instruction) 'CALL)
  136.                (let ((operand (cadr instruction)))
  137.              (or (and (pair? operand)
  138.                   (eq? (car operand) 'ENTRY))
  139.                  (let ((entry
  140.                     (interpreter-register? operand)))
  141.                    (and entry
  142.                     (eq? (car entry) 'ENTRY))))))))
  143.      'EXTERNAL-LABEL)
  144.     (else
  145.      'INSTRUCTION)))
  146.  
  147. (define (disassembler/guess-comment instruction state)
  148.   state ; ignored
  149.   (let loop ((insn instruction))
  150.     (and (pair? insn)
  151.      (if (and (eq? (car insn) '@PCO)
  152.           (pair? (cdr insn))
  153.           (exact-integer? (cadr insn))
  154.           (not (zero? (cadr insn))))
  155.          (+ (cadr insn) *current-offset)
  156.          (or (loop (car insn))
  157.          (loop (cdr insn)))))))
  158.  
  159. (define (disassembler/lookup-symbol symbol-table offset)
  160.   (and symbol-table
  161.        (let ((label (dbg-labels/find-offset symbol-table offset)))
  162.      (and label 
  163.           (dbg-label/name label)))))
  164.  
  165. (define (external-label-marker? symbol-table offset state)
  166.   (define-integrable (offset-word->offset word)
  167.     (fix:quotient (bit-string->unsigned-integer word) 2))
  168.  
  169.   (if symbol-table
  170.       (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
  171.     (and label
  172.          (dbg-label/external? label)))
  173.       (and *block
  174.        (not (eq? state 'INSTRUCTION))
  175.        (let loop ((offset (+ offset 4)))
  176.          (let ((contents (read-bits (- offset 2) 16)))
  177.            (if (bit-string-clear! contents 0)
  178.            (let ((offset (- offset (offset-word->offset contents))))
  179.              (and (positive? offset)
  180.               (loop offset)))
  181.            (= offset (offset-word->offset contents))))))))
  182.  
  183. (define (read-procedure offset)
  184.   (with-absolutely-no-interrupts
  185.    (lambda ()
  186.      (let-syntax ((ucode-type
  187.            (macro (name) (microcode-type name)))
  188.           (ucode-primitive
  189.            (macro (name arity)
  190.              (make-primitive-procedure name arity))))
  191.        ((ucode-primitive primitive-object-set-type 2)
  192.     (ucode-type compiled-entry)
  193.     ((ucode-primitive make-non-pointer-object 1)
  194.      (+ (read-signed-integer offset 32)
  195.         (+ (if *block
  196.            (object-datum *block)
  197.            0)
  198.            (+ offset 4)))))))))
  199.  
  200. (define (read-unsigned-integer offset size)
  201.   (bit-string->unsigned-integer (read-bits offset size)))
  202.  
  203. (define (read-signed-integer offset size)
  204.   (bit-string->signed-integer (read-bits offset size)))
  205.  
  206. (define (read-bits offset size-in-bits)
  207.   (let ((word (bit-string-allocate size-in-bits))
  208.     (bit-offset (* offset addressing-granularity)))
  209.     (with-absolutely-no-interrupts
  210.      (lambda ()
  211.        (if *block
  212.        (read-bits! *block bit-offset word)
  213.        (read-bits! offset 0 word))))
  214.     word))
  215.  
  216. (define-integrable (make-unsigned-reader nbits)
  217.   (let ((nbytes (fix:quotient nbits 8)))
  218.     (lambda ()
  219.       (let ((offset *current-offset))
  220.     (let ((word (read-bits offset nbits)))
  221.       (set! *current-offset (+ offset nbytes))
  222.       (bit-string->unsigned-integer word))))))
  223.  
  224. (define-integrable (make-signed-reader nbits)
  225.   (let ((nbytes (fix:quotient nbits 8)))
  226.     (lambda ()
  227.       (let ((offset *current-offset))
  228.     (let ((word (read-bits offset nbits)))
  229.       (set! *current-offset (+ offset nbytes))
  230.       (bit-string->signed-integer word))))))
  231.  
  232. (define next-byte (make-signed-reader 8))
  233. (define next-unsigned-byte (make-unsigned-reader 8))
  234. (define next-16-bit-word (make-signed-reader 16))
  235. (define next-unsigned-16-bit-word (make-unsigned-reader 16))
  236. (define next-32-bit-word (make-signed-reader 32))
  237. (define next-unsigned-32-bit-word (make-unsigned-reader 32))
  238.  
  239. (define (find-label offset)
  240.   (and disassembler/symbolize-output?
  241.        (disassembler/lookup-symbol *symbol-table offset)))
  242.  
  243. (define (interpreter-register? operand)
  244.   (define (regs-pointer? reg)
  245.     (if (symbol? reg)
  246.     (eq? reg 'ESI)
  247.     (= reg 6)))
  248.   
  249.   (define (offset->register offset)
  250.     (let ((place (assq offset interpreter-register-offsets)))
  251.       (and place
  252.        (cdr place))))
  253.  
  254.   (and (pair? operand)
  255.        (or (and (eq? (car operand) '@R)
  256.         (regs-pointer? (cadr operand))
  257.         (offset->register 0))
  258.        (and (eq? (car operand) '@RO)
  259.         (regs-pointer? (caddr operand))
  260.         (offset->register (cadddr operand))))))
  261.  
  262. (define interpreter-register-offsets
  263.   (letrec ((make-entries
  264.         (lambda (kind offset names)
  265.           (if (null? names)
  266.           '()
  267.           (cons (cons offset `(,kind ,(car names)))
  268.             (make-entries kind
  269.                       (+ offset 4)
  270.                       (cdr names)))))))
  271.     (append
  272.      (make-entries
  273.       'REGISTER 0
  274.       '(memtop
  275.     stack-guard
  276.     val
  277.     env
  278.     compiler-temp
  279.     expr
  280.     return-code
  281.     lexpr-actuals
  282.     primitive
  283.     closure-free
  284.     closure-space))
  285.  
  286.      (make-entries
  287.       'ENTRY #x40            ; 16 * 4
  288.       '(scheme-to-interface
  289.     scheme-to-interface/call
  290.     trampoline-to-interface
  291.     interrupt-procedure
  292.     interrupt-continuation
  293.     interrupt-closure
  294.     interrupt-dlink
  295.     primitive-apply
  296.     primitive-lexpr-apply
  297.     assignment-trap
  298.     reference-trap
  299.     safe-reference-trap
  300.     link
  301.     error
  302.     primitive-error
  303.     short-primitive-apply))
  304.  
  305.      (make-entries
  306.       'ENTRY #x-80
  307.       '(&+
  308.     &-
  309.     &*
  310.     &/
  311.     &=
  312.     &<
  313.     &>
  314.     1+
  315.     -1+
  316.     zero?
  317.     positive?
  318.     negative?
  319.     quotient
  320.     remainder
  321.     modulo
  322.     shortcircuit-apply        ; Used by rules3, for speed.
  323.     shortcircuit-apply-size-1    ; Small frames, save time and space.
  324.     shortcircuit-apply-size-2
  325.     shortcircuit-apply-size-3
  326.     shortcircuit-apply-size-4
  327.     shortcircuit-apply-size-5
  328.     shortcircuit-apply-size-6
  329.     shortcircuit-apply-size-7
  330.     shortcircuit-apply-size-8)))))
  331.  
  332. ;; These are used by dassm1.scm
  333.  
  334. (define compiled-code-block/procedure-cache-offset 1)
  335. (define compiled-code-block/objects-per-procedure-cache 2)
  336. (define compiled-code-block/objects-per-variable-cache 1)
  337.  
  338. ;; global variable used by runtime/udata.scm -- Moby yuck!
  339.  
  340. (set! compiled-code-block/bytes-per-object 4)