diff options
Diffstat (limited to 'stdlib/source')
-rw-r--r-- | stdlib/source/lux/concurrency/actor.lux | 197 | ||||
-rw-r--r-- | stdlib/source/lux/concurrency/promise.lux | 29 | ||||
-rw-r--r-- | stdlib/source/lux/concurrency/stm.lux | 66 | ||||
-rw-r--r-- | stdlib/source/lux/test.lux | 7 |
4 files changed, 135 insertions, 164 deletions
diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index f91b3c57f..3a032e00f 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -4,36 +4,49 @@ ["p" parser] ["ex" exception #+ exception:]) [io #- run "io/" Monad<IO>] - (data text/format - (coll [list "list/" Monoid<List> Monad<List> Fold<List>]) - [product]) + (data [product] + ["e" error] + text/format + (coll [list "list/" Monoid<List> Monad<List> Fold<List>])) [macro #+ with-gensyms Monad<Meta>] (macro [code] ["s" syntax #+ syntax: Syntax] (syntax ["cs" common] (common ["csr" reader] ["csw" writer]))) - (type abstract) - (lang [type])) - (// ["A" atom] - ["P" promise "P/" Monad<Promise>] - ["T" task] - [stm #+ Monad<STM>] - [frp])) + (type abstract)) + (// [atom #+ Atom atom] + [promise #+ Promise promise "promise/" Monad<Promise>] + [task #+ Task])) (exception: #export Poisoned) -(exception: #export Killed) (exception: #export Dead) ## [Types] (with-expansions - [<Message> (as-is (-> s (Actor s) (T.Task s))) - <Obituary> (as-is [Text s (List <Message>)])] + [<Message> (as-is (-> s (Actor s) (Task s))) + <Obituary> (as-is [Text s (List <Message>)]) + <Mailbox> (as-is (Rec Mailbox (Promise [<Message> Mailbox])))] + + (def: (obituary mailbox) + (All [a] (-> (Rec Mailbox (Promise [a Mailbox])) (List a))) + (case (promise.poll mailbox) + (#.Some [head tail]) + (#.Cons head (obituary tail)) + + #.None + #.Nil)) + (abstract: #export (Actor s) {#.doc "An actor, defined as all the necessities it requires."} - {#mailbox (stm.Var <Message>) - #kill-switch (P.Promise Unit) - #obituary (P.Promise <Obituary>)} + {#mailbox (Atom <Mailbox>) + #obituary (Promise <Obituary>)} + + ## TODO: Delete after new-luxc becomes the new standard compiler. + (def: (actor mailbox obituary) + (All [s] (-> (Atom <Mailbox>) (Promise <Obituary>) (Actor s))) + (@abstract {#mailbox mailbox + #obituary obituary})) (type: #export (Message s) <Message>) @@ -43,60 +56,36 @@ (type: #export (Behavior s) {#.doc "An actor's behavior when messages are received."} - {#handle (-> (Message s) s (Actor s) (T.Task s)) - #end (-> Text s (P.Promise Unit))}) + {#handle (-> (Message s) s (Actor s) (Task s)) + #end (-> Text s (Promise Unit))}) (def: #export (spawn behavior init) {#.doc "Given a behavior and initial state, spawns an actor and returns it."} (All [s] (-> (Behavior s) s (IO (Actor s)))) (io (let [[handle end] behavior - self (@abstract {#mailbox (stm.var (:! Message [])) - #kill-switch (P.promise #.None) - #obituary (P.promise #.None)}) - mailbox-channel (io.run (stm.follow (get@ #mailbox (@repr self)))) - |mailbox| (stm.var mailbox-channel) - _ (P/map (function [_] - (io.run (do Monad<IO> - [mb (stm.read! |mailbox|)] - (frp.close mb)))) - (get@ #kill-switch (@repr self))) + self (actor (atom (promise #.None)) + (promise #.None)) process (loop [state init - messages mailbox-channel] - (do P.Monad<Promise> - [?messages+ messages] - (case ?messages+ - ## No kill-switch so far, so I may proceed... - (#.Some [message messages']) - (do P.Monad<Promise> - [#let [_ (io.run (stm.write! messages' |mailbox|))] - ?state' (handle message state self)] - (case ?state' - (#.Left error) - (do @ - [#let [_ (io.run (do Monad<IO> - [_ (P.resolve [] (get@ #kill-switch (@repr self)))] - (frp.close messages')))] - _ (end error state) - remaining-messages (frp.consume messages')] - (wrap [error state (#.Cons message remaining-messages)])) - - (#.Right state') - (recur state' messages'))) - - ## Otherwise, clean-up and return current state. - #.None - (do P.Monad<Promise> - [#let [_ (io.run (frp.close messages)) - death-message (Killed "")] - _ (end death-message state)] - (wrap [death-message state (list)])))))] + |mailbox| (io.run (atom.read (get@ #mailbox (@repr self))))] + (do promise.Monad<Promise> + [[head tail] |mailbox| + ?state' (handle head state self)] + (case ?state' + (#e.Error error) + (do @ + [_ (end error state)] + (exec (io.run (promise.resolve [error state (#.Cons head (obituary tail))] + (get@ #obituary (@repr self)))) + (wrap []))) + + (#e.Success state') + (recur state' tail))))] self))) (def: #export (alive? actor) (All [s] (-> (Actor s) Bool)) - (case [(P.poll (get@ #kill-switch (@repr actor))) - (P.poll (get@ #obituary (@repr actor)))] - [#.None #.None] + (case (promise.poll (get@ #obituary (@repr actor))) + #.None true _ @@ -106,27 +95,33 @@ {#.doc "Communicate with an actor through message passing."} (All [s] (-> (Message s) (Actor s) (IO Bool))) (if (alive? actor) - (do Monad<IO> - [_ (stm.write! message (get@ #mailbox (@repr actor)))] - (wrap true)) - (io/wrap false))) - - (def: #export (kill actor) - {#.doc "Immediately kills the given actor (if it is not already dead)."} - (All [s] (-> (Actor s) (io.IO Bool))) - (if (alive? actor) - (|> actor @repr (get@ #kill-switch) (P.resolve [])) + (let [entry [message (promise #.None)]] + (do Monad<IO> + [|mailbox| (atom.read (get@ #mailbox (@repr actor)))] + (loop [|mailbox| |mailbox|] + (case (promise.poll |mailbox|) + #.None + (do @ + [resolved? (promise.resolve entry |mailbox|)] + (if resolved? + (do @ + [_ (atom.write (product.right entry) (get@ #mailbox (@repr actor)))] + (wrap true)) + (recur |mailbox|))) + + (#.Some [_ |mailbox|']) + (recur |mailbox|'))))) (io/wrap false))) )) ## [Values] -(def: #export (default-handle message state self) - (All [s] (-> (Message s) s (Actor s) (T.Task s))) +(def: (default-handle message state self) + (All [s] (-> (Message s) s (Actor s) (Task s))) (message state self)) -(def: #export (default-end cause state) - (All [s] (-> Text s (P.Promise Unit))) - (P/wrap [])) +(def: (default-end cause state) + (All [s] (-> Text s (Promise Unit))) + (promise/wrap [])) (def: #export default-behavior (All [s] (Behavior s)) @@ -138,7 +133,7 @@ but allows the actor to handle previous messages."} (All [s] (-> (Actor s) (IO Bool))) (send (function [state self] - (T.throw Poisoned "")) + (task.throw Poisoned "")) actor)) ## [Syntax] @@ -206,16 +201,16 @@ Nat ((stop cause state) - (:: P.Monad<Promise> wrap - (log! (if (ex.match? ..Killed cause) - (format "Counter was killed: " (%n state)) + (:: promise.Monad<Promise> wrap + (log! (if (ex.match? ..Poisoned cause) + (format "Counter was poisoned: " (%n state)) cause))))) (actor: #export (Stack a) (List a) ((handle message state self) - (do T.Monad<Task> + (do task.Monad<Task> [#let [_ (log! "BEFORE")] output (message state self) #let [_ (log! "AFTER")]] @@ -240,23 +235,23 @@ (..Behavior ((~ g!type) (~+ g!vars)))) {#..handle (~ (case ?handle #.None - (` ..default-handle) + (` (~! ..default-handle)) (#.Some [[messageN stateN selfN] bodyC]) (` (function [(~ (code.local-symbol messageN)) (~ (code.local-symbol stateN)) (~ (code.local-symbol selfN))] - (do T.Monad<Task> + (do task.Monad<Task> [] (~ bodyC)))))) #..end (~ (case ?stop #.None - (` ..default-end) + (` (~! ..default-end)) (#.Some [[causeN stateN] bodyC]) (` (function [(~ (code.local-symbol causeN)) (~ (code.local-symbol stateN))] - (do P.Monad<Promise> + (do promise.Monad<Promise> [] (~ bodyC))))))})) (` (def: (~+ (csw.export export)) ((~ g!new) (~ g!init)) @@ -300,16 +295,18 @@ (message: #export Counter (count! [increment Nat] state self Nat) (let [state' (n/+ increment state)] - (T.return [state' state']))) + (task.return [state' state']))) (message: #export (Stack a) (push [value a] state self (List a)) (let [state' (#.Cons value state)] - (T.return [state' state']))))} + (task.return [state' state']))))} (with-gensyms [g!return g!error g!task g!sent?] (do @ - [actor-name (resolve-actor actor-name) - #let [g!type (code.symbol (product.both id state-name actor-name)) + [current-module macro.current-module-name + actor-name (resolve-actor actor-name) + #let [message-name [current-module (get@ #name signature)] + g!type (code.symbol (product.both id state-name actor-name)) g!message (code.local-symbol (get@ #name signature)) g!actor-vars (list/map code.local-symbol actor-vars) actorC (` ((~ (code.symbol actor-name)) (~+ g!actor-vars))) @@ -338,28 +335,30 @@ (~ (|> annotations (with-message actor-name) csw.annotations)) - (All [(~+ g!all-vars)] (-> (~+ g!inputsT) (~ actorC) (T.Task (~ (get@ #output signature))))) - (let [(~ g!task) (T.task (~ g!outputT))] + (All [(~+ g!all-vars)] (-> (~+ g!inputsT) (~ actorC) (Task (~ (get@ #output signature))))) + (let [(~ g!task) (task.task (~ g!outputT))] (io.run (do io.Monad<IO> [(~ g!sent?) (..send (function [(~ g!state) (~ g!self)] - (do P.Monad<Promise> - [(~ g!return) (: (T.Task [((~ g!type) (~+ g!actor-refs)) - (~ g!outputT)]) - (do T.Monad<Task> + (do promise.Monad<Promise> + [(~ g!return) (: (Task [((~ g!type) (~+ g!actor-refs)) + (~ g!outputT)]) + (do task.Monad<Task> [] (~ body)))] (case (~ g!return) (#.Right [(~ g!state) (~ g!return)]) - (exec (io.run (P.resolve (#.Right (~ g!return)) (~ g!task))) - (T.return (~ g!state))) + (exec (io.run (promise.resolve (#.Right (~ g!return)) (~ g!task))) + (task.return (~ g!state))) (#.Left (~ g!error)) - (exec (io.run (P.resolve (#.Left (~ g!error)) (~ g!task))) - (T.fail (~ g!error)))) + (exec (io.run (promise.resolve (#.Left (~ g!error)) (~ g!task))) + (task.fail (~ g!error)))) )) (~ g!self))] (if (~ g!sent?) ((~' wrap) (~ g!task)) - ((~' wrap) (T.throw ..Dead "")))))))) + ((~' wrap) (<| (task.throw ..Dead) + (~ (code.text (format " Actor: " (%ident actor-name) "\n" + "Message: " (%ident message-name) "\n"))))))))))) )) ))) diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index d45e8e55a..429a11931 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -5,31 +5,27 @@ (control [functor #+ Functor] [applicative #+ Applicative] [monad #+ do Monad]) + (data [product]) (concurrency [atom #+ Atom atom]))) (def: #export concurrency-level Nat ("lux process concurrency-level")) -(type: (Promise-State a) - {#value (Maybe a) - #observers (List (-> a (IO Top)))}) - (type: #export (Promise a) {#.doc "Represents values produced by asynchronous computations (unlike IO, which is synchronous)."} - (Atom (Promise-State a))) + (Atom [(Maybe a) (List (-> a (IO Top)))])) (def: #export (promise ?value) (All [a] (-> (Maybe a) (Promise a))) - (atom {#value ?value - #observers (list)})) + (atom [?value (list)])) (def: #export (poll promise) {#.doc "Polls a promise's value."} (All [a] (-> (Promise a) (Maybe a))) (|> (atom.read promise) io.run - (get@ #value))) + product.left)) (def: #export (resolved? promise) {#.doc "Checks whether a promise's value has already been resolved."} @@ -45,31 +41,31 @@ {#.doc "Sets an promise's value if it has not been done yet."} (All [a] (-> a (Promise a) (IO Bool))) (do io.Monad<IO> - [old (atom.read promise)] - (case (get@ #value old) + [(^@ old [_value _observers]) (atom.read promise)] + (case _value (#.Some _) (wrap false) #.None (do @ - [#let [new (set@ #value (#.Some value) old)] + [#let [new [(#.Some value) _observers]] succeeded? (atom.compare-and-swap old new promise)] (if succeeded? (do @ [_ (monad.map @ (function [f] (f value)) - (get@ #observers old))] + _observers)] (wrap true)) (resolve value promise)))))) (def: #export (await f promise) (All [a] (-> (-> a (IO Top)) (Promise a) Top)) - (let [old (io.run (atom.read promise))] - (case (get@ #value old) + (let [(^@ old [_value _observers]) (io.run (atom.read promise))] + (case _value (#.Some value) (io.run (f value)) #.None - (let [new (update@ #observers (|>> (#.Cons f)) old)] + (let [new [_value (#.Cons f _observers)]] (if (io.run (atom.compare-and-swap old new promise)) [] (await f promise)))))) @@ -85,8 +81,7 @@ (def: functor Functor<Promise>) (def: (wrap a) - (atom {#value (#.Some a) - #observers (list)})) + (atom [(#.Some a) (list)])) (def: (apply ff fa) (let [fb (promise #.None)] diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index 0fe9ee9df..09daa5e2d 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -4,28 +4,20 @@ [applicative #+ Applicative] [monad #+ do Monad]) [io #- run] - (data (coll [list "list/" Functor<List> Fold<List>] - [dict #+ Dict]) - [product] - [text] - maybe + (data [product] + [maybe] [number "nat/" Codec<Text,Nat>] - text/format) - [macro] - (macro [code] - ["s" syntax #+ syntax: Syntax]) + [text] + (coll [list "list/" Functor<List> Fold<List>] + [dict #+ Dict])) (concurrency [atom #+ Atom atom] ["P" promise] [frp "frp/" Functor<Channel>]) )) -(type: (Var-State a) - {#value a - #observers (Dict Text (-> a (IO Unit)))}) - (type: #export (Var a) {#.doc "A mutable cell containing a value, and observers that will be alerted of any change to it."} - (Atom (Var-State a))) + (Atom [a (Dict Text (-> a (IO Unit)))])) (type: (Tx-Frame a) {#var (Var a) @@ -42,12 +34,11 @@ (def: #export (var value) {#.doc "Creates a new STM var, with a default value."} (All [a] (-> a (Var a))) - (atom.atom {#value value - #observers (dict.new text.Hash<Text>)})) + (atom.atom [value (dict.new text.Hash<Text>)])) (def: raw-read (All [a] (-> (Var a) a)) - (|>> atom.read io.run (get@ #value))) + (|>> atom.read io.run product.left)) (def: (find-var-value var tx) (All [a] (-> (Var a) Tx (Maybe a))) @@ -55,8 +46,8 @@ (list.find (function [[_var _original _current]] (is (:! (Var Unit) var) (:! (Var Unit) _var)))) - (:: Monad<Maybe> map (function [[_var _original _current]] - _current)) + (:: maybe.Monad<Maybe> map (function [[_var _original _current]] + _current)) (:!!) )) @@ -77,7 +68,7 @@ (All [a] (-> (Var a) (IO a))) (|> var atom.read - (:: Functor<IO> map (get@ #value)))) + (:: Functor<IO> map product.left))) (def: (update-tx-value var value tx) (All [a] (-> (Var a) a Tx Tx)) @@ -99,6 +90,7 @@ )) (def: #export (write value var) + {#.doc "Writes value to var."} (All [a] (-> a (Var a) (STM Unit))) (function [tx] (case (find-var-value var tx) @@ -110,18 +102,14 @@ [(#.Cons [var (raw-read var) value] tx) []]))) -(def: #export (write! new-value var) - {#.doc "Writes value to var immediately, without going through a transaction."} +(def: (write! new-value var) (All [a] (-> a (Var a) (IO Unit))) (do Monad<IO> - [old (atom.read var) - #let [old-value (get@ #value old) - new (set@ #value new-value old)] - succeeded? (atom.compare-and-swap old new var)] + [(^@ old [_value _observers]) (atom.read var) + succeeded? (atom.compare-and-swap old [new-value _observers] var)] (if succeeded? (do @ - [_ (|> old - (get@ #observers) + [_ (|> _observers dict.values (monad.map @ (function [f] (f new-value))))] (wrap [])) @@ -185,18 +173,6 @@ (let [[tx' ma] (mma tx)] (ma tx'))))) -(def: #export (update! f var) - {#.doc "Will update a Var's value, and return a tuple with the old and the new values."} - (All [a] (-> (-> a a) (Var a) (IO [a a]))) - (io (loop [_ []] - (let [(^@ state [value observers]) (io.run (atom.read var)) - value' (f value)] - (if (io.run (atom.compare-and-swap state - [value' observers] - var)) - [value value'] - (recur [])))))) - (def: #export (update f var) {#.doc "Will update a Var's value, and return a tuple with the old and the new values."} (All [a] (-> (-> a a) (Var a) (STM [a a]))) @@ -212,7 +188,7 @@ (is _original (raw-read _var))) tx)) -(def: (commit-var [_var _original _current]) +(def: (commit-var! [_var _original _current]) (-> (Ex [a] (Tx-Frame a)) Unit) (if (is _original _current) [] @@ -231,10 +207,10 @@ (def: (process-commit [stm-proc output]) (-> [(STM Unit) (P.Promise Unit)] Top) (let [[finished-tx value] (stm-proc fresh-tx)] - (if (can-commit? finished-tx) - (exec (list/map commit-var finished-tx) - (io.run (P.resolve value output))) - (io.run (write! [stm-proc output] pending-commits))))) + (io.run (if (can-commit? finished-tx) + (exec (list/map commit-var! finished-tx) + (P.resolve value output)) + (write! [stm-proc output] pending-commits))))) (def: init-processor! (IO Unit) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index b755299cd..e000f6130 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -56,9 +56,10 @@ (def: #export (assert message condition) {#.doc "Check that a condition is true, and fail with the given message otherwise."} (-> Text Bool (Promise [Counters Text])) - (if condition - (:: promise.Monad<Promise> wrap [success (format "[Success] " message)]) - (:: promise.Monad<Promise> wrap [failure (format " [Error] " message)]))) + (<| (:: promise.Monad<Promise> wrap) + (if condition + [success (format "[Success] " message)] + [failure (format " [Error] " message)]))) (def: #export (test message condition) {#.doc "Check that a condition is true, and fail with the given message otherwise."} |