mirror of
https://github.com/urbit/shrub.git
synced 2024-12-21 01:41:37 +03:00
479 lines
12 KiB
Plaintext
479 lines
12 KiB
Plaintext
:: Thread manager
|
|
::
|
|
/- spider
|
|
/+ libstrand=strand, default-agent, verb
|
|
=, strand=strand:libstrand
|
|
|%
|
|
+$ card card:agent:gall
|
|
+$ thread thread:spider
|
|
+$ tid tid:spider
|
|
+$ input input:spider
|
|
+$ yarn (list tid)
|
|
+$ thread-form _*eval-form:eval:(strand ,vase)
|
|
+$ trie
|
|
$~ [*thread-form ~]
|
|
[=thread-form kid=(map tid trie)]
|
|
::
|
|
+$ trying ?(%find %build %none)
|
|
+$ state
|
|
$: starting=(map yarn [=trying =vase])
|
|
running=trie
|
|
tid=(map tid yarn)
|
|
==
|
|
::
|
|
+$ clean-slate
|
|
$: starting=(map yarn [=trying =vase])
|
|
running=(list yarn)
|
|
tid=(map tid yarn)
|
|
==
|
|
::
|
|
+$ start-args
|
|
[parent=(unit tid) use=(unit tid) file=term =vase]
|
|
--
|
|
::
|
|
:: Trie operations
|
|
::
|
|
|%
|
|
++ get-yarn
|
|
|= [=trie =yarn]
|
|
^- (unit =thread-form)
|
|
?~ yarn
|
|
`thread-form.trie
|
|
=/ son (~(get by kid.trie) i.yarn)
|
|
?~ son
|
|
~
|
|
$(trie u.son, yarn t.yarn)
|
|
::
|
|
++ get-yarn-children
|
|
|= [=trie =yarn]
|
|
^- (list ^yarn)
|
|
?~ yarn
|
|
(turn (tap-yarn trie) head)
|
|
=/ son (~(get by kid.trie) i.yarn)
|
|
?~ son
|
|
~
|
|
$(trie u.son, yarn t.yarn)
|
|
::
|
|
::
|
|
++ has-yarn
|
|
|= [=trie =yarn]
|
|
!=(~ (get-yarn trie yarn))
|
|
::
|
|
++ put-yarn
|
|
|= [=trie =yarn =thread-form]
|
|
^+ trie
|
|
?~ yarn
|
|
trie(thread-form thread-form)
|
|
=/ son (~(gut by kid.trie) i.yarn [*^thread-form ~])
|
|
%= trie
|
|
kid
|
|
%+ ~(put by kid.trie) i.yarn
|
|
$(trie son, yarn t.yarn)
|
|
==
|
|
::
|
|
++ del-yarn
|
|
|= [=trie =yarn]
|
|
^+ trie
|
|
?~ yarn
|
|
trie
|
|
|-
|
|
?~ t.yarn
|
|
trie(kid (~(del by kid.trie) i.yarn))
|
|
=/ son (~(get by kid.trie) i.yarn)
|
|
?~ son
|
|
trie
|
|
%= trie
|
|
kid
|
|
%+ ~(put by kid.trie) i.yarn
|
|
$(trie u.son, yarn t.yarn)
|
|
==
|
|
::
|
|
++ tap-yarn
|
|
=| =yarn
|
|
|= =trie
|
|
^- (list [=^yarn =thread-form])
|
|
%+ welp
|
|
?~ yarn
|
|
~
|
|
[(flop yarn) thread-form.trie]~
|
|
=/ kids ~(tap by kid.trie)
|
|
|- ^- (list [=^yarn =thread-form])
|
|
?~ kids
|
|
~
|
|
=/ next-1 ^$(yarn [p.i.kids yarn], trie q.i.kids)
|
|
=/ next-2 $(kids t.kids)
|
|
(welp next-1 next-2)
|
|
--
|
|
::
|
|
^- agent:gall
|
|
=| =state
|
|
=<
|
|
%+ verb |
|
|
|_ =bowl:gall
|
|
+* this .
|
|
spider-core +>
|
|
sc ~(. spider-core bowl)
|
|
def ~(. (default-agent this %|) bowl)
|
|
::
|
|
++ on-init on-init:def
|
|
++ on-save clean-state:sc
|
|
++ on-load
|
|
|= old-state=vase
|
|
=+ !<(=clean-slate old-state)
|
|
=. tid.state tid.clean-slate
|
|
=/ yarns=(list yarn)
|
|
%+ welp running.clean-slate
|
|
~(tap in ~(key by starting.clean-slate))
|
|
|- ^- (quip card _this)
|
|
?~ yarns
|
|
`this
|
|
?. ?=([@ ~] i.yarns)
|
|
$(yarns t.yarns)
|
|
~| killing=i.yarns
|
|
=^ cards-1 state
|
|
(handle-stop-thread:sc (yarn-to-tid i.yarns) |)
|
|
=^ cards-2 this
|
|
$(yarns t.yarns)
|
|
[(weld cards-1 cards-2) this]
|
|
::
|
|
++ on-poke
|
|
|= [=mark =vase]
|
|
^- (quip card _this)
|
|
?: ?=(%spider-kill mark)
|
|
(on-load on-save)
|
|
=^ cards state
|
|
?+ mark (on-poke:def mark vase)
|
|
%spider-input (on-poke-input:sc !<(input vase))
|
|
%spider-start (handle-start-thread:sc !<(start-args vase))
|
|
%spider-stop (handle-stop-thread:sc !<([tid ?] vase))
|
|
==
|
|
[cards this]
|
|
::
|
|
++ on-watch
|
|
|= =path
|
|
^- (quip card _this)
|
|
=^ cards state
|
|
?+ path (on-watch:def path)
|
|
[%thread @ *] (on-watch:sc t.path)
|
|
[%thread-result @ ~] (on-watch-result:sc i.t.path)
|
|
==
|
|
[cards this]
|
|
::
|
|
++ on-leave on-leave:def
|
|
++ on-peek
|
|
|= =path
|
|
^- (unit (unit cage))
|
|
?+ path (on-peek:def path)
|
|
[%x %tree ~]
|
|
``noun+!>((turn (tap-yarn running.state) head))
|
|
::
|
|
[%x %starting @ ~]
|
|
``noun+!>((has-yarn running.state (~(got by tid.state) i.t.t.path)))
|
|
::
|
|
[%x %saxo @ ~]
|
|
``noun+!>((~(got by tid.state) i.t.t.path))
|
|
==
|
|
::
|
|
++ on-agent
|
|
|= [=wire =sign:agent:gall]
|
|
^- (quip card _this)
|
|
=^ cards state
|
|
?+ wire !!
|
|
[%thread @ *] (on-agent:sc i.t.wire t.t.wire sign)
|
|
==
|
|
[cards this]
|
|
::
|
|
++ on-arvo
|
|
|= [=wire =sign-arvo]
|
|
^- (quip card _this)
|
|
=^ cards state
|
|
?+ wire (on-arvo:def wire sign-arvo)
|
|
[%thread @ *] (handle-sign:sc i.t.wire t.t.wire sign-arvo)
|
|
[%find @ ~] (handle-find:sc i.t.wire sign-arvo)
|
|
[%build @ ~] (handle-build:sc i.t.wire sign-arvo)
|
|
==
|
|
[cards this]
|
|
:: On unexpected failure, kill all outstanding strands
|
|
::
|
|
++ on-fail
|
|
|= [=term =tang]
|
|
^- (quip card _this)
|
|
%- (slog leaf+"spider crashed, killing all strands: {<term>}" tang)
|
|
(on-load on-save)
|
|
--
|
|
::
|
|
|_ =bowl:gall
|
|
++ on-poke-input
|
|
|= input
|
|
=/ yarn (~(got by tid.state) tid)
|
|
(take-input yarn ~ %poke cage)
|
|
::
|
|
++ on-watch
|
|
|= [=tid =path]
|
|
(take-input (~(got by tid.state) tid) ~ %watch path)
|
|
::
|
|
++ on-watch-result
|
|
|= =tid
|
|
^- (quip card ^state)
|
|
`state
|
|
::
|
|
++ handle-sign
|
|
|= [=tid =wire =sign-arvo]
|
|
=/ yarn (~(get by tid.state) tid)
|
|
?~ yarn
|
|
%- (slog leaf+"spider got sign for non-existent {<tid>}" ~)
|
|
`state
|
|
(take-input u.yarn ~ %sign wire sign-arvo)
|
|
::
|
|
++ on-agent
|
|
|= [=tid =wire =sign:agent:gall]
|
|
=/ yarn (~(get by tid.state) tid)
|
|
?~ yarn
|
|
%- (slog leaf+"spider got agent for non-existent {<tid>}" ~)
|
|
`state
|
|
(take-input u.yarn ~ %agent wire sign)
|
|
::
|
|
++ handle-start-thread
|
|
|= [parent-tid=(unit tid) use=(unit tid) file=term =vase]
|
|
^- (quip card ^state)
|
|
=/ parent-yarn=yarn
|
|
?~ parent-tid
|
|
/
|
|
(~(got by tid.state) u.parent-tid)
|
|
=/ new-tid (fall use (scot %uv (sham eny.bowl)))
|
|
=/ =yarn (snoc parent-yarn new-tid)
|
|
::
|
|
?: (has-yarn running.state yarn)
|
|
~| [%already-started yarn]
|
|
!!
|
|
?: (~(has by starting.state) yarn)
|
|
~| [%already-starting yarn]
|
|
!!
|
|
::
|
|
=: starting.state (~(put by starting.state) yarn [%find vase])
|
|
tid.state (~(put by tid.state) new-tid yarn)
|
|
==
|
|
=/ =card
|
|
=/ =schematic:ford [%path [our.bowl %home] %ted file]
|
|
[%pass /find/[new-tid] %arvo %f %build live=%.n schematic]
|
|
[[card ~] state]
|
|
::
|
|
++ handle-find
|
|
|= [=tid =sign-arvo]
|
|
^- (quip card ^state)
|
|
=/ =yarn (~(got by tid.state) tid)
|
|
=. starting.state
|
|
(~(jab by starting.state) yarn |=([=trying =vase] [%none vase]))
|
|
?> ?=([%f %made *] sign-arvo)
|
|
?: ?=(%incomplete -.result.sign-arvo)
|
|
(thread-fail-not-running tid %find-thread-incomplete tang.result.sign-arvo)
|
|
=/ =build-result:ford build-result.result.sign-arvo
|
|
?: ?=(%error -.build-result)
|
|
(thread-fail-not-running tid %find-thread-error message.build-result)
|
|
?. ?=([%path *] +.build-result)
|
|
(thread-fail-not-running tid %find-thread-strange ~)
|
|
=. starting.state
|
|
(~(jab by starting.state) yarn |=([=trying =vase] [%build vase]))
|
|
=/ =card
|
|
=/ =schematic:ford [%core rail.build-result]
|
|
[%pass /build/[tid] %arvo %f %build live=%.n schematic]
|
|
[[card ~] state]
|
|
::
|
|
++ handle-build
|
|
|= [=tid =sign-arvo]
|
|
^- (quip card ^state)
|
|
=/ =yarn (~(got by tid.state) tid)
|
|
=. starting.state
|
|
(~(jab by starting.state) yarn |=([=trying =vase] [%none vase]))
|
|
?> ?=([%f %made *] sign-arvo)
|
|
?: ?=(%incomplete -.result.sign-arvo)
|
|
(thread-fail-not-running tid %build-thread-incomplete tang.result.sign-arvo)
|
|
=/ =build-result:ford build-result.result.sign-arvo
|
|
?: ?=(%error -.build-result)
|
|
(thread-fail-not-running tid %build-thread-error message.build-result)
|
|
=/ =cage (result-to-cage:ford build-result)
|
|
?. ?=(%noun p.cage)
|
|
(thread-fail-not-running tid %build-thread-strange >p.cage< ~)
|
|
=/ maybe-thread (mule |.(!<(thread q.cage)))
|
|
?: ?=(%| -.maybe-thread)
|
|
(thread-fail-not-running tid %thread-not-thread ~)
|
|
(start-thread yarn p.maybe-thread)
|
|
::
|
|
++ start-thread
|
|
|= [=yarn =thread]
|
|
^- (quip card ^state)
|
|
=/ =vase vase:(~(got by starting.state) yarn)
|
|
?< (has-yarn running.state yarn)
|
|
=/ m (strand ,^vase)
|
|
=/ res (mule |.((thread vase)))
|
|
?: ?=(%| -.res)
|
|
(thread-fail-not-running (yarn-to-tid yarn) %false-start p.res)
|
|
=/ =eval-form:eval:m
|
|
(from-form:eval:m p.res)
|
|
=: starting.state (~(del by starting.state) yarn)
|
|
running.state (put-yarn running.state yarn eval-form)
|
|
==
|
|
(take-input yarn ~)
|
|
::
|
|
++ handle-stop-thread
|
|
|= [=tid nice=?]
|
|
^- (quip card ^state)
|
|
=/ =yarn (~(got by tid.state) tid)
|
|
?: (has-yarn running.state yarn)
|
|
?: nice
|
|
(thread-done yarn *vase)
|
|
(thread-fail yarn %cancelled ~)
|
|
?: (~(has by starting.state) yarn)
|
|
(thread-fail-not-running tid %stopped-before-started ~)
|
|
~& [%thread-not-started yarn]
|
|
?: nice
|
|
(thread-done yarn *vase)
|
|
(thread-fail yarn %cancelled ~)
|
|
::
|
|
++ take-input
|
|
|= [=yarn input=(unit input:strand)]
|
|
^- (quip card ^state)
|
|
=/ m (strand ,vase)
|
|
?. (has-yarn running.state yarn)
|
|
%- (slog leaf+"spider got input for non-existent {<yarn>} 2" ~)
|
|
`state
|
|
=/ =eval-form:eval:m
|
|
thread-form:(need (get-yarn running.state yarn))
|
|
=| cards=(list card)
|
|
|- ^- (quip card ^state)
|
|
=^ r=[cards=(list card) =eval-result:eval:m] eval-form
|
|
=/ out
|
|
%- mule |.
|
|
(take:eval:m eval-form (convert-bowl yarn bowl) input)
|
|
?- -.out
|
|
%& p.out
|
|
%| [[~ [%fail %crash p.out]] eval-form]
|
|
==
|
|
=. running.state (put-yarn running.state yarn eval-form)
|
|
=/ =tid (yarn-to-tid yarn)
|
|
=. cards.r
|
|
%+ turn cards.r
|
|
|= =card
|
|
^- ^card
|
|
?+ card card
|
|
[%pass * *] [%pass [%thread tid p.card] q.card]
|
|
[%give %fact *]
|
|
?~ path.p.card
|
|
card
|
|
card(path.p `[%thread tid u.path.p.card])
|
|
::
|
|
[%give %kick *]
|
|
?~ path.p.card
|
|
card
|
|
card(path.p `[%thread tid u.path.p.card])
|
|
==
|
|
=. cards (weld cards cards.r)
|
|
=^ final-cards=(list card) state
|
|
?- -.eval-result.r
|
|
%next `state
|
|
%fail (thread-fail yarn err.eval-result.r)
|
|
%done (thread-done yarn value.eval-result.r)
|
|
==
|
|
[(weld cards final-cards) state]
|
|
::
|
|
++ thread-fail-not-running
|
|
|= [=tid =term =tang]
|
|
=/ =yarn (~(got by tid.state) tid)
|
|
:_ state(starting (~(del by starting.state) yarn))
|
|
%- welp :_ (thread-say-fail tid term tang)
|
|
=/ =trying trying:(~(got by starting.state) yarn)
|
|
?- trying
|
|
%find [%pass /find/[tid] %arvo %f %kill ~]~
|
|
%build [%pass /build/[tid] %arvo %f %kill ~]~
|
|
%none ~
|
|
==
|
|
::
|
|
++ thread-say-fail
|
|
|= [=tid =term =tang]
|
|
^- (list card)
|
|
:~ [%give %fact `/thread-result/[tid] %thread-fail !>([term tang])]
|
|
[%give %kick `/thread-result/[tid] ~]
|
|
==
|
|
::
|
|
++ thread-fail
|
|
|= [=yarn =term =tang]
|
|
^- (quip card ^state)
|
|
%- (slog leaf+"strand {<yarn>} failed" leaf+<term> tang)
|
|
=/ =tid (yarn-to-tid yarn)
|
|
=/ fail-cards (thread-say-fail tid term tang)
|
|
=^ cards state (thread-clean yarn)
|
|
[(weld fail-cards cards) state]
|
|
::
|
|
++ thread-done
|
|
|= [=yarn =vase]
|
|
^- (quip card ^state)
|
|
:: %- (slog leaf+"strand {<yarn>} finished" (sell vase) ~)
|
|
=/ =tid (yarn-to-tid yarn)
|
|
=/ done-cards=(list card)
|
|
:~ [%give %fact `/thread-result/[tid] %thread-done vase]
|
|
[%give %kick `/thread-result/[tid] ~]
|
|
==
|
|
=^ cards state (thread-clean yarn)
|
|
[(weld done-cards cards) state]
|
|
::
|
|
++ thread-clean
|
|
|= =yarn
|
|
^- (quip card ^state)
|
|
=/ children=(list ^yarn)
|
|
[yarn (get-yarn-children running.state yarn)]
|
|
|- ^- (quip card ^state)
|
|
?~ children
|
|
`state
|
|
=^ cards-children state $(children t.children)
|
|
=^ cards-our state
|
|
=/ =^yarn i.children
|
|
=/ =tid (yarn-to-tid yarn)
|
|
=: running.state (del-yarn running.state yarn)
|
|
tid.state (~(del by tid.state) tid)
|
|
==
|
|
:_ state
|
|
%+ murn ~(tap by wex.bowl)
|
|
|= [[=wire =ship =term] [acked=? =path]]
|
|
^- (unit card)
|
|
?. ?& ?=([%thread @ *] wire)
|
|
=(tid i.t.wire)
|
|
==
|
|
~
|
|
`[%pass wire %agent [ship term] %leave ~]
|
|
[(welp cards-children cards-our) state]
|
|
::
|
|
++ convert-bowl
|
|
|= [=yarn =bowl:gall]
|
|
^- bowl:spider
|
|
:* our.bowl
|
|
src.bowl
|
|
(yarn-to-tid yarn)
|
|
(yarn-to-parent yarn)
|
|
wex.bowl
|
|
sup.bowl
|
|
eny.bowl
|
|
now.bowl
|
|
byk.bowl
|
|
==
|
|
::
|
|
++ yarn-to-tid
|
|
|= =yarn
|
|
^- tid
|
|
=/ nary (flop yarn)
|
|
?> ?=([@ *] nary)
|
|
i.nary
|
|
::
|
|
++ yarn-to-parent
|
|
|= =yarn
|
|
^- (unit tid)
|
|
=/ nary (flop yarn)
|
|
?> ?=([@ *] nary)
|
|
?~ t.nary
|
|
~
|
|
`i.t.nary
|
|
::
|
|
++ clean-state
|
|
!> ^- clean-slate
|
|
state(running (turn (tap-yarn running.state) head))
|
|
--
|