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