extra/concurrency/locks/locks.factor

   1 ! Copyright (C) 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: dequeues dlists kernel threads continuations math\r
   4 concurrency.conditions ;\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 lock-owner\r
  20     [ 2dup >r lock-threads r> "lock" wait ] when drop\r
  21     self swap set-lock-owner ;\r
  22 \r
  23 : release-lock ( lock -- )\r
  24     f over set-lock-owner\r
  25     lock-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 lock-reentrant? [\r
  38         pick lock-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     dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;\r
  60 \r
  61 : acquire-read-lock ( lock timeout -- )\r
  62     over rw-lock-writer\r
  63     [ 2dup >r rw-lock-readers r> "read lock" wait ] when drop\r
  64     add-reader ;\r
  65 \r
  66 : notify-writer ( lock -- )\r
  67     rw-lock-writers notify-1 ;\r
  68 \r
  69 : remove-reader ( lock -- )\r
  70     dup rw-lock-reader# 1- swap set-rw-lock-reader# ;\r
  71 \r
  72 : release-read-lock ( lock -- )\r
  73     dup remove-reader\r
  74     dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ;\r
  75 \r
  76 : acquire-write-lock ( lock timeout -- )\r
  77     over rw-lock-writer pick rw-lock-reader# 0 > or\r
  78     [ 2dup >r rw-lock-writers r> "write lock" wait ] when drop\r
  79     self swap set-rw-lock-writer ;\r
  80 \r
  81 : release-write-lock ( lock -- )\r
  82     f over set-rw-lock-writer\r
  83     dup rw-lock-readers dequeue-empty?\r
  84     [ notify-writer ] [ rw-lock-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     rw-lock-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     dup rw-lock-writer self eq?\r
  96     swap rw-lock-reader# zero? and ;\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