Complete interpreter, less process system: spawn, receive

This commit is contained in:
Scott Richmond 2023-05-22 16:56:24 -04:00
parent 618d6b856c
commit 6cf09fb177
5 changed files with 131 additions and 108 deletions

View File

@ -137,7 +137,7 @@
(zero+ struct-entry) (zero+ struct-entry)
(quiet :rbrace)]))) (quiet :rbrace)])))
(def dict-term (flat (choice :dict-term [:word pair splat]))) (def dict-term (flat (choice :dict-term [splat :word pair])))
(def dict-entry (order-1 :dict-entry [dict-term separators])) (def dict-entry (order-1 :dict-entry [dict-term separators]))
@ -246,12 +246,12 @@
(def importt (group (order-1 :import [(quiet :import) :string (quiet :as) :word]))) (def importt (group (order-1 :import [(quiet :import) :string (quiet :as) :word])))
(def nss (group (order-1 :nss [(quiet :ns) (def nss (group (order-1 :ns [(quiet :ns)
:word :word
(quiet :lbrace) (quiet :lbrace)
(quiet (zero+ separator)) (quiet (zero+ separator))
(zero+ struct-entry) (zero+ struct-entry)
(quiet :rbrace)]))) (quiet :rbrace)])))
(def toplevel (flat (choice :toplevel [importt nss expression testt]))) (def toplevel (flat (choice :toplevel [importt nss expression testt])))

View File

@ -495,21 +495,10 @@
(let [[k v] kv] (let [[k v] kv]
[k (f v)])))) [k (f v)]))))
(defn- interpret-ns [ast ctx]
(let [members (:members ast)
name (:name ast)]
(if (contains? @ctx name)
(throw (ex-info (str "ns name " name " is already bound") {:ast ast}))
(let [ns (into
{::data/struct true ::data/type ::data/ns ::data/name name}
(map-values #(interpret-ast % ctx))
members)]
(vswap! ctx update-ctx {name ns})
ns))))
(defn- interpret-import [ast ctx] (defn- interpret-import [ast ctx]
(let [path (:path ast) (let [data (:data ast)
name (:name ast) path (-> data first :data first)
name (-> data second :data first)
file (ludus-resolve :file ctx) file (ludus-resolve :file ctx)
from (if (= ::not-found file) :cwd file)] from (if (= ::not-found file) :cwd file)]
(if (contains? @ctx name) (if (contains? @ctx name)
@ -521,14 +510,14 @@
(throw (ex-info (ex-message e) {:ast ast})) (throw (ex-info (ex-message e) {:ast ast}))
(throw e)))) (throw e))))
result (-> source (scanner/scan) (parser/parse) (interpret-file path))] result (-> source (scanner/scan) (parser/parse) (interpret-file path))]
;; (pp/pprint @ctx)
(vswap! ctx update-ctx {name result}) (vswap! ctx update-ctx {name result})
;; (pp/pprint @ctx)
result result
)))) ))))
(defn- interpret-ref [ast ctx] (defn- interpret-ref [ast ctx]
(let [name (:name ast) expr (:expr ast)] (let [data (:data ast)
name (-> data first :data first)
expr (-> data second)]
(when (contains? @ctx name) (when (contains? @ctx name)
(throw (ex-info (str "Name " name " is already bound") {:ast ast}))) (throw (ex-info (str "Name " name " is already bound") {:ast ast})))
(let [value (interpret-ast expr ctx) (let [value (interpret-ast expr ctx)
@ -579,24 +568,25 @@
(defn- list-term [ctx] (defn- list-term [ctx]
(fn [list member] (fn [list member]
(if (= (::ast/type member) ::ast/splat) (if (= (:type member) :splat)
(let [splatted (interpret-ast (:expr member) ctx) (let [splatted (interpret-ast (-> member :data first) ctx)
splat-list? (and splattable? (vector? splatted)
(vector? splatted) tuple-splat? (= (first splatted) ::data/tuple)]
(not (= (first splatted) ::data/tuple)))] (if splattable?
(if splat-list? (if tuple-splat?
(concat list splatted) (into [] (concat list (rest splatted)))
(concat list splatted))
(throw (ex-info "Cannot splat non-list into list" {:ast member})))) (throw (ex-info "Cannot splat non-list into list" {:ast member}))))
(concat list [(interpret-ast member ctx)])))) (conj list (interpret-ast member ctx)))))
(defn- interpret-list [ast ctx] (defn- interpret-list [ast ctx]
(let [members (:members ast)] (let [members (:data ast)]
(into [] (reduce (list-term ctx) [] members)))) (into [] (reduce (list-term ctx) [] members))))
(defn- set-term [ctx] (defn- set-term [ctx]
(fn [set member] (fn [set member]
(if (= (::ast/type member) ::ast/splat) (if (= (:type member) :splat)
(let [splatted (interpret-ast (:expr member) ctx) (let [splatted (interpret-ast (-> member :data first) ctx)
splat-set? (set? splatted)] splat-set? (set? splatted)]
(if splat-set? (if splat-set?
(clojure.set/union set splatted) (clojure.set/union set splatted)
@ -604,26 +594,68 @@
(conj set (interpret-ast member ctx))))) (conj set (interpret-ast member ctx)))))
(defn- interpret-set [ast ctx] (defn- interpret-set [ast ctx]
(let [members (:members ast)] (let [members (:data ast)]
(reduce (set-term ctx) #{} members))) (reduce (set-term ctx) #{} members)))
(defn- dict-term [ctx] (defn- dict-term [ctx]
(fn [dict member] (fn [dict member]
(if (= (::ast/type member) ::ast/splat) (case (:type member)
(let [splatted (interpret-ast (:expr member) ctx) :splat (let [splatted (interpret-ast (-> member :data first) ctx)
splat-map? (and splat-map? (or (::data/dict splatted)
(map? splatted) (::data/struct splatted))]
(::data/dict splatted))] (if splat-map?
(if splat-map? (merge dict splatted)
(merge dict splatted) (throw (ex-info "Cannot splat non-dict into dict" {:ast member}))))
(throw (ex-info "Cannot splat non-dict into dict" {:ast member})))) :word (let [data (:data member) k (-> data first keyword)]
(let [k (first member) v (second member)] (assoc dict k (interpret-ast member ctx)))
(assoc dict k (interpret-ast v ctx))))))
:pair (let [data (:data member) k (-> data first :data first) v (second data)]
(assoc dict k (interpret-ast v ctx))))))
(defn- interpret-dict [ast ctx] (defn- interpret-dict [ast ctx]
(let [members (:members ast)] (let [members (:data ast)]
(assoc (reduce (dict-term ctx) {} members) ::data/dict true))) (assoc (reduce (dict-term ctx) {} members) ::data/dict true)))
(defn- struct-term [ctx]
(fn [struct member]
(case (:type member)
:splat (throw (ex-info "Cannot splat into struct" {:ast member}))
:word (let [data (:data member) k (-> data first keyword)]
(assoc struct k (interpret-ast member ctx)))
:pair (let [data (:data member) k (-> data first :data first) v (second data)]
(assoc struct k (interpret-ast v ctx))))))
(defn- interpret-struct [ast ctx]
(let [members (:data ast)]
(assoc (reduce (struct-term ctx) {} members) ::data/struct true)))
(defn- ns-term [ctx]
(fn [ns member]
(case (:type member)
:splat (throw (ex-info "Cannot splat into ns" {:ast member}))
:word (let [data (:data member) k (-> data first keyword)]
(assoc ns k (interpret-ast member ctx)))
:pair (let [data (:data member) k (-> data first :data first) v (second data)]
(assoc ns k (interpret-ast v ctx))))))
(defn- interpret-ns [ast ctx]
(let [data (:data ast)
name (-> data first :data first)
members (rest data)]
(if (contains? @ctx name)
(throw (ex-info (str "ns name " name " is already bound") {:ast ast}))
(let [ns (merge {
::data/struct true
::data/type ::data/ns
::data/name name}
(reduce (ns-term ctx) {} members))]
(vswap! ctx update-ctx {name ns})
ns))))
(defn- interpret-receive [ast ctx] (defn- interpret-receive [ast ctx]
(let [process-atom (get @process/processes self) (let [process-atom (get @process/processes self)
inbox (promise) inbox (promise)
@ -668,7 +700,7 @@
msg)) msg))
(defn- interpret-spawn [ast ctx] (defn- interpret-spawn [ast ctx]
(let [expr (:expr ast) (let [expr (-> ast :data first)
process (process/new-process) process (process/new-process)
pid (:pid @process)] pid (:pid @process)]
(with-bindings {#'self pid} (with-bindings {#'self pid}
@ -710,16 +742,14 @@
:placeholder ::data/placeholder :placeholder ::data/placeholder
::ast/ns (interpret-ns ast ctx) :ns (interpret-ns ast ctx)
::ast/import (interpret-import ast ctx) :import (interpret-import ast ctx)
::ast/ref (interpret-ref ast ctx) :ref (interpret-ref ast ctx)
::ast/spawn (interpret-spawn ast ctx) ::ast/spawn (interpret-spawn ast ctx)
::ast/send (interpret-send ast ctx)
::ast/receive (interpret-receive ast ctx) ::ast/receive (interpret-receive ast ctx)
:recur :recur
@ -749,15 +779,14 @@
(let [members (:data ast)] (let [members (:data ast)]
(into [::data/tuple] (map #(interpret-ast % ctx)) members)) (into [::data/tuple] (map #(interpret-ast % ctx)) members))
::ast/list (interpret-list ast ctx) :list (interpret-list ast ctx)
::ast/set (interpret-set ast ctx) :set (interpret-set ast ctx)
::ast/dict (interpret-dict ast ctx) :dict (interpret-dict ast ctx)
::ast/struct :struct
(let [members (:members ast)] (let [members (:members ast)] (interpret-struct ast ctx))
(into {::data/struct true} (map-values #(interpret-ast % ctx)) members))
(throw (ex-info "Unknown AST node type" {:ast ast})))) (throw (ex-info "Unknown AST node type" {:ast ast}))))
@ -777,7 +806,7 @@
process (process/new-process)] process (process/new-process)]
(process/start-vm) (process/start-vm)
(with-bindings {#'self (:pid @process)} (with-bindings {#'self (:pid @process)}
(let [result (interpret-ast (::parser/ast parsed) base-ctx)] (let [result (interpret-ast (::parser/ast parsed) {::parent base-ctx})]
(swap! process #(assoc % :status :dead)) (swap! process #(assoc % :status :dead))
(process/stop-vm) (process/stop-vm)
result))) result)))
@ -789,7 +818,7 @@
(defn interpret-safe [parsed] (defn interpret-safe [parsed]
(try (try
(let [base-ctx (volatile! (merge {} prelude/prelude)) (let [base-ctx (volatile! {::parent (volatile! prelude/prelude)})
process (process/new-process)] process (process/new-process)]
(process/start-vm) (process/start-vm)
(with-bindings {#'self (:pid @process)} (with-bindings {#'self (:pid @process)}
@ -835,13 +864,7 @@
(do (do
(process/start-vm) (process/start-vm)
(def source " (def source "
loop (4) with { ref a = 1
(0) -> print (:done)
(x) -> {
print (x)
recur (dec (x))
}
}
") ")
(println "") (println "")

View File

@ -5,13 +5,13 @@
[ludus.scanner :as s])) [ludus.scanner :as s]))
(def source (def source
"fn () -> {recur (x)} "spawn foo
" "
) )
(def tokens (-> source s/scan :tokens)) (def tokens (-> source s/scan :tokens))
(def result (p/apply-parser g/script tokens)) (def result (p/apply-parser g/spawn tokens))
(-> result :data) (-> result :data)

View File

@ -1,6 +1,6 @@
(ns ludus.process (ns ludus.process
(:require (:require
[ludus.data :as data]) [ludus.data :as data])
(:import (java.util.concurrent Executors))) (:import (java.util.concurrent Executors)))
;; virtual thread patch from https://ales.rocks/notes-on-virtual-threads-and-clojure ;; virtual thread patch from https://ales.rocks/notes-on-virtual-threads-and-clojure
@ -20,13 +20,13 @@
(defn new-process [] (defn new-process []
(let [pid @current-pid (let [pid @current-pid
process (atom {:pid pid process (atom {:pid pid
:queue clojure.lang.PersistentQueue/EMPTY :queue clojure.lang.PersistentQueue/EMPTY
:inbox nil :inbox nil
:status :occupied :status :occupied
})] })]
(swap! processes #(assoc % pid process)) (swap! processes #(assoc % pid process))
(swap! current-pid inc) (swap! current-pid inc)
process)) process))
(def vm-state (atom :stopped)) (def vm-state (atom :stopped))
@ -37,7 +37,7 @@
(defn process-msg [process] (defn process-msg [process]
;;(println "processing message" self) ;;(println "processing message" self)
(let [q (:queue process) (let [q (:queue process)
inbox (:inbox process)] inbox (:inbox process)]
(when (not (realized? inbox)) (when (not (realized? inbox))
;;(println "delivering message in" self) ;;(println "delivering message in" self)
(deliver inbox (peek q)) (deliver inbox (peek q))
@ -45,9 +45,9 @@
(defn run-process [process-atom] (defn run-process [process-atom]
(let [process @process-atom (let [process @process-atom
status (:status process) status (:status process)
q (:queue process) q (:queue process)
inbox (:inbox process)] inbox (:inbox process)]
;;(println "running process" self ":" (into [] q)) ;;(println "running process" self ":" (into [] q))
(when (and (= status :idle) (not-empty q) inbox) (when (and (= status :idle) (not-empty q) inbox)
(swap! process-atom process-msg)))) (swap! process-atom process-msg))))
@ -59,10 +59,10 @@
(reset! vm-state :running) (reset! vm-state :running)
(loop [] (loop []
(when (= @vm-state :running) (when (= @vm-state :running)
(run! run-process (values @processes)) (run! run-process (values @processes))
(recur) (recur)
;; (println "Ludus VM shutting down") ;; (println "Ludus VM shutting down")
))))) )))))
(defn stop-vm [] (defn stop-vm []
(reset! vm-state :stopped) (reset! vm-state :stopped)
@ -71,26 +71,26 @@
nil) nil)
(def process {"process" { (def process {"process" {
::data/struct true ::data/struct true
::data/type ::data/ns ::data/type ::data/ns
::data/name "process" ::data/name "process"
:list {::data/type ::data/clj "list" {::data/type ::data/clj
:name "list" :name "list"
:body (fn [] (into [] (keys @processes)))} :body (fn [] (into [] (keys @processes)))}
:info {::data/type ::data/clj "info" {::data/type ::data/clj
:name "info" :name "info"
:body (fn [pid] :body (fn [pid]
(let [process @(get @processes pid) (let [process @(get @processes pid)
queue (into [] (:queue process))] queue (into [] (:queue process))]
(assoc process :queue queue ::data/dict true)))} (assoc process :queue queue ::data/dict true)))}
:flush {::data/type ::data/clj "flush" {::data/type ::data/clj
:name "flush" :name "flush"
:body (fn [pid] :body (fn [pid]
(let [process (get @processes pid) (let [process (get @processes pid)
queue (into [] (:queue @process))] queue (into [] (:queue @process))]
(swap! process #(assoc % :queue clojure.lang.PersistentQueue/EMPTY)) (swap! process #(assoc % :queue clojure.lang.PersistentQueue/EMPTY))
queue))} queue))}
}}) }})

View File

@ -25,7 +25,7 @@
(str "@{" (apply str (into [] show-keyed (dissoc v ::data/struct))) "}") (str "@{" (apply str (into [] show-keyed (dissoc v ::data/struct))) "}")
(::data/ref v) ;; TODO: reconsider this (::data/ref v) ;; TODO: reconsider this
(str "ref:" (::data/name v) " <" (deref (::data/value v)) ">") (str "ref: " (::data/name v) " [" (deref (::data/value v)) "]")
(::data/dict v) (::data/dict v)
(str "#{" (apply str (into [] show-keyed (dissoc v ::data/dict))) "}") (str "#{" (apply str (into [] show-keyed (dissoc v ::data/dict))) "}")