aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--luxc/src/lux/analyser/proc/common.clj39
-rw-r--r--luxc/src/lux/compiler/jvm/proc/common.clj48
-rw-r--r--luxc/src/lux/type.clj11
-rw-r--r--stdlib/source/lux/control/thread.lux78
-rw-r--r--stdlib/test/test/lux/control/thread.lux20
-rw-r--r--stdlib/test/tests.lux3
6 files changed, 196 insertions, 3 deletions
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/luxc/src/lux/type.clj b/luxc/src/lux/type.clj
index d5d6b0316..84c00b978 100644
--- a/luxc/src/lux/type.clj
+++ b/luxc/src/lux/type.clj
@@ -32,13 +32,20 @@
(def Ident (&/$Named (&/T ["lux" "Ident"]) (&/$Product Text Text)))
(do-template [<name> <tag>]
- (defn <name> [elem-type]
- (&/$Primitive <tag> (&/|list elem-type)))
+ (defn <name> [elemT]
+ (&/$Primitive <tag> (&/|list elemT)))
Array "#Array"
Atom "#Atom"
)
+(do-template [<name> <tag>]
+ (defn <name> [threadT elemT]
+ (&/$Primitive <tag> (&/|list threadT elemT)))
+
+ Box "#Box"
+ )
+
(def Bottom
(&/$Named (&/T ["lux" "Bottom"])
(&/$UnivQ empty-env
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<Thread>
+ (All [!] (Functor (Thread !)))
+
+ (def: (map f)
+ (function [fa]
+ (function [!]
+ (f (fa !))))))
+
+(struct: #export Applicative<Thread>
+ (All [!] (Applicative (Thread !)))
+
+ (def: functor Functor<Thread>)
+
+ (def: (wrap value)
+ (function [!]
+ value))
+
+ (def: (apply ff fa)
+ (function [!]
+ ((ff !) (fa !)))))
+
+(struct: #export Monad<Thread>
+ (All [!] (Monad (Thread !)))
+
+ (def: applicative Applicative<Thread>)
+
+ (def: (join ffa)
+ (function [!]
+ ((ffa !) !))))
+
+(def: #export (update f box)
+ (All [a] (-> (-> a a) (All [!] (-> (Box ! a) (Thread ! a)))))
+ (do Monad<Thread>
+ [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<Thread>
+ [box (/.box +123)
+ old (/.update (n/* +2) box)
+ new (/.read box)]
+ (wrap (n/+ old new)))))
+
+(def: _test1_
+ (All [!] (/.Thread ! Nat))
+ (do /.Monad<Thread>
+ [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]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 15:54:53 +0000