application/octet-stream
•
18.20 KB
•
597 lines
a;;; 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 opcode literals
;;; and emits. Additionally it calculates branch offsets using the labels provided.
(defn $nop ()
"() -> () --- Do Nothing"
:cat :bytecode
:internal
:inline
'(#x00))
(defn $ret ()
"(a) -> () --- Return top of value stack"
:cat :bytecode
:internal
:inline
'(#x01))
(defn $add/int ()
"(a b) -> (result) --- Adds the two topmost values and pushes the result"
:cat :bytecode
:internal
:inline
'(#x03))
(defn $ref ()
"(col key) -> (result) --- Looks up key in col"
:cat :bytecode
:internal
:inline
'(#x2B))
(defn $dup ()
"(a) -> (a a) --- Duplicates the value that is on the top of the stack"
:cat :bytecode
:internal
:inline
'(#x0C))
(defn $drop ()
"(a) -> () --- Drop whatever is on top of the stack"
:cat :bytecode
:internal
:inline
'(#x0D))
(defn $closure/push ()
"() -> (closure) --- Push the current closure as a λ on the stack"
:cat :bytecode
:internal
:inline
'(#x13))
(defn $let ()
"() -> () --- Create a new let closure and switch to it"
:cat :bytecode
:internal
:inline
'(#x15))
(defn $closure/pop ()
"() -> () --- Leave the current closure and return to the parent one"
:cat :bytecode
:internal
:inline
'(#x16))
(defn $< ()
"(a b) -> (bool) --- Compare A and B and push the result on the stack"
:cat :bytecode
:internal
:inline
'(#x1E))
(defn $<= ()
"(a b) -> (bool) --- Compare A and B and push the result on the stack"
:cat :bytecode
:internal
:inline
'(#x1F))
(defn $= ()
"(a b) -> (bool) --- Compare A and B and push the result on the stack"
:cat :bytecode
:internal
:inline
'(#x20))
(defn $not= ()
"(a b) -> (bool) --- Compare A and B and push the result on the stack"
:cat :bytecode
:internal
:inline
'(#x38))
(defn $>= ()
"(a b) -> (bool) --- Compare A and B and push the result on the stack"
:cat :bytecode
:internal
:inline
'(#x21))
(defn $> ()
"(a b) -> (bool) --- Compare A and B and push the result on the stack"
:cat :bytecode
:internal
:inline
'(#x22))
(defn $push/nil ()
"() -> (nil) --- Push a #nil on the stack"
:cat :bytecode
:internal
:inline
'(#x24))
(defn $car ()
"(l) -> (car) --- Replace L with its car"
:cat :bytecode
:internal
:inline
'(#x11))
(defn $cdr ()
"(l) -> (cdr) --- Replace L with its cdr"
:cat :bytecode
:internal
:inline
'(#x12))
(defn $cadr ()
"(l) -> (cadr) --- Replace L with its cadr"
:cat :bytecode
:internal
:inline
'(#x2C))
(defn $cons ()
"(car cdr) -> (pair) --- Cons CAR and CDR together and put it on the stack"
:cat :bytecode
:internal
:inline
'(#x14))
(defn $fn/new ()
"(args meta body) -> (λ) --- Create a new λ"
:cat :bytecode
:internal
:inline
'(#x17))
(defn $macro/new ()
"(args meta body) -> (μ) --- Create a new μ"
:cat :bytecode
:internal
:inline
'(#x18))
(defn $fn/dynamic ()
"(name args docs body) -> (λ) --- Create a new λ"
:cat :bytecode
:internal
:inline
'(#x2F))
(defn $macro/dynamic ()
"(name args docs body) -> (μ) --- Create a new μ"
:cat :bytecode
:internal
:inline
'(#x30))
(defn $add ()
"(a b) -> (result)"
:cat :bytecode
:internal
:inline
'(#x25))
(defn $sub ()
"(a b) -> (result)"
:cat :bytecode
:internal
:inline
'(#x26))
(defn $mul ()
"(a b) -> (result)"
:cat :bytecode
:internal
:inline
'(#x27))
(defn $div ()
"(a b) -> (result)"
:cat :bytecode
:internal
:inline
'(#x28))
(defn $rem ()
"(a b) -> (result)"
:cat :bytecode
:internal
:inline
'(#x29))
(defn $push/true ()
"() -> (#t)"
:cat :bytecode
:internal
:inline
'(#x1B))
(defn $push/false ()
"() -> (#f)"
:cat :bytecode
:internal
:inline
'(#x1C))
(defn $eval ()
"(bc env) -> (return-val)"
:cat :bytecode
:internal
:inline
'(#x1D))
(defn $mutable-eval ()
"(bc env) -> (return-val)"
:cat :bytecode
:internal
:inline
'(#x2D))
(defn $zero? ()
"(a) -> (result)"
:cat :bytecode
:internal
:inline
'(#x2A))
(defn $inc/int ()
"(a) -> (result) --- Adds 1 to the topmost int"
:cat :bytecode
:internal
:inline
'(#x23))
(defn $bit-shift-left ()
"(a b) -> (result)"
:cat :bytecode
:internal
:inline
'(#x31))
(defn $bit-shift-right ()
"(a b) -> (result)"
:cat :bytecode
:internal
:inline
'(#x32))
(defn $bit-and ()
"(a b) -> (result)"
:cat :bytecode
:internal
:inline
'(#x33))
(defn $bit-or ()
"(a b) -> (result)"
:cat :bytecode
:internal
:inline
'(#x34))
(defn $bit-xor ()
"(a b) -> (result)"
:cat :bytecode
:internal
:inline
'(#x35))
(defn $bit-not ()
"(a) -> (result)"
:cat :bytecode
:internal
:inline
'(#x36))
(defn int-fit-in-byte? (a)
(and (<= a 127) (>= a -128)))
(defn $push/int (a)
"() -> (a) --- Push A on the stack as an :int"
:cat :bytecode
:internal
(if (int-fit-in-byte? a)
($push/int/byte a)
($push/val a)))
(defn $push/int/byte (a)
"() -> (a) --- Push A on the stack as an :int that fits within a byte"
:cat :bytecode
:internal
(when-not (int-fit-in-byte? a)
(exception :invalid-bc-op "$push/int/byte can only push a signed 8-bit value" a ))
(list #x2 a))
(defn $apply/optimized (arg-count fun)
"arguments -> (result) --- Read arg-count arguments from the stack, apply the to fun and push the result on the stack"
:cat :bytecode
:internal
(when (= fun list)
(return ($list arg-count)))
(case arg-count
(1 (case fun
(car ($car))
(cdr ($cdr))
(cadr ($cadr))
(zero? ($zero?))
(inc/int ($inc/int))
(throw ($throw))
(bit-not ($bit-not))
(otherwise #nil)))
(2 (case fun
(add/int ($add/int))
(ref ($ref))
(+ ($add))
(- ($sub))
(* ($mul))
(/ ($div))
(rem ($rem))
(cons ($cons))
(< ($<))
(<= ($<=))
(= ($=))
(not= ($not=))
(>= ($>=))
(> ($>))
(bytecode-eval* ($eval))
(mutable-eval* ($mutable-eval))
(bit-shift-left ($bit-shift-left))
(bit-shift-right ($bit-shift-right))
(bit-and ($bit-and))
(bit-or ($bit-or))
(bit-xor ($bit-xor))
(otherwise #nil)))
(otherwise #nil)))
(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"
:cat :bytecode
:internal
(when (> arg-count 255)
(exception :arity-error "Functions can only take up to 255 arguments directly, try to pass a list/array/map instead" arg-count))
(list #x4 arg-count))
(defn $apply/collection ()
"(arguments function) -> (result) --- Read arg-count arguments from the stack, apply the to fun and push the result on the stack"
:cat :bytecode
:internal
(list #x30))
(defn $list (count)
"arguments -> (result) --- Read count arguments from the stack and put a list of those on the stack instead."
:cat :bytecode
:internal
(when (> count 255)
(exception :arity-error "$list can only generate lists with up to 255 arguments in one go, try and use cons instead" count))
(list #x2E count))
(defn $try (target)
"() -> () --- Try something, jumping to target if an exception occurs"
:cat :bytecode
:internal
(list #x19 (list :relocate target 8 0 0)
(list :relocate target 0 1 0)))
(defn $throw ()
"(v) -> () --- Throw an exception"
:cat :bytecode
:internal
#x2F)
(defn $jmp (target)
:cat :bytecode
:internal
(list #x9
(list :relocate target 8 0 0)
(list :relocate target 0 1 0)))
(defn $push/val (v)
"() -> (v) --- Pushes v onto the stack"
:cat :bytecode
:internal
(when (nil? v)
(exception :invalid-bc-op "Can't push #nil as a normal lVal" v ))
(list #x1A
(list :literal v)))
(defn $get/val (v)
"() -> (v) --- Resolve V and get the associated value on the stack"
:cat :bytecode
:internal
(when-not (symbol? v)
(exception :invalid-bc-op "Can only get symbol" v ))
(list #xE
(list :literal v)))
(defn $set/val (v)
"(v) -> (v) --- Resolve V and get the associated value on the stack"
:cat :bytecode
:internal
(when-not (symbol? v)
(exception :invalid-bc-op "Can only get symbol" v ))
(list #x5
(list :literal v)))
(defn $set/gen ()
"(v v v) -> (v) --- Resolve V and get the associated value on the stack"
:cat :bytecode
:internal
(list #x37))
(defn $def/val (v)
"(v) -> (v) --- Resolve V and get the associated value on the stack"
:cat :bytecode
:internal
(when-not (symbol? v)
(exception :invalid-bc-op "Can only get symbol" v ))
(list #x7
(list :literal v)))
(defn $jt (target)
:cat :bytecode
:internal
(list #xA
(list :relocate target 8 0 0)
(list :relocate target 0 1 0)))
(defn $jf (target)
:cat :bytecode
:internal
(list #xB
(list :relocate target 8 0 0)
(list :relocate target 0 1 0)))
(defn $fn (name args docs body)
:cat :bytecode
:internal
(list #x25
(val->bytecode-op name)
(val->bytecode-op args)
(val->bytecode-op docs)
(val->bytecode-op body)))
(defn $macro* (name args docs body)
:cat :bytecode
:internal
(list #x26
(val->bytecode-op name)
(val->bytecode-op args)
(val->bytecode-op docs)
(val->bytecode-op body)))
(def assemble* (let*
(defn assemble/build-sym-map (code sym-map pos)
(while code
(case (:type-name (car code))
(:int (set! sym-map :last-op (inc! pos)))
(:keyword (case (car code)
(:label (set! sym-map (cadr code) pos)
(return pos))
(:relocate (set! sym-map :last-op (inc! pos))
(return pos))
(:literal (return pos))))
(:pair (set! pos (assemble/build-sym-map (car code) sym-map pos))))
(cdr! code))
(return pos))
(defn assemble/relocate-op (code sym-map pos out)
(def target (ref sym-map (cadr code)))
(def off (- (+ target (cadddr code)) pos))
(set! out (inc! pos) (bit-and (bit-shift-right off (caddr code)) #xFF))
(return 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))
(doseq (op code pos)
(case (:type-name op)
(:int (set! out (inc! pos) op))
(:pair (set! pos (assemble/emit-relocated-ops op sym-map pos out)))))))
(defn literal-index->bytecode-op (i)
(if (< i 256)
i
(list (bit-and (bit-shift-right i 8) #xFF)
(bit-and i #xFF))))
(def *max-literal-arr* 0)
(defn assemble/add-literal (lit lit-arr)
(when (>= (:length lit-arr) 65535)
(exception :out-of-bounds "Can only store up to 255 literals per bytecode-arr" code))
(when (not= (:type-name lit) :pair)
(dotimes (i (:length lit-arr))
(when (equal? (ref lit-arr i) lit)
(return (literal-index->bytecode-op i)))))
(:length! lit-arr (+ 1 (:length lit-arr)))
(set! lit-arr (- (:length lit-arr) 1) lit)
(literal-index->bytecode-op (- (:length lit-arr) 1)))
(defn assemble/build-lit-arr (code lit-arr)
(when-not code (return #nil))
(cond ((pair? (car code))
(cons (assemble/build-lit-arr (car code) lit-arr)
(assemble/build-lit-arr (cdr code) lit-arr)))
((and (= (car code) #x1A)
(= (car (cadr code)) :literal))
(cdr! code) ; Skip the literal, especially important for :bytecode-op literals
(def index-op (assemble/add-literal (cadar code) lit-arr))
(cons (if (pair? index-op)
#x6
#x1A)
(cons index-op
(assemble/build-lit-arr (cdr code) lit-arr))))
((and (= (car code) #xE)
(= (car (cadr code)) :literal))
(cdr! code) ; Skip the literal, especially important for :bytecode-op literals
(def index-op (assemble/add-literal (cadar code) lit-arr))
(cons (if (pair? index-op)
#xF
#xE)
(cons index-op
(assemble/build-lit-arr (cdr code) lit-arr))))
((and (= (car code) #x5)
(= (car (cadr code)) :literal))
(cdr! code) ; Skip the literal, especially important for :bytecode-op literals
(def index-op (assemble/add-literal (cadar code) lit-arr))
(cons (if (pair? index-op)
#x10
#x5)
(cons index-op
(assemble/build-lit-arr (cdr code) lit-arr))))
((and (= (car code) #x7)
(= (car (cadr code)) :literal))
(cdr! code) ; Skip the literal, especially important for :bytecode-op literals
(def index-op (assemble/add-literal (cadar code) lit-arr))
(cons (if (pair? index-op)
#x8
#x7)
(cons index-op
(assemble/build-lit-arr (cdr code) lit-arr))))
((= :literal (car code))
(cdr! code) ; Skip the literal, especially important for :bytecode-op literals
(cons (assemble/add-literal (car code) lit-arr)
(assemble/build-lit-arr (cdr code) lit-arr)))
(otherwise (cons (car code)
(assemble/build-lit-arr (cdr code) lit-arr)))))
(defn assemble/flatten (code ret)
(when-not code (return ret))
(when-not (pair? code) (return ret))
(set! ret (assemble/flatten (cdr code) ret))
(if (and (pair? (car code))
(not (keyword? (caar code))))
(assemble/flatten (car code) ret)
(cons (car code) ret)))
(defn assemble* (code)
"Assemble all arguments into a single :bytecode-array"
:cat :bytecode
:internal
(def sym-map {})
(def lit-arr [])
(def tmp (-> (assemble/flatten code)
(assemble/build-lit-arr lit-arr)))
(assemble/build-sym-map tmp sym-map 0)
(def out (:alloc Array (ref sym-map :last-op)))
(assemble/emit-relocated-ops tmp sym-map -1 out)
(:bytecode-array out lit-arr))))
(defn assemble l
"Assemble all arguments into a single :bytecode-array"
:cat :bytecode
:internal
(assemble* l))
(defmacro asmrun ops
"Assemble and evaluate all bytecode arguments"
:cat :bytecode
:internal
`(bytecode-eval* (assemble ~@ops) (current-closure)))
