Fix "if", cleanup clj-kondo warnings, pointless indirection

This commit is contained in:
Jeremy Penner 2024-08-06 22:30:42 -04:00
parent 7bf14eb508
commit 56299b20c3
8 changed files with 63 additions and 53 deletions

14
.vscode/settings.json vendored Normal file
View file

@ -0,0 +1,14 @@
{
"calva.replConnectSequences": [
{
"name": "Experiment",
"autoSelectForJackIn": true,
"projectType": "shadow-cljs",
"cljsType": "shadow-cljs",
"menuSelections": {
"cljsDefaultBuild": "experiment",
"cljsLaunchBuilds": ["experiment"]
}
}
]
}

View file

@ -49,8 +49,8 @@
(typecheck specials) (typecheck specials)
(collect-definitions program)))) (collect-definitions program))))
(defn compile (defn compile-wasm
([forms] (compile forms specials)) ([forms] (compile-wasm forms specials))
([forms specials] ([forms specials]
(-> (reduce compile-form (make-empty-program specials) forms) (-> (reduce compile-form (make-empty-program specials) forms)
generate-wasm))) generate-wasm)))

View file

@ -1,7 +1,7 @@
(ns tock.compiler.bind (ns tock.compiler.bind
(:require [meander.epsilon :as m] (:require [meander.epsilon :as m]
[tock.compiler.util :refer [get-special new-scope bind! lookup]] [tock.compiler.util :refer [get-special new-scope bind! lookup]]
[tock.compiler.meander :refer [bottom-up all-subexpressions m+ merge-metafield]])) [tock.compiler.meander :refer [bottom-up all-subexpressions merge-metafield]]))
(defn decorate-ctx [specials ctx form] (defn decorate-ctx [specials ctx form]
(let [special (get-special specials form) (let [special (get-special specials form)

View file

@ -1,7 +1,6 @@
(ns tock.compiler.desugar (ns tock.compiler.desugar
(:require [meander.epsilon :as m] (:require [meander.epsilon :as m]
[meander.strategy.epsilon :as r] [meander.strategy.epsilon :as r]
[tock.compiler.specials :refer [specials]]
[tock.compiler.meander :refer [parse-type to-sym label]])) [tock.compiler.meander :refer [parse-type to-sym label]]))
(def leaf-pass (def leaf-pass
@ -23,35 +22,32 @@
; [vectors] and {maps} are _not_ expressions and are parsed by special form's desugaring only ; [vectors] and {maps} are _not_ expressions and are parsed by special form's desugaring only
?syntax ?syntax))) ?syntax ?syntax)))
(defn make-desugar-pass [specials] (defn desugar-pass [form specials]
(let [desugar-strat (apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))] (let [desugar-strat (apply r/pipe (mapcat (fn [[_ {:keys [desugar]}]] (if desugar [(r/attempt desugar)] [])) specials))
(r/until = pass (r/until =
(r/rewrite (r/rewrite
((m/cata ?special) ?m . (m/cata !args) ...) ((m/cata ?special) ?m . (m/cata !args) ...)
(m/app desugar-strat (?special ?m . !args ...)) (m/app desugar-strat (?special ?m . !args ...))
?form ?form)))) ?form ?form))]
(pass form)))
(defn make-call-pass [specials] (defn call-pass [form specials]
(let [special? (fn [key] (and (symbol? key) (contains? specials key)))] (let [special? (fn [key] (and (symbol? key) (contains? specials key)))
(r/rewrite pass (r/rewrite
(m/and (m/pred symbol? ?sym) (m/app meta ?m)) ('l/lookup {:name ?sym & ?m}) (m/and (m/pred symbol? ?sym) (m/app meta ?m)) ('l/lookup {:name ?sym & ?m})
((m/pred special? ?special) ?m . (m/cata !args) ...) ((m/pred special? ?special) ?m . (m/cata !args) ...)
(?special ?m . !args ...) (?special ?m . !args ...)
((m/cata ?func) ?m . (m/cata !args) ...) ((m/cata ?func) ?m . (m/cata !args) ...)
('l/call ?m (label ?func "function") . (label !args "argument") ...) ('l/call ?m (label ?func "function") . (label !args "argument") ...)
?unknown ('l/compile-error {:form ?unknown :error "Unrecognized form"})))) ?unknown ('l/compile-error {:form ?unknown :error "Unrecognized form"}))]
(pass form)))
(defn desugar (defn desugar [form specials]
([form] (desugar form specials)) (-> form
([form specials] leaf-pass
(let [desugar-pass (make-desugar-pass specials) (desugar-pass specials)
call-pass (make-call-pass specials)] (call-pass specials)))
(-> form
leaf-pass
desugar-pass
call-pass
))))

View file

@ -10,6 +10,8 @@
(list? form) (apply list (first form) (merge (second form) m) (rest (rest form))) (list? form) (apply list (first form) (merge (second form) m) (rest (rest form)))
:else (do (print "m+ " form meta "\n") form))) :else (do (print "m+ " form meta "\n") form)))
(declare m+ label typed)
(m/defsyntax m+ (m/defsyntax m+
[meta-pattern pattern] [meta-pattern pattern]
(case (::r.syntax/phase &env) (case (::r.syntax/phase &env)

View file

@ -2,7 +2,8 @@
(:require [meander.epsilon :as m] (:require [meander.epsilon :as m]
[meander.strategy.epsilon :as r] [meander.strategy.epsilon :as r]
[helins.wasm.bin :as op] [helins.wasm.bin :as op]
[tock.compiler.meander :refer [parse-type to-sym label m+]])) [tock.compiler.meander :refer [parse-type to-sym label m+]]
[tock.compiler.wasm :refer [type-to-wasmtype]]))
;; no namespace - source symbol ;; no namespace - source symbol
;; l/sym - "lowered" form - special form not directly writable from source ;; l/sym - "lowered" form - special form not directly writable from source
@ -45,7 +46,7 @@
(m/match form (m/match form
('l/if {:type ?type} ?cond ?l ?r) ('l/if {:type ?type} ?cond ?l ?r)
(concat (emit ?cond) (concat (emit ?cond)
[[op/if- [:wasm/valtype ?type] (emit ?l) (emit ?r)]])))} [[op/if- [:wasm/valtype (type-to-wasmtype ?type)] (emit ?l) (emit ?r)]])))}
'l/fn 'l/fn
{:desugar (r/rewrite {:desugar (r/rewrite

View file

@ -1,9 +1,5 @@
(ns tock.compiler.util) (ns tock.compiler.util)
(defn compile-error [term message]
; todo: extract location of error term
(js/Error. [term message]))
; ctx is a vector of atoms of maps ; ctx is a vector of atoms of maps
(defn new-scope (defn new-scope
([ctx base] (conj ctx (atom base))) ([ctx base] (conj ctx (atom base)))

View file

@ -1,24 +1,25 @@
(ns tock.experiment (ns tock.experiment
(:require [helins.wasm :as wasm] (:require [helins.wasm :as wasm]
[helins.binf :as binf] [helins.binf :as binf]
[tock.compiler :refer [compile]] [tock.compiler :refer [compile-wasm]]))
[cljs.pprint :as pp]))
;; ; https://github.com/kalai-transpiler/kalai
(def test-wasm (def test-wasm
(compile (compile-wasm
'[(fn add [^f64 left ^f64 right -> f64] (+ left right)) '[(fn add [^f64 left ^f64 right -> f64] (+ left right))
(fn double [^f64 val -> f64] (* val 2)) (fn double [^f64 val -> f64] (* val 2))
(fn add_double [^f64 left ^f64 right -> f64] (double (add left right)))])) (fn add_double [^bool add-first? ^f64 left ^f64 right -> f64]
(if add-first?
(double (add left right))
(add (double left) right)))]))
(defn decompile-url [url] ;; (defn decompile-url [url]
(-> (js/fetch url) ;; (-> (js/fetch url)
(.then #(.arrayBuffer %)) ;; (.then #(.arrayBuffer %))
(.then #(let [v (binf/view %)] ;; (.then #(let [v (binf/view %)]
(binf/endian-set v :little-endian) ;; (binf/endian-set v :little-endian)
(wasm/decompile v))))) ;; (wasm/decompile v)))))
(defn instantiate-wasm [wasm importObject] (defn instantiate-wasm [wasm importObject]
(-> (wasm/compile wasm) (-> (wasm/compile wasm)
@ -29,7 +30,7 @@
(defn main [] (defn main []
(js/console.log test-wasm) (js/console.log test-wasm)
(-> (instantiate-wasm test-wasm #js {}) (-> (instantiate-wasm test-wasm #js {})
(.then #(js/console.log (-> % (.-instance) (.-exports) (.add-double 2 3))))) (.then (fn [^js x] (js/console.log (-> x (.-instance) (.-exports) (.add-double false 2 3))))))
;; (-> (decompile-url "release.wasm") ;; (-> (decompile-url "release.wasm")
;; (.then #(js/console.log (-> % :wasm/exportsec :wasm.export/func (get 0))))) ;; (.then #(js/console.log (-> % :wasm/exportsec :wasm.export/func (get 0)))))
) )