basis/concurrency/messaging/messaging.factor

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