Add annotated disassembly output
ober
72e1d6e45255420bbab8c2a32e8e9d236b14ceff
--- a/docs/disassembly.md +++ b/docs/disassembly.md @@ -245,7 +245,7 @@ The module is: Current exports: -```scheme +```text (procedure-code-info proc) (write-procedure-code-info proc port) (hex-string->bytevector str) @@ -257,10 +257,17 @@ Current exports: (disassembly-instruction-size insn) (disassembly-instruction-text insn) (disassembly-instruction-bytes insn) +(describe-disassembly-instruction insn) +(format-disassembly-instruction insn [options]) +(format-disassembly-instruction/annotated insn [options]) +(format-disassembly-instructions insns [options]) +(format-disassembly-instructions/annotated insns [options]) (procedure-code-bytes proc) -(procedure-disassembly proc) +(procedure-disassembly proc [options]) (disassemble proc) (disassemble proc port) +(disassemble proc 'annotate) +(disassemble proc port options) ``` `procedure-code-info` returns an alist with procedure name, source metadata, @@ -294,6 +301,22 @@ procedure memory: '((syntax . intel))) ``` +Annotated output is opt-in: + +```scheme +(disassemble-bytevector->string + 'aarch64 + (hex-string->bytevector "20 00 80 d2 c0 03 5f d6") + '((annotate . #t))) +``` + +This adds a right-side explanation column for decoded mnemonics: + +```text +0x0: mov x0, #1 ; move/copy: x0 = 1 +0x4: ret ; return from the current procedure +``` + The current decoder slice supports: - `x86-64`: seed register-only decode for common prologue, return, no-op, @@ -333,9 +356,16 @@ Formatting should stay separate from extraction. ### Phase 3: Disassembly Formatting -Status: seed formatter implemented in `lib/std/debug/disassemble.ss`. +Status: seed formatter and opt-in annotation column implemented in +`lib/std/debug/disassemble.ss`. + +Now that bytes are available, Jerboa formats them with the built-in seed +decoder. Passing `((annotate . #t))`, or the shorthand `(disassemble proc +'annotate)`, adds a right-side explanation column derived from decoded +mnemonics and operands. The first annotation pass covers the instructions the +seed decoder already emits, including move/copy, add/subtract, load/store, +push, return, branch/call, no-op, and raw `.byte`/`.word` fallbacks. -Now that bytes are available, Jerboa formats them with the built-in seed decoder. Future expansion can still add one of these broader approaches: 1. Shell out to `llvm-objdump` or another platform disassembler after wrapping @@ -359,6 +389,8 @@ The Common Lisp inspired API can be: ```scheme (disassemble proc) (disassemble proc port) +(disassemble proc 'annotate) +(disassemble proc port '((annotate . #t) (max-bytes . 128))) ``` It should print a human-readable report: --- a/lib/std/debug/disassemble.ss +++ b/lib/std/debug/disassemble.ss @@ -16,8 +16,11 @@ disassembly-instruction-size disassembly-instruction-text disassembly-instruction-bytes + describe-disassembly-instruction format-disassembly-instruction + format-disassembly-instruction/annotated format-disassembly-instructions + format-disassembly-instructions/annotated disassemble-bytevector disassemble-bytevector->string procedure-code-info @@ -35,7 +38,8 @@ eval read open-input-string - interaction-environment) ; jerboa-security: suppress direct-chezscheme-import-user-code + interaction-environment + output-port?) ; jerboa-security: suppress direct-chezscheme-import-user-code (only (jerboa core) def) (std format)) @@ -111,6 +115,23 @@ (let ((cell (assq key options))) (if cell (cdr cell) default))) + (def (coerce-disassembly-options options who) + (cond + ((not options) '()) + ((null? options) '()) + ((eq? options 'annotate) '((annotate . #t))) + ((and (pair? options) (pair? (car options))) options) + (#t (error who "expected an option alist or 'annotate" options)))) + + (def (optional-disassembly-options maybe-options who) + (if (null? maybe-options) + '() + (coerce-disassembly-options (car maybe-options) who))) + + (def (annotate-disassembly? options) + (let ((value (option-ref options 'annotate #f))) + (if value #t #f))) + (def (hex-digit c) (cond ((and (char>=? c #\0) (char<=? c #\9)) @@ -183,6 +204,201 @@ (def (hex-number n) (string-append "0x" (number->hex n))) + (def default-annotation-column 36) + + (def (string-empty? s) + (= (string-length s) 0)) + + (def (string-trim-simple s) + (let ((n (string-length s))) + (let left ((start 0)) + (if (and (< start n) (char-whitespace? (string-ref s start))) + (left (+ start 1)) + (let right ((end n)) + (if (and (> end start) + (char-whitespace? (string-ref s (- end 1)))) + (right (- end 1)) + (substring s start end))))))) + + (def (strip-leading-operand-marker operand) + (let ((s (string-trim-simple operand))) + (if (string-empty? s) + s + (let ((c (string-ref s 0))) + (if (or (char=? c #\%) + (char=? c #\$) + (char=? c #\#)) + (substring s 1 (string-length s)) + s))))) + + (def (instruction-mnemonic text) + (let ((n (string-length text))) + (let loop ((i 0)) + (cond + ((= i n) text) + ((char-whitespace? (string-ref text i)) (substring text 0 i)) + (#t (loop (+ i 1))))))) + + (def (instruction-operand-text text) + (let ((n (string-length text))) + (let find-end ((i 0)) + (cond + ((= i n) "") + ((char-whitespace? (string-ref text i)) + (let skip-space ((j i)) + (if (and (< j n) (char-whitespace? (string-ref text j))) + (skip-space (+ j 1)) + (substring text j n)))) + (#t (find-end (+ i 1))))))) + + (def (add-split-operand text out) + (let ((operand (string-trim-simple text))) + (if (string-empty? operand) + out + (cons operand out)))) + + (def (split-operands text) + (let ((n (string-length text))) + (let loop ((i 0) (start 0) (depth 0) (out '())) + (cond + ((= i n) + (reverse (add-split-operand (substring text start n) out))) + ((char=? (string-ref text i) #\[) + (loop (+ i 1) start (+ depth 1) out)) + ((char=? (string-ref text i) #\]) + (loop (+ i 1) start (if (> depth 0) (- depth 1) 0) out)) + ((and (= depth 0) (char=? (string-ref text i) #\,)) + (loop (+ i 1) + (+ i 1) + depth + (add-split-operand (substring text start i) out))) + (#t (loop (+ i 1) start depth out)))))) + + (def (operand-at operands index default) + (let loop ((items operands) (i index)) + (cond + ((null? items) default) + ((= i 0) (car items)) + (#t (loop (cdr items) (- i 1)))))) + + (def (operand-count operands) + (length operands)) + + (def (memory-operand? operand) + (let ((s (string-trim-simple operand))) + (and (> (string-length s) 1) + (char=? (string-ref s 0) #\[) + (char=? (string-ref s (- (string-length s) 1)) #\])))) + + (def (memory-operand-address operand) + (let* ((s (string-trim-simple operand)) + (inner (substring s 1 (- (string-length s) 1))) + (parts (split-operands inner)) + (base (strip-leading-operand-marker (operand-at parts 0 "memory"))) + (offset (operand-at parts 1 #f))) + (if offset + (string-append base " + " (strip-leading-operand-marker offset)) + base))) + + (def (x86-att-mnemonic? mnemonic) + (or (string=? mnemonic "movq") + (string=? mnemonic "movl") + (string=? mnemonic "addq") + (string=? mnemonic "addl") + (string=? mnemonic "subq") + (string=? mnemonic "subl") + (string=? mnemonic "pushq") + (string=? mnemonic "retq"))) + + (def (mnemonic-root mnemonic) + (cond + ((or (string=? mnemonic "movq") (string=? mnemonic "movl")) "mov") + ((or (string=? mnemonic "addq") (string=? mnemonic "addl")) "add") + ((or (string=? mnemonic "subq") (string=? mnemonic "subl")) "sub") + ((string=? mnemonic "pushq") "push") + ((string=? mnemonic "retq") "ret") + (#t mnemonic))) + + (def (describe-move arch mnemonic operands) + (let* ((att? (and (eq? arch 'x86-64) (x86-att-mnemonic? mnemonic))) + (dst (strip-leading-operand-marker + (operand-at operands (if att? 1 0) "destination"))) + (src (strip-leading-operand-marker + (operand-at operands (if att? 0 1) "source"))) + (shift (operand-at operands 2 #f))) + (if shift + (format "move/copy: ~a = ~a (~a)" dst src shift) + (format "move/copy: ~a = ~a" dst src)))) + + (def (describe-add-sub op arch mnemonic operands) + (let ((sign (if (string=? op "add") "+" "-")) + (verb (if (string=? op "add") "add" "subtract"))) + (cond + ((>= (operand-count operands) 3) + (format "~a: ~a = ~a ~a ~a" + verb + (strip-leading-operand-marker (operand-at operands 0 "destination")) + (strip-leading-operand-marker (operand-at operands 1 "source")) + sign + (strip-leading-operand-marker (operand-at operands 2 "value")))) + ((>= (operand-count operands) 2) + (let* ((att? (and (eq? arch 'x86-64) (x86-att-mnemonic? mnemonic))) + (dst (strip-leading-operand-marker + (operand-at operands (if att? 1 0) "destination"))) + (src (strip-leading-operand-marker + (operand-at operands (if att? 0 1) "value")))) + (format "~a: ~a = ~a ~a ~a" verb dst dst sign src))) + (#t (format "~a values" verb))))) + + (def (describe-load operands) + (let ((dst (strip-leading-operand-marker (operand-at operands 0 "destination"))) + (mem (operand-at operands 1 #f))) + (if (and mem (memory-operand? mem)) + (format "load: ~a = memory[~a]" dst (memory-operand-address mem)) + (format "load memory value into ~a" dst)))) + + (def (describe-store operands) + (let ((src (strip-leading-operand-marker (operand-at operands 0 "source"))) + (mem (operand-at operands 1 #f))) + (if (and mem (memory-operand? mem)) + (format "store: memory[~a] = ~a" (memory-operand-address mem) src) + (format "store ~a to memory" src)))) + + (def (describe-disassembly-instruction insn) + (unless (disassembly-instruction? insn) + (error 'describe-disassembly-instruction "not a disassembly instruction" insn)) + (let* ((arch (disassembly-instruction-arch insn)) + (text (disassembly-instruction-text insn)) + (mnemonic (instruction-mnemonic text)) + (root (mnemonic-root mnemonic)) + (operands (split-operands (instruction-operand-text text)))) + (cond + ((string=? mnemonic ".byte") "raw byte; decoder does not yet recognize this instruction") + ((string=? mnemonic ".word") "raw 32-bit word; decoder does not yet recognize this instruction") + ((string=? root "mov") (describe-move arch mnemonic operands)) + ((string=? root "add") (describe-add-sub "add" arch mnemonic operands)) + ((string=? root "sub") (describe-add-sub "sub" arch mnemonic operands)) + ((string=? root "ldr") (describe-load operands)) + ((string=? root "str") (describe-store operands)) + ((string=? root "push") + (format "push: place ~a on the stack" + (strip-leading-operand-marker (operand-at operands 0 "value")))) + ((string=? root "ret") "return from the current procedure") + ((string=? root "nop") "no operation") + ((string=? root "call") + (format "call procedure at ~a" + (strip-leading-operand-marker (operand-at operands 0 "target")))) + ((string=? root "jmp") + (format "jump to ~a" + (strip-leading-operand-marker (operand-at operands 0 "target")))) + ((string=? root "je") + (format "jump to ~a if equal or zero" + (strip-leading-operand-marker (operand-at operands 0 "target")))) + ((string=? root "jne") + (format "jump to ~a if not equal or not zero" + (strip-leading-operand-marker (operand-at operands 0 "target")))) + (#t (format "instruction: ~a" mnemonic))))) + (def (signed8 b) (if (>= b 128) (- b 256) b)) @@ -415,21 +631,72 @@ "decoder not implemented for architecture" arch))))) - (def (format-disassembly-instruction insn) + (def (format-disassembly-instruction-line insn) (string-append (hex-number (disassembly-instruction-address insn)) ":\t" - (disassembly-instruction-text insn) - "\n")) - - (def (format-disassembly-instructions insns) - (apply string-append (map format-disassembly-instruction insns))) + (disassembly-instruction-text insn))) + + (def (pad-right text width) + (let ((n (string-length text))) + (if (< n width) + (string-append text (make-string (- width n) #\space)) + (string-append text "\t")))) + + (def (format-disassembly-instruction/plain insn) + (string-append (format-disassembly-instruction-line insn) "\n")) + + (def (format-disassembly-instruction/annotated insn . maybe-options) + (let* ((options (optional-disassembly-options + maybe-options + 'format-disassembly-instruction/annotated)) + (column (option-ref options 'annotation-column default-annotation-column)) + (line (format-disassembly-instruction-line insn))) + (string-append + (pad-right line column) + "; " + (describe-disassembly-instruction insn) + "\n"))) + + (def format-disassembly-instruction + (case-lambda + ((insn) (format-disassembly-instruction/plain insn)) + ((insn options) + (let ((options (coerce-disassembly-options + options + 'format-disassembly-instruction))) + (if (annotate-disassembly? options) + (format-disassembly-instruction/annotated insn options) + (format-disassembly-instruction/plain insn)))))) + + (def (format-disassembly-instructions/plain insns) + (apply string-append (map format-disassembly-instruction/plain insns))) + + (def (format-disassembly-instructions/annotated insns . maybe-options) + (let ((options (optional-disassembly-options + maybe-options + 'format-disassembly-instructions/annotated))) + (apply string-append + (map (lambda (insn) + (format-disassembly-instruction/annotated insn options)) + insns)))) + + (def format-disassembly-instructions + (case-lambda + ((insns) (format-disassembly-instructions/plain insns)) + ((insns options) + (let ((options (coerce-disassembly-options + options + 'format-disassembly-instructions))) + (if (annotate-disassembly? options) + (format-disassembly-instructions/annotated insns options) + (format-disassembly-instructions/plain insns)))))) (def (disassemble-bytevector arch bv . maybe-options) (unless (bytevector? bv) (error 'disassemble-bytevector "not a bytevector" bv)) (let* ((arch (normalize-disassembly-architecture arch)) - (options (if (null? maybe-options) '() (car maybe-options))) + (options (optional-disassembly-options maybe-options 'disassemble-bytevector)) (base (option-ref options 'address 0)) (max-bytes (option-ref options 'max-bytes #f)) (stop-address (option-ref options 'stop-address #f)) @@ -452,8 +719,12 @@ (cons insn out))))))) (def (disassemble-bytevector->string arch bv . maybe-options) - (let ((options (if (null? maybe-options) '() (car maybe-options)))) - (format-disassembly-instructions (disassemble-bytevector arch bv options)))) + (let ((options (optional-disassembly-options + maybe-options + 'disassemble-bytevector->string))) + (format-disassembly-instructions + (disassemble-bytevector arch bv options) + options))) (def (source-values code-object) (guard (e (#t '())) @@ -585,7 +856,8 @@ (case-lambda ((proc) (procedure-disassembly proc '())) ((proc options) - (let* ((info (procedure-code-info proc)) + (let* ((options (coerce-disassembly-options options 'procedure-disassembly)) + (info (procedure-code-info proc)) (bytes (procedure-code-bytes proc)) (arch (machine-type->disassembly-architecture (alist-value 'machine-type info #f))) (instructions (if arch (disassemble-bytevector arch bytes options) '()))) @@ -594,7 +866,7 @@ (instructions . ,instructions) (status . ,(if arch 'decoded 'bytes-only))))))) - (def (write-disassembly-instructions instructions port) + (def (write-disassembly-instructions instructions port options) (if (null? instructions) (begin (display "assembly: unavailable for this machine type" port) @@ -604,19 +876,30 @@ (newline port) (for-each (lambda (insn) - (display (format-disassembly-instruction insn) port)) + (display (format-disassembly-instruction insn options) port)) instructions)))) + (def (disassemble/write proc port options) + (let* ((options (coerce-disassembly-options options 'disassemble)) + (report (procedure-disassembly proc options))) + (write-procedure-code-info proc port) + (newline port) + (write-disassembly-instructions + (alist-value 'instructions report '()) + port + options)) + #t) + (def disassemble (case-lambda ((proc) (disassemble proc (current-output-port))) ((proc port) - (let ((report (procedure-disassembly proc))) - (write-procedure-code-info proc port) - (newline port) - (write-disassembly-instructions - (alist-value 'instructions report '()) - port)) - #t))) + (if (output-port? port) + (disassemble/write proc port '()) + (disassemble/write proc (current-output-port) port))) + ((proc port options) + (unless (output-port? port) + (error 'disassemble "expected an output port" port)) ; jerboa-security: suppress bare-error-no-condition + (disassemble/write proc port options)))) ) --- a/tests/test-disassemble.ss +++ b/tests/test-disassemble.ss @@ -75,6 +75,27 @@ (disassemble-bytevector->string 'aarch64 bv) "0x0:\tmov\tx0, #1\n0x4:\tret\n")) +(let* ((bv (hex-string->bytevector "20 00 80 d2 c0 03 5f d6 81 06 00 f9 81 06 40 f9")) + (insns (disassemble-bytevector 'aarch64 bv)) + (options '((annotate . #t) (annotation-column . 24)))) + (check "describe aarch64 mov" + (describe-disassembly-instruction (car insns)) + "move/copy: x0 = 1") + (check "describe aarch64 store" + (describe-disassembly-instruction (caddr insns)) + "store: memory[x20 + 8] = x1") + (check "aarch64 annotated string" + (disassemble-bytevector->string 'aarch64 bv options) + "0x0:\tmov\tx0, #1 ; move/copy: x0 = 1\n0x4:\tret ; return from the current procedure\n0x8:\tstr\tx1, [x20, #8] ; store: memory[x20 + 8] = x1\n0xc:\tldr\tx1, [x20, #8] ; load: x1 = memory[x20 + 8]\n")) + +(let ((bv (hex-string->bytevector "55 48 89 e5 48 83 c4 08 48 83 ec 10 c3"))) + (check "x86 annotated intel string" + (disassemble-bytevector->string + 'x86-64 + bv + '((syntax . intel) (annotate . #t) (annotation-column . 24))) + "0x0:\tpush\trbp ; push: place rbp on the stack\n0x1:\tmov\trbp, rsp ; move/copy: rbp = rsp\n0x4:\tadd\trsp, 8 ; add: rsp = rsp + 8\n0x8:\tsub\trsp, 0x10 ; subtract: rsp = rsp - 0x10\n0xc:\tret ; return from the current procedure\n")) + (let ((info (procedure-code-info sample-procedure))) (check "info kind" (alist-value 'kind info #f) 'procedure-code-info) (check "status has bytes" (alist-value 'status info #f) 'bytes-available) @@ -113,6 +134,13 @@ (check-true "disassemble includes metadata" (contains? text "procedure:")) (check-true "disassemble includes assembly" (contains? text "assembly:"))) +(let ((text (with-output-to-string + (lambda () + (disassemble sample-procedure + '((annotate . #t) (max-bytes . 16))))))) + (check-true "disassemble annotate shorthand includes comments" + (contains? text "; "))) + (display "Disassemble tests: ") (display pass-count) (display " passed, ")