I have successfully added 1 + 2!!

This commit is contained in:
Jeremy Penner 2024-06-18 20:17:22 -04:00
parent e768d36318
commit 65675bcb00

View file

@ -15,14 +15,14 @@
; functions to have explicit type annotations
; first task: decorate types for (if (= 1 2) 3 4)
; ^i64 (if ^bool (= ^i64 (lit 1) ^i64 (lit 2)) ^i64 (lit 3) ^i64 (lit 4))
; ^f64 (if ^bool (= ^f64 (lit 1) ^f64 (lit 2)) ^f64 (lit 3) ^f64 (lit 4))
(defn expr-type [expr] (:type (meta expr)))
(defn assoc-type [expr symbol] (with-meta expr (assoc (meta expr) :type symbol)))
(defn make-type [symbol] (fn [expr] (assoc-type expr symbol)))
(def void (make-type 'void))
(def i64 (make-type 'i64))
(def f64 (make-type 'f64))
(def bool (make-type 'bool))
(defn coerce [expr typesym error]
@ -72,32 +72,40 @@
type (expr-type true-expr)]
(assoc-type (list 'if test-expr true-expr false-expr) type))))
(defn equatable-type? [typesym] (contains? #{'i64 'bool} typesym))
(defn ordered-type? [typesym] (= typesym 'i64))
(defn equatable-type? [typesym] (contains? #{'f64 'bool} typesym))
(defn ordered-type? [typesym] (= typesym 'f64))
(defn logical-type? [typesym] (= typesym 'bool))
(defn numerical-type? [typesym] (= typesym 'f64))
(defn decorate-comparison [form _ctx typecheck]
(defn decorate-binop [form compute-resulttype verb]
(m/match form
(?comparitor ?left ?right)
(let [[left-expr right-expr] (unify ?left ?right (compile-error ?right "Cannot compare incompatible types"))]
(if (typecheck (expr-type left-expr))
(bool (list '= left-expr right-expr))
(throw (compile-error left-expr ["is not comparable using " ?comparitor]))))))
(?op ?left ?right)
(let [[left-expr right-expr] (unify ?left ?right (compile-error ?right (str "Cannot " verb " incompatible types")))]
(if-let [type (compute-resulttype (expr-type left-expr))]
(assoc-type (list ?op left-expr right-expr) type)
(throw (compile-error ?right (str "Cannot " verb " values of type " type " using " ?op)))))))
(defmethod decorate-type '= [form ctx] (decorate-comparison form ctx equatable-type?))
(defmethod decorate-type 'not= [form ctx] (decorate-comparison form ctx equatable-type?))
(defmethod decorate-type '< [form ctx] (decorate-comparison form ctx ordered-type?))
(defmethod decorate-type '<= [form ctx] (decorate-comparison form ctx ordered-type?))
(defmethod decorate-type '> [form ctx] (decorate-comparison form ctx ordered-type?))
(defmethod decorate-type '>= [form ctx] (decorate-comparison form ctx ordered-type?))
(defmethod decorate-type 'and [form ctx] (decorate-comparison form ctx logical-type?))
(defmethod decorate-type 'or [form ctx] (decorate-comparison form ctx logical-type?))
(defn decorate-comparison [form typecheck]
(decorate-binop form (fn [type] (if (typecheck type) 'bool nil)) "compare"))
(defn decorate-combinator [form typecheck verb]
(decorate-binop form (fn [type] (if (typecheck type) type nil)) verb))
(defmethod decorate-type '= [form _ctx] (decorate-comparison form equatable-type?))
(defmethod decorate-type 'not= [form _ctx] (decorate-comparison form equatable-type?))
(defmethod decorate-type '< [form _ctx] (decorate-comparison form ordered-type?))
(defmethod decorate-type '<= [form _ctx] (decorate-comparison form ordered-type?))
(defmethod decorate-type '> [form _ctx] (decorate-comparison form ordered-type?))
(defmethod decorate-type '>= [form _ctx] (decorate-comparison form ordered-type?))
(defmethod decorate-type 'and [form _ctx] (decorate-combinator form logical-type? "accept"))
(defmethod decorate-type 'or [form _ctx] (decorate-combinator form logical-type? "accept"))
(defmethod decorate-type '+ [form _ctx] (decorate-combinator form numerical-type? "add"))
(defmethod decorate-type `atom [form ctx]
(cond (integer? form) (i64 `(lit ~form))
(cond (integer? form) (f64 `(lit ~form))
(boolean? form) (bool `(lit ~form))
(simple-symbol? form) (m/match (lookup ctx form)
{:local ?local-id :type ?type} (assoc-type `(local ~?local-id) ?type)
{:funcref ?funcref} ?funcref
_ (throw (compile-error form "Undefined symbol")))
:else (throw (compile-error form "Not a valid literal"))))
@ -147,38 +155,106 @@
return-type (expr-type return-expr)]
(assoc-type (apply list (concat ['do] statements [return-expr])) return-type))))
(defmulti compile-toplevel (fn [form _ctx] (form-dispatch form)))
(defmethod compile-toplevel :default [form _ctx]
(throw (compile-error form "Unrecognized form")))
(defmethod compile-toplevel 'defn [form ctx]
(m/match form
(_ (m/pred simple-symbol? ?name) . !fndef ...)
(let [funcref (typecheck-expr (apply list 'fn !fndef) ctx)
exported-funcs (lookup ctx ::exported-funcs)]
(bind! ctx ?name {:funcref funcref})
(swap! exported-funcs assoc (name ?name) (last funcref)))))
(defn new-ctx [] [(atom {::module-funcs (atom []) ::exported-funcs (atom {})})])
(def operator-assembly
{['= 'f64] [[op/f64-eq]]
['= 'bool] [[op/i32-eq]]
['not= 'f64] [[op/f64-eq] [op/i32-eqz]]
['not= 'bool] [[op/i32-ne]]
['< 'f64] [[op/f64-lt]]
['<= 'f64] [[op/f64-le]]
['> 'f64] [[op/f64-gt]]
['>= 'f64] [[op/f64-ge]]
['and 'bool] [[op/i32-and]]
['or 'bool] [[op/i32-or]]
['+ 'f64] [[op/f64-add]]})
(defmulti emit-code (fn [form] (form-dispatch form)))
(defmethod emit-code :default [form]
(m/match form
((m/and (funcref ?func-id) (m/app meta {:type ?type})) . !params ...)
(concat (mapcat emit-code !params) [[op/call ?func-id]])
(?op . !params ...)
(if-let [ops (get operator-assembly [?op (expr-type form)])]
(concat (mapcat emit-code !params) ops)
(throw (compile-error form ["Don't know how to compile" ?op])))))
(defmethod emit-code `local [form]
(m/match form (_ ?local-id) [[op/local-get ?local-id]]))
(defmethod emit-code `lit [form]
(m/match form (m/and (_ ?lit) (m/app meta {:type ?type}))
(cond
(= ?type 'f64) [[op/f64-const ?lit]]
(= ?type 'bool) [[op/i32-const (if ?lit 0xffff 0)]]
:else (throw (compile-error form "Invalid literal")))))
(defmethod emit-code 'do [form]
(mapcat #(emit-code %) (rest form)))
(defn type-to-wasmtype [type]
(m/match type
'f64 op/numtype-f64
'bool op/numtype-i32
['fn . !types ... ?return-type]
[(apply vector (map type-to-wasmtype !types))
(if (= ?return-type 'void) [] [(type-to-wasmtype ?return-type)])]))
(defn ctx-to-wasm [ctx]
(let [funcs (deref (lookup ctx ::module-funcs))
exported-funcs (deref (lookup ctx ::exported-funcs))]
(pr "generating" funcs exported-funcs)
(as-> (wasm/ctx) wasm
(reduce (fn [wasm i]
(let [{:keys [body type]} (get funcs i)]
(-> wasm
(ir/assoc-type (ir/type-signature {} (type-to-wasmtype type)))
(ir/assoc-func (ir/func {} i))
(assoc-in [:wasm/codesec i] (ir/func' {} [] (emit-code body))))))
wasm
(range (count funcs)))
(reduce (fn [wasm [name funcid]]
(assoc-in wasm [:wasm/exportsec :wasm.export/func funcid] [(ir/export' {} (binf.string/encode name))]))
wasm
exported-funcs))))
(defn compile [forms]
(let [ctx (new-ctx)]
(doseq [form forms] (compile-toplevel form ctx)) ; todo: top-level compiler
(ctx-to-wasm ctx)))
(binding [*print-meta* true]
(let [ctx [(atom {::module-funcs (atom [])})]
form '(fn [x i64 y i64 bool] (< x y))]
(let [ctx (new-ctx)
form '(fn [x f64 y f64 bool] (< x y))]
(pr (typecheck-expr form ctx))
(pr (deref (first ctx)))))
; first task: compile (+ 1 2)
; expected output:
; {:pretype []
; :posttype [:i64]
; :ops [[op/i64-const 1] [op/i64-const 2] [op/i64-add]]}
; possible intermediate output:
; {:pretype []
; :posttype [:i64]
; :subexprs [
; {:pretype [] :posttype [:i64] :ops [[op/i64-const 1]]}
; {:pretype [] :posttype [:i64] :ops [[op/i64-const 2]]}
; {:pretype [:i64 :i64] :posttype [:i64] :ops [[op/i64-add]]}
; ]}
;; ; https://github.com/kalai-transpiler/kalai
;; (defn compile-expr [expr scope expected-type]
;; (m/match expr
;; (+ ?l ?r)))
;; (def test-wasm
;; (-> (wasm/ctx)
;; (ir/assoc-type (ir/type-signature {} [[op/numtype-i32 op/numtype-i32] [op/numtype-i32]]))
;; (ir/assoc-func (ir/func {} 0))
;; (assoc-in [:wasm/codesec 0] (ir/func' {} [] [[op/local-get 0] [op/local-get 1] [op/i32-add]]))
;; (assoc-in [:wasm/exportsec :wasm.export/func 0] [(ir/export' {} (binf.string/encode "add"))])))
(def test-wasm
(-> (wasm/ctx)
(ir/assoc-type (ir/type-signature {} [[op/numtype-i32 op/numtype-i32] [op/numtype-i32]]))
(ir/assoc-func (ir/func {} 0))
(assoc-in [:wasm/codesec 0] (ir/func' {} [] [[op/local-get 0] [op/local-get 1] [op/i32-add]]))
(assoc-in [:wasm/exportsec :wasm.export/func 0] [(ir/export' {} (binf.string/encode "add"))])))
(compile
'[(defn add [left f64 right f64 f64] (+ left right))]))
(defn decompile-url [url]
(-> (js/fetch url)