From fca1219d2ee20a914e50e73dec07b6be0be8b5ff Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Sat, 22 Jun 2024 19:54:59 -0400 Subject: [PATCH] Refactor into modules, fix `if` typing --- notes.md | 53 +++++++ src/main/tock/compiler.cljc | 24 +++ src/main/tock/compiler/type.cljc | 158 +++++++++++++++++++ src/main/tock/compiler/util.cljs | 30 ++++ src/main/tock/compiler/wasm.cljc | 95 ++++++++++++ src/main/tock/experiment.cljs | 252 +------------------------------ 6 files changed, 363 insertions(+), 249 deletions(-) create mode 100644 notes.md create mode 100644 src/main/tock/compiler.cljc create mode 100644 src/main/tock/compiler/type.cljc create mode 100644 src/main/tock/compiler/util.cljs create mode 100644 src/main/tock/compiler/wasm.cljc diff --git a/notes.md b/notes.md new file mode 100644 index 0000000..b5b2fb4 --- /dev/null +++ b/notes.md @@ -0,0 +1,53 @@ +# type system + +data types: + +i64, f64 - numbers +bool - logical boolean values +{fn [type1 type2 ... -> rettype]} + +{array [type length]} + +(struct name + ^type1 member1 + ^type2 member2 + ^type3 member3) +{tuple [^{name member1} type1 ^{name member2} type2 ^{name member3} type3]} + +(enum name + (clause1 type1 type2 ...) + (clause2 type1 type2 ...) + clause3) +{variant [^{tuple [type1 type2 ...]} clause1 + ^{tuple [type1 type2 ...]} clause2 + ^void clause3]} + +(protocol name + (method name [self ^type1 arg1 ^type2 arg2 -> rettype])) + +(impl protocol type + (method name [self ^type1 arg1 ^type2 arg2 -> rettype] + body...)) + +Variables have both a datatype and an isolation modifier. There are three possible isolation types: + +* `const` - this is the default, if no isolation modifier is given. No in-place mutations are possible with `const` values. +* `val` - a `val` variable can be mutated in-place, but changes _only_ affect that variable. If it is assigned to any other + variable or passed as a parameter, it is copied if necessary and can be treated as a new, totally distinct value. +* `ref` - a `ref` is analogous to a full pointer or object reference. Copies of the same `ref` can exist in multiple places, + and refer to the same object in memory. Changes to data mutated via a `ref` are immediately visible to any other + code that has the same `ref`. + +When defining data structures, individual members can be annotated as `ref`, but not `const` or `val` - only the structure +as a whole can be `const` or `val`. + +Q: should `const` structures be able to modify `ref` members directly? leaning towards yes. `ref` seems to inherently imply + interior mutability. + +# memory management + +* "hot reload" implies "given the previous source code and a memory, I can reason about the types of everything in the memory" +* compacting garbage collection is simply the degenerate case of rearranging memory to be legible to new code! +* we have typed roots (globals), and we can follow typed references from there + * stack is not accessible from wasm, and GC / reload would only happen when wasm code returns to JS - no suspension + diff --git a/src/main/tock/compiler.cljc b/src/main/tock/compiler.cljc new file mode 100644 index 0000000..db0a394 --- /dev/null +++ b/src/main/tock/compiler.cljc @@ -0,0 +1,24 @@ +(ns tock.compiler + (:require [tock.compiler.util :refer [form-dispatch compile-error lookup bind!] :as u] + [tock.compiler.type :refer [typecheck-expr]] + [tock.compiler.wasm :refer [ctx-to-wasm]] + [meander.epsilon :as m])) + +(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 ::u/exported-funcs)] + (bind! ctx ?name {:funcref funcref}) + (swap! exported-funcs assoc (name ?name) (last funcref))))) + +(defn new-ctx [] [(atom {::u/module-funcs (atom []) ::u/exported-funcs (atom {})})]) + +(defn compile [forms] + (let [ctx (new-ctx)] + (doseq [form forms] (compile-toplevel form ctx)) + (ctx-to-wasm ctx))) \ No newline at end of file diff --git a/src/main/tock/compiler/type.cljc b/src/main/tock/compiler/type.cljc new file mode 100644 index 0000000..f5fb9d5 --- /dev/null +++ b/src/main/tock/compiler/type.cljc @@ -0,0 +1,158 @@ +(ns tock.compiler.type + (:require [meander.epsilon :as m] + [tock.compiler.util :refer [bind! compile-error form-dispatch lookup map-subexpressions new-scope] :as u])) + +; there are two type syntaxes: + +; 1. internal syntax - always stored in a form's metadata under the :type key. fetched with `expr-type`, added by +; `decorate-type`. generally is either a bare symbol, or for parameterized types, a dynamic +; variant stored as a vector, like ['fn type type type]. + +; 2. input syntax - stored in metadata with ^{} prefix syntax. converted to tock's internal syntax with `syntax-type`. +; generally, type names are stored as {:tag 'name}, and parameterized types like ['enum ...] are +; written in the input as ^{enum [...]}. (if there is only one parameter, the vector is skipped). + +(defn syntax-type [metadata _ctx error] + (m/match metadata + (m/pred symbol? ?symbol) ?symbol + {:tag ?symbol} ?symbol + {:fn [!type ... '-> ?return-type]} (apply vector (concat '[fn] !type [?return-type])) + {:fn [!type ...]} (apply vector (concat '[fn] !type '[void])) + _ (when error (throw error)))) + +(defn expr-type [expr] (:type (meta expr))) +(defn assoc-type [expr symbol] (with-meta expr (assoc (meta expr) :type symbol))) + +;; built-in types +(defn make-type [symbol] (fn [expr] (assoc-type expr symbol))) +(def void (make-type 'void)) +(def f64 (make-type 'f64)) +(def bool (make-type 'bool)) + +;; typechecking helpers +(defn coerce [expr typesym error] + (let [ltype (expr-type expr)] + (cond (= ltype typesym) expr + (= typesym 'void) (void `(u/cast ~expr)) + :else (throw error)))) + +(defn unify [lexpr rexpr error] + (let [ltype (expr-type lexpr) + rtype (expr-type rexpr)] + (cond (= ltype rtype) [lexpr rexpr] + (nil? error) [(coerce lexpr 'void nil) (coerce rexpr 'void nil)] + :else (throw error)))) + +;; The typechecker itself! +;; This is currently doing several jobs at once: +;; 1. Convert from input syntax to internal syntax (wrapping literal values in (`lit) so they can have +;; metadata attached) +;; 2. Attach type metadata for each subexpression +;; 3. Validate that the calculated type actually makes sense +;; 4. Create bindings for local variables and function parameters when defined +;; 5. Replace naked references to locals with wrapper syntax specifying exactly where the value comes from +;; (such as (`local index)) +;; 6. Mark expressions where returned values need to be explicitly discarded (`cast 'void) + +;; todo: +;; - implicitly coerce numeric values when it can be done losslessly + +;; External syntax uses simple namespaceless 'symbols, internal syntax uses `symbols + +(defmulti decorate-type (fn [form _ctx] (form-dispatch form))) +(defmethod decorate-type 'if [form _ctx] + (m/match form + (_ ?test ?when-true ?when-false) + (let [test-expr (coerce ?test 'bool (compile-error ?test "Condition must be a boolean expression")) + [true-expr false-expr] (unify ?when-true ?when-false nil) + type (expr-type true-expr)] + (assoc-type (list 'if test-expr true-expr false-expr) type)))) + +(defn equatable-type? [typesym] (contains? #{'f64 'i32 'bool} typesym)) +(defn ordered-type? [typesym] (= typesym 'f64)) +(defn logical-type? [typesym] (= typesym 'bool)) +(defn numerical-type? [typesym] (= typesym 'f64)) + +(defn decorate-binop [form compute-resulttype verb] + (m/match form + (?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))))))) + +(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 '- [form _ctx] (decorate-combinator form numerical-type? "subtract")) +(defmethod decorate-type '* [form _ctx] (decorate-combinator form numerical-type? "multiply")) +(defmethod decorate-type '/ [form _ctx] (decorate-combinator form numerical-type? "divide")) + +(defmethod decorate-type `u/atom [form ctx] + (cond (integer? form) (f64 `(u/lit ~form)) + (boolean? form) (bool `(u/lit ~form)) + (simple-symbol? form) (m/match (lookup ctx form) + {:local ?local-id :type ?type} (assoc-type `(u/local ~?local-id) ?type) + {:funcref ?funcref} ?funcref + _ (throw (compile-error form "Undefined symbol"))) + :else (throw (compile-error form "Not a valid literal")))) + +(defmulti typecheck-expr (fn [form _ctx] (form-dispatch form))) +(defmethod typecheck-expr :default [form ctx] + (decorate-type (map-subexpressions form #(typecheck-expr % ctx)) ctx)) + +; todo: actually validate types +(defn validate-type [type] type) + +; (fn [^type name ^type name -> return-type] body) +(defn alloc-local [ctx] + (swap! (lookup ctx ::u/lastlocal) inc)) + +; todo: must store function metadata globally +(defn alloc-func [ctx func-type func-body] + (let [funcs (swap! (lookup ctx ::u/module-funcs) + (fn [funcs] + (conj funcs {:type func-type :body func-body})))] + (- (count funcs) 1))) + +(defn bind-params! [params ctx] + (let [bind-param! (fn [name type] + (bind! ctx name {:local (alloc-local ctx) + :type (validate-type type)})) + bind-all! (fn [names return-type] + (doseq [name names] (bind-param! name (syntax-type (meta name) ctx (compile-error name "Expected explicit type")))) + (apply vector (concat ['fn] + (map #(syntax-type (meta %) ctx nil) names) + [(syntax-type return-type ctx (compile-error return-type "Invalid return type"))])))] + (m/match params + [!name ... '-> ?return-type] (bind-all! !name ?return-type) + [!name ...] (bind-all! !name 'void)))) + +(defmethod typecheck-expr 'fn [form ctx] + (let [fn-ctx (new-scope ctx {::u/lastlocal (atom -1)})] + (m/match form + (_ ?params . !body ..1) + (let [fn-type (bind-params! ?params fn-ctx) + return-type (last fn-type) + body-expr (coerce (typecheck-expr (apply list 'do !body) fn-ctx) return-type + (compile-error form ["Expected return type" return-type]))] + (assoc-type (list 'funcref (alloc-func ctx fn-type body-expr)) fn-type))))) + +(defmethod typecheck-expr 'do [form ctx] + (m/match form + (_ . !statement ... ?return-expr) + (let [statements (apply list (map (fn [expr] (coerce (typecheck-expr expr ctx) 'void nil)) !statement)) + return-expr (typecheck-expr ?return-expr ctx) + return-type (expr-type return-expr)] + (assoc-type (apply list (concat ['do] statements [return-expr])) return-type)))) diff --git a/src/main/tock/compiler/util.cljs b/src/main/tock/compiler/util.cljs new file mode 100644 index 0000000..6145aff --- /dev/null +++ b/src/main/tock/compiler/util.cljs @@ -0,0 +1,30 @@ +(ns tock.compiler.util) + +(defn compile-error [term message] + ; todo: extract location of error term + (js/Error. [term message])) + +(defn form-dispatch [form] + (if (list? form) (first form) 'tock.compiler.util/atom)) + +; not sure about this... in non-special-form cases, all first values are subexpressions +; as well, it's simply not needed for decorate-type, as in order to typecheck any special +; form, you need to explicitly recurse anyway +(defmulti map-subexpressions (fn [form _f] (form-dispatch form))) +(defmethod map-subexpressions :default [form f] + (apply list (first form) (map f (rest form)))) +(defmethod map-subexpressions 'tock.compiler.util/atom [form _f] form) + +; ctx is a vector of atoms of maps +(defn new-scope + ([ctx base] (conj ctx (atom base))) + ([ctx] (new-scope ctx {}))) + +(defn lookup [ctx key] + (loop [scopes (reverse ctx)] + (when (seq scopes) + (let [scope (deref (first scopes)) + value (get scope key)] + (if (nil? value) (recur (rest scopes)) value))))) +(defn bind! [ctx key data] + (swap! (last ctx) assoc key data)) diff --git a/src/main/tock/compiler/wasm.cljc b/src/main/tock/compiler/wasm.cljc new file mode 100644 index 0000000..aab80cc --- /dev/null +++ b/src/main/tock/compiler/wasm.cljc @@ -0,0 +1,95 @@ +(ns tock.compiler.wasm + (:require [helins.wasm :as wasm] + [helins.wasm.ir :as ir] + [helins.wasm.bin :as op] + [helins.binf.string :as binf.string] + [tock.compiler.util :refer [compile-error form-dispatch lookup] :as u] + [tock.compiler.type :refer [expr-type]] + [meander.epsilon :as m])) + +(def operator-assembly + {['= 'f64] [[op/f64-eq]] + ['= 'i32] [[op/i32-eq]] + ['= 'bool] [[op/i32-eq]] + ['not= 'f64] [[op/f64-eq] [op/i32-eqz]] + ['not= 'i32] [[op/i32-ne]] + ['not= 'bool] [[op/i32-ne]] + ['< 'f64] [[op/f64-lt]] + ['<= 'f64] [[op/f64-le]] + ['> 'f64] [[op/f64-gt]] + ['>= 'f64] [[op/f64-ge]] + ['< 'i32] [[op/i32-lt_s]] + ['<= 'i32] [[op/i32-le_s]] + ['> 'i32] [[op/i32-gt_s]] + ['>= 'i32] [[op/i32-ge_s]] + ['and 'bool] [[op/i32-and]] + ['or 'bool] [[op/i32-or]] + ['+ 'f64] [[op/f64-add]] + ['+ 'i32] [[op/i32-add]] + ['- 'f64] [[op/f64-sub]] + ['- 'i32] [[op/i32-sub]] + ['* 'f64] [[op/f64-mul]] + ['* 'i32] [[op/i32-mul]] + ['/ 'f64] [[op/f64-div]] + ['/ 'i32] [[op/i32-div_s]]}) + +(defn type-to-wasmtype [type] + (m/match type + 'f64 op/numtype-f64 + 'bool op/numtype-i32 + 'void op/blocktype-nil + ['fn . _ ...] op/numtype-i32)) + +(defn wasm-function-signature [type] + (m/match type + ['fn . !types ... ?return-type] + [(apply vector (map type-to-wasmtype !types)) + (if (= ?return-type 'void) [] [(type-to-wasmtype ?return-type)])])) +(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 `u/local [form] + (m/match form (_ ?local-id) [[op/local-get ?local-id]])) + +(defmethod emit-code `u/lit [form] + (m/match form (m/and (_ ?lit) (m/app meta {:type ?type})) + (cond + (= ?type 'i32) [[op/i32-const ?lit]] + (= ?type 'i64) [[op/i64-const ?lit]] + (= ?type 'f64) [[op/f64-const ?lit]] + (= ?type 'bool) [[op/i32-const (if ?lit 1 0)]] + :else (throw (compile-error form "Invalid literal"))))) + +(defmethod emit-code 'do [form] + (mapcat #(emit-code %) (rest form))) + +(defmethod emit-code 'if [form] + (m/match form + (_ ?cond ?when-true ?when-false) + (concat (emit-code ?cond) [[op/if- [:wasm/valtype (type-to-wasmtype (expr-type form))] (emit-code ?when-true) (emit-code ?when-false)]]))) + +(defn ctx-to-wasm [ctx] + (let [funcs (deref (lookup ctx ::u/module-funcs)) + exported-funcs (deref (lookup ctx ::u/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 {} (wasm-function-signature type))) + (ir/assoc-func (ir/func {} i)) + (assoc-in [:wasm/codesec i] (ir/func' {} [] (apply vector (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)))) diff --git a/src/main/tock/experiment.cljs b/src/main/tock/experiment.cljs index 69e7e50..bda7643 100644 --- a/src/main/tock/experiment.cljs +++ b/src/main/tock/experiment.cljs @@ -1,260 +1,14 @@ (ns tock.experiment (:require [helins.wasm :as wasm] - [helins.wasm.ir :as ir] - [helins.wasm.bin :as op] [helins.binf :as binf] - [helins.binf.string :as binf.string] - [meander.epsilon :as m])) + [tock.compiler :refer [compile]])) -(defn compile-error [term message] - ; todo: extract location of error term - (js/Error. [term message])) - -; typechecking pass: rewrite expressions with type decorations, depth-first. -; I can't think of any reason this shouldn't work fine, as long as we require -; functions to have explicit type annotations - -; first task: decorate types for (if (= 1 2) 3 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 f64 (make-type 'f64)) -(def bool (make-type 'bool)) - -(defn coerce [expr typesym error] - (let [ltype (expr-type expr)] - (cond (= ltype typesym) expr - (= typesym 'void) (void `(cast ~expr)) - :else (throw error)))) - -(defn unify [lexpr rexpr error] - (let [ltype (expr-type lexpr) - rtype (expr-type rexpr)] - (cond (= ltype rtype) [lexpr rexpr] - (nil? error) [(coerce lexpr 'void nil) (coerce rexpr 'void nil)] - :else (throw error)))) - -(defn form-dispatch [form] - (if (list? form) (first form) `atom)) - -; not sure about this... in non-special-form cases, all first values are subexpressions -; as well, it's simply not needed for decorate-type, as in order to typecheck any special -; form, you need to explicitly recurse anyway -(defmulti map-subexpressions (fn [form _f] (form-dispatch form))) -(defmethod map-subexpressions :default [form f] - (apply list (first form) (map f (rest form)))) -(defmethod map-subexpressions `atom [form _f] form) - -; ctx is a vector of atoms of maps -(defn new-scope - ([ctx base] (conj ctx (atom base))) - ([ctx] (new-scope ctx {}))) - -(defn lookup [ctx key] - (loop [scopes (reverse ctx)] - (when (seq scopes) - (let [scope (deref (first scopes)) - value (get scope key)] - (if (nil? value) (recur (rest scopes)) value))))) -(defn bind! [ctx key data] - (swap! (last ctx) assoc key data)) - -(defmulti decorate-type (fn [form _ctx] (form-dispatch form))) -(defmethod decorate-type 'if [form _ctx] - (m/match form - (_ ?test ?when-true ?when-false) - (let [test-expr (coerce ?test 'bool (compile-error ?test "Condition must be a boolean expression")) - [true-expr false-expr] (unify ?when-true ?when-false nil) - type (expr-type true-expr)] - (assoc-type (list 'if test-expr true-expr false-expr) type)))) - -(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-binop [form compute-resulttype verb] - (m/match form - (?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))))))) - -(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) (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")))) - -(defmulti typecheck-expr (fn [form _ctx] (form-dispatch form))) -(defmethod typecheck-expr :default [form ctx] - (decorate-type (map-subexpressions form #(typecheck-expr % ctx)) ctx)) - -; todo: actually validate types -(defn validate-type [type] type) - -; (fn [name type name type return-type] body) -(defn alloc-local [ctx] - (swap! (lookup ctx ::lastlocal) inc)) -; todo: must store function metadata globally -(defn alloc-func [ctx func-type func-body] - (let [funcs (swap! (lookup ctx ::module-funcs) - (fn [funcs] - (conj funcs {:type func-type :body func-body})))] - (- (count funcs) 1))) - -(defn bind-params! [params ctx] - (let [bind-param! (fn [name type] - (bind! ctx name {:local (alloc-local ctx) - :type (validate-type type)})) - bind-all! (fn [names types return-type] - (doseq [[name type] (map vector names types)] (bind-param! name type)) - (apply vector (concat ['fn] types [return-type])))] - (m/match params - [!name !type ... ?return-type] (bind-all! !name !type ?return-type) - [!name !type ...] (bind-all! !name !type 'void)))) - -(defmethod typecheck-expr 'fn [form ctx] - (let [fn-ctx (new-scope ctx {::lastlocal (atom -1)})] - (m/match form - (_ ?params . !body ..1) - (let [fn-type (bind-params! ?params fn-ctx) - return-type (last fn-type) - body-expr (coerce (typecheck-expr (apply list 'do !body) fn-ctx) return-type - (compile-error form ["Expected return type" return-type]))] - (assoc-type (list 'funcref (alloc-func ctx fn-type body-expr)) fn-type))))) - -(defmethod typecheck-expr 'do [form ctx] - (m/match form - (_ . !statement ... ?return-expr) - (let [statements (apply list (map (fn [expr] (coerce (typecheck-expr expr ctx) 'void nil)) !statement)) - return-expr (typecheck-expr ?return-expr ctx) - 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 (new-ctx) - form '(fn [x f64 y f64 bool] (< x y))] - (pr (typecheck-expr form ctx)) - (pr (deref (first ctx))))) ;; ; https://github.com/kalai-transpiler/kalai -;; (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 (compile - '[(defn add [left f64 right f64 f64] (+ left right))])) + '[(defn thing [^bool op ^f64 val -> f64] (if op (+ val 1) (* val 2)))])) (defn decompile-url [url] (-> (js/fetch url) @@ -272,6 +26,6 @@ (defn main [] (js/console.log test-wasm) (-> (instantiate-wasm test-wasm #js {}) - (.then #(js/console.log (-> % (.-instance) (.-exports) (.add 1 2))))) + (.then #(js/console.log (-> % (.-instance) (.-exports) (.thing false 2))))) (-> (decompile-url "release.wasm") (.then #(js/console.log (-> % :wasm/exportsec :wasm.export/func (get 0))))))