module/system/vm/disasm.scm

   1 ;;; Guile VM Disassembler
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (system vm disasm)
  23   :use-module (system vm core)
  24   :use-module (system vm conv)
  25   :use-module (ice-9 regex)
  26   :use-module (ice-9 match)
  27   :use-module (ice-9 format)
  28   :use-module (ice-9 receive)
  29   :export (disassemble-objcode disassemble-program disassemble-bytecode))
  30
  31 (define (disassemble-objcode objcode . opts)
  32   (let* ((prog  (objcode->program objcode))
  33          (arity (program-arity prog))
  34          (nlocs (arity:nlocs arity))
  35          (nexts (arity:nexts arity))
  36          (bytes (program-bytecode prog)))
  37     (format #t "Disassembly of ~A:\n\n" objcode)
  38     (format #t "nlocs = ~A  nexts = ~A\n\n" nlocs nexts)
  39     (disassemble-bytecode bytes #f)))
  40
  41 (define (disassemble-program prog . opts)
  42   (let* ((arity (program-arity prog))
  43          (nargs (arity:nargs arity))
  44          (nrest (arity:nrest arity))
  45          (nlocs (arity:nlocs arity))
  46          (nexts (arity:nexts arity))
  47          (bytes (program-bytecode prog))
  48          (objs  (program-objects prog))
  49          (exts  (program-external prog)))
  50     ;; Disassemble this bytecode
  51     (format #t "Disassembly of ~A:\n\n" prog)
  52     (format #t "nargs = ~A  nrest = ~A  nlocs = ~A  nexts = ~A\n\n"
  53             nargs nrest nlocs nexts)
  54     (format #t "Bytecode:\n\n")
  55     (disassemble-bytecode bytes objs)
  56     (if (> (vector-length objs) 0)
  57         (disassemble-objects objs))
  58     (if (pair? exts)
  59         (disassemble-externals exts))
  60     ;; Disassemble other bytecode in it
  61     (for-each
  62      (lambda (x)
  63        (if (program? x)
  64            (begin (display "----------------------------------------\n")
  65                   (apply disassemble-program x opts))))
  66      (vector->list objs))))
  67
  68 (define (disassemble-bytecode bytes objs)
  69   (let ((decode (make-byte-decoder bytes))
  70         (programs '()))
  71     (do ((addr+code (decode) (decode)))
  72         ((not addr+code) (newline))
  73       (receive (addr code) addr+code
  74         (match code
  75           (('load-program x)
  76            (let ((sym (gensym "")))
  77              (set! programs (acons sym x programs))
  78              (print-info addr (format #f "(load-program #~A)" sym) #f)))
  79           (else
  80            (let ((info (list->info code))
  81                  (extra (original-value addr code objs)))
  82              (print-info addr info extra))))))
  83     (for-each (lambda (sym+bytes)
  84                 (format #t "Bytecode #~A:\n\n" (car sym+bytes))
  85                 (disassemble-bytecode (cdr sym+bytes) #f))
  86               (reverse! programs))))
  87
  88 (define (disassemble-objects objs)
  89   (display "Objects:\n\n")
  90   (let ((len (vector-length objs)))
  91     (do ((n 0 (1+ n)))
  92         ((= n len) (newline))
  93       (let ((info (object->string (vector-ref objs n))))
  94         (print-info n info #f)))))
  95
  96 (define (disassemble-externals exts)
  97   (display "Externals:\n\n")
  98   (let ((len (length exts)))
  99     (do ((n 0 (1+ n))
 100          (l exts (cdr l)))
 101         ((null? l) (newline))
 102       (let ((info (object->string (car l))))
 103         (print-info n info #f)))))
 104
 105 (define (disassemble-meta meta)
 106   (display "Meta info:\n\n")
 107   (for-each (lambda (data)
 108               (print-info (car data) (list->info (cdr data)) #f))
 109             meta)
 110   (newline))
 111
 112 (define (original-value addr code objs)
 113   (define (branch-code? code)
 114     (string-match "^br" (symbol->string (car code))))
 115   (define (list-or-vector? code)
 116     (case (car code)
 117       ((list vector) #t)
 118       (else #f)))
 119
 120   (let ((code (code-unpack code)))
 121     (cond ((list-or-vector? code)
 122            (let ((len (+ (* (cadr code) 256) (caddr code))))
 123              (format #f "~a element~a" len (if (> len 1) "s" ""))))
 124           ((code->object code) => object->string)
 125           ((branch-code? code)
 126            (let ((offset (+ (* (cadr code) 256) (caddr code))))
 127              (format #f "-> ~A" (+ addr offset 3))))
 128           (else
 129            (let ((inst (car code)) (args (cdr code)))
 130              (case inst
 131                ((make-false) "#f")
 132                ((object-ref)
 133                 (if objs (object->string (vector-ref objs (car args))) #f))
 134                (else #f)))))))
 135
 136 (define (list->info list)
 137   (object->string list))
 138
 139 ;   (define (u8vector->string vec)
 140 ;     (list->string (map integer->char (u8vector->list vec))))
 141
 142 ;   (case (car list)
 143 ;     ((link)
 144 ;      (object->string `(link ,(u8vector->string (cadr list)))))
 145 ;     (else
 146 ;      (object->string list))))
 147
 148 (define (print-info addr info extra)
 149   (if extra
 150       (format #t "~4@A    ~32A;; ~A\n" addr info extra)
 151       (format #t "~4@A    ~A\n" addr info)))
 152
 153 (define (simplify x)
 154   (cond ((string? x)
 155          (cond ((string-index x #\newline) =>
 156                 (lambda (i) (set! x (substring x 0 i)))))
 157          (cond ((> (string-length x) 16)
 158                 (set! x (string-append (substring x 0 13) "..."))))))
 159   x)