application/octet-stream
•
8.06 KB
•
130 lines
;;; Nujel - Copyright (C) 2020-2021 - Benjamin Vincent Schulenburg
;;; This project uses the MIT license, a copy should be included under /LICENSE
;;;
;;; Contains the disassembler, which is probably not that important to most
;;; people, but invaluable when working on compiler internals
(def disassemble (let*
(defn disassemble/length (op)
"Return the length in bytes of a bytecode operation and all its arguments"
(case op
((#x0 #x1 #x3 #xC #xD #x11 #x12 #x13 #x14 #x15 #x16 #x17 #x18 #x19 #x1B #x1C #x1D #x1E #x1F #x20 #x21 #x22 #x23 #x24 #x25 #x26 #x27 #x28 #x29 #x2A #x2B #x2C #x2D #x2F #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38) 1)
((#x2 #x4 #x5 #x7 #xE #x1A #x2E) 2)
((#x6 #x8 #x9 #xA #xB #xF #x10 ) 3)
(otherwise (exception :unknown-op "This op needs its length specified for disassembly to work" op))))
(defn bytecode/nil-catcher (error) (if (= (car error) :type-error) #nil (throw error)))
(defn bytecode-arr->val (a i)
"Read a bytecode encoded value in A at I and return it"
(try bytecode/nil-catcher (bytecode-op->val (ref a i) (ref a (+ 1 i)) (ref a (+ 2 i)))))
(defn bytecode-arr->sym (a i)
"Read a bytecode encoded symbol in A at I and return it"
(try bytecode/nil-catcher (bytecode-op->sym (ref a i) (ref a (+ 1 i)) (ref a (+ 2 i)))))
(defn bytecode-op->offset (a b)
"Turn two bytecode ops encoding an offset into the integer representation"
(def t (bit-or (bit-shift-left a 8) b))
(if-not (> t 32768) t
(- (- 65536 t))))
(defn bytecode-arr->offset (a i)
"Read a bytecode encoded offset in A at I and return it as a signed integer"
(bytecode-op->offset (ref a i) (ref a (+ 1 i))))
(defn disassemble/maybe-quote (v)
"Quotes symbols but just passes through every other value"
(cond ((symbol? v) (list 'quote v))
((bytecode-array? v) (disassemble/bytecode-array v))
(#t v)))
(defn disassemble/op (a i literals)
"Disassemble a single bytecode op in A at I and return it as an s-expression, that could be applied to eval"
(case (ref a i)
(#x0 '($nop))
(#x1 '($ret))
(#x2 `($push/int/byte ~(ref a (+ i 1))))
(#x3 '($add/int))
(#x4 `($apply ~(ref a (+ i 1))))
(#x5 `($set/val ~(disassemble/maybe-quote (ref literals (ref a (+ i 1))))))
(#x6 `($push/val/ext ~(ref literals (bit-or (ref a (+ i 1))
(bit-shift-left (ref a (+ i 2))) 8))))
(#x7 `($def/val ~(disassemble/maybe-quote (ref literals (ref a (+ i 1))))))
(#x8 `($def/val/ext ~(ref literals (bit-or (ref a (+ i 1))
(bit-shift-left (ref a (+ i 2)) 8)))))
(#x9 `($jmp* ~(bytecode-arr->offset a (+ i 1))))
(#xA `($jt* ~(bytecode-arr->offset a (+ i 1))))
(#xB `($jf* ~(bytecode-arr->offset a (+ i 1))))
(#xC '($dup))
(#xD '($drop))
(#xE `($get/val ~(disassemble/maybe-quote (ref literals (ref a (+ i 1))))))
(#xF `($get/val/ext ~(ref literals (bit-or (ref a (+ i 1))
(bit-shift-left (ref a (+ i 2)) 8)))))
(#x10 `($set/val/ext ~(ref literals (bit-or (ref a (+ i 1))
(bit-shift-left (ref a (+ i 2)) 8)))))
(#x11 '($car))
(#x12 '($cdr))
(#x13 '($closure/push))
(#x14 '($cons))
(#x15 '($let))
(#x16 '($closure/pop))
(#x17 '($fn/dynamic))
(#x18 '($macro/dynamic))
(#x19 `($try ~(bytecode-arr->offset a (+ i 1))))
(#x1A `($push/val ~(disassemble/maybe-quote (ref literals (ref a (+ i 1))))))
(#x1B '($push/true))
(#x1C '($push/false))
(#x1D '($eval))
(#x1E '($<))
(#x1F '($<=))
(#x20 '($=))
(#x21 '($>=))
(#x22 '($>))
(#x23 '($inc/int))
(#x24 '($push/nil))
(#x25 '($add))
(#x26 '($sub))
(#x27 '($mul))
(#x28 '($div))
(#x29 '($rem))
(#x2A '($zero?))
(#x2B '($ref))
(#x2C '($cadr))
(#x2D '($mutable-eval))
(#x2E `($list ~(ref a (+ i 1))))
(#x2F '($throw))
(#x30 '($apply/collection))
(#x31 '($bit-shift-left))
(#x32 '($bit-shift-right))
(#x33 '($bit-and))
(#x34 '($bit-or))
(#x35 '($bit-xor))
(#x36 '($bit-not))
(#x37 '($set/gen))
(#x38 '($not=))
(otherwise :unknown-op)))
(defn disassemble/array (a i literals)
"Disassemble all bytecode operations in the plain array A starting at I, turning it into an assembler S-Expression and return it as a dotted pair, with the car containing the offset and the cdr containing the S-Expression"
(def ret #nil)
(while (< i (:length a))
(cons! (cons i (disassemble/op a i literals)) ret)
(set! i (+ i (disassemble/length (ref a i)))))
(nreverse ret))
(defn disassemble/bytecode-array (code)
"Disassemble the bytecode array CODE, turning it into a list of dotted pairs, with the car containing the offset and the cdr containing assembler S-Expressions,"
(disassemble/array (:array code) 0 (:literals code)))
(defn disassemble/to-string (bc)
(disassemble/bytecode-array bc))
(defn disassemble (bc)
"Disassemble the bytecode array CODE, turning it into a list of dotted pairs, with the car containing the offset and the cdr containing assembler S-Expressions,"
:cat :bytecode
:internal
(case (:type-name bc)
((:lambda :macro) (disassemble/to-string (:code bc)))
(:bytecode-array (disassemble/to-string bc))
(otherwise (exception :type-error "Can't disassemble that" bc))))))
