From 7bf14eb50824fcfc2872f69e544bbfadc9cd93e4 Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Mon, 5 Aug 2024 22:46:47 -0400 Subject: [PATCH] Move wasm emission logic into specials.cljc, specials into program --- src/main/tock/compiler.cljc | 22 ++-- src/main/tock/compiler/specials.cljc | 151 ++++++++++++++++++++++----- src/main/tock/compiler/wasm.cljc | 144 ++++--------------------- src/main/tock/experiment.cljs | 2 +- 4 files changed, 155 insertions(+), 164 deletions(-) diff --git a/src/main/tock/compiler.cljc b/src/main/tock/compiler.cljc index 88dfa84..24174ad 100644 --- a/src/main/tock/compiler.cljc +++ b/src/main/tock/compiler.cljc @@ -3,7 +3,7 @@ [tock.compiler.bind :refer [bind]] [tock.compiler.specials :refer [specials]] [tock.compiler.type :refer [typecheck]] - [tock.compiler.wasm :refer [collect-definitions]])) + [tock.compiler.wasm :refer [make-empty-program collect-definitions]])) ;; compiler structure: ;; a quoted form is passed through a series of passes: @@ -39,16 +39,18 @@ ;; 6. codegen pass ;; * function expression trees are recursively walked to generate linear wasm bytecode -(def empty-program tock.compiler.wasm/empty-program) (def generate-wasm tock.compiler.wasm/generate-wasm) (defn compile-form [program form] - (-> form - (desugar specials) - (bind specials [(atom (:globals program))]) - (typecheck specials) - (collect-definitions program))) + (let [specials (:specials program)] + (-> form + (desugar specials) + (bind specials [(atom (:globals program))]) + (typecheck specials) + (collect-definitions program)))) -(defn compile [forms] - (-> (reduce compile-form empty-program forms) - generate-wasm)) +(defn compile + ([forms] (compile forms specials)) + ([forms specials] + (-> (reduce compile-form (make-empty-program specials) forms) + generate-wasm))) diff --git a/src/main/tock/compiler/specials.cljc b/src/main/tock/compiler/specials.cljc index 613b896..325fd54 100644 --- a/src/main/tock/compiler/specials.cljc +++ b/src/main/tock/compiler/specials.cljc @@ -1,6 +1,7 @@ (ns tock.compiler.specials (:require [meander.epsilon :as m] [meander.strategy.epsilon :as r] + [helins.wasm.bin :as op] [tock.compiler.meander :refer [parse-type to-sym label m+]])) ;; no namespace - source symbol @@ -35,23 +36,28 @@ ('i/if ?m) ('do ?m) ('i/if _ ?else) (label ?else "else block") ('i/if ?m ?cond ?body & ?more) ('l/if ?m (label ?cond "condition") - (label ?body "body") - ('i/if {} & ?more))) + (label ?body "body") + ('i/if {} & ?more))) :validate (r/rewrite ('if _) "if statement needs at least a condition and a body" ('if _ _) "if statement needs at least one body expression") - :typecheck (r/rewrite (_ ?cond ?l ?r) [[?l 'bool ?l ?l] [?r 'bool ?r ?r] ['void 'bool 'void 'void]])} - + :typecheck (r/rewrite (_ ?cond ?l ?r) [[?l 'bool ?l ?l] [?r 'bool ?r ?r] ['void 'bool 'void 'void]]) + :emit (fn [form emit] + (m/match form + ('l/if {:type ?type} ?cond ?l ?r) + (concat (emit ?cond) + [[op/if- [:wasm/valtype ?type] (emit ?l) (emit ?r)]])))} + 'l/fn {:desugar (r/rewrite - ('fn {& ?m} (m/pred symbol? ?name) & ?rest) + ('fn {& ?m} (m/pred symbol? ?name) & ?rest) ('def {:name ?name} ('fn {:name ?name & ?m} & ?rest)) ('fn {& ?m} [(m/app (fn [params] [params (parse-type (meta params))]) [(m/pred symbol? !names) {:type !types}]) ... (m/app to-sym '->) (m/app parse-type {:type !types})] & ?body) ('l/fn (m/app merge ?m {:type ['fn . !types ...] :params [!names ...]}) - ('do {} & ?body)) - + ('do {} & ?body)) + ('fn {& ?m} [(m/app (fn [params] [params (parse-type (meta params))]) [(m/pred symbol? !names) {:type !types}]) ...] & ?body) ('l/fn (m/app merge ?m {:type ['fn . !types ... 'void] :params [!names ...]}) @@ -60,29 +66,73 @@ :scope {:local-counter 0 :valid-binding-forms #{'l/local 'l/param}} :new-bindings (fn [form _ctx] (into {} (map-indexed (fn [index [name type]] [name (list 'l/param {:type type :name name :index index})]) - (m/rewrite form + (m/rewrite form ('l/fn {:params [!names ...] :type ['fn . !types ... _]} _) - [[!names !types] ...]))))} + [[!names !types] ...])))) + :emit (fn [form emit] + (m/match form ('l/fn _ ?expr) (emit ?expr)))} '+ {:desugar (left-binop-desugar '+) - :typecheck (combinator-typecheck numerical-type?)} + :typecheck (combinator-typecheck numerical-type?) + :ops {['i64 'i64] [[op/i64-add]] + ['i32 'i32] [[op/i32-add]] + ['f64 'f64] [[op/f64-add]]}} '- {:desugar (r/choice (r/rewrite ('- ?m ?v) ('- ?m ('l/lit {:value 0 :type 'i64}) ?v)) (left-associative '-)) - :typecheck (combinator-typecheck numerical-type?)} + :typecheck (combinator-typecheck numerical-type?) + :ops {['i64 'i64] [[op/i64-sub]] + ['i32 'i32] [[op/i32-sub]] + ['f64 'f64] [[op/f64-sub]]}} '* {:desugar (left-binop-desugar '*) - :typecheck (combinator-typecheck numerical-type?)} + :typecheck (combinator-typecheck numerical-type?) + :ops {['i64 'i64] [[op/i64-mul]] + ['i32 'i32] [[op/i32-mul]] + ['f64 'f64] [[op/f64-mul]]}} '/ {:desugar (left-binop-desugar '/) - :typecheck (combinator-typecheck numerical-type?)} - '= {:typecheck (comparitor-typecheck equatable-type?)} - 'not= {:typecheck (comparitor-typecheck equatable-type?)} - '< {:typecheck (comparitor-typecheck ordered-type?)} - '<= {:typecheck (comparitor-typecheck ordered-type?)} - '> {:typecheck (comparitor-typecheck ordered-type?)} - '>= {:typecheck (comparitor-typecheck ordered-type?)} + :typecheck (combinator-typecheck numerical-type?) + :ops {['i64 'i64] [[op/i64-div_s]] + ['i32 'i32] [[op/i32-div_s]] + ['f64 'f64] [[op/f64-div]]}} + '= {:typecheck (comparitor-typecheck equatable-type?) + :ops {['i64 'i64] [[op/i64-eq]] + ['i32 'i32] [[op/i32-eq]] + ['f64 'f64] [[op/f64-eq]] + ['fn 'fn] [[op/i32-eq]] + ['bool 'bool] [[op/i32-eq]]}} + 'not= {:typecheck (comparitor-typecheck equatable-type?) + :ops {['i64 'i64] [[op/i64-ne]] + ['i32 'i32] [[op/i32-ne]] + ['f64 'f64] [[op/f64-eq] [op/i32-eqz]] + ['fn 'fn] [[op/i32-ne]] + ['bool 'bool] [[op/i32-ne]]}} + '< {:typecheck (comparitor-typecheck ordered-type?) + :ops {['i64 'i64] [[op/i64-lt_s]] + ['i32 'i32] [[op/i32-lt_s]] + ['f64 'f64] [[op/f64-lt]]}} + '<= {:typecheck (comparitor-typecheck ordered-type?) + :ops {['i64 'i64] [[op/i64-le_s]] + ['i32 'i32] [[op/i32-le_s]] + ['f64 'f64] [[op/f64-le]]}} + '> {:typecheck (comparitor-typecheck ordered-type?) + :ops {['i64 'i64] [[op/i64-gt_s]] + ['i32 'i32] [[op/i32-gt_s]] + ['f64 'f64] [[op/f64-gt]]}} + '>= {:typecheck (comparitor-typecheck ordered-type?) + :ops {['i64 'i64] [[op/i64-ge_s]] + ['i32 'i32] [[op/i32-ge_s]] + ['f64 'f64] [[op/f64-ge]]}} 'and {:desugar (left-binop-desugar 'and) - :typecheck (comparitor-typecheck logical-type?)} + :typecheck (comparitor-typecheck logical-type?) + :emit (fn [form emit] + (m/match form + ('and _ ?l ?r) + [[op/if- [:wasm/valtype 'i32] (emit ?l) (emit ?r) [[op/i32-const 0]]]]))} 'or {:desugar (left-binop-desugar 'or) - :typecheck (comparitor-typecheck logical-type?)} + :typecheck (comparitor-typecheck logical-type?) + :emit (fn [form emit] + (m/match form + ('or _ ?l ?r) + [[op/if- [:wasm/valtype 'i32] (emit ?l) [[op/i32-const -1]] (emit ?r)]]))} 'def {:desugar (r/rewrite ('def (m/pred symbol? ?name) ?expr) ('def {:name ?name} ?expr)) :typecheck (r/rewrite (_ ?t) [[?t ?t]]) @@ -90,12 +140,59 @@ :mark-bound-subexpressions (r/rewrite ('def (m/and ?m {:name ?symbol}) ?expr) ('def ?m (m+ {:binding ?symbol} ?expr)))} 'do {:typecheck (r/rewrite (_) [['void]] (_ . !stmt ... ?last) [[?last . (m/app (constantly 'void) !stmt) ... ?last]]) - :scope {}} + :scope {} + :emit (fn [form emit] + (m/match form + ('do _ . !exprs ...) + (mapcat emit !exprs)))} 'l/lookup {} 'l/local {} - 'l/param {} - 'l/lit {} - 'l/call + 'l/param + {:emit (fn [form _emit] + (m/match form + ('l/param {:index ?id}) [[op/local-get ?id]]))} + 'l/lit + {:emit (fn [form _emit] + (m/match form + ('l/lit {:type 'i64 :value ?num}) [[op/i64-const ?num]] + ('l/lit {:type 'i32 :value ?num}) [[op/i32-const ?num]] + ('l/lit {:type 'bool :value ?b}) [[op/i32-const (if ?b -1 0)]]))} + + 'l/call {:typecheck (r/rewrite (_ (m/and ['fn . !param-types ... ?return-type] ?fn-type) . _ ...) - [[?return-type ?fn-type . !param-types ...]])} - }) + [[?return-type ?fn-type . !param-types ...]]) + :emit-meta (fn [form {:keys [emit program]}] + (m/match form + ('l/call _ ('l/funcref {:id ?id}) . !args ...) + (concat (mapcat emit !args) [[op/call ?id]]) + + ('l/call _ (typed ?expr ?fntype) . !args ...) + (concat (mapcat emit !args) + [[op/call_indirect (get-in program [:fntypes ?fntype])]])))} + 'l/cast + {:emit (fn [form emit] + (m/match form + ('l/cast {:type ?type} (typed ?expr ?type)) + (emit ?expr) + + ('l/cast {:type 'void} ?expr) + (concat (emit ?expr) [[op/drop]]) + + ('l/cast {:type 'f64} ('l/lit {:type (m/or 'i32 'i64) :value ?val})) + [[op/f64-const ?val]] + + ('l/cast {:type 'i64} ('l/lit {:type 'i32 :value ?val})) + [[op/i32-const ?val]] + + ('l/cast {:type 'i64} (typed ?expr 'i32)) + (concat (emit ?expr) [[op/i64-extend_i32_s]]) + + ('l/cast {:type 'f64} (typed ?expr 'i32)) + (concat (emit ?expr) [[op/f64-convert_i32_s]]) + + ('l/cast {:type 'f64} (typed ?expr 'i64)) + (concat (emit ?expr) [[op/f64-convert_i64_s]])))} + 'l/funcref + {:emit (fn [form _emit] + (m/match form + ('l/funcref {:id ?id}) [[op/i32-const ?id]]))}}) diff --git a/src/main/tock/compiler/wasm.cljc b/src/main/tock/compiler/wasm.cljc index cca53cd..ec6973c 100644 --- a/src/main/tock/compiler/wasm.cljc +++ b/src/main/tock/compiler/wasm.cljc @@ -44,137 +44,28 @@ (r/attempt collect-function-types))) collect-globals))) -(def wasm-specials - {'l/if - {:emit (fn [form emit] - (m/match form - ('l/if {:type ?type} ?cond ?l ?r) - (concat (emit ?cond) - [[op/if- [:wasm/valtype ?type] (emit ?l) (emit ?r)]])))} - '+ {:ops {['i64 'i64] [[op/i64-add]] - ['i32 'i32] [[op/i32-add]] - ['f64 'f64] [[op/f64-add]]}} - '- {:ops {['i64 'i64] [[op/i64-sub]] - ['i32 'i32] [[op/i32-sub]] - ['f64 'f64] [[op/f64-sub]]}} - '* {:ops {['i64 'i64] [[op/i64-mul]] - ['i32 'i32] [[op/i32-mul]] - ['f64 'f64] [[op/f64-mul]]}} - '/ {:ops {['i64 'i64] [[op/i64-div_s]] - ['i32 'i32] [[op/i32-div_s]] - ['f64 'f64] [[op/f64-div]]}} - '= {:ops {['i64 'i64] [[op/i64-eq]] - ['i32 'i32] [[op/i32-eq]] - ['f64 'f64] [[op/f64-eq]] - ['fn 'fn] [[op/i32-eq]] - ['bool 'bool] [[op/i32-eq]]}} - 'not= {:ops {['i64 'i64] [[op/i64-ne]] - ['i32 'i32] [[op/i32-ne]] - ['f64 'f64] [[op/f64-eq] [op/i32-eqz]] - ['fn 'fn] [[op/i32-ne]] - ['bool 'bool] [[op/i32-ne]]}} - '< {:ops {['i64 'i64] [[op/i64-lt_s]] - ['i32 'i32] [[op/i32-lt_s]] - ['f64 'f64] [[op/f64-lt]]}} - '<= {:ops {['i64 'i64] [[op/i64-le_s]] - ['i32 'i32] [[op/i32-le_s]] - ['f64 'f64] [[op/f64-le]]}} - '> {:ops {['i64 'i64] [[op/i64-gt_s]] - ['i32 'i32] [[op/i32-gt_s]] - ['f64 'f64] [[op/f64-gt]]}} - '>= {:ops {['i64 'i64] [[op/i64-ge_s]] - ['i32 'i32] [[op/i32-ge_s]] - ['f64 'f64] [[op/f64-ge]]}} - 'not {:ops {['bool] [[op/i32-eqz]]}} - 'and - {:emit (fn [form emit] - (m/match form - ('and _ ?l ?r) - [[op/if- [:wasm/valtype 'i32] (emit ?l) (emit ?r) [[op/i32-const 0]]]]))} - 'or - {:emit (fn [form emit] - (m/match form - ('or _ ?l ?r) - [[op/if- [:wasm/valtype 'i32] (emit ?l) [[op/i32-const -1]] (emit ?r)]]))} - 'do - {:emit (fn [form emit] - (m/match form - ('do _ . !exprs ...) - (mapcat emit !exprs)))} - 'l/call - {:emit-meta (fn [form {:keys [emit program]}] - (m/match form - ('l/call _ ('l/funcref {:id ?id}) . !args ...) - (concat (mapcat emit !args) [[op/call ?id]]) - - ('l/call _ (typed ?expr ?fntype) . !args ...) - (concat (mapcat emit !args) - [[op/call_indirect (get-in program [:fntypes ?fntype])]])))} - 'l/funcref - {:emit (fn [form _emit] - (m/match form - ('l/funcref {:id ?id}) [[op/i32-const ?id]]))} - 'l/lit - {:emit (fn [form _emit] - (m/match form - ('l/lit {:type 'i64 :value ?num}) [[op/i64-const ?num]] - ('l/lit {:type 'i32 :value ?num}) [[op/i32-const ?num]] - ('l/lit {:type 'bool :value ?b}) [[op/i32-const (if ?b -1 0)]]))} - 'l/param - {:emit (fn [form _emit] - (m/match form - ('l/param {:index ?id}) [[op/local-get ?id]]))} - 'l/cast - {:emit (fn [form emit] - (m/match form - ('l/cast {:type ?type} (typed ?expr ?type)) - (emit ?expr) - - ('l/cast {:type 'void} ?expr) - (concat (emit ?expr) [[op/drop]]) - - ('l/cast {:type 'f64} ('l/lit {:type (m/or 'i32 'i64) :value ?val})) - [[op/f64-const ?val]] - - ('l/cast {:type 'i64} ('l/lit {:type 'i32 :value ?val})) - [[op/i32-const ?val]] - - ('l/cast {:type 'i64} (typed ?expr 'i32)) - (concat (emit ?expr) [[op/i64-extend_i32_s]]) - - ('l/cast {:type 'f64} (typed ?expr 'i32)) - (concat (emit ?expr) [[op/f64-convert_i32_s]]) - - ('l/cast {:type 'f64} (typed ?expr 'i64)) - (concat (emit ?expr) [[op/f64-convert_i64_s]])))} - 'l/fn - {:emit (fn [form emit] - (m/match form ('l/fn _ ?expr) (emit ?expr)))}}) - (defn type-based-emit [form opmap emit] (let [subexprs (rest (rest form)) types (into [] (map #(get-meta % :type) subexprs)) ops (get opmap types)] (or (concat (mapcat emit subexprs) ops) [[:compile-error form "Unexpected types" types]]))) -(defn make-emitter [specials] - (fn [form program] - ((fn emit [form] - (let [special (first form) - emitter (get specials special)] - (try - (cond - (contains? emitter :ops) (type-based-emit form (:ops emitter) emit) - (contains? emitter :emit) ((:emit emitter) form emit) - (contains? emitter :emit-meta) ((:emit-meta emitter) form {:emit emit :program program}) - :else [[:compile-error form "No wasm emitter defined for special" special]]) - (catch :default e - [[:compile-error form "Error during emission:" e]])))) - form))) +(defn make-emitter [program] + (fn emit [form] + (let [specials (:specials program) + special (first form) + emitter (get specials special)] + (try + (cond + (contains? emitter :ops) (type-based-emit form (:ops emitter) emit) + (contains? emitter :emit) ((:emit emitter) form emit) + (contains? emitter :emit-meta) ((:emit-meta emitter) form {:emit emit :program program}) + :else [[:compile-error form "No wasm emitter defined for special" special]]) + (catch :default e + [[:compile-error form "Error during emission:" e]]))))) -(def wasm-emit (make-emitter wasm-specials)) - -(def empty-program {:fndefs [] :fntypes {} :globals {}}) +(defn make-empty-program [specials] + {:fndefs [] :fntypes {} :globals {} :specials specials}) (defn type-to-wasmtype [type] (m/match type @@ -190,8 +81,9 @@ [(apply vector (map type-to-wasmtype !types)) (if (= ?return-type 'void) [] [(type-to-wasmtype ?return-type)])])) -(defn generate-wasm [{:keys [fndefs fntypes globals]}] - (let [index-to-fntype (into {} (map (fn [[sym index]] [index sym]) fntypes)) +(defn generate-wasm [{:keys [fndefs fntypes globals] :as program}] + (let [wasm-emit (make-emitter program) + index-to-fntype (into {} (map (fn [[sym index]] [index sym]) fntypes)) fntypes (into [] (map #(get index-to-fntype %) (range (count index-to-fntype))))] (as-> (wasm/ctx) wasm (reduce (fn [wasm fntype] diff --git a/src/main/tock/experiment.cljs b/src/main/tock/experiment.cljs index df7b5a3..01ab63e 100644 --- a/src/main/tock/experiment.cljs +++ b/src/main/tock/experiment.cljs @@ -1,7 +1,7 @@ (ns tock.experiment (:require [helins.wasm :as wasm] [helins.binf :as binf] - [tock.compiler :refer [compile compile-form empty-program]] + [tock.compiler :refer [compile]] [cljs.pprint :as pp]))