I have successfully added 1 + 2!!
This commit is contained in:
parent
e768d36318
commit
65675bcb00
|
@ -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)
|
||||
|
|
Loading…
Reference in a new issue