summaryrefslogtreecommitdiff
path: root/module/system/vm/disassembler.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/vm/disassembler.scm')
-rw-r--r--module/system/vm/disassembler.scm394
1 files changed, 203 insertions, 191 deletions
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 710797793..d51c14d23 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -1,6 +1,6 @@
;;; Guile bytecode disassembler
-;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2019 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2020 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -43,27 +43,6 @@
instruction-stack-size-after
instruction-slot-clobbers))
-(define-syntax-rule (u32-ref buf n)
- (bytevector-u32-native-ref buf (* n 4)))
-
-(define-syntax-rule (s32-ref buf n)
- (bytevector-s32-native-ref buf (* n 4)))
-
-(define-syntax visit-opcodes
- (lambda (x)
- (syntax-case x ()
- ((visit-opcodes macro arg ...)
- (with-syntax (((inst ...)
- (map (lambda (x) (datum->syntax #'macro x))
- (instruction-list))))
- #'(begin
- (macro arg ... . inst)
- ...))))))
-
-(eval-when (expand compile load eval)
- (define (id-append ctx a b)
- (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
-
(define (unpack-scm n)
(pointer->scm (make-pointer n)))
@@ -82,8 +61,31 @@
s
(- s (ash 1 32))))
-(define-syntax disassembler
- (lambda (x)
+(eval-when (expand)
+ (define-syntax-rule (u32-ref buf n)
+ (bytevector-u32-native-ref buf (* n 4)))
+
+ (define-syntax-rule (s32-ref buf n)
+ (bytevector-s32-native-ref buf (* n 4)))
+
+ (define-syntax-rule (define-op-handlers handlers make-handler)
+ (define handlers
+ (let ((handlers (make-vector 256 #f)))
+ (define-syntax init-handlers
+ (lambda (stx)
+ #`(begin
+ #,@(filter-map
+ (match-lambda
+ ((name opcode kind . word-types)
+ (match (make-handler name kind word-types)
+ (#f #f)
+ (init #`(vector-set! handlers #,opcode #,init)))))
+ (instruction-list)))))
+ (init-handlers)
+ handlers))))
+
+(define-op-handlers disassemblers
+ (lambda (name kind word-types)
(define (parse-first-word word type)
(with-syntax ((word word))
(case type
@@ -114,75 +116,76 @@
(else
(error "bad head kind" type)))))
- (define (parse-tail-word word type)
- (with-syntax ((word word))
+ (define (parse-tail-word word type n)
+ (with-syntax ((word word) (n n))
(case type
((C32 I32 A32 B32 AU32 BU32 AS32 BS32 AF32 BF32)
- #'(word))
+ #'(1 word))
((N32 R32 L32 LO32)
- #'((unpack-s32 word)))
+ #'(1 (unpack-s32 word)))
((C8_C24 C8_S24)
- #'((logand word #xff)
+ #'(1
+ (logand word #xff)
(ash word -8)))
((C16_C16)
- #'((logand word #xffff)
+ #'(1
+ (logand word #xffff)
(ash word -16)))
((B1_C7_L24)
- #'((not (zero? (logand word #x1)))
+ #'(1
+ (not (zero? (logand word #x1)))
(logand (ash word -1) #x7f)
(unpack-s24 (ash word -8))))
((B1_X7_S24 B1_X7_F24 B1_X7_C24)
- #'((not (zero? (logand word #x1)))
+ #'(1
+ (not (zero? (logand word #x1)))
(ash word -8)))
((B1_X7_L24)
- #'((not (zero? (logand word #x1)))
+ #'(1
+ (not (zero? (logand word #x1)))
(unpack-s24 (ash word -8))))
((B1_X31)
- #'((not (zero? (logand word #x1)))))
+ #'(1 (not (zero? (logand word #x1)))))
((X8_S24 X8_F24 X8_C24)
- #'((ash word -8)))
+ #'(1 (ash word -8)))
((X8_L24)
- #'((unpack-s24 (ash word -8))))
+ #'(1 (unpack-s24 (ash word -8))))
+ ((V32_X8_L24)
+ #'((+ 1 word)
+ (let ((v (make-vector word))
+ (base (+ offset n 1)))
+ (let lp ((i 0))
+ (when (< i word)
+ (vector-set! v i
+ (unpack-s24 (ash (u32-ref buf (+ base i)) -8)))
+ (lp (1+ i))))
+ v)))
(else
(error "bad tail kind" type)))))
- (syntax-case x ()
- ((_ name opcode word0 word* ...)
- (let ((vars (generate-temporaries #'(word* ...))))
- (with-syntax (((word* ...) vars)
- ((n ...) (map 1+ (iota (length #'(word* ...)))))
+ (match word-types
+ ((first-word . tail-words)
+ (let ((vars (generate-temporaries tail-words))
+ (word-offsets (map 1+ (iota (length tail-words)))))
+ (with-syntax ((name (datum->syntax #'nowhere name))
+ ((word* ...) vars)
+ ((n ...) word-offsets)
((asm ...)
- (parse-first-word #'first (syntax->datum #'word0)))
- (((asm* ...) ...)
- (map (lambda (word type)
- (parse-tail-word word type))
- vars
- (syntax->datum #'(word* ...)))))
+ (parse-first-word #'first first-word))
+ (((len asm* ...) ...)
+ (map parse-tail-word vars tail-words word-offsets)))
#'(lambda (buf offset first)
(let ((word* (u32-ref buf (+ offset n)))
...)
- (values (+ 1 (length '(word* ...)))
+ (values (+ 1 len ...)
(list 'name asm ... asm* ... ...))))))))))
-(define (disasm-invalid buf offset first)
- (error "bad instruction" (logand first #xff) first buf offset))
-
-(define disassemblers (make-vector 256 disasm-invalid))
-
-(define-syntax define-disassembler
- (lambda (x)
- (syntax-case x ()
- ((_ name opcode kind arg ...)
- (with-syntax ((parse (id-append #'name #'parse- #'name)))
- #'(let ((parse (disassembler name opcode arg ...)))
- (vector-set! disassemblers opcode parse)))))))
-
-(visit-opcodes define-disassembler)
-
;; -> len list
(define (disassemble-one buf offset)
(let ((first (u32-ref buf offset)))
- ((vector-ref disassemblers (logand first #xff)) buf offset first)))
+ (match (vector-ref disassemblers (logand first #xff))
+ (#f (error "bad instruction" (logand first #xff) first buf offset))
+ (disassemble (disassemble buf offset first)))))
(define (u32-offset->addr offset context)
"Given an offset into an image in 32-bit units, return the absolute
@@ -305,7 +308,15 @@ address of that offset."
((prompt)
(match arg
((_ ... target)
- (add-label! (+ offset target) "H")))))))
+ (add-label! (+ offset target) "H"))))
+ ((jtable)
+ (match arg
+ ((_ ... targets)
+ (let ((len (vector-length targets)))
+ (let lp ((i 0))
+ (when (< i len)
+ (add-label! (+ offset (vector-ref targets i)) "L")
+ (lp (1+ i)))))))))))
(lp (+ offset len))))))
(let lp ((offset start) (n 1))
(when (< offset end)
@@ -473,15 +484,27 @@ address of that offset."
((_)
(let ((lengths (make-vector 256 #f)))
(for-each (match-lambda
+ ((name opcode kind word ... 'V32_X8_L24)
+ ;; Indicate variable-length instruction by setting
+ ;; statically known length to 0.
+ (vector-set! lengths opcode 0))
((name opcode kind words ...)
(vector-set! lengths opcode (* 4 (length words)))))
(instruction-list))
(datum->syntax x lengths))))))
(define (instruction-length code pos)
+ (unless (zero? (modulo pos 4))
+ (error "invalid pos"))
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
- (or (vector-ref (instruction-lengths-vector) opcode)
- (error "Unknown opcode" opcode))))
+ (match (vector-ref (instruction-lengths-vector) opcode)
+ (#f (error "Unknown opcode" opcode))
+ (0 (call-with-values (lambda ()
+ (let ((offset (/ pos 4)))
+ (disassemble-one code offset)))
+ (lambda (u32-len disasm)
+ (* u32-len 4))))
+ (len len))))
(define-syntax static-opcode-set
(lambda (x)
@@ -507,139 +530,128 @@ address of that offset."
tail-call tail-call-label
return-values
subr-call foreign-call continuation-call
- j))
+ j jtable))
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
(bitvector-bit-clear? non-fallthrough-set opcode)))
-(define-syntax define-jump-parser
- (lambda (x)
- (syntax-case x ()
- ((_ name opcode kind word0 word* ...)
- (let ((symname (syntax->datum #'name)))
- (if (memq symname '(prompt j je jl jge jne jnl jnge))
- (let ((offset (* 4 (length #'(word* ...)))))
- #`(vector-set!
- jump-parsers
- opcode
- (lambda (code pos)
- (let ((target
- (bytevector-s32-native-ref code (+ pos #,offset))))
- ;; Assume that the target is in the last word, as
- ;; an L24 in the high bits.
- (list (* 4 (ash target -8)))))))
- #'(begin)))))))
-
-(define jump-parsers (make-vector 256 (lambda (code pos) '())))
-(visit-opcodes define-jump-parser)
+(define (word-offset->byte-offset n)
+ (* n 4))
+
+(define-op-handlers jump-parsers
+ (lambda (op kind word-types)
+ (case op
+ ((prompt j je jl jge jne jnl jnge)
+ #'(lambda (code pos)
+ (call-with-values (lambda () (disassemble-one code (/ pos 4)))
+ (lambda (len disasm)
+ (match disasm
+ ;; Assume that the target is in the last word, as a
+ ;; word offset.
+ ((_ ___ target) (list (word-offset->byte-offset target))))))))
+ ((jtable)
+ #'(lambda (code pos)
+ (call-with-values (lambda () (disassemble-one code (/ pos 4)))
+ (lambda (len disasm)
+ (match disasm
+ ;; Assume that the target is in the last word, as a
+ ;; vector of word offsets.
+ ((_ ___ targets)
+ (map word-offset->byte-offset (vector->list targets))))))))
+ (else #f))))
(define (instruction-relative-jump-targets code pos)
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
- ((vector-ref jump-parsers opcode) code pos)))
-
-(define-syntax define-stack-effect-parser
- (lambda (x)
- (define (stack-effect-parser name)
- (case name
- ((push)
- #'(lambda (code pos size) (and size (+ size 1))))
- ((pop)
- #'(lambda (code pos size) (and size (- size 1))))
- ((drop)
- #'(lambda (code pos size)
- (let ((count (ash (bytevector-u32-native-ref code pos) -8)))
- (and size (- size count)))))
- ((alloc-frame reset-frame bind-optionals)
- #'(lambda (code pos size)
- (let ((nlocals (ash (bytevector-u32-native-ref code pos) -8)))
- nlocals)))
- ((receive)
- #'(lambda (code pos size)
- (let ((nlocals (ash (bytevector-u32-native-ref code (+ pos 4))
- -8)))
- nlocals)))
- ((bind-kwargs)
- #'(lambda (code pos size)
- (let ((ntotal (ash (bytevector-u32-native-ref code (+ pos 8)) -8)))
- ntotal)))
- ((bind-rest)
- #'(lambda (code pos size)
- (let ((dst (ash (bytevector-u32-native-ref code pos) -8)))
- (+ dst 1))))
- ((assert-nargs-ee/locals)
- #'(lambda (code pos size)
- (let ((nargs (logand (ash (bytevector-u32-native-ref code pos) -8)
- #xfff))
- (nlocals (ash (bytevector-u32-native-ref code pos) -20)))
- (+ nargs nlocals))))
- ((call call-label tail-call tail-call-label expand-apply-argument)
- #'(lambda (code pos size) #f))
- ((shuffle-down)
- #'(lambda (code pos size)
- (let ((from (logand (ash (bytevector-u32-native-ref code pos) -8)
- #xfff))
- (to (ash (bytevector-u32-native-ref code pos) -20)))
- (and size (- size (- from to))))))
- (else
- #f)))
- (syntax-case x ()
- ((_ name opcode kind word0 word* ...)
- (let ((parser (stack-effect-parser (syntax->datum #'name))))
- (if parser
- #`(vector-set! stack-effect-parsers opcode #,parser)
- #'(begin)))))))
-
-(define stack-effect-parsers (make-vector 256 (lambda (code pos size) size)))
-(visit-opcodes define-stack-effect-parser)
+ (match (vector-ref jump-parsers opcode)
+ (#f '())
+ (proc (proc code pos)))))
+
+(define-op-handlers stack-effect-parsers
+ (lambda (name kind word-types)
+ (case name
+ ((push)
+ #'(lambda (code pos size) (and size (+ size 1))))
+ ((pop)
+ #'(lambda (code pos size) (and size (- size 1))))
+ ((drop)
+ #'(lambda (code pos size)
+ (let ((count (ash (bytevector-u32-native-ref code pos) -8)))
+ (and size (- size count)))))
+ ((alloc-frame reset-frame bind-optionals)
+ #'(lambda (code pos size)
+ (let ((nlocals (ash (bytevector-u32-native-ref code pos) -8)))
+ nlocals)))
+ ((receive)
+ #'(lambda (code pos size)
+ (let ((nlocals (ash (bytevector-u32-native-ref code (+ pos 4))
+ -8)))
+ nlocals)))
+ ((bind-kwargs)
+ #'(lambda (code pos size)
+ (let ((ntotal (ash (bytevector-u32-native-ref code (+ pos 8)) -8)))
+ ntotal)))
+ ((bind-rest)
+ #'(lambda (code pos size)
+ (let ((dst (ash (bytevector-u32-native-ref code pos) -8)))
+ (+ dst 1))))
+ ((assert-nargs-ee/locals)
+ #'(lambda (code pos size)
+ (let ((nargs (logand (ash (bytevector-u32-native-ref code pos) -8)
+ #xfff))
+ (nlocals (ash (bytevector-u32-native-ref code pos) -20)))
+ (+ nargs nlocals))))
+ ((call call-label tail-call tail-call-label expand-apply-argument)
+ #'(lambda (code pos size) #f))
+ ((shuffle-down)
+ #'(lambda (code pos size)
+ (let ((from (logand (ash (bytevector-u32-native-ref code pos) -8)
+ #xfff))
+ (to (ash (bytevector-u32-native-ref code pos) -20)))
+ (and size (- size (- from to))))))
+ (else
+ #f))))
(define (instruction-stack-size-after code pos size)
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
- ((vector-ref stack-effect-parsers opcode) code pos size)))
-
-(define-syntax define-clobber-parser
- (lambda (x)
- (syntax-case x ()
- ((_ name opcode kind arg0 arg* ...)
- (case (syntax->datum #'kind)
- ((!)
- (case (syntax->datum #'name)
- ((call call-label)
- #'(let ((parse (lambda (code pos nslots-in nslots-out)
- (call-with-values
- (lambda ()
- (disassemble-one code (/ pos 4)))
- (lambda (len elt)
- (define frame-size 3)
- (match elt
- ((_ proc . _)
- (let lp ((slot (- proc frame-size)))
- (if (and nslots-in (< slot nslots-in))
- (cons slot (lp (1+ slot)))
- '())))))))))
- (vector-set! clobber-parsers opcode parse)))
- (else
- #'(begin))))
- ((<-)
- #`(let ((parse (lambda (code pos nslots-in nslots-out)
- (call-with-values
- (lambda ()
- (disassemble-one code (/ pos 4)))
- (lambda (len elt)
- (match elt
- ((_ dst . _)
- #,(case (syntax->datum #'arg0)
- ((X8_F24 X8_F12_F12)
- #'(list dst))
- (else
- #'(if nslots-out
- (list (- nslots-out 1 dst))
- '()))))))))))
- (vector-set! clobber-parsers opcode parse)))
- (else (error "unexpected instruction kind" #'kind)))))))
-
-(define clobber-parsers
- (make-vector 256 (lambda (code pos nslots-in nslots-out) '())))
-(visit-opcodes define-clobber-parser)
+ (match (vector-ref stack-effect-parsers opcode)
+ (#f size)
+ (proc (proc code pos size)))))
+
+(define-op-handlers clobber-parsers
+ (lambda (name kind word-types)
+ (match kind
+ ('!
+ (case name
+ ((call call-label)
+ #'(lambda (code pos nslots-in nslots-out)
+ (call-with-values
+ (lambda ()
+ (disassemble-one code (/ pos 4)))
+ (lambda (len elt)
+ (define frame-size 3)
+ (match elt
+ ((_ proc . _)
+ (let lp ((slot (- proc frame-size)))
+ (if (and nslots-in (< slot nslots-in))
+ (cons slot (lp (1+ slot)))
+ '()))))))))
+ (else #f)))
+ ('<-
+ #`(lambda (code pos nslots-in nslots-out)
+ (call-with-values (lambda ()
+ (disassemble-one code (/ pos 4)))
+ (lambda (len elt)
+ (match elt
+ ((_ dst . _)
+ #,(match word-types
+ (((or 'X8_F24 'X8_F12_F12) . _)
+ #'(list dst))
+ (else
+ #'(if nslots-out
+ (list (- nslots-out 1 dst))
+ '()))))))))))))
(define (instruction-slot-clobbers code pos nslots-in nslots-out)
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
- ((vector-ref clobber-parsers opcode) code pos nslots-in nslots-out)))
+ (match (vector-ref clobber-parsers opcode)
+ (#f '())
+ (proc (proc code pos nslots-in nslots-out)))))