Refactor into modules, fix if typing
This commit is contained in:
parent
65675bcb00
commit
fca1219d2e
53
notes.md
Normal file
53
notes.md
Normal file
|
|
@ -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
|
||||
|
||||
24
src/main/tock/compiler.cljc
Normal file
24
src/main/tock/compiler.cljc
Normal file
|
|
@ -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)))
|
||||
158
src/main/tock/compiler/type.cljc
Normal file
158
src/main/tock/compiler/type.cljc
Normal file
|
|
@ -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))))
|
||||
30
src/main/tock/compiler/util.cljs
Normal file
30
src/main/tock/compiler/util.cljs
Normal file
|
|
@ -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))
|
||||
95
src/main/tock/compiler/wasm.cljc
Normal file
95
src/main/tock/compiler/wasm.cljc
Normal file
|
|
@ -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))))
|
||||
|
|
@ -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))))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue