Move wasm emission logic into specials.cljc, specials into program
This commit is contained in:
parent
2a69d98b49
commit
7bf14eb508
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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]]))}})
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue