Ben / Nujel

;; Nujel - Copyright (C) 2020-2021 - Benjamin Vincent Schulenburg
;; This project uses the MIT license, a copy should be included under /LICENSE
;;
;; 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 $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 $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 $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 $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 $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]]]