diff --git a/src/main/tock/experiment.cljs b/src/main/tock/experiment.cljs index c50359f..69e7e50 100644 --- a/src/main/tock/experiment.cljs +++ b/src/main/tock/experiment.cljs @@ -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)