basis/concurrency/mailboxes/mailboxes.factor

   1 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: dlists deques threads sequences continuations\r
   4 destructors namespaces math quotations words kernel\r
   5 arrays assocs init system concurrency.conditions accessors\r
   6 debugger debugger.threads locals fry ;\r
   7 IN: concurrency.mailboxes\r
   8 \r
   9 TUPLE: mailbox threads data disposed ;\r
  10 \r
  11 M: mailbox dispose* threads>> notify-all ;\r
  12 \r
  13 : <mailbox> ( -- mailbox )\r
  14     <dlist> <dlist> f mailbox boa ;\r
  15 \r
  16 : mailbox-empty? ( mailbox -- bool )\r
  17     data>> deque-empty? ;\r
  18 \r
  19 : mailbox-put ( obj mailbox -- )\r
  20     [ data>> push-front ]\r
  21     [ threads>> notify-all ] bi yield ;\r
  22 \r
  23 : wait-for-mailbox ( mailbox timeout -- )\r
  24     [ threads>> ] dip "mailbox" wait ;\r
  25 \r
  26 :: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )\r
  27     mailbox check-disposed\r
  28     mailbox data>> pred dlist-any? [\r
  29         mailbox timeout wait-for-mailbox\r
  30         mailbox timeout pred block-unless-pred\r
  31     ] unless ; inline recursive\r
  32 \r
  33 : block-if-empty ( mailbox timeout -- mailbox )\r
  34     over check-disposed\r
  35     over mailbox-empty? [\r
  36         2dup wait-for-mailbox block-if-empty\r
  37     ] [\r
  38         drop\r
  39     ] if ;\r
  40 \r
  41 : mailbox-peek ( mailbox -- obj )\r
  42     data>> peek-back ;\r
  43 \r
  44 : mailbox-get-timeout ( mailbox timeout -- obj )\r
  45     block-if-empty data>> pop-back ;\r
  46 \r
  47 : mailbox-get ( mailbox -- obj )\r
  48     f mailbox-get-timeout ;\r
  49 \r
  50 : mailbox-get-all-timeout ( mailbox timeout -- array )\r
  51     block-if-empty\r
  52     [ dup mailbox-empty? not ]\r
  53     [ dup data>> pop-back ]\r
  54     produce nip ;\r
  55 \r
  56 : mailbox-get-all ( mailbox -- array )\r
  57     f mailbox-get-all-timeout ;\r
  58 \r
  59 : while-mailbox-empty ( mailbox quot -- )\r
  60     [ '[ _ mailbox-empty? ] ] dip while ; inline\r
  61 \r
  62 : mailbox-get-timeout? ( mailbox timeout pred -- obj )\r
  63     [ block-unless-pred ]\r
  64     [ [ drop data>> ] dip delete-node-if ]\r
  65     3bi ; inline\r
  66 \r
  67 : mailbox-get? ( mailbox pred -- obj )\r
  68     f swap mailbox-get-timeout? ; inline\r
  69 \r
  70 : wait-for-close-timeout ( mailbox timeout -- )\r
  71     over disposed>>\r
  72     [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;\r
  73 \r
  74 : wait-for-close ( mailbox -- )\r
  75     f wait-for-close-timeout ;\r
  76 \r
  77 TUPLE: linked-error error thread ;\r
  78 \r
  79 M: linked-error error.\r
  80     [ thread>> error-in-thread. ] [ error>> error. ] bi ;\r
  81 \r
  82 C: <linked-error> linked-error\r
  83 \r
  84 : ?linked ( message -- message )\r
  85     dup linked-error? [ rethrow ] when ;\r
  86 \r
  87 TUPLE: linked-thread < thread supervisor ;\r
  88 \r
  89 M: linked-thread error-in-thread\r
  90     [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;\r
  91 \r
  92 : <linked-thread> ( quot name mailbox -- thread' )\r
  93     [ linked-thread new-thread ] dip >>supervisor ;\r
  94 \r
  95 : spawn-linked-to ( quot name mailbox -- thread )\r
  96     <linked-thread> [ (spawn) ] keep ;\r