basis/concurrency/locks/locks.factor

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