From 64a2cf543232df320374d0676607e2855765b5ed Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 31 Dec 2017 20:43:51 -0400 Subject: - Added safe (single-threaded) mutation. --- luxc/src/lux/analyser/proc/common.clj | 39 ++++++++++++++++ luxc/src/lux/compiler/jvm/proc/common.clj | 48 +++++++++++++++++++ stdlib/source/lux/control/thread.lux | 78 +++++++++++++++++++++++++++++++ stdlib/test/test/lux/control/thread.lux | 20 ++++++++ stdlib/test/tests.lux | 3 +- 5 files changed, 187 insertions(+), 1 deletion(-) create mode 100644 stdlib/source/lux/control/thread.lux create mode 100644 stdlib/test/test/lux/control/thread.lux diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 7031a9135..e3951da18 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -436,6 +436,41 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["atom" "compare-and-swap"]) (&/|list =atom =old =new) (&/|list))))))))) +(defn ^:private analyse-box-new [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] + =init (&&/analyse-1 analyse $var ?init) + _ (&type/check exo-type (&/$UnivQ (&/|list) (&type/Box (&/$Bound 1) $var))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["box" "new"]) (&/|list =init) (&/|list))))))))) + +(defn ^:private analyse-box-read [analyse exo-type ?values] + (&type/with-var + (fn [threadT] + (&type/with-var + (fn [valueT] + (|do [:let [(&/$Cons boxC (&/$Nil)) ?values] + boxA (&&/analyse-1 analyse (&type/Box threadT valueT) boxC) + _ (&type/check exo-type valueT) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["box" "read"]) (&/|list boxA) (&/|list))))))))))) + +(defn ^:private analyse-box-write [analyse exo-type ?values] + (&type/with-var + (fn [threadT] + (&type/with-var + (fn [valueT] + (|do [:let [(&/$Cons valueC (&/$Cons boxC (&/$Nil))) ?values] + boxA (&&/analyse-1 analyse (&type/Box threadT valueT) boxC) + valueA (&&/analyse-1 analyse valueT valueC) + _ (&type/check exo-type &/$Unit) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["box" "write"]) (&/|list valueA boxA) (&/|list))))))))))) + (defn ^:private analyse-process-concurrency-level [analyse exo-type ?values] (|do [:let [(&/$Nil) ?values] _ (&type/check exo-type &type/Nat) @@ -465,6 +500,10 @@ "lux is" (analyse-lux-is analyse exo-type ?values) "lux try" (analyse-lux-try analyse exo-type ?values) + "lux box new" (analyse-box-new analyse exo-type ?values) + "lux box read" (analyse-box-read analyse exo-type ?values) + "lux box write" (analyse-box-write analyse exo-type ?values) + "lux io log" (analyse-io-log analyse exo-type ?values) "lux io error" (analyse-io-error analyse exo-type ?values) "lux io exit" (analyse-io-exit analyse exo-type ?values) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index bead93256..b23a59ce1 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -759,6 +759,47 @@ &&/wrap-boolean)]] (return nil))) +(defn ^:private compile-box-new [compile ?values special-args] + (|do [:let [(&/$Cons initS (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn (int 1)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)))] + _ (compile initS) + :let [_ (doto *writer* + (.visitInsn Opcodes/AASTORE))]] + (return nil))) + +(defn ^:private compile-box-read [compile ?values special-args] + (|do [:let [(&/$Cons boxS (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile boxS) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD))]] + (return nil))) + +(defn ^:private compile-box-write [compile ?values special-args] + (|do [:let [(&/$Cons valueS (&/$Cons boxS (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile boxS) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int 0)))] + _ (compile valueS) + :let [_ (doto *writer* + (.visitInsn Opcodes/AASTORE) + (.visitLdcInsn &/unit-tag))]] + (return nil))) + (defn ^:private compile-process-concurrency-level [compile ?values special-args] (|do [:let [(&/$Nil) ?values] ^MethodVisitor *writer* &/get-writer @@ -929,6 +970,13 @@ "pow" (compile-math-pow compile ?values special-args) ) + "box" + (case proc + "new" (compile-box-new compile ?values special-args) + "read" (compile-box-read compile ?values special-args) + "write" (compile-box-write compile ?values special-args) + ) + "atom" (case proc "new" (compile-atom-new compile ?values special-args) diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux new file mode 100644 index 000000000..daee09900 --- /dev/null +++ b/stdlib/source/lux/control/thread.lux @@ -0,0 +1,78 @@ +(.module: + lux + (lux (control [functor #+ Functor] + [applicative #+ Applicative] + [monad #+ Monad do]) + [io #+ IO])) + +(type: #export (Thread ! a) + (-> ! a)) + +(type: #export (Box t v) + {#.doc "A mutable box holding a value."} + (#.Primitive "#Box" (~ (list t v)))) + +(def: #export (box init) + (All [a] (-> a (All [!] (Thread ! (Box ! a))))) + (function [!] + ("lux box new" init))) + +(def: #export (read box) + (All [! a] (-> (Box ! a) (Thread ! a))) + (function [!] + ("lux box read" box))) + +(def: #export (write value box) + (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Unit))))) + (function [!] + ("lux box write" value box))) + +(def: #export (run thread) + (All [a] + (-> (All [!] (Thread ! a)) + a)) + (thread [])) + +(struct: #export Functor + (All [!] (Functor (Thread !))) + + (def: (map f) + (function [fa] + (function [!] + (f (fa !)))))) + +(struct: #export Applicative + (All [!] (Applicative (Thread !))) + + (def: functor Functor) + + (def: (wrap value) + (function [!] + value)) + + (def: (apply ff fa) + (function [!] + ((ff !) (fa !))))) + +(struct: #export Monad + (All [!] (Monad (Thread !))) + + (def: applicative Applicative) + + (def: (join ffa) + (function [!] + ((ffa !) !)))) + +(def: #export (update f box) + (All [a] (-> (-> a a) (All [!] (-> (Box ! a) (Thread ! a))))) + (do Monad + [old (read box) + _ (write (f old) box)] + (wrap old))) + +(def: #export (io thread) + (All [a] + (-> (All [!] (Thread ! a)) + (IO a))) + (function [void] + (thread void))) diff --git a/stdlib/test/test/lux/control/thread.lux b/stdlib/test/test/lux/control/thread.lux new file mode 100644 index 000000000..3dd27d0ad --- /dev/null +++ b/stdlib/test/test/lux/control/thread.lux @@ -0,0 +1,20 @@ +(.module: + lux + (lux (control [monad #+ do] + ["/" thread]))) + +(def: _test0_ + Nat + (/.run (do /.Monad + [box (/.box +123) + old (/.update (n/* +2) box) + new (/.read box)] + (wrap (n/+ old new))))) + +(def: _test1_ + (All [!] (/.Thread ! Nat)) + (do /.Monad + [box (/.box +123) + old (/.update (n/* +2) box) + new (/.read box)] + (wrap (n/+ old new)))) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index ecce3d56b..87f9c913d 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -21,7 +21,8 @@ ["_." reader] ["_." writer] ["_." state] - ["_." parser]) + ["_." parser] + ["_." thread]) (data ["_." bit] ["_." bool] ["_." error] -- cgit v1.2.3