--- a/ProcessorScheduler.st Tue Feb 04 21:09:59 2014 +0100
+++ b/ProcessorScheduler.st Wed Apr 01 10:20:10 2015 +0100
@@ -11,6 +11,8 @@
"
"{ Package: 'stx:libbasic' }"
+"{ NameSpace: Smalltalk }"
+
Object subclass:#ProcessorScheduler
instanceVariableNames:'quiescentProcessLists scheduler zombie activeProcess
activeProcessId currentPriority readFdArray readSemaphoreArray
@@ -27,7 +29,7 @@
UserSchedulingPriority UserInterruptPriority TimingPriority
HighestPriority SchedulingPriority MaxNumberOfProcesses
InvalidProcessSignal TimeSlicingPriorityLimit TimeSliceInterval
- EventPollingInterval'
+ EventPollingInterval MaxProcessId'
poolDictionaries:''
category:'Kernel-Processes'
!
@@ -280,8 +282,16 @@
'Processor [error]: no process support - running event driven' errorPrintCR
].
- "Modified: 23.9.1996 / 14:24:50 / stefan"
- "Modified: 10.1.1997 / 18:03:03 / cg"
+%{
+#ifndef MAX_PROCESS_ID
+# define MAX_PROCESS_ID _MAX_INT
+#endif
+ @global(ProcessorScheduler:MaxProcessId) = __MKSMALLINT(MAX_PROCESS_ID);
+%}
+
+ "Modified: / 23-09-1996 / 14:24:50 / stefan"
+ "Modified: / 10-01-1997 / 18:03:03 / cg"
+ "Modified: / 19-09-2014 / 12:47:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!ProcessorScheduler class methodsFor:'instance creation'!
@@ -462,6 +472,14 @@
MaxNumberOfProcesses := aNumber
!
+maxProcessId
+ "Return a maximum allowed value of a Process id. "
+
+ ^ MaxProcessId
+
+ "Created: / 19-09-2014 / 12:47:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
processDriven
"turn on process driven mode"
@@ -580,6 +598,12 @@
^ interruptedProcess
!
+maxProcessId
+ ^ self class maxProcessId
+
+ "Created: / 19-09-2014 / 12:53:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
scheduler
"return the scheduling process"
@@ -828,11 +852,22 @@
dispatchAction := [ [dispatching] whileTrue:[ self dispatch ] ].
handlerAction := [:ex |
- ('Processor [info]: ignored signal (', ex creator printString, ')') infoPrintCR.
+ (HaltInterrupt accepts:ex creator) ifTrue:[
+ "/ in a standalone application, we do not want those
+ Smalltalk isStandAloneApp ifTrue:[
+ Smalltalk isStandAloneDebug ifFalse:[
+ ('Processor [info]: ignored (', ex creator printString, ')') infoPrintCR.
+ ex proceed.
+ ]
+ ].
+ ].
+
+ ('Processor [info]: caught (and ignored) signal (', ex creator printString, ')') infoPrintCR.
ex return
].
ignoredSignals := SignalSet
+ with:HaltInterrupt
with:TerminateProcessRequest
with:RecursionError
with:AbortAllOperationRequest.
@@ -876,7 +911,7 @@
KnownProcesses isNil ifTrue:[
KnownProcesses := WeakArray new:30.
KnownProcesses addDependent:self class.
- KnownProcessIds := OrderedCollection new.
+ KnownProcessIds := OrderedCollection new:30.
].
"
@@ -898,14 +933,16 @@
anyTimeouts := false.
dispatching := false.
- exitWhenNoMoreUserProcesses isNil ifTrue:[
- exitWhenNoMoreUserProcesses := false. "/ mhmh - how about true ?
- ].
useIOInterrupts := OperatingSystem supportsIOInterrupts.
gotIOInterrupt := false.
osChildExitActions := Dictionary new.
gotChildSignalInterrupt := false.
+ supportDynamicPriorities := false.
+ exitWhenNoMoreUserProcesses isNil ifTrue:[
+ exitWhenNoMoreUserProcesses := false. "/ mhmh - how about true ?
+ ].
+
"
handcraft the first (dispatcher-) process - this one will never
block, but go into a select if there is nothing to do.
@@ -914,10 +951,11 @@
"
currentPriority := SchedulingPriority.
p := Process basicNew.
- p setId:0 state:#run.
- p setPriority:currentPriority.
- p name:'scheduler'.
- p beSystemProcess.
+ p
+ setId:0 state:#run;
+ setPriority:currentPriority;
+ name:'scheduler';
+ beSystemProcess.
scheduler := activeProcess := p.
activeProcessId := 0.
@@ -929,8 +967,9 @@
let me handle IO and timer interrupts
"
useIOInterrupts ifTrue:[ObjectMemory ioInterruptHandler:self].
- ObjectMemory timerInterruptHandler:self.
- ObjectMemory childSignalInterruptHandler:self.
+ ObjectMemory
+ timerInterruptHandler:self;
+ childSignalInterruptHandler:self.
"Modified: / 7.1.1997 / 16:48:26 / stefan"
"Modified: / 4.2.1999 / 13:08:39 / cg"
@@ -1153,71 +1192,20 @@
status of the OS process changes (e.g. the process terminates).
The method returns the value from aBlockReturningPid (i.e a pid or nil)."
- |pid wasBlocked osProcessStatus|
-
- OperatingSystem supportsChildInterrupts ifTrue:[
- "/ SIGCHLD is supported,
- "/ aBlock will be evaluated, as soon as a SIGCHLD interrupt for pid has been received.
-
- OperatingSystem enableChildSignalInterrupts.
- wasBlocked := OperatingSystem blockInterrupts.
- pid := aBlockReturningPid value.
- pid notNil ifTrue:[
- osChildExitActions at:pid put:actionBlock.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ] ifFalse:[
- "/ SIGCHLD is not supported, fork a high prio process
- "/ to poll for for the exit of pid.
-
- wasBlocked := OperatingSystem blockInterrupts.
- pid := aBlockReturningPid value.
- pid notNil ifTrue:[
- osChildExitActions at:pid put:actionBlock.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- pid notNil ifTrue:[
- [
- [
- |polling myDelay t|
-
- polling := true.
- myDelay := Delay forMilliseconds:(t := EventPollingInterval).
- [polling] whileTrue:[
- t ~~ EventPollingInterval ifTrue:[
- "/ interval changed -> need a new delay
- myDelay delay:(t := EventPollingInterval).
- ].
- myDelay wait.
- (osChildExitActions includesKey:pid) ifFalse:[
- polling := false.
- ] ifTrue:[
- osProcessStatus := OperatingSystem childProcessWait:false pid:pid.
- osProcessStatus notNil ifTrue:[
- (osProcessStatus pid = pid) ifTrue:[
- OperatingSystem blockInterrupts.
- osChildExitActions removeKey:pid ifAbsent:nil.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- actionBlock value:osProcessStatus.
- polling := false.
- ] ifFalse:[
- osProcessStatus stillAlive
- ]
- ]
- ].
- ]
- ] ifCurtailed:[
- OperatingSystem blockInterrupts.
- osChildExitActions removeKey:pid ifAbsent:nil.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ]
- ] newProcess
- priority:TimingPriority;
-"/ beSystemProcess;
- resume.
- ].
+ |pid wasBlocked|
+
+ "/ aBlock will be evaluated:
+ "/ on unix: as soon as a SIGCHLD interrupt for pid has been received.
+ "/ on win: as soon as a select for the pid handle returns
+
+ OperatingSystem enableChildSignalInterrupts. "/ no-op in windows
+ wasBlocked := OperatingSystem blockInterrupts.
+ "/ start the OS-Process
+ pid := aBlockReturningPid value.
+ pid notNil ifTrue:[
+ osChildExitActions at:pid put:actionBlock.
].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
^ pid
"Created: / 25.3.1997 / 10:54:56 / stefan"
@@ -1571,8 +1559,8 @@
[prio >= 1] whileTrue:[
l := listArray at:prio.
l notNil ifTrue:[
- l do:[:aProcess |
- aProcess processGroupId ~~ 0 ifTrue:[
+ l linksDo:[:aProcess |
+ aProcess isUserProcess ifTrue:[
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
^ true.
]
@@ -1604,7 +1592,7 @@
l := listArray at:prio.
l notNil ifTrue:[
l notEmpty ifTrue:[
- p := l first.
+ p := l firstLink.
"
if it got corrupted somehow ...
"
@@ -1656,6 +1644,34 @@
"
"Modified: 17.1.1997 / 17:48:41 / cg"
+!
+
+processWithId:anInteger
+ "answer the process with id anInteger, or nil if there is none"
+
+ |wasBlocked slot process|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ slot := KnownProcessIds indexOf:anInteger.
+ slot ~~ 0 ifTrue:[
+ process := KnownProcesses at:slot ifAbsent:[].
+ ].
+
+ wasBlocked ifFalse:[
+ OperatingSystem unblockInterrupts.
+ ].
+
+ "Take care, the process may already have been collected"
+ process == 0 ifTrue:[
+ ^ nil.
+ ].
+ ^ process.
+
+ "
+ Processor processWithId:4
+ Processor processWithId:4711
+ "
! !
!ProcessorScheduler methodsFor:'scheduling'!
@@ -1919,7 +1935,7 @@
l isEmpty ifTrue:[
p := scheduler
] ifFalse:[
- p := l first
+ p := l firstLink
].
self threadSwitch:p
].
@@ -2025,7 +2041,7 @@
!
yield
- "move the currently running process to the end of the currentList
+ "move the currently running process to the end of the current list
and reschedule to the first in the list, thus switching to the
next same-prio-process."
@@ -2071,7 +2087,7 @@
"
and switch to first in the list
"
- self threadSwitch:(l first).
+ self threadSwitch:(l firstLink).
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -2092,7 +2108,7 @@
"/ time, no rescheduling is req'd
scheduledProcesses do:[:aProcess |
- |range prio|
+ |range|
"/ decrease priority of processes that did run
(range := aProcess priorityRange) notNil ifTrue:[
@@ -2121,7 +2137,7 @@
|list|
(list := quiescentProcessLists at:i) size > 0 ifTrue:[
- list do:[:aProcess |
+ list linksDo:[:aProcess |
|range prio|
(range := aProcess priorityRange) notNil ifTrue:[
@@ -2199,11 +2215,12 @@
'Processor [info]: timeslicer finished' infoPrintCR.
]
] newProcess.
- timeSliceProcess priority:HighestPriority.
- timeSliceProcess name:'time slicer'.
- timeSliceProcess restartable:true.
- timeSliceProcess beSystemProcess.
- timeSliceProcess resume.
+ timeSliceProcess
+ priority:HighestPriority;
+ name:'time slicer';
+ restartable:true;
+ beSystemProcess;
+ resume.
"
Processor stopTimeSlicing.
@@ -2261,7 +2278,7 @@
flipFlop := true.
'Processor [info]: timeslicer started' infoPrintCR.
- [true] whileTrue: [
+ [
t ~~ TimeSliceInterval ifTrue:[
"/ interval changed -> need a new delay
myDelay delay:(t := TimeSliceInterval).
@@ -2273,14 +2290,15 @@
flipFlop := flipFlop not.
flipFlop ifTrue:[
scheduledProcesses notNil ifTrue:[
- supportDynamicPriorities == true ifTrue:[
+ supportDynamicPriorities ifTrue:[
self recomputeDynamicPriorities.
].
- scheduledProcesses removeAll.
+ scheduledProcesses clearContents.
+ ] ifFalse:[
+ scheduledProcesses := IdentitySet new.
].
- scheduledProcesses := IdentitySet new.
].
- ]
+ ] loop.
! !
!ProcessorScheduler methodsFor:'semaphore signalling'!
@@ -2348,6 +2366,12 @@
"Modified: / 9.11.1998 / 20:39:06 / cg"
!
+signal:aSemaphore after:aTimeDuration
+ "arrange for a semaphore to be triggered after aTimeDuration"
+
+ self signal:aSemaphore afterMilliseconds:aTimeDuration getMilliseconds
+!
+
signal:aSemaphore afterMilliseconds:millis
"arrange for a semaphore to be triggered after some milliseconds"
@@ -2399,7 +2423,8 @@
signal:aSemaphore onInput:aFileDescriptor
"arrange for a semaphore to be triggered when input on aFileDescriptor
- arrives. This will only happen, if the OS supports selecting on fileDescriptors."
+ arrives. This will only happen, if the OS supports selecting on fileDescriptors.
+ The semaphore is removed from the set of semaphores, after being signaled."
self signal:aSemaphore onInput:aFileDescriptor orCheck:nil
!
@@ -2411,58 +2436,69 @@
(i.e. every few milliseconds).
(This is req'd for buffered input, where a select may not detect
data which has already been read into a buffer - as in Xlib.
- Or on systems, where we cannot select on a displays eventQ, such as windows)"
+ Or on systems, where we cannot select on a displays eventQ, such as windows).
+ If aBlock is nil, the semaphore is removed from the set of semaphores, after being signaled."
|idx "{ Class: SmallInteger }"
- wasBlocked|
+ wasBlocked slot|
wasBlocked := OperatingSystem blockInterrupts.
+ "Here we assume, that for every triple (aSemaphore, aFileDescriptor, aBlock)
+ aSemphore is never nil, but one of aFileDescriptor, aBlock may be nil"
+
aFileDescriptor isNil ifTrue:[
- (idx := readCheckArray identityIndexOf:aSemaphore startingAt:1) == 0 ifTrue:[
- idx := readFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
+ idx := readSemaphoreArray identityIndexOf:aSemaphore or:nil.
+ idx == 0 ifTrue:[
+ "aSemaphore is not registered yet, have to create a new slot"
+ readFdArray := readFdArray copyWith:nil.
+ readSemaphoreArray := readSemaphoreArray copyWith:aSemaphore.
+ readCheckArray := readCheckArray copyWith:aBlock.
+ ] ifFalse:[
+ slot := readSemaphoreArray at:idx.
+ slot isNil ifTrue:[
+ readSemaphoreArray at:idx put:aSemaphore.
+ readCheckArray at:idx put:aBlock
+ ] ifFalse:[
+ "/ someone has already registered aSemaphore.
+ "/ Check if it is the block changes...
+ (readCheckArray at:idx) notNil ifTrue:[
+ (readCheckArray at:idx) ~~ aBlock ifTrue:[
+ 'Processor [info]: checkblock changed for read-check' infoPrintCR.
+ readCheckArray at:idx put:aBlock.
+ ].
+ ].
+ ].
+ ]
+ ] ifFalse:[
+ idx := readFdArray identityIndexOf:aFileDescriptor or:nil.
+ idx == 0 ifTrue:[
+ "aFileDescriptor is not registered yet, have to create a new slot"
+ readFdArray := readFdArray copyWith:aFileDescriptor.
+ readSemaphoreArray := readSemaphoreArray copyWith:aSemaphore.
+ readCheckArray := readCheckArray copyWith:aBlock.
+ ] ifFalse:[
+ slot := readFdArray at:idx.
+ slot isNil ifTrue:[
readFdArray at:idx put:aFileDescriptor.
readSemaphoreArray at:idx put:aSemaphore.
readCheckArray at:idx put:aBlock
] ifFalse:[
- readFdArray := readFdArray copyWith:nil.
- readSemaphoreArray := readSemaphoreArray copyWith:aSemaphore.
- readCheckArray := readCheckArray copyWith:aBlock.
- ]
- ] ifFalse:[
- (readCheckArray at:idx) notNil ifTrue:[
+ "/ someone has already registered aFileDescriptor.
+ "/ Check if it is the semaphore or block changes...
+ (readSemaphoreArray at:idx) ~~ aSemaphore ifTrue:[
+ 'Processor [info]: sema changed for read-check' infoPrintCR.
+ readSemaphoreArray at:idx put:aSemaphore.
+ ].
(readCheckArray at:idx) ~~ aBlock ifTrue:[
- 'ouch - checkblock changed for read-check' infoPrintCR.
+ 'Processor [info]: checkblock changed for read-check' infoPrintCR.
readCheckArray at:idx put:aBlock.
- ]
+ ].
].
- ]
- ] ifFalse:[
- (idx := readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
- idx := readFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
- readFdArray at:idx put:aFileDescriptor.
- readSemaphoreArray at:idx put:aSemaphore.
- readCheckArray at:idx put:aBlock
- ] ifFalse:[
- readFdArray := readFdArray copyWith:aFileDescriptor.
- readSemaphoreArray := readSemaphoreArray copyWith:aSemaphore.
- readCheckArray := readCheckArray copyWith:aBlock.
- ].
- useIOInterrupts ifTrue:[
- OperatingSystem enableIOInterruptsOn:aFileDescriptor
- ].
- ] ifFalse:[
- (readSemaphoreArray at:idx) ~~ aSemaphore ifTrue:[
- 'ouch - sema changed for read-check' infoPrintCR.
- readSemaphoreArray at:idx put:aSemaphore.
- ].
- (readCheckArray at:idx) ~~ aBlock ifTrue:[
- 'ouch - checkblock changed for read-check' infoPrintCR.
- readCheckArray at:idx put:aBlock.
- ].
- ]
+ ].
+ (useIOInterrupts and:[slot isNil]) ifTrue:[
+ OperatingSystem enableIOInterruptsOn:aFileDescriptor
+ ].
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -2487,7 +2523,8 @@
signal:aSemaphore onOutput:aFileDescriptor
"arrange for a semaphore to be triggered when output on aFileDescriptor
- is possible without blocking."
+ is possible without blocking.
+ The semaphore is removed from the set of semaphores, after being signaled."
self signal:aSemaphore onOutput:aFileDescriptor orCheck:nil
@@ -2500,44 +2537,70 @@
The checkBlock will be evaluated by the scheduler from time to time
(i.e. every few milliseconds).
This checkBlock is required for poor windows, where a WaitForObject does
- not know about sockets."
+ not know about sockets.
+ If aBlock is nil, the semaphore is removed from the set of semaphores, after being signaled."
|idx "{ Class: SmallInteger }"
- wasBlocked|
+ wasBlocked slot|
wasBlocked := OperatingSystem blockInterrupts.
+ "Here we assume, that for every triple (aSemaphore, aFileDescriptor, aBlock)
+ aSemphore is never nil, but one of aFileDescriptor, aBlock may be nil"
+
aFileDescriptor isNil ifTrue:[
- (writeCheckArray identityIndexOf:aBlock startingAt:1) == 0 ifTrue:[
- idx := writeFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
+ idx := writeSemaphoreArray identityIndexOf:aSemaphore or:nil.
+ idx == 0 ifTrue:[
+ "aSemaphore is not registered yet, have to create a new slot"
+ writeFdArray := writeFdArray copyWith:nil.
+ writeSemaphoreArray := writeSemaphoreArray copyWith:aSemaphore.
+ writeCheckArray := writeCheckArray copyWith:aBlock.
+ ] ifFalse:[
+ slot := writeSemaphoreArray at:idx.
+ slot isNil ifTrue:[
+ writeSemaphoreArray at:idx put:aSemaphore.
+ writeCheckArray at:idx put:aBlock
+ ] ifFalse:[
+ "/ someone has already registered aSemaphore.
+ "/ Check if it is the block changes...
+ (writeCheckArray at:idx) notNil ifTrue:[
+ (writeCheckArray at:idx) ~~ aBlock ifTrue:[
+ 'Processor [info]: checkblock changed for write-check' infoPrintCR.
+ writeCheckArray at:idx put:aBlock.
+ ].
+ ].
+ ].
+ ]
+ ] ifFalse:[
+ idx := writeFdArray identityIndexOf:aFileDescriptor or:nil.
+ idx == 0 ifTrue:[
+ "aFileDescriptor is not registered yet, have to create a new slot"
+ writeFdArray := writeFdArray copyWith:aFileDescriptor.
+ writeSemaphoreArray := writeSemaphoreArray copyWith:aSemaphore.
+ writeCheckArray := writeCheckArray copyWith:aBlock.
+ ] ifFalse:[
+ slot := writeFdArray at:idx.
+ slot isNil ifTrue:[
writeFdArray at:idx put:aFileDescriptor.
writeSemaphoreArray at:idx put:aSemaphore.
writeCheckArray at:idx put:aBlock
] ifFalse:[
- writeFdArray := writeFdArray copyWith:nil.
- writeSemaphoreArray := writeSemaphoreArray copyWith:aSemaphore.
- writeCheckArray := writeCheckArray copyWith:aBlock.
- ]
- ]
- ] ifFalse:[
- (writeFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
- idx := writeFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
- writeFdArray at:idx put:aFileDescriptor.
- writeSemaphoreArray at:idx put:aSemaphore.
- writeCheckArray at:idx put:aBlock
- ] ifFalse:[
- writeFdArray := writeFdArray copyWith:aFileDescriptor.
- writeSemaphoreArray := writeSemaphoreArray copyWith:aSemaphore.
- writeCheckArray := writeCheckArray copyWith:aBlock.
+ "/ someone has already registered aFileDescriptor.
+ "/ Check if it is the semaphore or block changes...
+ (writeSemaphoreArray at:idx) ~~ aSemaphore ifTrue:[
+ 'Processor [info]: sema changed for write-check' infoPrintCR.
+ writeSemaphoreArray at:idx put:aSemaphore.
+ ].
+ (writeCheckArray at:idx) ~~ aBlock ifTrue:[
+ 'Processor [info]: checkblock changed for write-check' infoPrintCR.
+ writeCheckArray at:idx put:aBlock.
+ ].
].
- useIOInterrupts ifTrue:[
- OperatingSystem enableIOInterruptsOn:aFileDescriptor
- ].
- ]
+ ].
+ (useIOInterrupts and:[slot isNil]) ifTrue:[
+ OperatingSystem enableIOInterruptsOn:aFileDescriptor
+ ].
].
-
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
"Modified: 4.8.1997 / 15:21:49 / cg"
@@ -2589,6 +2652,19 @@
!ProcessorScheduler methodsFor:'timeout handling'!
+addTimedBlock:aBlock after:timeDuration
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated after timeDuration. The process which installs this timed
+ block will be interrupted for execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once).
+ Returns an ID, which can be used in #removeTimeoutWidthID:"
+
+ ^ self addTimedBlock:aBlock for:activeProcess afterMilliseconds:timeDuration getMilliseconds
+!
+
addTimedBlock:aBlock afterMilliseconds:delta
"add the argument, aBlock to the list of time-scheduled-blocks; to be
evaluated after delta milliseconds. The process which installs this timed
@@ -2635,6 +2711,23 @@
"Modified: 23.9.1996 / 14:34:09 / cg"
!
+addTimedBlock:aBlock for:aProcess after:timeDuration
+ "add the argument, aBlock to the list of time-scheduled-blocks.
+ to be evaluated after timeDuration. aProcess will be interrupted for
+ execution of the block.
+ (if it is running, the interrupt will occur in whatever method it is
+ executing; if it is suspended, it will be resumed).
+ If aProcess is nil, the block will be evaluated by the scheduler itself
+ (which is dangerous - the block should not raise any error conditions).
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once).
+ Returns an ID, which can be used in #removeTimeoutWidthID:"
+
+ ^ self addTimedBlock:aBlock for:aProcess afterMilliseconds:timeDuration getMilliseconds
+
+ "Modified: 23.9.1996 / 14:34:18 / cg"
+!
+
addTimedBlock:aBlock for:aProcess afterMilliseconds:delta
"add the argument, aBlock to the list of time-scheduled-blocks; to be
evaluated after delta milliseconds. The process specified by the argument,
@@ -2777,17 +2870,27 @@
evaluateTimeouts
"walk through timeouts and evaluate blocks or signal semas that need to be .."
- |sema now aTime block blocksToEvaluate
- processes n "{ Class: SmallInteger }"
+ |sema now aTime block blocksAndProcessesToEvaluate
+ firstBlockToEvaluate firstProcess
+ n "{ Class: SmallInteger }"
indexOfLastTimeout "{ Class: SmallInteger }"
halfSize "{ Class: SmallInteger }"
- wasBlocked|
+ wasBlocked p|
+
anyTimeouts ifFalse:[ ^ self].
anyTimeouts := false.
- "have to collect the blocks first, then evaluate them. This avoids
- problems due to newly inserted blocks."
+ "have to collect the blocks first, then evaluate them.
+ This avoids problems due to newly inserted blocks."
+
+ "/ notice: the code looks uglier than seems to be required;
+ "/ the observation is that in almost all cases, only a single block (or no block at all)
+ "/ is found in the loops below.
+ "/ To avoid idle memory allocation, we avoid the allocation of the OrderedCollection in this case,
+ "/ by remembering the first block+process in a variable until another block is found.
+ "/ Thus firstBlockToEvaluate+firstProcess effectively cache the first slot of the lazy allocated collection.
+ "/ looks ugly, but as this is called very often, reduces idle allocation by a lot.
now := OperatingSystem getMillisecondTime.
n := timeoutArray size.
@@ -2805,12 +2908,18 @@
"to support pure-events"
block := timeoutActionArray at:index.
block notNil ifTrue:[
- blocksToEvaluate isNil ifTrue:[
- blocksToEvaluate := OrderedCollection new.
- processes := OrderedCollection new.
+ firstBlockToEvaluate isNil ifTrue:[
+ firstBlockToEvaluate := block.
+ firstProcess := timeoutProcessArray at:index.
+ ] ifFalse:[
+ blocksAndProcessesToEvaluate isNil ifTrue:[
+ blocksAndProcessesToEvaluate := OrderedCollection
+ with:firstBlockToEvaluate
+ with:firstProcess.
+ ].
+ blocksAndProcessesToEvaluate add:block.
+ blocksAndProcessesToEvaluate add:(timeoutProcessArray at:index).
].
- blocksToEvaluate add:block.
- processes add:(timeoutProcessArray at:index).
timeoutActionArray at:index put:nil.
timeoutProcessArray at:index put:nil.
]
@@ -2824,8 +2933,9 @@
]
].
+ "shrink the arrays, if they are 50% free"
n > 20 ifTrue:[
- halfSize := (n // 2).
+ halfSize := n // 2.
indexOfLastTimeout < halfSize ifTrue:[
wasBlocked := OperatingSystem blockInterrupts.
(timeoutArray at:indexOfLastTimeout+1) isNil ifTrue:[ "/ no new timeouts arrived
@@ -2838,30 +2948,58 @@
].
].
- n := blocksToEvaluate size.
- 1 to:n do:[:index |
- |block p|
-
- block := blocksToEvaluate at:index.
- p := processes at:index.
- (p isNil or:[p == scheduler or:[PureEventDriven]]) ifTrue:[
- block value
- ] ifFalse:[
- p isDead ifTrue:[
-
- "/ a timedBlock for a process which has already terminated
- "/ issue a warning and do not execute it.
- "/ (exeuting here may be dangerous, since it would run at scheduler priority here,
- "/ and thereby could block the whole smalltalk system.
- "/ For this reason is it IGNORED here.)
-
- ('ProcessorScheduler [warning]: cannot evaluate timedBlock for dead process: ''' , p name , '''') infoPrintCR.
- ('ProcessorScheduler [warning]: the timedBlock is: ' , block displayString) infoPrintCR.
+ blocksAndProcessesToEvaluate isNil ifTrue:[
+ firstBlockToEvaluate notNil ifTrue:[
+ (firstProcess isNil or:[firstProcess == scheduler or:[PureEventDriven]]) ifTrue:[
+ firstBlockToEvaluate value
] ifFalse:[
- p interruptWith:block
+ firstProcess isDead ifTrue:[
+ "/ a timedBlock for a process which has already terminated
+ "/ issue a warning and do not execute it.
+ "/ (exeuting here may be dangerous, since it would run at scheduler priority here,
+ "/ and thereby could block the whole smalltalk system.
+ "/ For this reason is it IGNORED here.)
+"/ Could handle it in timeoutProcess, but we don't,
+"/ because otherwise timeouts might be reissued forever...
+"/ (timeoutHandlerProcess notNil and:[timeoutHandlerProcess isDead not]) ifTrue:[
+"/ timeoutHandlerProcess interruptWith:block.
+"/ ] ifFalse:[
+ ('ProcessorScheduler [warning]: cannot evaluate timedBlock for dead process: ''' , firstProcess name , '''') infoPrintCR.
+ ('ProcessorScheduler [warning]: the timedBlock is: ' , firstBlockToEvaluate displayString) infoPrintCR.
+"/ ].
+ ] ifFalse:[
+ firstProcess interruptWith:firstBlockToEvaluate
+ ]
+ ]
+ ].
+ ] ifFalse:[
+ n := blocksAndProcessesToEvaluate size.
+ 1 to:n by:2 do:[:index |
+ block := blocksAndProcessesToEvaluate at:index.
+ p := blocksAndProcessesToEvaluate at:index+1.
+ (p isNil or:[p == scheduler or:[PureEventDriven]]) ifTrue:[
+ block value
+ ] ifFalse:[
+ p isDead ifTrue:[
+ "/ a timedBlock for a process which has already terminated
+ "/ issue a warning and do not execute it.
+ "/ (exeuting here may be dangerous, since it would run at scheduler priority here,
+ "/ and thereby could block the whole smalltalk system.
+ "/ For this reason is it IGNORED here.)
+"/ Could handle it in timeoutProcess, but we don't,
+"/ because otherwise timeouts might be reissued forever...
+"/ (timeoutHandlerProcess notNil and:[timeoutHandlerProcess isDead not]) ifTrue:[
+"/ timeoutHandlerProcess interruptWith:block.
+"/ ] ifFalse:[
+ ('ProcessorScheduler [warning]: cannot evaluate timedBlock for dead process: ''' , p name , '''') infoPrintCR.
+ ('ProcessorScheduler [warning]: the timedBlock is: ' , block displayString) infoPrintCR.
+"/ ].
+ ] ifFalse:[
+ p interruptWith:block
+ ]
]
]
- ]
+ ].
"Modified: / 30-07-2013 / 19:33:24 / cg"
!
@@ -2887,7 +3025,7 @@
removeTimeoutWithID:anID
"remove the timeOut with anID (as returned by #addTimedBlock)
- from the list of time-sceduled-blocks."
+ from the list of time-scheduled-blocks."
|index "{ Class: SmallInteger }"
wasBlocked|
@@ -2913,15 +3051,7 @@
timeoutHandlerProcess :=
[
[
- [true] whileTrue:[
- [
- self timeoutHandlerProcessLoop
- ] on:Exception do:[:ex|
- "ignore errors, but tell the user"
- ('ProcessorScheduler [warning]: error while handling timeouts in TimeoutHandlerProcess: ''' , ex description , '''') infoPrintCR.
-"/ thisContext fullPrintAll.
- ].
- ]
+ self timeoutHandlerProcessLoop.
] ensure:[
timeoutHandlerProcess := nil
].
@@ -2942,7 +3072,17 @@
"The timeoutHandlerProcess does nothing but wait.
It exists only, so that timeout blocks may be executed in its context."
- (Semaphore new name:'timeoutHandler') wait.
+ [
+ [
+ (Semaphore new name:'timeoutHandler') wait.
+ ] on:Exception do:[:ex|
+ "ignore errors, but tell the user"
+ InfoPrinting == true ifTrue:[
+ ('ProcessorScheduler [warning]: error while handling timeouts in TimeoutHandlerProcess: ''' , ex description , '''') infoPrintCR.
+ thisContext fullPrintAll.
+ ].
+ ].
+ ] loop.
! !
!ProcessorScheduler methodsFor:'wait hooks'!
@@ -2984,85 +3124,13 @@
or a timeout to occur."
|nReady index sema action wasBlocked err fd readyIndex
- newProcessMaybeReady|
+ newProcessMaybeReady pidsFinished pid exceptArray|
"/ must enable interrupts, to be able to get out of a
"/ long wait (especially, to handle sigChild in the meantime)
wasBlocked := OperatingSystem unblockInterrupts.
- OperatingSystem isMSWINDOWSlike ifTrue:[
- "/ temporary kludge - until interface below is implemented in Win32OS
- ControlInterrupt handle:[:ex |
- 'Processor [info]: interrupted in select' infoPrintCR.
- ex reject.
- ] do:[
- fd := OperatingSystem
- selectOnAnyReadable:readFdArray
- writable:writeFdArray
- exception:nil
- withTimeOut:millis.
- ].
- wasBlocked ifTrue:[
- OperatingSystem blockInterrupts.
- ].
-
- (fd isNil or:[fd == #error]) ifTrue:[
- "/ either still nothing to do,
- "/ or error (which should not happen)
-
- err := OperatingSystem lastErrorSymbol.
- err notNil ifTrue:[
- err == #EBADF ifTrue:[
-
- "/ mhmh - one of the fd's given to me is corrupt.
- "/ find out which one .... and remove it
-
- 'Processor [info]: obsolete FD in select - clearing' infoPrintCR.
- OperatingSystem clearLastErrorNumber.
- self removeCorruptedFds
- ] ifFalse:[
- err == #ENOENT ifTrue:[
- 'Processor [warning]: ENOENT in select; rd=' infoPrint.
- readFdArray infoPrint.
- ' wr=' infoPrint.
- writeFdArray infoPrintCR.
- ] ifFalse:[
- "/ 'Processor [warning]: error in select: ' infoPrint. err infoPrintCR.
- ]
- ].
- ]
- ] ifFalse:[
- index := readFdArray identityIndexOf:fd.
- index ~~ 0 ifTrue:[
- sema := readSemaphoreArray at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ^ true
- ].
- action := readCheckArray at:index.
- action notNil ifTrue:[
- action value.
- ^ true
- ]
- ].
- index := writeFdArray identityIndexOf:fd.
- index ~~ 0 ifTrue:[
- sema := writeSemaphoreArray at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ^ true
- ].
- action := writeCheckArray at:index.
- action notNil ifTrue:[
- action value.
- ^ true
- ]
- ]
- ].
- ^ false
- ].
-
newProcessMaybeReady := false.
readableResultFdArray size < readFdArray size ifTrue:[
readableResultFdArray := Array new:(40 max:readFdArray size).
@@ -3071,13 +3139,31 @@
writableResultFdArray := Array new:(40 max:writeFdArray size).
].
+ OperatingSystem isMSWINDOWSlike ifTrue:[
+ "/
+ "/ win32 does a WaitForMultipleObjects in select...
+ "/ unix waits for SIGCHLD
+ "/
+ osChildExitActions keysDo:[:eachPid|
+ eachPid address = 0 ifTrue:[
+ 'Processor: remove 0 handle pid: ' infoPrint. eachPid infoPrintCR.
+ osChildExitActions safeRemoveKey:eachPid.
+ ] ifFalse:[
+ pidsFinished isNil ifTrue:[
+ exceptArray := osChildExitActions keyArray.
+ pidsFinished := Array new:osChildExitActions size.
+ ].
+ ].
+ ].
+ ].
+
nReady := OperatingSystem
selectOnAnyReadable:readFdArray
writable:writeFdArray
- exception:nil
+ exception:exceptArray
readableInto:readableResultFdArray
writableInto:writableResultFdArray
- exceptionInto:nil
+ exceptionInto:pidsFinished
withTimeOut:millis.
wasBlocked ifTrue:[
@@ -3088,14 +3174,10 @@
"/ either still nothing to do,
"/ or error (which should not happen)
- (err := OperatingSystem lastErrorSymbol) notNil ifTrue:[
+ (nReady < 0 and:[(err := OperatingSystem lastErrorSymbol) notNil]) ifTrue:[
err == #EBADF ifTrue:[
-
"/ mhmh - one of the fd's given to me is corrupt.
"/ find out which one .... and remove it
-
- 'Processor [info]: obsolete FD in select - clearing' infoPrintCR.
- OperatingSystem clearLastErrorNumber.
self removeCorruptedFds
] ifFalse:[
err == #ENOENT ifTrue:[
@@ -3116,19 +3198,31 @@
whileTrue:[
index := readFdArray identityIndexOf:fd.
index ~~ 0 ifTrue:[
+ action := readCheckArray at:index.
sema := readSemaphoreArray at:index.
sema notNil ifTrue:[
sema signalOnce.
- newProcessMaybeReady := true
+ newProcessMaybeReady := true.
+ action isNil ifTrue:[
+ "before May 2014 we disabled the sema in the caller after wakeup.
+ This caused ST/X to consume 100% cpu, when the caller didn't read
+ the data (e.g. because his process was stopped)."
+ useIOInterrupts ifTrue:[
+ OperatingSystem disableIOInterruptsOn:fd
+ ].
+ readFdArray at:index put:nil.
+ readSemaphoreArray at:index put:nil.
+ "disable possible write side and timeouts as well"
+ self disableSemaphore:sema.
+ ].
].
- action := readCheckArray at:index.
action notNil ifTrue:[
action value.
newProcessMaybeReady := true
- ]
+ ].
].
nReady := nReady - 1.
- index := index + 1.
+ readyIndex := readyIndex + 1.
].
readyIndex := 1.
@@ -3138,19 +3232,53 @@
whileTrue:[
index := writeFdArray identityIndexOf:fd.
index ~~ 0 ifTrue:[
+ action := writeCheckArray at:index.
sema := writeSemaphoreArray at:index.
sema notNil ifTrue:[
sema signalOnce.
- newProcessMaybeReady := true
+ newProcessMaybeReady := true.
+ action isNil ifTrue:[
+ "now this is a one shot operation - see the input above"
+ useIOInterrupts ifTrue:[
+ OperatingSystem disableIOInterruptsOn:fd
+ ].
+ writeFdArray at:index put:nil.
+ writeSemaphoreArray at:index put:nil.
+ "disable possible read side and timeouts as well"
+ self disableSemaphore:sema.
+ ].
].
- action := writeCheckArray at:index.
action notNil ifTrue:[
action value.
newProcessMaybeReady := true
]
].
nReady := nReady - 1.
- index := index + 1.
+ readyIndex := readyIndex + 1.
+ ].
+
+ exceptArray notNil ifTrue:[
+ "/ only for win32
+ readyIndex := 1.
+ [nReady > 0
+ and:[ readyIndex <= pidsFinished size
+ and:[ (pid := pidsFinished at:readyIndex) notNil ]]]
+ whileTrue:[
+ |osProcessStatus actionBlock|
+"/'pid signaled: ' infoPrint. pid infoPrintCR.
+ actionBlock := osChildExitActions removeKey:pid ifAbsent:nil.
+ osProcessStatus := OperatingSystem childProcessWait:false pid:pid.
+ osProcessStatus notNil ifTrue:[
+ (osProcessStatus pid = pid) ifTrue:[
+ actionBlock notNil ifTrue:[
+ actionBlock value:osProcessStatus.
+ newProcessMaybeReady := true
+ ].
+ ].
+ ].
+ nReady := nReady - 1.
+ readyIndex := readyIndex + 1.
+ ].
].
].
^ newProcessMaybeReady
@@ -3189,51 +3317,69 @@
readFdArray/writeFdArray in the debugger)"
readFdArray keysAndValuesDo:[:idx :fd |
- |rslt sema|
-
- (fd notNil "and:[fd >= 0]") ifTrue:[
- rslt := OperatingSystem
- selectOnAnyReadable:(Array with:fd)
- writable:nil
- exception:nil
- withTimeOut:0.
-
- (rslt == #error or:[rslt isNil and:[OperatingSystem lastErrorSymbol == #EBADF]]) ifTrue:[
- "/ ('Processor [info]: removing invalid read-select fileDescriptor: ' , fd printString) infoPrintCR.
+ |result sema|
+
+ fd notNil ifTrue:[
+ result := OperatingSystem
+ selectOnAnyReadable:(Array with:fd) writable:nil exception:nil
+ readableInto:nil writableInto:nil exceptionInto:nil
+ withTimeOut:0.
+
+ result < 0 ifTrue:[
+ ('Processor [info]: removing invalid read-select fileDescriptor: ' , fd printString) infoPrintCR.
readFdArray at:idx put:nil.
readCheckArray at:idx put:nil.
- OperatingSystem clearLastErrorNumber.
(sema := readSemaphoreArray at:idx) notNil ifTrue:[
readSemaphoreArray at:idx put:nil.
- sema signal.
+ sema signalOnce.
].
]
].
].
writeFdArray keysAndValuesDo:[:idx :fd |
- |rslt sema|
+ |result sema|
fd notNil ifTrue:[
- rslt := OperatingSystem
- selectOnAnyReadable:nil
- writable:(Array with:fd)
- exception:nil
- withTimeOut:0.
-
- (rslt == #error or:[rslt isNil and:[OperatingSystem lastErrorSymbol == #EBADF]]) ifTrue:[
- "/ ('Processor [info]: removing invalid write-select fileDescriptor: ' , fd printString) infoPrintCR.
+ result := OperatingSystem
+ selectOnAnyReadable:(Array with:fd) writable:nil exception:nil
+ readableInto:nil writableInto:nil exceptionInto:nil
+ withTimeOut:0.
+
+ result < 0 ifTrue:[
+ ('Processor [info]: removing invalid write-select fileDescriptor: ' , fd printString) infoPrintCR.
writeFdArray at:idx put:nil.
writeCheckArray at:idx put:nil.
- OperatingSystem clearLastErrorNumber.
(sema := writeSemaphoreArray at:idx) notNil ifTrue:[
writeSemaphoreArray at:idx put:nil.
- sema signal.
+ sema signalOnce.
].
]
]
].
+ OperatingSystem isMSWINDOWSlike ifTrue:[
+ "/
+ "/ win32 does a WaitForMultipleObjects in select...
+ "/ unix waits for SIGCHLD
+ "/
+ osChildExitActions keysDo:[:eachPid |
+ |result sema|
+
+ eachPid notNil ifTrue:[
+ result := OperatingSystem
+ selectOnAnyReadable:nil writable:nil exception:(Array with:eachPid)
+ readableInto:nil writableInto:nil exceptionInto:nil
+ withTimeOut:0.
+
+ result < 0 ifTrue:[
+ ('Processor [info]: removing invalid except-select pid: ' , eachPid printString) infoPrintCR.
+ osChildExitActions safeRemoveKey:eachPid.
+ ]
+ ]
+ ].
+ ].
+
"Modified: 12.4.1996 / 09:32:58 / stefan"
"Modified: 27.1.1997 / 20:09:27 / cg"
!
@@ -3347,19 +3493,21 @@
exitWhenNoMoreUserProcesses ifTrue:[
"/ check if there are any processes at all
"/ stop dispatching if there is none
- "/ (and millis is nil, which means that no timeout blocks are present)
+ "/ (and anyTimeouts is false, which means that no timeout blocks are present)
"/ and no readSemaphores are present (which means that noone is waiting for input)
"/ and no writeSemaphores are present
- anySema := (readSemaphoreArray findFirst:[:sema | sema notNil]) ~~ 0.
- anySema ifFalse:[
- anySema := (writeSemaphoreArray findFirst:[:sema | sema notNil]) ~~ 0.
- ].
- anySema ifFalse:[
- self anyUserProcessAtAll ifFalse:[
- dispatching := false.
- ^ self
- ]
+ anyTimeouts ifFalse:[
+ anySema := (readSemaphoreArray findFirst:[:sema | sema notNil]) ~~ 0.
+ anySema ifFalse:[
+ anySema := (writeSemaphoreArray findFirst:[:sema | sema notNil]) ~~ 0.
+ anySema ifFalse:[
+ self anyUserProcessAtAll ifFalse:[
+ dispatching := false.
+ ^ self
+ ]
+ ].
+ ].
].
].
@@ -3403,11 +3551,11 @@
!ProcessorScheduler class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.277 2013-08-23 11:23:28 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.302 2015-02-04 20:08:53 stefan Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.277 2013-08-23 11:23:28 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.302 2015-02-04 20:08:53 stefan Exp $'
! !