basis/concurrency/locks/locks.factor

   1 ! Copyright (C) 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: deques dlists kernel threads continuations math\r
   4 concurrency.conditions combinators.short-circuit accessors ;\r
   5 IN: concurrency.locks\r
   6 \r
   7 ! Simple critical sections\r
   8 TUPLE: lock threads owner reentrant? ;\r
   9 \r
  10 : <lock> ( -- lock )\r
  11     <dlist> f f lock boa ;\r
  12 \r
  13 : <reentrant-lock> ( -- lock )\r
  14     <dlist> f t lock boa ;\r
  15 \r
  16 <PRIVATE\r
  17 \r
  18 : acquire-lock ( lock timeout -- )\r
  19     over owner>>\r
  20     [ 2dup >r threads>> r> "lock" wait ] when drop\r
  21     self >>owner drop ;\r
  22 \r
  23 : release-lock ( lock -- )\r
  24     f >>owner\r
  25     threads>> notify-1 ;\r
  26 \r
  27 : do-lock ( lock timeout quot acquire release -- )\r
  28     >r >r pick rot r> call ! use up  timeout acquire\r
  29     swap r> curry [ ] cleanup ; inline\r
  30 \r
  31 : (with-lock) ( lock timeout quot -- )\r
  32     [ acquire-lock ] [ release-lock ] do-lock ; inline\r
  33 \r
  34 PRIVATE>\r
  35 \r
  36 : with-lock-timeout ( lock timeout quot -- )\r
  37     pick reentrant?>> [\r
  38         pick owner>> self eq? [\r
  39             2nip call\r
  40         ] [\r
  41             (with-lock)\r
  42         ] if\r
  43     ] [\r
  44         (with-lock)\r
  45     ] if ; inline\r
  46 \r
  47 : with-lock ( lock quot -- )\r
  48     f swap with-lock-timeout ; inline\r
  49 \r
  50 ! Many-reader/single-writer locks\r
  51 TUPLE: rw-lock readers writers reader# writer ;\r
  52 \r
  53 : <rw-lock> ( -- lock )\r
  54     <dlist> <dlist> 0 f rw-lock boa ;\r
  55 \r
  56 <PRIVATE\r
  57 \r
  58 : add-reader ( lock -- )\r
  59     [ 1+ ] change-reader# drop ;\r
  60 \r
  61 : acquire-read-lock ( lock timeout -- )\r
  62     over writer>>\r
  63     [ 2dup >r readers>> r> "read lock" wait ] when drop\r
  64     add-reader ;\r
  65 \r
  66 : notify-writer ( lock -- )\r
  67     writers>> notify-1 ;\r
  68 \r
  69 : remove-reader ( lock -- )\r
  70     [ 1- ] change-reader# drop ;\r
  71 \r
  72 : release-read-lock ( lock -- )\r
  73     dup remove-reader\r
  74     dup reader#>> zero? [ notify-writer ] [ drop ] if ;\r
  75 \r
  76 : acquire-write-lock ( lock timeout -- )\r
  77     over writer>> pick reader#>> 0 > or\r
  78     [ 2dup >r writers>> r> "write lock" wait ] when drop\r
  79     self >>writer drop ;\r
  80 \r
  81 : release-write-lock ( lock -- )\r
  82     f >>writer\r
  83     dup readers>> deque-empty?\r
  84     [ notify-writer ] [ readers>> notify-all ] if ;\r
  85 \r
  86 : reentrant-read-lock-ok? ( lock -- ? )\r
  87     #! If we already have a write lock, then we can grab a read\r
  88     #! lock too.\r
  89     writer>> self eq? ;\r
  90 \r
  91 : reentrant-write-lock-ok? ( lock -- ? )\r
  92     #! The only case where we have a writer and > 1 reader is\r
  93     #! write -> read re-entrancy, and in this case we prohibit\r
  94     #! a further write -> read -> write re-entrancy.\r
  95     { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;\r
  96 \r
  97 PRIVATE>\r
  98 \r
  99 : with-read-lock-timeout ( lock timeout quot -- )\r
 100     pick reentrant-read-lock-ok? [\r
 101         [ drop add-reader ] [ remove-reader ] do-lock\r
 102     ] [\r
 103         [ acquire-read-lock ] [ release-read-lock ] do-lock\r
 104     ] if ; inline\r
 105 \r
 106 : with-read-lock ( lock quot -- )\r
 107     f swap with-read-lock-timeout ; inline\r
 108 \r
 109 : with-write-lock-timeout ( lock timeout quot -- )\r
 110     pick reentrant-write-lock-ok? [ 2nip call ] [\r
 111         [ acquire-write-lock ] [ release-write-lock ] do-lock\r
 112     ] if ; inline\r
 113 \r
 114 : with-write-lock ( lock quot -- )\r
 115     f swap with-write-lock-timeout ; inline\r