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/lux.lux | 56 ++-- .../source/lux/control/concurrency/semaphore.lux | 148 ++++++---- stdlib/source/lux/data/collection/queue.lux | 8 +- .../source/lux/tool/compiler/default/platform.lux | 319 +++++++++++++++------ .../compiler/language/lux/analysis/evaluation.lux | 26 +- .../lux/tool/compiler/language/lux/generation.lux | 5 + .../language/lux/phase/extension/directive/lux.lux | 8 +- stdlib/source/lux/tool/compiler/meta/archive.lux | 32 +-- stdlib/source/lux/type.lux | 11 +- stdlib/source/lux/type/refinement.lux | 15 +- stdlib/source/program/compositor.lux | 56 +--- stdlib/source/program/compositor/cli.lux | 31 +- stdlib/source/program/compositor/static.lux | 11 + stdlib/source/test/lux/abstract/equivalence.lux | 25 +- stdlib/source/test/lux/control.lux | 5 +- .../test/lux/control/concurrency/semaphore.lux | 277 ++++++++++-------- 16 files changed, 633 insertions(+), 400 deletions(-) create mode 100644 stdlib/source/program/compositor/static.lux (limited to 'stdlib') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index cabbb1154..bda5f60d9 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -2702,7 +2702,11 @@ (let' [[left right] pair] (list left right))) -(def:' (%code code) +(def:' (text@encode original) + (-> Text Text) + ($_ text@compose ..double-quote original ..double-quote)) + +(def:' (code@encode code) (-> Code Text) ({[_ (#Bit value)] (bit@encode value) @@ -2720,7 +2724,7 @@ (frac@encode value) [_ (#Text value)] - ($_ text@compose ..double-quote value ..double-quote) + (text@encode value) [_ (#Identifier [prefix name])] (if (text@= "" prefix) @@ -2734,21 +2738,21 @@ [_ (#Form xs)] ($_ text@compose "(" (|> xs - (list@map %code) + (list@map code@encode) (interpose " ") list@reverse (list@fold text@compose "")) ")") [_ (#Tuple xs)] ($_ text@compose "[" (|> xs - (list@map %code) + (list@map code@encode) (interpose " ") list@reverse (list@fold text@compose "")) "]") [_ (#Record kvs)] ($_ text@compose "{" (|> kvs - (list@map (function' [kv] ({[k v] ($_ text@compose (%code k) " " (%code v))} + (list@map (function' [kv] ({[k v] ($_ text@compose (code@encode k) " " (code@encode v))} kv))) (interpose " ") list@reverse @@ -2782,7 +2786,7 @@ _ (fail ($_ text@compose "'lux.case' expects an even number of tokens: " (|> branches - (list@map %code) + (list@map code@encode) (interpose " ") list@reverse (list@fold text@compose ""))))} @@ -2991,13 +2995,13 @@ _ (` (#.Cons [[(~ cursor-code) (#.Tag ["lux" "func-args"])] [(~ cursor-code) (#.Tuple (.list (~+ (list@map (function (_ arg) - (` [(~ cursor-code) (#.Text (~ (text$ (%code arg))))])) + (` [(~ cursor-code) (#.Text (~ (text$ (code@encode arg))))])) args))))]] (~ meta))))) (def:' (with-type-args args) (-> (List Code) Code) - (` {#.type-args [(~+ (list@map (function (_ arg) (text$ (%code arg))) + (` {#.type-args [(~+ (list@map (function (_ arg) (text$ (code@encode arg))) args))]})) (def:' (export^ tokens) @@ -3987,18 +3991,18 @@ [current-module current-module-name] (fail ($_ text@compose "Wrong syntax for import @ " current-module - ..new-line (%code token))))))) + ..new-line (code@encode token))))))) imports)] (wrap (list@join imports')))) (def: (exported-definitions module state) (-> Text (Meta (List Text))) - (let [modules (case state - {#info info #source source #current-module _ #modules modules - #scopes scopes #type-context types #host host - #seed seed #expected expected #cursor cursor #extensions extensions - #scope-type-vars scope-type-vars} - modules)] + (let [[current-module modules] (case state + {#info info #source source #current-module current-module #modules modules + #scopes scopes #type-context types #host host + #seed seed #expected expected #cursor cursor #extensions extensions + #scope-type-vars scope-type-vars} + [current-module modules])] (case (get module modules) (#Some =module) (let [to-alias (list@map (: (-> [Text Global] @@ -4017,7 +4021,19 @@ (#Right state (list@join to-alias))) #None - (#Left ($_ text@compose "Unknown module: " module))) + (#Left ($_ text@compose + "Unknown module: " (text@encode module) ..new-line + "Current module: " (case current-module + (#Some current-module) + (text@encode current-module) + + #None + "???") ..new-line + "Known modules: " (|> modules + (list@map (function (_ [name module]) + (text$ name))) + tuple$ + code@encode)))) )) (def: (filter p xs) @@ -4484,7 +4500,7 @@ _ (fail ($_ text@compose "Wrong syntax for refer @ " current-module ..new-line (|> options - (list@map %code) + (list@map code@encode) (interpose " ") (list@fold text@compose ""))))))) @@ -4892,10 +4908,6 @@ _ (#Doc-Example code))) -(def: (text@encode original) - (-> Text Text) - ($_ text@compose ..double-quote original ..double-quote)) - (template [ ] [(def: #export {#.doc } @@ -5547,7 +5559,7 @@ (undefined)))} (case tokens #Nil - (return (list (` (error! "Undefined behavior.")))) + (return (list (` (..error! "Undefined behavior.")))) _ (fail (..wrong-syntax-error (name-of ..undefined))))) diff --git a/stdlib/source/lux/control/concurrency/semaphore.lux b/stdlib/source/lux/control/concurrency/semaphore.lux index ade45984e..39bac32a1 100644 --- a/stdlib/source/lux/control/concurrency/semaphore.lux +++ b/stdlib/source/lux/control/concurrency/semaphore.lux @@ -2,79 +2,115 @@ [lux #* [abstract [monad (#+ do)]] + [control + ["." io (#+ IO)] + ["." try (#+ Try)] + ["." exception (#+ exception:)]] [data + [text + ["%" format (#+ format)]] [number - ["n" nat]]] - [control - ["." io (#+ IO)]] + ["n" nat] + ["i" int]] + [collection + ["." queue (#+ Queue)]]] [type abstract - ["." refinement]]] + ["." refinement]] + ["." macro]] [// ["." atom (#+ Atom)] - ["." promise (#+ Promise)]]) + ["." promise (#+ Promise Resolver)]]) (type: State - {#open-positions Nat - #waiting-list (List (Promise Any))}) + {#max-positions Nat + #open-positions Int + #waiting-list (Queue (Resolver Any))}) (abstract: #export Semaphore {#.doc "A tool for controlling access to resources by multiple concurrent processes."} (Atom State) - (def: #export (semaphore init-open-positions) + (def: most-positions-possible + (.nat (:: i.interval top))) + + (def: #export (semaphore initial-open-positions) (-> Nat Semaphore) - (:abstraction (atom.atom {#open-positions init-open-positions - #waiting-list (list)}))) + (let [max-positions (n.min initial-open-positions + ..most-positions-possible)] + (:abstraction (atom.atom {#max-positions max-positions + #open-positions (.int max-positions) + #waiting-list queue.empty})))) (def: #export (wait semaphore) (Ex [k] (-> Semaphore (Promise Any))) - (let [semaphore (:representation semaphore)] - (io.run - (loop [signal (: (Promise Any) - (promise.promise #.None))] - (do io.monad - [state (atom.read semaphore) - #let [[ready? state'] (: [Bit State] - (case (get@ #open-positions state) - 0 [#0 (update@ #waiting-list (|>> (#.Cons signal)) - state)] - _ [#1 (update@ #open-positions dec - state)]))] - success? (atom.compare-and-swap state state' semaphore) - _ (if ready? - (promise.resolve [] signal) - (wrap #0))] - (if success? - (wrap signal) - (recur signal))))))) + (let [semaphore (:representation semaphore) + [signal sink] (: [(Promise Any) (Resolver Any)] + (promise.promise []))] + (exec (promise.future + (loop [_ []] + (do io.monad + [state (atom.read semaphore) + #let [[ready? state'] (: [Bit State] + (if (i.> +0 (get@ #open-positions state)) + [true (|> state + (update@ #open-positions dec))] + [false (|> state + (update@ #open-positions dec) + (update@ #waiting-list (queue.push sink)))]))] + success? (atom.compare-and-swap state state' semaphore)] + (if success? + (if ready? + (sink []) + (wrap false)) + (recur []))))) + signal))) + + (exception: #export (semaphore-is-maxed-out {max-positions Nat}) + (exception.report + ["Max Positions" (%.nat max-positions)])) (def: #export (signal semaphore) - (Ex [k] (-> Semaphore (Promise Any))) + (Ex [k] (-> Semaphore (Promise (Try Int)))) (let [semaphore (:representation semaphore)] (promise.future (loop [_ []] (do io.monad [state (atom.read semaphore) - #let [[?signal state'] (: [(Maybe (Promise Any)) State] - (case (get@ #waiting-list state) - #.Nil - [#.None (update@ #open-positions inc state)] - - (#.Cons head tail) - [(#.Some head) (set@ #waiting-list tail state)]))] - success? (atom.compare-and-swap state state' semaphore)] - (if success? + #let [[?sink state' maxed-out?] (: [(Maybe (Resolver Any)) State Bit] + (case (queue.peek (get@ #waiting-list state)) + #.None + (if (n.= (get@ #max-positions state) + (.nat (get@ #open-positions state))) + [#.None + state + true] + [#.None + (update@ #open-positions inc state) + false]) + + (#.Some head) + [(#.Some head) + (|> state + (update@ #open-positions inc) + (update@ #waiting-list queue.pop)) + false]))]] + (if maxed-out? + (wrap (exception.throw ..semaphore-is-maxed-out [(get@ #max-positions state)])) (do @ - [_ (case ?signal - #.None - (wrap #1) - - (#.Some signal) - (promise.resolve [] signal))] - (wrap [])) - (recur []))))))) + [#let [open-positions (get@ #open-positions state')] + success? (atom.compare-and-swap state state' semaphore)] + (if success? + (do @ + [_ (case ?sink + #.None + (wrap true) + + (#.Some sink) + (sink []))] + (wrap (#try.Success open-positions))) + (recur []))))))))) ) (abstract: #export Mutex @@ -104,7 +140,7 @@ ) (def: #export limit (refinement.refinement (n.> 0))) -(`` (type: #export Limit (~~ (refinement.type limit)))) +(type: #export Limit (:~ (refinement.type limit))) (abstract: #export Barrier {#.doc "A barrier that blocks all processes from proceeding until a given number of processes are parked at the barrier."} @@ -126,7 +162,7 @@ (loop [step 0] (if (n.< times step) (do promise.monad - [_ (signal turnstile)] + [_ (..signal turnstile)] (recur (inc step))) (:: promise.monad wrap [])))) @@ -136,11 +172,11 @@ (do promise.monad [#let [limit (refinement.un-refine (get@ #limit barrier)) goal - count (io.run (atom.update (get@ #count barrier)))] - _ (if (n.= goal count) - (un-block limit (get@ barrier)) - (wrap []))] - (wait (get@ barrier))))] + count (io.run (atom.update (get@ #count barrier))) + reached? (n.= goal count)]] + (if reached? + (un-block limit (get@ barrier)) + (wait (get@ barrier)))))] [start inc limit #start-turnstile] [end dec 0 #end-turnstile] @@ -149,6 +185,6 @@ (def: #export (block barrier) (-> Barrier (Promise Any)) (do promise.monad - [_ (start barrier)] - (end barrier))) + [_ (..start barrier)] + (..end barrier))) ) diff --git a/stdlib/source/lux/data/collection/queue.lux b/stdlib/source/lux/data/collection/queue.lux index 9bf4dcf81..c0e16ee29 100644 --- a/stdlib/source/lux/data/collection/queue.lux +++ b/stdlib/source/lux/data/collection/queue.lux @@ -7,7 +7,7 @@ [number ["n" nat]] [collection - ["." list ("#;." monoid functor)]]]]) + ["." list ("#@." monoid functor)]]]]) (type: #export (Queue a) {#front (List a) @@ -26,7 +26,7 @@ (def: #export (to-list queue) (All [a] (-> (Queue a) (List a))) (let [(^slots [#front #rear]) queue] - (list;compose front (list.reverse rear)))) + (list@compose front (list.reverse rear)))) (def: #export peek (All [a] (-> (Queue a) (Maybe a))) @@ -79,5 +79,5 @@ (structure: #export functor (Functor Queue) (def: (map f fa) - {#front (|> fa (get@ #front) (list;map f)) - #rear (|> fa (get@ #rear) (list;map f))})) + {#front (|> fa (get@ #front) (list@map f)) + #rear (|> fa (get@ #rear) (list@map f))})) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 76939bb08..f562e762a 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -7,7 +7,8 @@ [control ["." try (#+ Try)] [concurrency - ["." promise (#+ Promise) ("#@." monad)]]] + ["." promise (#+ Promise Resolver) ("#@." monad)] + ["." stm (#+ Var STM)]]] [data ["." binary (#+ Binary)] ["." bit] @@ -15,10 +16,10 @@ ["." text ["%" format (#+ format)]] [collection - [dictionary (#+ Dictionary)] - ["." row ("#@." fold)] + ["." dictionary (#+ Dictionary)] + ["." row (#+ Row) ("#@." fold)] ["." set] - ["." list ("#@." monoid)]] + ["." list ("#@." monoid functor fold)]] [format ["_" binary (#+ Writer)]]] [world @@ -51,7 +52,8 @@ ["ioW" archive]]]]] [program [compositor - ["." cli (#+ Configuration)]]]) + ["." cli (#+ Configuration)] + ["." static (#+ Static)]]]) (type: #export (Platform anchor expression directive) {#&file-system (file.System Promise) @@ -79,23 +81,23 @@ (_.and descriptor.writer (document.writer $.writer))) - (def: (cache-module platform host target-dir module-id extension [[descriptor document] output]) + (def: (cache-module static platform module-id [[descriptor document] output]) (All [] - (-> Host Path archive.ID Text [[Descriptor (Document Any)] Output] + (-> Static archive.ID [[Descriptor (Document Any)] Output] (Promise (Try Any)))) (let [system (get@ #&file-system platform) write-artifact! (: (-> [Text Binary] (Action Any)) (function (_ [name content]) - (ioW.write system host target-dir module-id name extension content)))] + (ioW.write system (get@ #static.host static) (get@ #static.target static) module-id name (get@ #static.artifact-extension static) content)))] (do ..monad - [_ (ioW.prepare system host target-dir module-id) + [_ (ioW.prepare system (get@ #static.host static) (get@ #static.target static) module-id) _ (|> output row.to-list (monad.map ..monad write-artifact!) (: (Action (List Any)))) document (:: promise.monad wrap (document.check $.key document))] - (ioW.cache system host target-dir module-id + (ioW.cache system (get@ #static.host static) (get@ #static.target static) module-id (_.run ..writer [descriptor document]))))) ## TODO: Inline ASAP @@ -173,11 +175,9 @@ (///phase.run' state) (:: try.monad map product.left))) - (def: #export (initialize extension target host module expander host-analysis platform generation-bundle host-directive-bundle program extender) + (def: #export (initialize static module expander host-analysis platform generation-bundle host-directive-bundle program extender) (All [] - (-> Text - Path - Host + (-> Static Module Expander ///analysis.Bundle @@ -188,7 +188,7 @@ Extender (Promise (Try [ Archive])))) (do (try.with promise.monad) - [#let [state (//init.state host + [#let [state (//init.state (get@ #static.host static) module expander host-analysis @@ -198,8 +198,8 @@ host-directive-bundle program extender)] - _ (ioW.enable (get@ #&file-system platform) host target) - [archive analysis-state bundles] (ioW.thaw extension (get@ #host platform) (get@ #&file-system platform) host target) + _ (ioW.enable (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static)) + [archive analysis-state bundles] (ioW.thaw (get@ #static.artifact-extension static) (get@ #host platform) (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static)) state (promise@wrap (initialize-state extender bundles analysis-state state))] (if (archive.archived? archive archive.runtime-module) (wrap [state archive]) @@ -207,7 +207,7 @@ [[state [archive payload]] (|> (..process-runtime archive platform) (///phase.run' state) promise@wrap) - _ (..cache-module platform host target 0 extension payload)] + _ (..cache-module static platform 0 payload)] (wrap [state archive]))))) (def: module-compilation-log @@ -232,83 +232,212 @@ #///generation.log] row.empty)) - (def: #export (compile target partial-host-extension expander platform host configuration archive extension state) - (All [] - (-> Text Text Expander Host Configuration Archive Text (Promise (Try [Archive ])))) - (let [source-module (get@ #cli.module configuration) - compiler (:share [] - { - state} - {(///.Compiler .Module Any) - ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list))})] - (loop [module source-module - [archive state] [archive state]] - (if (archive.archived? archive module) - (promise@wrap (#try.Success [archive state])) - (let [import! (:share [] - { - platform} - {(-> Module [Archive ] - (Action [Archive ])) - recur})] - (do (try.with promise.monad) - [[module-id archive] (promise@wrap (archive.reserve module archive)) - input (context.read (get@ #&file-system platform) - (get@ #cli.sources configuration) - partial-host-extension - module)] - (loop [archive archive - state state - compilation (compiler (:coerce ///.Input input)) - all-dependencies (: (List Module) - (list))] - (do @ - [#let [new-dependencies (get@ #///.dependencies compilation) - all-dependencies (list@compose new-dependencies all-dependencies)] - [archive state] (:share [] - { - platform} - {(Action [Archive ]) - (monad.fold ..monad import! [archive state] new-dependencies)}) - #let [continue! (:share [] - { - platform} - {(-> Archive (///.Compilation .Module Any) (List Module) - (Action [Archive ])) - recur})]] - (case ((get@ #///.process compilation) - (case new-dependencies - #.Nil - state + (with-expansions [ (as-is [Archive ]) + (as-is (Try )) + (as-is (Promise )) + (as-is (Resolver )) + (as-is [ ]) + (as-is (-> Module )) + (as-is (-> archive.ID Module ))] + (def: (parallel initial) + (All [] + (-> + (-> ))) + (let [current (:share [] + { + initial} + {(Var ) + (stm.var initial)}) + pending (:share [] + { + initial} + {(Var (Dictionary Module )) + (stm.var (dictionary.new text.hash))})] + (function (_ compile) + (function (import! module) + (do promise.monad + [[return signal] (:share [] + { + initial} + {(Promise [ (Maybe [ + archive.ID + ])]) + (stm.commit + (do stm.monad + [[archive state] (stm.read current)] + (if (archive.archived? archive module) + (wrap [(promise@wrap (#try.Success [archive state])) + #.None]) + (do @ + [@pending (stm.read pending)] + (case (dictionary.get module @pending) + (#.Some [return signal]) + (wrap [return + #.None]) + + #.None + (case (archive.reserve module archive) + (#try.Success [module-id archive]) + (do @ + [_ (stm.write [archive state] current) + #let [[return signal] (:share [] + { + initial} + { + (promise.promise [])})] + _ (stm.update (dictionary.put module [return signal]) pending)] + (wrap [return + (#.Some [[archive state] + module-id + signal])])) + + (#try.Failure error) + (wrap [(promise@wrap (#try.Failure error)) + #.None])))))))}) + _ (case signal + #.None + (wrap []) + + (#.Some [context module-id resolver]) + (do @ + [result (compile import! module-id context module) + result (case result + (#try.Failure error) + (wrap result) + + (#try.Success [resulting-archive resulting-state]) + (stm.commit (do stm.monad + [[_ [merged-archive _]] (stm.update (function (_ [archive state]) + [(archive.merge resulting-archive archive) + state]) + current)] + (wrap (#try.Success [merged-archive resulting-state]))))) + _ (promise.future (resolver result))] + (wrap [])))] + return))))) + + ## TODO: Find a better way, as this only works for the Lux compiler. + (def: (updated-state archive state) + (All [] + (-> Archive (Try ))) + (do try.monad + [modules (monad.map @ (function (_ module) + (do @ + [[descriptor document] (archive.find module archive) + lux-module (document.read $.key document)] + (wrap [module lux-module]))) + (archive.archived archive)) + #let [additions (|> modules + (list@map product.left) + (set.from-list text.hash))]] + (wrap (update@ [#extension.state + #///directive.analysis + #///directive.state + #extension.state] + (function (_ analysis-state) + (|> analysis-state + (:coerce .Lux) + (update@ #.modules (function (_ current) + (list@compose (list.filter (|>> product.left + (set.member? additions) + not) + current) + modules))) + :assume)) + state)))) + + (def: (set-current-module module state) + (All [] + (-> Module )) + (|> (///directive.set-current-module module) + (///phase.run' state) + try.assume + product.left)) + + (def: #export (compile static expander platform configuration context) + (All [] + (-> Static Expander Configuration )) + (let [base-compiler (:share [] + { + context} + {(///.Compiler .Module Any) + ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list))}) + parallel-compiler (..parallel + context + (function (_ import! module-id [archive state] module) + (do (try.with promise.monad) + [#let [state (..set-current-module module state)] + input (context.read (get@ #&file-system platform) + (get@ #cli.sources configuration) + (get@ #static.host-module-extension static) + module)] + (loop [[archive state] [archive state] + compilation (base-compiler (:coerce ///.Input input)) + all-dependencies (: (List Module) + (list))] + (do (try.with promise.monad) + [#let [new-dependencies (get@ #///.dependencies compilation) + all-dependencies (list@compose new-dependencies all-dependencies) + continue! (:share [] + { + platform} + {(-> (///.Compilation .Module Any) (List Module) + (Action [Archive ])) + recur})] + archive,document+ (|> new-dependencies + (list@map import!) + (monad.seq ..monad)) + #let [archive (case archive,document+ + #.Nil + archive + + archive,document+ + (|> archive,document+ + (list@map product.left) + (list@fold archive.merge archive))) + state (case archive,document+ + #.Nil + state - _ - ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP. - ## TODO: The context shouldn't need to be re-set either. - (|> (///directive.set-current-module module) - (///phase.run' state) - try.assume - product.left)) - archive) - (#try.Success [state more|done]) - (case more|done - (#.Left more) - (continue! archive state more all-dependencies) + archive,document+ + (try.assume + (:share [|state|] + {|state| + state} + {(Try |state|) + (..updated-state archive state)})))]] + (case ((get@ #///.process compilation) + ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP. + ## TODO: The context shouldn't need to be re-set either. + (|> (///directive.set-current-module module) + (///phase.run' state) + try.assume + product.left) + archive) + (#try.Success [state more|done]) + (case more|done + (#.Left more) + (continue! [archive state] more all-dependencies) - (#.Right [[descriptor document] output]) - (do (try.with promise.monad) - [#let [_ (log! (..module-compilation-log state)) - descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)] - _ (..cache-module platform host target module-id extension [[descriptor document] output])] - (case (archive.add module [descriptor document] archive) - (#try.Success archive) - (wrap [archive - (..with-reset-log state)]) - - (#try.Failure error) - (promise@wrap (#try.Failure error))))) + (#.Right [[descriptor document] output]) + (do (try.with promise.monad) + [#let [_ (log! (..module-compilation-log state)) + descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)] + _ (..cache-module static platform module-id [[descriptor document] output])] + (case (archive.add module [descriptor document] archive) + (#try.Success archive) + (wrap [archive + (..with-reset-log state)]) + + (#try.Failure error) + (promise@wrap (#try.Failure error))))) - (#try.Failure error) - (do (try.with promise.monad) - [_ (ioW.freeze (get@ #&file-system platform) host target archive)] - (promise@wrap (#try.Failure error)))))))))))) - ) + (#try.Failure error) + (do (try.with promise.monad) + [_ (ioW.freeze (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static) archive)] + (promise@wrap (#try.Failure error)))) + )) + )))] + (parallel-compiler (get@ #cli.module configuration)) + )) + )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux index 66efb1dde..2e42e2c45 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux @@ -1,16 +1,18 @@ (.module: - [lux #* + [lux (#- Module) [abstract [monad (#+ do)]] [control ["." try]] [data - [text - ["%" format (#+ format)]]]] + ["." text + ["%" format (#+ format)]]] + ["." macro]] [// (#+ Operation) [macro (#+ Expander)] [// [phase + [".P" extension] [".P" synthesis] [".P" analysis ["." type]] @@ -20,11 +22,20 @@ [/// ["." phase] [meta - [archive (#+ Archive)]]]]]]]) + [archive (#+ Archive) + [descriptor (#+ Module)]]]]]]]]) (type: #export Eval (-> Archive Nat Type Code (Operation Any))) +(def: #export (id prefix module count) + (-> Text Module Nat Text) + (format prefix + "$" + (text.replace-all "/" "$" module) + "$" + (%.nat count))) + (def: #export (evaluator expander synthesis-state generation-state generate) (All [anchor expression artifact] (-> Expander @@ -36,10 +47,13 @@ (function (eval archive count type exprC) (do phase.monad [exprA (type.with-type type - (analyze archive exprC))] + (analyze archive exprC)) + module (extensionP.lift + macro.current-module-name)] (phase.lift (do try.monad [exprS (|> exprA (synthesisP.phase archive) (phase.run synthesis-state))] (phase.run generation-state (do phase.monad [exprO (generate archive exprS)] - (generation.evaluate! (format "eval" (%.nat count)) exprO))))))))) + (generation.evaluate! (..id "analysis" module count) + exprO))))))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux index 41dcdd990..7196d13f1 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux @@ -177,6 +177,11 @@ (-> Module (Operation anchor expression directive Any))) (extension.update (set@ #module module))) +(def: #export module + (All [anchor expression directive] + (Operation anchor expression directive Module)) + (extension.read (get@ #module))) + (template [ ] [(def: #export ( label code) (All [anchor expression directive] diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux index 24d059031..96eb95f41 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -11,7 +11,7 @@ [data ["." product] ["." maybe] - [text + ["." text ["%" format (#+ format)]] [collection ["." dictionary]]] @@ -65,9 +65,11 @@ (Operation anchor expression directive [Type expression Any]))) (/////directive.lift-generation (do phase.monad - [codeG (generate archive codeS) + [module /////generation.module id /////generation.next - codeV (/////generation.evaluate! (format "evaluate" (%.nat id)) codeG)] + codeG (generate archive codeS) + codeV (/////generation.evaluate! (/////analysis/evaluation.id "directive" module id) + codeG)] (wrap [code//type codeG codeV])))) (def: #export (evaluate! archive type codeC) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux index 37b47777d..3756e257a 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive.lux @@ -173,22 +173,22 @@ [module id])))) (def: #export (merge additions archive) - (-> Archive Archive (Try Archive)) - (|> additions - :representation - (get@ #resolver) - dictionary.entries - (monad.fold try.monad - (function (_ [module' [id descriptor+document']] archive') - (case descriptor+document' - (#.Some descriptor+document') - (if (archived? archive' module') - (#try.Success archive') - (..add module' descriptor+document' archive')) - - #.None - (#try.Success archive'))) - archive))) + (-> Archive Archive Archive) + (let [[+next +resolver] (:representation additions)] + (|> archive + :representation + (update@ #next (n.max +next)) + (update@ #resolver (function (_ resolver) + (list@fold (function (_ [module [id entry]] resolver) + (case entry + (#.Some _) + (dictionary.put module [id entry] resolver) + + #.None + resolver)) + resolver + (dictionary.entries +resolver)))) + :abstraction))) (type: Reservation [Module ID]) (type: Frozen [Version ID (List Reservation)]) diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux index 247f2db15..c3a17f34a 100644 --- a/stdlib/source/lux/type.lux +++ b/stdlib/source/lux/type.lux @@ -410,11 +410,12 @@ (syntax: #export (:by-example {type-vars type-parameters} {exemplar typed} {extraction s.any}) - (wrap (list (` (:of (:share [(~+ (list@map code.local-identifier type-vars))] - {(~ (get@ #type exemplar)) - (~ (get@ #expression exemplar))} - {(~ extraction) - (:assume [])})))))) + (wrap (list (` (:of ((~! :share) + [(~+ (list@map code.local-identifier type-vars))] + {(~ (get@ #type exemplar)) + (~ (get@ #expression exemplar))} + {(~ extraction) + (:assume [])})))))) (exception: #export (hole-type {location Cursor} {type Type}) (exception.report diff --git a/stdlib/source/lux/type/refinement.lux b/stdlib/source/lux/type/refinement.lux index 1c428fc23..3a9b8cfd2 100644 --- a/stdlib/source/lux/type/refinement.lux +++ b/stdlib/source/lux/type/refinement.lux @@ -2,7 +2,9 @@ [lux (#- type) [abstract [predicate (#+ Predicate)]] - [type (#+ :by-example) ("#;." equivalence) + ["." macro + [syntax (#+ syntax:)]] + [type (#+ :by-example) abstract]]) (abstract: #export (Refined t r) @@ -77,8 +79,9 @@ [yes (#.Cons head no)])))) -(template: #export (type ) - (:by-example [t r] - {(..Refiner t r) - } - (..Refined t r))) +(syntax: #export (type refiner) + (macro.with-gensyms [g!t g!r] + (wrap (list (` ((~! :by-example) [(~ g!t) (~ g!r)] + {(..Refiner (~ g!t) (~ g!r)) + (~ refiner)} + (..Refined (~ g!t) (~ g!r)))))))) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index fcf05f164..43bc084c5 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -49,7 +49,8 @@ ## ["." interpreter] ]] ["." / #_ - ["#." cli (#+ Service)]]) + ["#." cli (#+ Configuration)] + ["#." static (#+ Static)]]) (def: (or-crash! failure-description action) (All [a] @@ -67,48 +68,20 @@ (wrap output)))) (with-expansions [ (as-is anchor expression artifact)] - ## TODO: Clean-up ASAP. - ## (def: (save-artifacts! system state [packager package]) - ## (All [] - ## (-> (file.System Promise) - ## (directive.State+ ) - ## [(-> (Row [Module (generation.Buffer artifact)]) Binary) Path] - ## (Promise (Try Any)))) - ## (let [?outcome (phase.run' state - ## (:share [] - ## {(directive.State+ ) - ## state} - ## {(directive.Operation - ## (generation.Output artifact)) - ## (directive.lift-generation generation.output)}))] - ## (case ?outcome - ## (#try.Success [state output]) - ## (do (try.with promise.monad) - ## [file (: (Promise (Try (File Promise))) - ## (file.get-file promise.monad system package))] - ## (!.use (:: file over-write) (packager output))) - - ## (#try.Failure error) - ## (promise@wrap (#try.Failure error))))) - - (def: #export (compiler target partial-host-extension - expander host-analysis platform host generation-bundle host-directive-bundle program extender - service - extension + (def: #export (compiler static + expander host-analysis platform generation-bundle host-directive-bundle program extender + configuration packager,package) (All [] - (-> Path - Text + (-> Static Expander analysis.Bundle (IO (Platform )) - Host (generation.Bundle ) (directive.Bundle ) (-> expression artifact) Extender - Service - Text + Configuration [(-> (Row [Module (generation.Buffer artifact)]) Binary) Path] (Promise Any))) (do promise.monad @@ -116,8 +89,8 @@ console (|> console.system promise.future (:: @ map (|>> try.assume console.async)))] - (case service - (#/cli.Compilation configuration) + (case (get@ #/cli.service configuration) + #/cli.Compilation (<| (or-crash! "Compilation failed:") (do (try.with promise.monad) [[state archive] (:share [] @@ -125,19 +98,16 @@ platform} {(Promise (Try [(directive.State+ ) Archive])) - (platform.initialize extension target host (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)}) + (platform.initialize static (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)}) [archive state] (:share [] {(Platform ) platform} {(Promise (Try [Archive (directive.State+ )])) - (platform.compile target partial-host-extension expander platform host configuration archive extension state)}) - _ (ioW.freeze (get@ #platform.&file-system platform) host target archive) - ## _ (save-artifacts! (get@ #platform.&file-system platform) state packager,package) - ## _ (cache/io.clean target ...) - ] + (platform.compile static expander platform configuration [archive state])}) + _ (ioW.freeze (get@ #platform.&file-system platform) (get@ #/static.host static) (get@ #/static.target static) archive)] (wrap (log! "Compilation complete!")))) - (#/cli.Interpretation configuration) + #/cli.Interpretation ## TODO: Fix the interpreter... (undefined) ## (<| (or-crash! "Interpretation failed:") diff --git a/stdlib/source/program/compositor/cli.lux b/stdlib/source/program/compositor/cli.lux index 4453d5d36..0c20257ed 100644 --- a/stdlib/source/program/compositor/cli.lux +++ b/stdlib/source/program/compositor/cli.lux @@ -4,23 +4,20 @@ ["p" parser ["." cli (#+ Parser)]]] [world - [file (#+ Path)]]] - ## [/// - ## [importer (#+ Source)]] - ) + [file (#+ Path)]]]) + +(type: #export Service + #Compilation + #Interpretation) (type: #export Configuration - {## #sources (List Source) + {#service Service #sources (List Path) #target Path #module Text}) -(type: #export Service - (#Compilation Configuration) - (#Interpretation Configuration)) - (template [ ] - [(def: #export + [(def: (Parser Text) (cli.named cli.any))] @@ -29,15 +26,17 @@ [module "--module"] ) + +(def: service + (Parser Service) + ($_ p.or + (cli.this "build") + (cli.this "repl"))) + (def: #export configuration (Parser Configuration) ($_ p.and + ..service (p.some ..source) ..target ..module)) - -(def: #export service - (Parser Service) - ($_ p.or - (p.after (cli.this "build") ..configuration) - (p.after (cli.this "repl") ..configuration))) diff --git a/stdlib/source/program/compositor/static.lux b/stdlib/source/program/compositor/static.lux new file mode 100644 index 000000000..3fdd8727e --- /dev/null +++ b/stdlib/source/program/compositor/static.lux @@ -0,0 +1,11 @@ +(.module: + [lux #* + [target (#+ Host)] + [world + [file (#+ Path)]]]) + +(type: #export Static + {#host Host + #host-module-extension Text + #target Path + #artifact-extension Text}) 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