I have successfully added 1 + 2!!

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)