application/octet-stream
•
6.48 KB
•
137 lines
; Contains the disassembler, which is probably not that important to most
; people, but invaluable when working on compiler internals
[defn disassemble/length [op]
"Return the length in bytes of a bytecode operation and all its arguments"
[case op
[[#$0 #$1 #$3 #$4 #$C #$D #$13 #$15 #$16 #$1B #$1C #$1E #$1F #$20 #$21 #$22 #$24 #$27] 1]
[[#$2 #$1A] 2]
[[#$9 #$A #$B #$18] 3]
[[#$5 #$E #$F #$10 #$23] 4]
[[#$8] 5]
[[#$25 #$26] 13]
[otherwise [throw [list :unknown-op "This op needs its length specified for disassembly to work" op [current-lambda]]]]]]
[defn bytecode/nil-catcher [error] [if [== [car error] :argument-mismatch] #nil [throw error]]]
[defn bytecode-op->val [a b c]
"Turn three bytecode ops representing an encoded value into an actual value"
[index->val [logior [ash [bytecode-op->int a] 16]
[ash [bytecode-op->int b] 8]
[bytecode-op->int c]]]]
[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-op->sym [a b c]
"Turn three bytecode ops representing an encoded symbol into an actual symbol"
[index->sym [logior [ash [bytecode-op->int a] 16]
[ash [bytecode-op->int b] 8]
[bytecode-op->int c]]]]
[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 [logior [ash [bytecode-op->int a] 8]
[bytecode-op->int 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/op [a i]
"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]
[#$0 '[$nop]]
[#$1 '[$ret]]
[#$2 `[$push/int/byte ~[bytecode-op->int [ref a [+ i 1]]]]]
[#$3 '[$add/int]]
[#$4 '[$debug/print-stack]]
[#$5 `[$push/lval ~[bytecode-arr->val a [+ i 1]]]]
[#$6 `[$make-list ~[bytecode-op->int [ref a [+ i 1]]]]]
[#$7 '[$eval]]
[#$8 `[$apply ~[bytecode-op->int [ref a [+ i 1]]]
~[bytecode-arr->val a [+ i 2]]]]
[#$9 `[$jmp* ~[bytecode-arr->offset a [+ i 1]]]]
[#$A `[$jt* ~[bytecode-arr->offset a [+ i 1]]]]
[#$B `[$jf* ~[bytecode-arr->offset a [+ i 1]]]]
[#$C '[$dup]]
[#$D '[$drop]]
[#$E `[$def ~[bytecode-arr->sym a [+ i 1]]]]
[#$F `[$set ~[bytecode-arr->sym a [+ i 1]]]]
[#$10 `[$get ~[bytecode-arr->sym a [+ i 1]]]]
[#$13 '[$closure/push]]
[#$14 '[$closure/enter]]
[#$15 '[$let]]
[#$16 '[$closure/pop]]
[#$17 `[$call ~[bytecode-arr->offset a [+ i 1]]]]
[#$18 `[$try ~[bytecode-arr->offset a [+ i 1]]]]
[#$19 '[$throw]]
[#$1A `[$apply/dynamic ~[bytecode-op->int [ref a [+ i 1]]]]]
[#$1B `[$roots/push]]
[#$1C `[$roots/pop]]
[#$1D `[$roots/peek]]
[#$1E `[$<]]
[#$1F `[$<=]]
[#$20 `[$==]]
[#$21 `[$>=]]
[#$22 `[$>]]
[#$23 `[$push/symbol ~[bytecode-arr->sym a [+ i 1]]]]
[#$24 `[$push/nil]]
[#$25 `[$fn ~[bytecode-arr->val a [+ i 1]]
~[bytecode-arr->val a [+ i 4]]
~[bytecode-arr->val a [+ i 7]]
~[bytecode-arr->val a [+ i 10]]]]
[#$26 `[$macro* ~[bytecode-arr->val a [+ i 1]]
~[bytecode-arr->val a [+ i 4]]
~[bytecode-arr->val a [+ i 7]]
~[bytecode-arr->val a [+ i 10]]]]
[#$27 `[$swap]]
[otherwise :unknown-op]]]
[defn disassemble/array [a i]
"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 [array/length a]]
[set! ret [cons [cons i [disassemble/op a i]] 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 [bytecode-arr->arr code] 0]]
[defn disassemble/print [bc]
[for-in [a [disassemble/bytecode-array bc]]
[println [cat [ansi-blue [string/pad-start [string [car a]] 6]]
" - "
[cdr a]]]]]
[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,"
[case [type-of bc]
[[:lambda :macro] [disassemble/print [ref [closure bc] :code]]]
[:bytecode-array [disassemble/print bc]]
[otherwise [throw [list :type-error "Can't disassemble that" bc [current-lambda]]]]]]
[defn disassemble/test [asm]
"Verbose way of testing the disassembler"
[println [ansi-blue "--------- Assembly -----------"]]
[def cur-line 0]
[for-in [a asm]
[println [cat [ansi-yellow [string/pad-start [++ cur-line] 6]]
" - "
a]]]
[println [ansi-yellow "--------- Raw Bytecode -----------"]]
[def bc [apply assemble asm]]
[println [str/write bc]]
[println [ansi-green "--------- Now for the disassembly -----------"]]
[disassemble bc]
[println [ansi-red "--------- Fin -----------\n"]]
[try display/error [println [str/write [bytecode-eval bc]]]]]
