From 9965c551e7ccd6de8c47c7b1b78f804801810dac Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 16 May 2020 20:19:34 -0400 Subject: Parallel compilation for the new compiler(s). --- stdlib/source/test/lux/abstract/equivalence.lux | 25 +- stdlib/source/test/lux/control.lux | 5 +- .../test/lux/control/concurrency/semaphore.lux | 277 ++++++++++++--------- 3 files changed, 179 insertions(+), 128 deletions(-) (limited to 'stdlib/source/test') diff --git a/stdlib/source/test/lux/abstract/equivalence.lux b/stdlib/source/test/lux/abstract/equivalence.lux index b7db2ee70..7cc5c95f9 100644 --- a/stdlib/source/test/lux/abstract/equivalence.lux +++ b/stdlib/source/test/lux/abstract/equivalence.lux @@ -18,7 +18,9 @@ [leftN random.nat rightN random.nat leftI random.int - rightI random.int] + rightI random.int + sample random.nat + different (|> random.nat (random.filter (|>> (n.= sample) not)))] (<| (_.covering /._) ($_ _.and (_.cover [/.sum] @@ -38,7 +40,26 @@ (:: equivalence = [leftN leftI] [leftN leftI])) (bit@= (and (:: n.equivalence = leftN rightN) (:: i.equivalence = leftI rightI)) - (:: equivalence = [leftN leftI] [rightN rightI]))))))))) + (:: equivalence = [leftN leftI] [rightN rightI]))))) + (_.cover [/.rec] + (let [equivalence (: (Equivalence (List Nat)) + (/.rec (function (_ equivalence) + (structure + (def: (= left right) + (case [left right] + [#.Nil #.Nil] + true + + [(#.Cons leftH lefT) (#.Cons rightH rightT)] + (and (n.= leftH rightH) + (:: equivalence = lefT rightT)) + + _ + false))))))] + (and (:: equivalence = (list sample sample) (list sample sample)) + (not (:: equivalence = (list sample sample) (list sample))) + (not (:: equivalence = (list sample sample) (list different different)))))) + )))) (def: #export (spec (^open "_@.") generator) (All [a] (-> (Equivalence a) (Random a) Test)) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index b393e1325..dbfb5b4a4 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -22,6 +22,7 @@ ["#." frp] ["#." process] ["#." promise] + ["#." semaphore] ["#." stm]] ["#." parser #_ ["#/." text] @@ -29,8 +30,7 @@ [security ["#." policy]] [function - ["#." memo]] - ]) + ["#." memo]]]) (def: concurrency Test @@ -40,6 +40,7 @@ /frp.test /process.test /promise.test + /semaphore.test /stm.test )) diff --git a/stdlib/source/test/lux/control/concurrency/semaphore.lux b/stdlib/source/test/lux/control/concurrency/semaphore.lux index bd5d72d43..e26c1a0f2 100644 --- a/stdlib/source/test/lux/control/concurrency/semaphore.lux +++ b/stdlib/source/test/lux/control/concurrency/semaphore.lux @@ -1,146 +1,175 @@ (.module: [lux #* + ["_" test (#+ Test)] [abstract ["." monad (#+ do)]] [control ["." io] + ["." try] + ["." exception (#+ exception:)] [concurrency - ["/" semaphore] ["." promise (#+ Promise)] ["." atom (#+ Atom)]]] [data ["." maybe] [number ["n" nat]] - ["." text ("#;." equivalence monoid) + ["." text ("#@." equivalence) ["%" format (#+ format)]] [collection - ["." list ("#;." functor)]]] + ["." list ("#@." functor)]]] + [type + ["." refinement]] [math - ["r" random]]] - lux/test) + ["." random]]] + {1 + ["." /]}) -## (def: (wait-many-times times semaphore) -## (-> Nat /.Semaphore (Promise Any)) -## (loop [steps times] -## (if (n.> 0 steps) -## (do promise.monad -## [_ (/.wait semaphore)] -## (recur (dec steps))) -## (:: promise.monad wrap [])))) +(def: semaphore + Test + (_.with-cover [/.Semaphore] + ($_ _.and + (do random.monad + [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + #let [semaphore (/.semaphore initial-open-positions)]] + (wrap (do promise.monad + [result (promise.time-out 10 (/.wait semaphore))] + (_.claim [/.semaphore] + (case result + (#.Some _) + true -## (context: "Semaphore." -## (<| (times 100) -## (do @ -## [open-positions (|> r.nat (:: @ map (|>> (n.% 10) (n.max 1))))] -## ($_ seq -## (let [semaphore (/.semaphore open-positions)] -## (wrap (do promise.monad -## [_ (wait-many-times open-positions semaphore)] -## (assert "Can wait on a semaphore up to the number of open positions without blocking." -## true)))) -## (let [semaphore (/.semaphore open-positions)] -## (wrap (do promise.monad -## [result (<| (promise.time-out 100) -## (wait-many-times (inc open-positions) semaphore))] -## (assert "Waiting on a semaphore more than the number of open positions blocks the process." -## (case result -## (#.Some _) -## false + #.None + false))))) + (do random.monad + [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + #let [semaphore (/.semaphore initial-open-positions)]] + (wrap (do promise.monad + [_ (monad.map @ /.wait (list.repeat initial-open-positions semaphore)) + result (promise.time-out 10 (/.wait semaphore))] + (_.claim [/.wait] + (case result + (#.Some _) + false -## #.None -## true))))) -## (let [semaphore (/.semaphore open-positions)] -## (wrap (do promise.monad -## [_ (: (Promise Any) -## (loop [steps (n.* 2 open-positions)] -## (if (n.> 0 steps) -## (do @ -## [_ (/.wait semaphore) -## _ (/.signal semaphore)] -## (recur (dec steps))) -## (wrap []))))] -## (assert "Signaling a semaphore replenishes its open positions." -## true)))) -## (let [semaphore (/.semaphore open-positions)] -## (wrap (do promise.monad -## [#let [resource (atom.atom "") -## blocked (do @ -## [_ (wait-many-times open-positions semaphore) -## _ (/.wait semaphore) -## #let [_ (io.run (atom.update (|>> (format "B")) -## resource))]] -## (wrap []))] -## _ (promise.wait 100) -## _ (exec (io.run (atom.update (|>> (format "A")) -## resource)) -## (/.signal semaphore)) -## _ blocked] -## (assert "A blocked process can be un-blocked by a signal somewhere else." -## (text;= "BA" -## (io.run (atom.read resource))))))) -## )))) + #.None + true))))) + (do random.monad + [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + #let [semaphore (/.semaphore initial-open-positions)]] + (wrap (do promise.monad + [_ (monad.map @ /.wait (list.repeat initial-open-positions semaphore)) + #let [block (/.wait semaphore)] + result/0 (promise.time-out 10 block) + open-positions (/.signal semaphore) + result/1 (promise.time-out 10 block)] + (_.claim [/.signal] + (case [result/0 result/1 open-positions] + [#.None (#.Some _) (#try.Success +0)] + true -## (context: "Mutex." -## (<| (times 100) -## (do @ -## [repetitions (|> r.nat (:: @ map (|>> (n.% 100) (n.max 10))))] -## ($_ seq -## (let [mutex (/.mutex [])] -## (wrap (do promise.monad -## [#let [resource (atom.atom "") -## expected-As (text.join-with "" (list.repeat repetitions "A")) -## expected-Bs (text.join-with "" (list.repeat repetitions "B")) -## processA (<| (/.synchronize mutex) -## io.io -## promise.future -## (do io.monad -## [_ (<| (monad.seq @) -## (list.repeat repetitions) -## (atom.update (|>> (format "A")) resource))] -## (wrap []))) -## processB (<| (/.synchronize mutex) -## io.io -## promise.future -## (do io.monad -## [_ (<| (monad.seq @) -## (list.repeat repetitions) -## (atom.update (|>> (format "B")) resource))] -## (wrap [])))] -## _ processA -## _ processB -## #let [outcome (io.run (atom.read resource))]] -## (assert "Mutexes only allow one process to execute at a time." -## (or (text;= (format expected-As expected-Bs) -## outcome) -## (text;= (format expected-Bs expected-As) -## outcome)))))) -## )))) + _ + false))))) + (do random.monad + [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + #let [semaphore (/.semaphore initial-open-positions)]] + (wrap (do promise.monad + [outcome (/.signal semaphore)] + (_.claim [/.semaphore-is-maxed-out] + (case outcome + (#try.Failure error) + (exception.match? /.semaphore-is-maxed-out error) -## (def: (waiter resource barrier id) -## (-> (Atom Text) /.Barrier Nat (Promise Any)) -## (do promise.monad -## [_ (/.block barrier) -## #let [_ (io.run (atom.update (|>> (format (%.nat id))) resource))]] -## (wrap []))) + _ + false))))) + ))) -## (context: "Barrier." -## (let [limit 10 -## barrier (/.barrier (maybe.assume (/.limit limit))) -## resource (atom.atom "")] -## ($_ seq -## (wrap (do promise.monad -## [#let [ids (list.n/range 0 (dec limit)) -## waiters (list;map (function (_ id) -## (let [process (waiter resource barrier id)] -## (exec (io.run (atom.update (|>> (format "_")) resource)) -## process))) -## ids)] -## _ (monad.seq @ waiters) -## #let [outcome (io.run (atom.read resource))]] -## (assert "A barrier can stop all processes from acting, until an amount of waiting processes is reached, and then the barrier is un-blocked for all." -## (and (text.ends-with? "__________" outcome) -## (list.every? (function (_ id) -## (text.contains? (%.nat id) outcome)) -## ids) -## ))))))) +(def: mutex + Test + (_.with-cover [/.Mutex] + ($_ _.and + (do random.monad + [repetitions (|> random.nat (:: @ map (|>> (n.% 100) (n.max 10)))) + #let [resource (atom.atom "") + expected-As (text.join-with "" (list.repeat repetitions "A")) + expected-Bs (text.join-with "" (list.repeat repetitions "B")) + mutex (/.mutex []) + processA (<| (/.synchronize mutex) + io.io + promise.future + (do io.monad + [_ (<| (monad.seq @) + (list.repeat repetitions) + (atom.update (|>> (format "A")) resource))] + (wrap []))) + processB (<| (/.synchronize mutex) + io.io + promise.future + (do io.monad + [_ (<| (monad.seq @) + (list.repeat repetitions) + (atom.update (|>> (format "B")) resource))] + (wrap [])))]] + (wrap (do promise.monad + [_ processA + _ processB + #let [outcome (io.run (atom.read resource))]] + (_.claim [/.mutex /.synchronize] + (or (text@= (format expected-As expected-Bs) + outcome) + (text@= (format expected-Bs expected-As) + outcome)))))) + ))) + +(def: (waiter resource barrier id) + (-> (Atom Text) /.Barrier Nat (Promise Any)) + (do promise.monad + [_ (/.block barrier) + _ (promise.future (atom.update (|>> (format (%.nat id))) resource))] + (wrap []))) + +(def: barrier + Test + (_.with-cover [/.Barrier] + ($_ _.and + (do random.monad + [raw random.nat] + (_.cover [/.Limit /.limit] + (case [raw (/.limit raw)] + [0 #.None] + true + + [_ (#.Some limit)] + (and (n.> 0 raw) + (n.= raw (refinement.un-refine limit)))))) + (do random.monad + [limit (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + #let [barrier (/.barrier (maybe.assume (/.limit limit))) + resource (atom.atom "")]] + (wrap (do promise.monad + [#let [ending (|> "_" + (list.repeat limit) + (text.join-with "")) + ids (list.n/range 0 (dec limit)) + waiters (list@map (function (_ id) + (exec (io.run (atom.update (|>> (format "_")) resource)) + (waiter resource barrier id))) + ids)] + _ (monad.seq @ waiters) + #let [outcome (io.run (atom.read resource))]] + (_.claim [/.barrier /.block] + (and (text.ends-with? ending outcome) + (list.every? (function (_ id) + (text.contains? (%.nat id) outcome)) + ids) + ))))) + ))) + +(def: #export test + Test + (<| (_.covering /._) + ($_ _.and + ..semaphore + ..mutex + ..barrier + ))) -- cgit v1.2.3