create rlock
acquire rlock
further down in code, call function that also acquires rlock (then releases it)
release rlock
It does this by using a counting semaphore to track depth and a page of shared memory to track the current owner's pid.
Regular locks function like mutexes (binary semaphores.) They only permit on level of locking, and are much faster than rlocks (but not as useful.)
It is an error for a process to attempt to release a lock which it does not hold.
Code: Select all
(constant 'ACQUIRE -1 'RELEASE 1)
(define (getpid) (sys-info 6))
(global 'getpid)
;;; Locks are generic binary-style semaphores like mutexes.
(define (Lock:Lock)
(let ((sem (semaphore)) (pid (share)))
(semaphore sem RELEASE)
(share pid nil)
(list (context) sem pid)))
(define (Lock:acquire lock)
(semaphore (lock 1) ACQUIRE)
(share (lock 2) (getpid)))
(define (Lock:release lock)
(if (= (getpid) (share (lock 2)))
(begin
(semaphore (lock 1) RELEASE)
(share (lock 2) nil))
(throw-error "Cannot release lock that is locked by another process.")))
;;; Recursive locks (RLocks) are locks that "owned" by a
;;; locking process and are not re-locked by subsequent code
;;; in the same process.
(define (RLock:RLock)
(let ((sem (semaphore)) (depth (semaphore)) (pid (share)))
(semaphore sem RELEASE)
(semaphore depth 0)
(share pid nil)
(list (context) sem depth pid)))
(define (RLock:acquire lock)
(let ((sem (lock 1)) (depth (lock 2)) (pid (lock 3)))
(if (= (share pid) (getpid))
(semaphore depth 1)
(begin
(semaphore sem ACQUIRE)
(semaphore depth 1)
(share pid (getpid))))))
(define (RLock:release lock)
(let ((sem (lock 1)) (depth (lock 2)) (pid (lock 3)))
(if (= (share pid) (getpid))
(begin
(semaphore depth -1)
(when (= 0 (semaphore depth))
(share pid nil)
(semaphore sem RELEASE)))
(throw-error "Cannot release rlock that is locked by another process."))))
Code: Select all
(setq mem (share)) ; shared resource that needs to be protected by a lock
(setq mem-lock (Lock))
(:acquire mem-lock)
(share mem "foo")
(spawn 's
(begin
(:acquire mem-lock)
(share mem "bar")
(:release mem-lock)))
;;; at this point, the spawned process is blocking, waiting for us
;;; to release mem-lock. mem still holds "foo"
(:release mem-lock)
;;; now, the spawned process continues, and sets mem to "bar"