!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: semaphore.gs,v 1.9 2008-01-09 22:50:15 stever Exp $
!
! Superclass Hierarchy:
!   Semaphore, Array, SequenceableCollection, Collection, Object.
!
!=========================================================================

! Forward references needed
run
Globals at: #ProcessorScheduler ifAbsent: [Globals at: #ProcessorScheduler put: nil].
true
%

! note, Semaphore is made NP in bomlastconv.gs 

expectvalue %String
run
^ Array _newKernelSubclass: #Semaphore
  instVarNames: #(#signalCount)
  classVars: #()
  classInstVars: #()
  poolDictionaries: #[]
  inDictionary: Globals
  constraints: #[
	#[#signalCount, SmallInteger]
	]
  instancesInvariant: false
  isModifiable: false
  reservedOop: 905

%

! Remove existing behavior from Semaphore
removeallmethods Semaphore
removeallclassmethods Semaphore

! ------------------- Class methods for Semaphore
category: 'For Documentation Installation only'
classmethod
installDocumentation
| doc txt |
doc := GsClassDocumentation newForClass: self.

txt := (GsDocText new) details:
'Instances of Semaphore are used to define critical regions in
 Smalltalk processes.  Only one instance of a GsProcess will
 may execute within a critical region at a time.  Instances of
 Semaphore may not be committed to disk; they exist only for the
 life of a session, or until garbage collected.' .

doc documentClassWith: txt.

self description: doc.
%

category: 'Instance Creation'
classmethod: Semaphore
forMutualExclusion
  "Answer a new semaphore that has an initial pending
   signal, that can be used for mutial exclusion
   processing."
  ^self new signal
%
category: 'Instance Creation'
classmethod: Semaphore
new
  "Answer a new semaphore"
  ^self basicNew initialize
%
category: 'Instance Creation'
classmethod: Semaphore
new: size
  "Answer a new semaphore"
  ^self new
%
! ------------------- Instance methods for Semaphore
category: 'Mutual Exclusion'
method: Semaphore
critical: aBlock
  "execute aBlock when no other critical blocks are executing"
  
  | value |
  self wait.
  value := aBlock ensure: [self signal].
  ^value
%
category: 'Initialization'
method: Semaphore
initialize

  signalCount := 0.
%
category: 'Private'
method: Semaphore
excessSignals

  ^signalCount
%
category: 'Formatting'
method: Semaphore
printOn: aStream
  aStream
    nextPutAll: self class name;
    nextPut: $(.
  self asOop printOn: aStream.
  self size > 0 ifTrue: [
    aStream nextPutAll: ',p='.
    1 to: self size do: [:i | (self at: i) printOn: aStream] ].
  aStream nextPut: $)
%
category: 'Communication'
method: Semaphore
signal
  "Send a signal through the receiver. If one or more GsProcesses have
   been suspended trying to receive a signal, make the one with the
   highest priority that has been waiting the longest ready to run.
   If no GsProcess is waiting, remember the excess signal.
   Returns the receiver."
   
  "if semaphores are signaled preemptively, this should be moved to
   a primitive"
  | proc |
  "ProcessorScheduler scheduler dbglog: [ 'signalling semaphore ', self printString ]."
  (self size > 0) ifTrue: [
    "ProcessorScheduler scheduler dbglog: [ '  resuming process' ]."
    proc := self removeFirst.
    proc _reapSignal: self ]
  ifFalse: [
    signalCount := signalCount + 1 ].
%
category: 'Communication'
method: Semaphore
signalAll
  "Just like signal except all of the GsProcesses waiting on the receiver
   are made ready to run.
   Returns the receiver."
   
  "ProcessorScheduler scheduler dbglog: [ 'signalling all semaphore ', self printString ]."
  self do: [:proc |
    "ProcessorScheduler scheduler dbglog: [ '  resuming process' ]."
    proc _reapSignal: self.
  ].
  self size: 0.
%
category: 'Communication'
method: Semaphore
wait
  "if signalCount > 0, this merely decrements the count.  Otherwise
   this will suspend the active process and add it to the end of
   the receiver's list of suspended processes"
  
  "if semaphores are signaled preemptively, this should be moved to
   a primitive"
  "ProcessorScheduler scheduler dbglog: [ ('wait for ', self printString) ]."
  (signalCount > 0) ifTrue: [
    signalCount := signalCount - 1
  ] ifFalse: [
    | me scheduler |
    scheduler := ProcessorScheduler scheduler.
    "scheduler dbglog: [ '  semaphore suspending process' ]."
    me := scheduler activeProcess.
    self add: me.
    me _location: self.
    scheduler _waiting: me.
    scheduler _reschedule. "find a new process to run"
  ].
%
category: 'Communication'
method: Semaphore
waitForMilliseconds: millisecondCount
  "if signalCount > 0, this merely decrements the count.  Otherwise
   this will suspend the active process and add it to the end of
   the receiver's list of suspended processes.
   It will wait for at least millisecondCount for the receiver to
   be signalled.
   Returns true if the semaphore was signalled for the caller.
   Returns false if the timeout expires without a signal for the caller."

  | ps |
  ps := ProcessorScheduler scheduler.
  "ps dbglog: [ ('wait for ', self printString) ]."
  (signalCount > 0) ifTrue: [
    signalCount := signalCount - 1.
    ^true
  ] ifFalse: [ | me |
    "ps dbglog: [ '  semaphore suspending process' ]."
    me := ps activeProcess.
    self add: me.
    me _location: self.
    ps _waiting: me.
    (ps _waitUntilMilliseconds: ((ps _now) + millisecondCount)) ifTrue: [
      "timed out so remove me from self"
      self removeIdentical: me ifAbsent: [
        "not in the semaphore so must have been signalled and timed out"
        ^true
      ].
      ^false
    ] ifFalse: [
      ^true
    ].
  ].
%

category: 'Communication'
method: Semaphore
waitForSeconds: secondCount
  "If signalCount > 0, this merely decrements the count.  Otherwise
   this will suspend the active process and add it to the end of
   the receiver's list of suspended processes.
   It will wait for at least secondCount seconds for the receiver to
   be signalled.
   Returns true if the semaphore was signalled for the caller.
   Returns false if the timeout expires without a signal for the caller."

  ^ self waitForMilliseconds: secondCount * 1000
%

category: 'Private'
method: Semaphore
_reapSignal: signalSource
  "Signal the receiver "

  self signal.
%
category: 'Private'
method: Semaphore
_setupReapSignalLocation: anObject
  "Make the receiver ready to be sent _reapSignal:."
  "Nothing is needed"
%
category: 'Private'
method: Semaphore
_signalAll
  "Wake up the receiver"

  self signalAll.
%
category: 'Private'
method: Semaphore
_wait

  self wait.
%

category: 'Adding'
method: Semaphore
add: newObject

"(R) Makes newObject one of the receiver's elements and returns newObject.
  Reimplemented so that it will add based on the priority of newObject."

  | count |
  count := self size.
  (count == 0) ifTrue: [
    super add: newObject.
  ] ifFalse: [
    | newPriority |
    newPriority := newObject priority.
    count downTo: 1 do: [ :i |
      (newPriority <= ((self at: i) priority)) ifTrue: [
        self insertObject: newObject at: (i + 1).
        ^ newObject.
      ].
    ].
    self insertObject: newObject at: 1.
  ].
  ^newObject.
%

category: 'Private'
method: Semaphore
_unscheduleProcess: aGsProcess
  "Used by ProcessorScheduler"
  self removeIdentical: aGsProcess ifAbsent: [].
%

category: 'Private'
method: Semaphore
_changePriority: aGsProcess from: oldPriority
  "Used by GsProcess to change the priority of a GsProcess in the receiver."
  self removeIdentical: aGsProcess ifAbsent: [^self].
  self add: aGsProcess.
%
