"

 COPYRIGHT (c) 1993 by Claus Gittinger

 COPYRIGHT (c) 2017 Jan Vrany

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

"{ Package: 'stx:libbasic' }"

"{ NameSpace: Smalltalk }"

Object subclass:#Semaphore

	instanceVariableNames:'count waitingProcesses lastOwnerId name owner'

	classVariableNames:''

	poolDictionaries:''

	category:'Kernel-Processes'

!

!Semaphore class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1993 by Claus Gittinger

 COPYRIGHT (c) 2017 Jan Vrany

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

documentation

"

    Semaphores are used to synchronize processes providing a nonBusy wait

    mechanism. A process can wait for the availability of some resource by

    performing a Semaphore>>wait, which will suspend the process until the

    resource becomes available. Signalling is done by (another process performing)

    Semaphore>>signal.

    If the resource has been already available before the wait, no suspending is

    done, but the resource immediately allocated.

    The resource internally keeps a count, the number of times the resource can be

    allocated. If the semaphore is created with a count greater than 1, the sema

    can be waited-upon that many times without blocking.

    On the other hand, if initialized with a negative count, the semaphore

    must be signalled that many times more often in order for a wait to not block.

    In other words: whenever the semaphore has a count greater than zero,

    the wait operation will proceed. Otherwise, it will block until the count has

    been incremented by signal operations to be greater than zero.

    There are also semaphores for mutual access to a critical region

    (Semaphore>>forMutualExclusion and Semaphore>>critical:).

    Additional protocol is provided for oneShot semaphores,

    (#signalOnce) and for conditional signalling (#signalIf).

    You can also attach semaphores to external events (such as I/O arrival or

    timer events).

    This is done by telling the Processor to signal the semaphore

    under some condition.

    See 'Processor>>signal:afterSeconds:', 'Processor>>signal:onInput:' etc.

    See examples in doc/coding (found in the CodingExamples-nameSpace).

    Warning/Note/Hint:

	a Semaphore-forMutualExclusion does NEVER allow for the critical

	region to be entered twice - NOT EVEN by the same process.

	That means, that a recursive attempt to enter that section leads

	to a deadlock.

	Use a RecursionLock instead, to avoid this.

    NOTE:

    You're encouraged to use `RecursionLock` for guarding a critical section.

    `RecursionLock` is not only reentrant but also much faster.

    Hint:

	now (Jul2002), Semaphores now allow for a negative count; this allows for

	a sync-point to be implemented easily (i.e. to wait for multiple other processes

	to arrive at a sync-point).

	See examples.

    [instance variables:]

	count                   <SmallInteger>          the number of waits, that will go through

							without blocking.

							Incremented on #signal; decremented on #wait.

	waitingProcesses        <OrderedCollection>     waiting processes - will be served first

							come first served when signalled.

	lastOwnerId             <SmallInteger>          a debugging aid: set when count drops

							to zero to the current processes id.

							Helps in finding deadlocks.

	name                    <String>                a debugging aid: an optional userFriendly

							name; helps to identify a semaphore easier.

    [see also:]

	SemaphoreSet RecursionLock Monitor

	SharedQueue Delay

	Process ProcessorScheduler

    [author:]

	Claus Gittinger

"

!

examples

"

    two processes synchronizing on a sema:

                                                        [exBegin]

        |sema thread1 thread2|

        sema := Semaphore new.

        thread1 := [

                        Transcript showCR:'here is thread 1; now waiting ...'.

                        sema wait.

                        Transcript showCR:'here is thread 1 again.'.

                   ] newProcess.

        thread2 := [

                        Transcript showCR:'here is thread 2; delaying a bit ...'.

                        Delay waitForSeconds:5.

                        Transcript showCR:'here is thread 2 again; now signalling the sema'.

                        sema signal.

                        Transcript showCR:'here is thread 2 after the signalling.'.

                  ] newProcess.

        thread1 priority:7.

        thread2 priority:6.

        thread1 resume.

        thread2 resume.

                                                        [exEnd]

    semaphore for critical regions:

                                                        [exBegin]

        |accessLock|

        accessLock := Semaphore forMutualExclusion.

        [

            5 timesRepeat:[

                Delay waitForSeconds:2.

                accessLock critical:[

                    Transcript showCR:'thread1 in critical region'.

                    Delay waitForSeconds:1.

                    Transcript showCR:'thread1 leaving critical region'.

                ].

            ]

        ] forkAt:5.

        [

            5 timesRepeat:[

                Delay waitForSeconds:1.

                accessLock critical:[

                    Transcript showCR:'thread2 in critical region'.

                    Delay waitForSeconds:2.

                    Transcript showCR:'thread2 leaving critical region'.

                ].

            ]

        ] forkAt:4.

                                                        [exEnd]

    a deadlock due to recursive enter of a critical region:

                                                        [exBegin]

        |accessLock block|

        accessLock := Semaphore forMutualExclusion.

        block := [:arg |

                    Transcript showCR:'about to enter'.

                    accessLock critical:[

                        Transcript showCR:'entered - doing action'.

                        arg value

                    ].

                    Transcript showCR:'left region'.

                 ].

        block value:[].                 'this works'.

        block value:[block value:[] ].  'this deadlocks'.

                                                        [exEnd]

    Avoid the deadlock by using a RecursionLock instead:

                                                        [exBegin]

        |accessLock block|

        accessLock := RecursionLock new.

        block := [:arg |

                    Transcript showCR:'about to enter'.

                    accessLock critical:[

                        Transcript showCR:'entered - doing action'.

                        arg value

                    ].

                    Transcript showCR:'left region'.

                 ].

        block value:[].                 'this works'.

        block value:[block value:[] ].  'this deadlocks'.

                                                        [exEnd]

   Wait for multiple processes to arrive at a sync-point:

                                                        [exBegin]

        |syncSema proceedSema thread1 thread2 thread3|

        syncSema := Semaphore new.

        syncSema setCount:(1-3).

        proceedSema := Semaphore new.

        thread1 := [

                        Transcript showCR:'here is thread 1; now busy ...'.

                        Delay waitForSeconds:(2 + (Random nextIntegerBetween:2 and:4)).

                        Transcript showCR:'here is thread 1 again - now syncing.'.

                        syncSema signal.

                        Transcript showCR:'thread 1 is waiting for all others...'.

                        proceedSema wait.

                        Transcript showCR:'thread 1 done.'.

                   ] newProcess.

        thread2 := [

                        Transcript showCR:'here is thread 2; now busy ...'.

                        Delay waitForSeconds:(3 + (Random nextIntegerBetween:2 and:4)).

                        Transcript showCR:'here is thread 2 again - now syncing.'.

                        syncSema signal.

                        Transcript showCR:'thread 2 is waiting for all others...'.

                        proceedSema wait.

                        Transcript showCR:'thread 2 done.'.

                  ] newProcess.

        thread3 := [

                        Transcript showCR:'here is thread 3; now busy ...'.

                        Delay waitForSeconds:(4 + (Random nextIntegerBetween:2 and:4)).

                        Transcript showCR:'here is thread 3 again - now syncing.'.

                        syncSema signal.

                        Transcript showCR:'thread 3 is waiting for all others...'.

                        proceedSema wait.

                        Transcript showCR:'thread 3 done.'.

                  ] newProcess.

        thread1 priority:7.

        thread2 priority:6.

        thread3 priority:9.

        thread1 resume.

        thread2 resume.

        thread3 resume.

        Transcript showCR:'main thread: now waiting for other threads...'.

        syncSema wait.

        Transcript showCR:'main thread: all other threads at syncPoint.'.

        Delay waitForSeconds:2.

        Transcript showCR:'main thread: now let them proceed...'.

        proceedSema signalForAll.

        Transcript showCR:'main thread: done.'.

                                                        [exEnd]

   waitWithTimeout:0 can also be used to conditionally acquire the semaphore

   i.e. only acquire it if it is available.

     |s|

     s := Semaphore new.

     [

          (s waitWithTimeout:0) notNil ifTrue:[

                Transcript showCR:'process1 got the sema'.

                Delay waitForSeconds:1.

                Transcript showCR:'process1 signals sema'.

                s signal.

          ] ifFalse:[

                Transcript showCR:'process1 has NOT got the sema'.

          ].

     ] fork.

     [

          (s waitWithTimeout:0) notNil ifTrue:[

                Transcript showCR:'process2 got the sema'.

                Delay waitForSeconds:1.

                Transcript showCR:'process2 signals sema'.

                s signal.

          ] ifFalse:[

                Transcript showCR:'process2 has NOT got the sema'.

          ]

     ] fork.

     s signal.

     Delay waitForSeconds:0.5.

     Transcript showCR:'master waits for sema'.

     s wait.

     Transcript showCR:'master got the sema'.

"

! !

!Semaphore class methodsFor:'instance creation'!

cleanup

    "an emergency helper: manually signal all semaphores which were held by a now dead process.

     Can only (;-?) happen, if a semaphore-holding process was hard terminated

     (i.e. no ensure handling happened), and semas remain in a bad state."

    self allInstancesDo:[:sema |

        |lastOwner|

        (sema count == 0

         and:[(lastOwner := sema lastOwner) notNil

         and:[lastOwner isDead]]) ifTrue:[

            sema signal

        ]

    ]

!

forMutualExclusion

    "create & return a new semaphore which allows exactly one process to

     wait on it without blocking. This type of semaphore is used

     for mutual exclusion from critical regions (see #critical:).

     Also see RecursionLock, to avoid deadlock in case of recursive entered

     critical regions."

    ^ super new setCount:1; name:'criticalRegionSema'

    "Modified: / 17.6.1998 / 16:23:09 / cg"

!

new

    "create & return a new semaphore which blocks until a signal is sent"

    ^ super new setCount:0

!

new:n

    "create & return a new semaphore which allows n waits before

     blocking"

    ^ super new setCount:n

! !

!Semaphore methodsFor:'Compatibility-Squeak'!

isSignaled

    ^ self wouldBlock not

!

waitTimeoutMSecs:milliSeconds

    ^ self waitWithTimeoutMs:milliSeconds

!

waitTimeoutSeconds:seconds

    ^ self waitWithTimeout:seconds

! !

!Semaphore methodsFor:'accessing'!

owner

    "an optional reference to someone who owns this semaphore,

     typically a shared queue or a windowgroup or similar.

     This has no semantic meaning and is only used to support debugging"

    ^ owner

!

owner:something

    "an optional reference to someone who owns this semaphore,

     typically a shared queue or a windowgroup or similar.

     This has no semantic meaning and is only used to support debugging"

    owner := something.

! !

!Semaphore methodsFor:'printing & storing'!

displayOn:aGCOrStream

    "return a string to display the receiver - include the

     count for your convenience"

    "/ what a kludge - Dolphin and Squeak mean: printOn: a stream;

    "/ ST/X (and some old ST80's) mean: draw-yourself on a GC.

    (aGCOrStream isStream) ifFalse:[

	^ super displayOn:aGCOrStream

    ].

    aGCOrStream

	nextPutAll:self class name;

	nextPut:$(.

    count printOn:aGCOrStream.

    aGCOrStream nextPutAll:' name: '.

    (name ? 'unnamed') printOn:aGCOrStream.

    aGCOrStream nextPut:$).

    "Modified: 28.6.1997 / 16:21:09 / cg"

!

name

    "return the semaphores userFriendly name"

    ^ name

!

name:aString

    "set the semaphores userFriendly name"

    name := aString

! !

!Semaphore methodsFor:'private'!

addWaitingProcess:aProcess

    "add aProcess to the list of waiting processes.

     all processes are ordered first-come-first-serve.

     NOTE: must be called with blocked interrupts"

    waitingProcesses isNil ifTrue:[

        "for now - assume that there is probably only one waiter"

        waitingProcesses := Array with:aProcess

    ] ifFalse:[

        waitingProcesses isArray ifTrue:[

            "add 2 to reserve space for additional waiters"

            waitingProcesses := (OrderedCollection new:waitingProcesses size + 2)

                                    addAll:waitingProcesses;

                                    yourself.

        ].

        waitingProcesses add:aProcess.

    ].

"/    "Sort, so that higher priority process are resumed first.

"/    Processes having the same priority are ordered first-come-first-serve."

"/

"/    |priority insertIndex|

"/

"/    (waitingProcesses size == 0

"/     or:[(priority := aProcess priority) <= waitingProcesses last priority]) ifTrue:[

"/        waitingProcesses add:aProcess.

"/        ^ self.

"/    ].

"/

"/    insertIndex := waitingProcesses findFirst:[:process| process priority < priority].

"/    waitingProcesses add:aProcess beforeIndex:insertIndex.

!

removeWaitingProcess:aProcess

    "remove aProcess from the list of waiting processes

     NO action if it is not in the list.

     NOTE: must be called with blocked interrupts"

    |nWaiting|

    nWaiting := waitingProcesses size.

    nWaiting == 0 ifTrue:[^ self].

    nWaiting == 1 ifTrue:[

	(waitingProcesses at:1) == aProcess ifTrue:[

	    waitingProcesses := nil.

	].

	^ self.

    ].

    waitingProcesses removeIdentical:aProcess ifAbsent:[].

!

wakeupWaiters

    "remove all waiting processes from the list of waiting processes

     and resume them.

     NOTE: Must be called when known that waitingProcesses is nonNil and

	   also with blocked interrupts"

    |processes anyDead needsReschedule|

    processes := waitingProcesses.

"/ do not set to nil - a waiting process may be suspended and will not be resumed by #makeRunnable: ...

"/    waitingProcesses := nil.

    needsReschedule := false.

    anyDead := false.

    processes do:[:eachProcess |

	(Processor makeRunnable:eachProcess) ifTrue:[

	    needsReschedule := true.

	] ifFalse:[

	    "if process is nil or dead (or for other reasons) makeRunnable returns false.