ref: bfe38a2454609a60bffe2f59340b075faeca7c4d
dir: /tools/gen.lsp/
(def opcodes '(
; C opcode, lisp compiler opcode, arg count, builtin lambda, DOC (NEW)
OP_LOADA0 loada0 nil nil nil
OP_LOADA1 loada1 nil nil nil
OP_LOADV loadv nil nil nil
OP_BRN brn nil nil nil
OP_POP pop nil nil nil
OP_CALL call nil nil nil
OP_TCALL tcall nil nil nil
OP_LOADG loadg nil nil nil
OP_LOADA loada nil nil nil
OP_LOADC loadc nil nil nil
OP_RET ret nil nil nil
OP_DUP dup nil nil nil
OP_CAR car 1 (λ (x) (car x)) (
((lst) "Return the first element of a list or NIL if not available."))
OP_CDR cdr 1 (λ (x) (cdr x)) (
((lst) "Return the tail of a list or NIL if not available."))
OP_CLOSURE closure nil nil nil
OP_SETA seta nil nil nil
OP_JMP jmp nil nil nil
OP_LOADC0 loadc0 nil nil nil
OP_CONSP cons? 1 (λ (x) (cons? x)) (
((value) "Return T if the value is a cons cell."))
OP_BRNE brne nil nil nil
OP_LOADT loadt nil nil nil
OP_LOAD0 load0 nil nil nil
OP_LOADC1 loadc1 nil nil nil
OP_AREF2 aref2 nil nil nil
OP_ATOMP atom? 1 (λ (x) (atom? x)) nil
OP_LOADVOID loadvoid nil nil nil
OP_BRNN brnn nil nil nil
OP_LOAD1 load1 nil nil nil
OP_LT < -1 (λ rest (apply < rest)) nil
OP_ADD2 add2 nil nil nil
OP_SETCDR set-cdr! 2 (λ (x y) (set-cdr! x y)) nil
OP_KEYARGS keyargs nil nil nil
OP_CONS cons 2 (λ (x y) (cons x y)) nil
OP_EQ eq? 2 (λ (x y) (eq? x y)) nil
OP_SYMBOLP symbol? 1 (λ (x) (symbol? x)) nil
OP_NOT not 1 (λ (x) (not x)) nil
OP_CADR cadr 1 (λ (x) (cadr x)) nil
OP_NEG neg nil nil nil
OP_NANP nan? 1 (λ (x) (nan? x)) nil
OP_BRBOUND brbound nil nil nil
OP_NUMBERP number? 1 (λ (x) (number? x)) nil
OP_FIXNUMP fixnum? 1 (λ (x) (fixnum? x)) nil
OP_BOUNDP bound? 1 (λ (x) (bound? x)) nil
OP_BUILTINP builtin? 1 (λ (x) (builtin? x)) nil
OP_FUNCTIONP function? 1 (λ (x) (function? x)) nil
OP_VECTORP vector? 1 (λ (x) (vector? x)) nil
OP_SHIFT shift nil nil nil
OP_SETCAR set-car! 2 (λ (x y) (set-car! x y)) nil
OP_JMPL jmp.l nil nil nil
OP_BRNL brn.l nil nil nil
OP_BOX box nil nil nil
OP_EQV eqv? 2 (λ (x y) (eqv? x y)) nil
OP_EQUAL equal? 2 (λ (x y) (equal? x y)) nil
OP_LIST list ANYARGS (λ rest rest) nil
OP_APPLY apply -2 (λ rest (apply apply rest)) nil
OP_ADD + ANYARGS (λ rest (apply + rest)) (
((number…) "Return sum of the numbers or 0 with no arguments."))
OP_SUB - -1 (λ rest (apply - rest)) nil
OP_MUL * ANYARGS (λ rest (apply * rest)) (
((number…) "Return product of the numbers or 1 with no arguments."))
OP_DIV / -1 (λ rest (apply / rest)) nil
OP_IDIV div0 2 (λ rest (apply div0 rest)) nil
OP_NUMEQ = -1 (λ rest (apply = rest)) nil
OP_COMPARE compare 2 (λ (x y) (compare x y)) nil
OP_ARGC argc nil nil nil
OP_VECTOR vector ANYARGS (λ rest (apply vector rest)) nil
OP_ASET aset! -3 (λ rest (apply aset! rest)) nil
OP_LOADNIL loadnil nil nil nil
OP_LOADI8 loadi8 nil nil nil
OP_LOADVL loadv.l nil nil nil
OP_LOADGL loadg.l nil nil nil
OP_LOADAL loada.l nil nil nil
OP_LOADCL loadc.l nil nil nil
OP_SETG setg nil nil nil
OP_SETGL setg.l nil nil nil
OP_SETAL seta.l nil nil nil
OP_VARGC vargc nil nil nil
OP_TRYCATCH trycatch nil nil nil
OP_FOR for 3 (λ (a b f) (for a b (λ (x) (f x)))) nil
OP_TAPPLY tapply nil nil nil
OP_SUB2 sub2 nil nil nil
OP_ARGCL argc.l nil nil nil
OP_VARGCL vargc.l nil nil nil
OP_CALLL call.l nil nil nil
OP_TCALLL tcall.l nil nil nil
OP_BRNEL brne.l nil nil nil
OP_BRNNL brnn.l nil nil nil
OP_AREF aref -2 (λ rest (apply aref rest)) nil
OP_BOXL box.l nil nil nil
OP_OPTARGS optargs nil nil nil
OP_EOF_OBJECT dummy_eof nil nil nil
))
(def (for-each-n f lst n)
(when (and (> n 0) (cons? lst))
(apply f (list-head lst n))
(for-each-n f (list-tail lst n) n)))
(let ((c-header (file "opcodes.h" :write :create :truncate))
(c-code (file "opcodes.c" :write :create :truncate))
(instructions (file "instructions.lsp" :write :create :truncate))
(builtins (file "builtins.lsp" :write :create :truncate))
(builtins-doc (file "docs_ops.lsp" :write :create :truncate))
(e (table))
(cl (table))
(ac (table))
(lms ())
(i 0))
(begin
(io-write c-header "typedef enum {\n")
(for-each-n
(λ (cop lop argc f docs)
(begin
(io-write c-header "\t")
(write cop c-header)
(io-write c-header ",\n")
(for-each (λ (doc)
(let ((docform (append `(,lop) (car doc))))
(write (append `(doc-for ,docform)
(list (cadr doc)))
builtins-doc)
(io-write builtins-doc "\n")))
docs)
(put! e lop (byte i))
(when argc
(put! cl cop (list lop argc))
(when (and (number? argc) (>= argc 0))
(put! ac lop argc)))
(set! lms (cons f lms))
(set! i (1+ i))))
opcodes 5)
(io-close builtins-doc)
(io-write c-header "\tN_OPCODES\n}sl_op;\n\n")
(io-write c-header "extern const Builtin builtins[N_OPCODES];\n")
(io-close c-header)
(io-write c-code "#include \"sl.h\"\n\n")
(io-write c-code "const Builtin builtins[N_OPCODES] = {\n")
(for-each
(λ (c la) (begin (io-write c-code "\t[")
(write c c-code)
(io-write c-code "] = {\"")
(write (car la) c-code)
(io-write c-code "\", ")
(write (cadr la) c-code)
(io-write c-code "},\n")))
cl)
(io-write c-code "};\n")
(io-close c-code)
(write `(def Instructions
"VM instructions mapped to their encoded byte representation."
,e)
instructions)
(io-write instructions "\n\n")
(write `(def arg-counts
"VM instructions mapped to their expected arguments count."
,ac)
instructions)
(io-write instructions "\n")
(io-close instructions)
(set! lms (cons vector (reverse! lms)))
(write `(def *builtins*
"VM instructions as closures."
,lms)
builtins)
(io-write builtins "\n")
(io-close builtins)))