basis/concurrency/messaging/messaging.factor

   1 ! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: kernel kernel.private threads concurrency.mailboxes\r
   4 continuations namespaces assocs accessors summary fry ;\r
   5 IN: concurrency.messaging\r
   6 \r
   7 GENERIC: send ( message thread -- )\r
   8 \r
   9 GENERIC: mailbox-of ( thread -- mailbox )\r
  10 \r
  11 M: thread mailbox-of\r
  12     dup mailbox>>\r
  13     [ { mailbox } declare ]\r
  14     [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline\r
  15 \r
  16 M: thread send ( message thread -- )\r
  17     mailbox-of mailbox-put ;\r
  18 \r
  19 : my-mailbox ( -- mailbox ) self mailbox-of ; inline\r
  20 \r
  21 : receive ( -- message )\r
  22     my-mailbox mailbox-get ?linked ;\r
  23 \r
  24 : receive-timeout ( timeout -- message )\r
  25     [ my-mailbox ] dip mailbox-get-timeout ?linked ;\r
  26 \r
  27 : receive-if ( pred -- message )\r
  28     [ my-mailbox ] dip mailbox-get? ?linked ; inline\r
  29 \r
  30 : receive-if-timeout ( timeout pred -- message )\r
  31     [ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline\r
  32 \r
  33 : rethrow-linked ( error process supervisor -- )\r
  34     [ <linked-error> ] dip send ;\r
  35 \r
  36 : spawn-linked ( quot name -- thread )\r
  37     my-mailbox spawn-linked-to ;\r
  38 \r
  39 TUPLE: synchronous data sender tag ;\r
  40 \r
  41 : <synchronous> ( data -- sync )\r
  42     self synchronous counter synchronous boa ;\r
  43 \r
  44 TUPLE: reply data tag ;\r
  45 \r
  46 : <reply> ( data synchronous -- reply )\r
  47     tag>> \ reply boa ;\r
  48 \r
  49 : synchronous-reply? ( response synchronous -- ? )\r
  50     over reply? [ [ tag>> ] same? ] [ 2drop f ] if ;\r
  51 \r
  52 ERROR: cannot-send-synchronous-to-self message thread ;\r
  53 \r
  54 M: cannot-send-synchronous-to-self summary\r
  55     drop "Cannot synchronous send to myself" ;\r
  56 \r
  57 : send-synchronous ( message thread -- reply )\r
  58     dup self eq? [\r
  59         cannot-send-synchronous-to-self\r
  60     ] [\r
  61         [ <synchronous> dup ] dip send\r
  62         '[ _ synchronous-reply? ] receive-if\r
  63         data>>\r
  64     ] if ;\r
  65 \r
  66 : reply-synchronous ( message synchronous -- )\r
  67     [ <reply> ] keep sender>> send ;\r
  68 \r
  69 : handle-synchronous ( quot -- )\r
  70     receive [\r
  71         data>> swap call\r
  72     ] keep reply-synchronous ; inline\r