application/octet-stream
•
16.92 KB
•
536 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
:internal
:inline
'(#x00))
(defn $ret ()
; (a) -> () --- Return top of value stack
:internal
:inline
'(#x01))
(defn $add/int ()
; (a b) -> (result) --- Adds the two topmost values and pushes the result
:internal
:inline
'(#x03))
(defn $ref ()
; (col key) -> (result) --- Looks up key in col
:internal
:inline
'(#x2B))
(defn $dup ()
; (a) -> (a a) --- Duplicates the value that is on the top of the stack
:internal
:inline
'(#x0C))
(defn $drop ()
; (a) -> () --- Drop whatever is on top of the stack
:internal
:inline
'(#x0D))
(defn $closure/push ()
; () -> (closure) --- Push the current closure as a λ on the stack
:internal
:inline
'(#x13))
(defn $let ()
; () -> () --- Create a new let closure and switch to it
:internal
:inline
'(#x15))
(defn $closure/pop ()
; () -> () --- Leave the current closure and return to the parent one
: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
:internal
:inline
'(#x1F))
(defn $= ()
; (a b) -> (bool) --- Compare A and B and push the result on the stack
:internal
:inline
'(#x20))
(defn $not= ()
; (a b) -> (bool) --- Compare A and B and push the result on the stack
:internal
:inline
'(#x38))
(defn $>= ()
; (a b) -> (bool) --- Compare A and B and push the result on the stack
:internal
:inline
'(#x21))
(defn $> ()
; (a b) -> (bool) --- Compare A and B and push the result on the stack
:internal
:inline
'(#x22))
(defn $push/nil ()
; () -> (nil) --- Push a #nil on the stack
:internal
:inline
'(#x24))
(defn $car ()
; (l) -> (car) --- Replace L with its car
:internal
:inline
'(#x11))
(defn $cdr ()
; (l) -> (cdr) --- Replace L with its cdr
:internal
:inline
'(#x12))
(defn $cadr ()
; (l) -> (cadr) --- Replace L with its cadr
:internal
:inline
'(#x2C))
(defn $cons ()
; (car cdr) -> (pair) --- Cons CAR and CDR together and put it on the stack
:internal
:inline
'(#x14))
(defn $fn/new ()
; (args meta body) -> (λ) --- Create a new λ
:internal
:inline
'(#x17))
(defn $macro/new ()
; (args meta body) -> (μ) --- Create a new μ
:internal
:inline
'(#x18))
(defn $fn/dynamic ()
; (name args docs body) -> (λ) --- Create a new λ
:internal
:inline
'(#x2F))
(defn $macro/dynamic ()
; (name args docs body) -> (μ) --- Create a new μ
:internal
:inline
'(#x30))
(defn $add ()
; (a b) -> (result)
:internal
:inline
'(#x25))
(defn $sub ()
; (a b) -> (result)
:internal
:inline
'(#x26))
(defn $mul ()
; (a b) -> (result)
:internal
:inline
'(#x27))
(defn $div ()
; (a b) -> (result)
:internal
:inline
'(#x28))
(defn $rem ()
; (a b) -> (result)
:internal
:inline
'(#x29))
(defn $push/true ()
; () -> (#t)
:internal
:inline
'(#x1B))
(defn $push/false ()
; () -> (#f)
:internal
:inline
'(#x1C))
(defn $eval ()
; (bc env) -> (return-val)
:internal
:inline
'(#x1D))
(defn $mutable-eval ()
; (bc env) -> (return-val)
:internal
:inline
'(#x2D))
(defn $zero? ()
; (a) -> (result)
:internal
:inline
'(#x2A))
(defn $inc/int ()
; (a) -> (result) --- Adds 1 to the topmost int
:internal
:inline
'(#x23))
(defn $bit-shift-left ()
; (a b) -> (result)
:internal
:inline
'(#x31))
(defn $bit-shift-right ()
; (a b) -> (result)
:internal
:inline
'(#x32))
(defn $bit-and ()
; (a b) -> (result)
:internal
:inline
'(#x33))
(defn $bit-or ()
; (a b) -> (result)
:internal
:inline
'(#x34))
(defn $bit-xor ()
; (a b) -> (result)
:internal
:inline
'(#x35))
(defn $bit-not ()
; (a) -> (result)
: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
: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
: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
: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
: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
:internal
(list #x30))
(defn $list (count)
; arguments -> (result) --- Read count arguments from the stack and put a list of those on the stack instead.
: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
:internal
(list #x19 (list :relocate target 8 0 0)
(list :relocate target 0 1 0)))
(defn $throw ()
; (v) -> () --- Throw an exception
:internal
#x2F)
(defn $jmp (target)
: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
: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
: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
: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
:internal
(list #x37))
(defn $def/val (v)
; (v) -> (v) --- Resolve V and get the associated value on the stack
:internal
(when-not (symbol? v)
(exception :invalid-bc-op "Can only get symbol" v ))
(list #x7
(list :literal v)))
(defn $jt (target)
:internal
(list #xA
(list :relocate target 8 0 0)
(list :relocate target 0 1 0)))
(defn $jf (target)
:internal
(list #xB
(list :relocate target 8 0 0)
(list :relocate target 0 1 0)))
(defn $fn (name args docs body)
: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)
: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
: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"
:internal
(assemble* l))
(defmacro asmrun ops
"Assemble and evaluate all bytecode arguments"
:internal
`(bytecode-eval* (assemble ~@ops) (current-closure)))
