application/octet-stream
•
12.75 KB
•
228 lines
;;; Nujel - Copyright (C) 2020-2021 - Benjamin Vincent Schulenburg
;;; This project uses the MIT license, a copy should be included under /LICENSE
;;;
;;; Contains the Bytecode compiler that takes macroexpanded/lowered Nujel code
;;; and emits bytecode assembly
(def bytecompile* (let*
(defn bytecompile/literal (source)
(case (:type-name source)
(:int ($push/int source))
(:nil ($push/nil))
(:bool (if source
($push/true)
($push/false)))
(:symbol (list ($get/val source)))
((:native-function :lambda) (bytecompile/literal (closure/name source)))
(otherwise ($push/val source))))
(defn bytecompile/quote (source)
(case (:type-name source)
(:nil ($push/nil))
(:int ($push/int source))
(otherwise ($push/val source))))
(defn bytecompile/do/form (source env)
(when source (cons (cons (bytecompile* (car source) env)
(if (last? source) #nil
(cons ($drop) #nil)))
(bytecompile/do/form (cdr source) env))))
(defn bytecompile/do (source env)
(list (bytecompile/do/form (cdr source) env)))
(defn bytecompile/def (source env)
(when (or (not (symbol? (cadr source)))
(not (cddr source)))
(throw (list :type-error
"(def) needs a symbol name and a value as arguments" #nil env)))
(list (bytecompile* (caddr source) env)
($def/val (cadr source))))
(defn bytecompile/set! (source env)
(case (:length (cdr source))
(2 (when (not (symbol? (cadr source)))
(throw (list :type-error
"(set!) needs a symbol name and a value as arguments" #nil env)))
(list (bytecompile* (caddr source) env)
($set/val (cadr source))))
(3 (list (bytecompile* (cadr source) env)
(bytecompile* (caddr source) env)
(bytecompile* (cadddr source) env)
($set/gen)))
(otherwise (throw (list :arity-error "(set!) needs 2 or 3 arguments" #nil env)))))
(defn bytecompile/if (source env)
(let ((sym-else (gensym))
(sym-after (gensym)))
(list (bytecompile* (cadr source) env)
($jf sym-else)
(bytecompile* (caddr source) env)
($jmp sym-after)
(list :label sym-else)
(bytecompile* (cadddr source) env)
(list :label sym-after))))
(defn bytecompile/while (source env)
(def sym-start (gensym))
(def sym-end (gensym))
(list ($push/nil) ;; Return value if predicate is #f from the beginning
($jmp sym-end)
(list :label sym-start)
($drop)
(bytecompile/do/form (cddr source) env)
(list :label sym-end)
(bytecompile* (cadr source) env)
($jt sym-start)))
(defn bytecompile/procedure/arg (source env)
(if (last? source)
(bytecompile* (car source) env)
(cons (bytecompile* (car source) env)
(bytecompile/procedure/arg (cdr source) env))))
(defn bytecompile/procedure/inline? (op)
(:meta op :inline))
(defn bytecompile/procedure/inline (op args env)
(def arg-count (:length args))
(when (> arg-count 1)
(throw (list :compiler-error "For now only monadic functions can be inlined" op env)))
(def form (macroexpand* (cons 'do (:meta op :source)) env))
(def arg-name (car (:arguments op)))
(if args
(bytecompile* (list/replace form arg-name (car args)) env)
(bytecompile* form env)))
(defn bytecompile/procedure (op args env op-raw)
(if (bytecompile/procedure/inline? op)
(bytecompile/procedure/inline op args env)
(bytecompile/procedure/default op args env op-raw)))
(defn bytecompile/procedure/default (op args env op-raw)
(when (and (not (procedure? op))
(not (symbol? op))
(not (pair? op))
(not (keyword? op)))
(exception :type-error "Can't apply to that" op))
(def arg-count (:length args))
(def optimized ($apply/optimized arg-count op))
(if optimized
(list (when args (bytecompile/procedure/arg args))
optimized)
(list (bytecompile* op-raw env)
(when args (bytecompile/procedure/arg args))
($apply arg-count))))
(defn bytecompile/and/rec (source env label-end)
(list (bytecompile* (car source) env)
(when (cdr source)
(list ($dup)
($jf label-end)
($drop)
(bytecompile/and/rec (cdr source) env label-end)))))
(defn bytecompile/and (source env)
(def label-end (gensym))
(list (bytecompile/and/rec (cdr source) env label-end)
(list :label label-end)))
(defn bytecompile/or/rec (source env label-end)
(when source(list (bytecompile* (car source) env)
($dup)
($jt label-end)
($drop)
(bytecompile/or/rec (cdr source) env label-end))))
(defn bytecompile/or (source env)
(def label-end (gensym))
(list (bytecompile/or/rec (cdr source) env label-end)
($push/val #f)
(list :label label-end)))
(defn bytecompile/fn* (source env)
(def arg-count (:length (cdr source)))
(when (not= arg-count 5) (exception :arity-error "(fn*) needs exactly 4 arguments" source))
(cdr! source)
(list (bytecompile* (car source) env)
(bytecompile* (cadr source) env)
(bytecompile* (caddr source) env)
($fn/new)))
(defn bytecompile/macro* (source env)
(def arg-count (:length (cdr source)))
(when (not= arg-count 5) (exception :arity-error "(macro*) needs exactly 4 arguments" source))
(cdr! source)
(list (bytecompile* (car source) env)
(bytecompile* (cadr source) env)
(bytecompile* (caddr source) env)
($macro/new)))
(defn bytecompile/environment* (source env)
(list ($let)
(bytecompile/do/form (cdr source) env)
($drop)
($closure/push)
($closure/pop)))
(defn bytecompile/let* (source env)
(list ($let)
(bytecompile/do (cadr source) env)
($closure/pop)))
(defn bytecompile/return (source env)
(list (bytecompile* (cadr source) env)
($ret)))
(defn bytecompile/try (source env)
(def end-sym (gensym))
(list (bytecompile* (cadr source) env)
($try end-sym)
(bytecompile/do/form (cddr source) env)
($closure/pop)
(list :label end-sym)))
(defn bytecompile/apply (source env)
(def arg-count (:length (cdr source)))
(cond ((= arg-count 1)
(list (bytecompile* (cadr source) env)
($list 0)
($apply/collection)))
((= arg-count 2)
(list (bytecompile* (cadr source) env)
(bytecompile* (caddr source) env)
($apply/collection)))))
(defn bytecompile* (source env)
"Compile the forms in source"
:internal
(def op (if (resolves? (car source) env)
(ref (or env (current-closure)) (car source))
(car source)))
(case (:type-name op)
((:lambda :native-function :pair :symbol :keyword)
(case op
(do (bytecompile/do source env))
(let* (bytecompile/let* source env))
(def (bytecompile/def source env))
(set! (bytecompile/set! source env))
(if (bytecompile/if source env))
(while (bytecompile/while source env))
(and (bytecompile/and source env))
(or (bytecompile/or source env))
(fn* (bytecompile/fn* source env))
(macro* (bytecompile/macro* source env))
(environment* (bytecompile/environment* source env))
(try (bytecompile/try source env))
(return (bytecompile/return source env))
(apply (bytecompile/apply source env))
(quote (bytecompile/quote (cadr source)))
(otherwise (bytecompile/procedure op (cdr source) env (car source)))))
(otherwise (if (pair? source)
(exception :type-error "Can't evaluate that" source)
(bytecompile/literal source)))))))
(defn bytecompile (form environment)
:internal
(list (bytecompile* form environment)
($ret)))
