application/octet-stream
•
7.04 KB
•
237 lines
; Contains the bytecode assembler, so we don't have to write opcodes directly
[defn val->bytecode-op [v]
[def i [val->index v]]
[list [int->bytecode-op [logand [>> i 16] #xFF]]
[int->bytecode-op [logand [>> i 8] #xFF]]
[int->bytecode-op [logand i #xFF]]]]
[defn sym->bytecode-op [v]
[def i [sym->index v]]
[list [int->bytecode-op [logand [>> i 16] #xFF]]
[int->bytecode-op [logand [>> i 8] #xFF]]
[int->bytecode-op [logand i #xFF]]]]
[defn int-fit-in-byte? [a]
[and [<= a 127] [>= a -128]]]
[defn $nop []
"- | Do nothing"
'[#$0]]
[defn $ret []
"a - | Return top of value stack"
'[#$1]]
[defn $push/int/byte [a]
"- a | Return top of value stack"
[when-not [int-fit-in-byte? a]
[throw [list :invalid-bc-op "$push/int/byte can only push a signed 8-bit value" a [current-lambda]]]]
[list #$2 [int->bytecode-op a]]]
[defn $push/int [a]
"- a | Return top of value stack"
[if [int-fit-in-byte? a]
[$push/int/byte a]
[$push/lval a]]]
[defn $add/int []
"a b - c | Adds the two topmost values and pushes the result"
'[#$3]]
[defn $debug/print-stack []
"- | Print out the stack for the current closure"
'[#$4]]
[defn $push/lval [v]
"- v | Pushes v onto the stack"
[when [nil? v]
[throw [list :invalid-bc-op "Can't push #nil as a normal lVal" v [current-lambda]]]]
[list #$5 [val->bytecode-op v]]]
[defn $push/symbol [v]
"- v | Pushes v onto the stack"
[list #$23 [sym->bytecode-op v]]]
[defn $make-list [item-count]
"items ... - list | Makes a list of item-count items from the stack and pushes the resulting list"
[list #$6 [int->bytecode-op item-count]]]
[defn $eval [a]
"form - | Evaluates the form from the top of the stack"
'[#$7]]
[defn $apply [arg-count fun]
"arguments ... - result | Read arg-count arguments from the stack, apply the to fun and push the result on the stack"
[case arg-count 2
[2 [case fun
[add/int [$add/int]]
[< [$<]]
[<= [$<=]]
[== [$==]]
[>= [$>=]]
[> [$>]]
[otherwise [list #$8
[int->bytecode-op arg-count]
[val->bytecode-op fun]]]]]
[otherwise [list #$8
[int->bytecode-op arg-count]
[val->bytecode-op fun]]]]]
[defn $apply/dynamic [arg-count fun]
[list #$1A [int->bytecode-op arg-count]]]
[defn $call [target]
" - | Call a bytecode subroutine"
[list #$17 [list :relocate target 8 0 [int->bytecode-op 0]]
[list :relocate target 0 1 [int->bytecode-op 0]]]]
[defn $try [target]
" - | Try something, jumping to target if an exception occurs"
[list #$18 [list :relocate target 8 0 [int->bytecode-op 0]]
[list :relocate target 0 1 [int->bytecode-op 0]]]]
[defn $throw []
" - | Return to the closest exception handler"
[list #$19]]
[defn $jmp [target]
[list #$9 [list :relocate target 8 0 [int->bytecode-op 0]]
[list :relocate target 0 1 [int->bytecode-op 0]]]]
[defn $jt [target]
[list #$A [list :relocate target 8 0 [int->bytecode-op 0]]
[list :relocate target 0 1 [int->bytecode-op 0]]]]
[defn $jf [target]
[list #$B [list :relocate target 8 0 [int->bytecode-op 0]]
[list :relocate target 0 1 [int->bytecode-op 0]]]]
[defn $dup []
'[#$C]]
[defn $drop []
'[#$D]]
[defn $def [v]
[list #$E [sym->bytecode-op v]]]
[defn $set [v]
[list #$F [sym->bytecode-op v]]]
[defn $get [v]
[list #$10 [sym->bytecode-op v]]]
[defn $lambda [name args docs body]
[list #$11
[val->bytecode-op name]
[val->bytecode-op args]
[val->bytecode-op docs]
[val->bytecode-op body]]]
[defn $macro [name args docs body]
[list #$12
[val->bytecode-op name]
[val->bytecode-op args]
[val->bytecode-op docs]
[val->bytecode-op body]]]
[defn $fn [name args docs body]
[list #$25
[val->bytecode-op name]
[val->bytecode-op args]
[val->bytecode-op docs]
[val->bytecode-op body]]]
[defn $macro* [name args docs body]
[list #$26
[val->bytecode-op name]
[val->bytecode-op args]
[val->bytecode-op docs]
[val->bytecode-op body]]]
[defn $closure/push []
'[#$13]]
[defn $closure/enter []
'[#$14]]
[defn $let []
'[#$15]]
[defn $closure/pop []
'[#$16]]
[defn $roots/save []
'[#$1B]]
[defn $roots/restore []
'[#$1C]]
[defn $< []
'[#$1E]]
[defn $<= []
'[#$1F]]
[defn $== []
'[#$20]]
[defn $>= []
'[#$21]]
[defn $> []
'[#$22]]
[defn $push/nil []
'[#$24]]
[defn $swap []
'[#$27]]
[defn assemble/build-sym-map [code sym-map pos]
[while code
[case [type-of [car code]]
[:bytecode-op [tree/set! sym-map :last-op [++ pos]]]
[[:symbol :keyword] [and [== [car code] :label]
[tree/set! sym-map [cadr code] pos]]]
[:pair [set! pos [assemble/build-sym-map [car code] sym-map pos]]]]
[cdr! code]]
pos]
[defn assemble/relocate-op [code sym-map pos out]
[def target [tree/ref sym-map [cadr code]]]
[def off [- [+ target [cadddr code]] pos]]
[array/set! out [++ pos] [int->bytecode-op [logand [>> off [caddr code]] #xFF]]]
pos]
[defn assemble/emit-relocated-ops [code sym-map pos out]
[if [== [car code] :relocate]
[set! pos [assemble/relocate-op code sym-map pos out]]
[for-in [op code]
[case [type-of op]
[:bytecode-op [array/set! out [++ pos] op]]
[:pair [set! pos [assemble/emit-relocated-ops op sym-map pos out]]]]]]
pos]
[def assemble/verbose #f]
[defn assemble* [code]
"Assemble all arguments into a single :bytecode-array"
[def sym-map @[]]
[and assemble/verbose [println [cat [ansi-blue "Input:\n" [str/write code]]]]]
[assemble/build-sym-map code sym-map 0]
[and assemble/verbose [println [cat [ansi-yellow "Symbol Map:\n" [str/write sym-map]]]]]
[def out [array/allocate [tree/ref sym-map :last-op]]]
[assemble/emit-relocated-ops code sym-map -1 out]
[and assemble/verbose [println [cat [ansi-green "Output:\n" [str/write out]]]]]
[arr->bytecode-arr out]]
[defn assemble l
"Assemble all arguments into a single :bytecode-array"
[assemble* l]]
[defmacro asmrun ops
"Assemble and evaluate all bytecode arguments"
`[bytecode-eval [assemble ~@ops]]]
