hg/stx-libbasic: comparison ProcessorScheduler.st

equal deleted inserted replaced

-:6dc31fd16564
+:56ec188751e7
 anyUserProcessAtAll
 "return true, if there is any user process still running,
 or waiting on a semaphore.
 This is used to determine if we should stop scheduling
 in standAlone applications.
-A user process has a non-zero processGroup."
+A user process has a non-zero processGroup.
+Should be called with interrupts blocked."
-|listArray l prio "{ Class: SmallInteger }"
-wasBlocked|
+|listArray l prio "{ Class: SmallInteger }"|
 prio := HighestPriority.
-wasBlocked := OperatingSystem blockInterrupts.
 listArray := quiescentProcessLists.
 [prio >= 1] whileTrue:[
-	l := listArray at:prio.
+l := listArray at:prio.
-	l notNil ifTrue:[
+l notNil ifTrue:[
-	    l linksDo:[:aProcess |
+l linksDo:[:aProcess |
-		aProcess isUserProcess ifTrue:[
+aProcess isUserProcess ifTrue:[
-		    wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+^ true.
-		    ^ true.
+]
-		]
+]
-	    ]
+].
-	].
+prio := prio - 1
-	prio := prio - 1
 ].
 "/ any user process waiting on a sema?
 (readSemaphoreArray contains:[:sema |
-	sema notNil and:[sema waitingProcesses contains:[:p | p notNil and:[p isUserProcess] ]]]
+sema notNil and:[sema waitingProcesses contains:[:p | p notNil and:[p isUserProcess] ]]]
 ) ifTrue:[
-	wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+^ true.
-	^ true.
 ].
 (writeSemaphoreArray contains:[:sema |
-	sema notNil and:[sema waitingProcesses contains:[:p | p notNil and:[p isUserProcess] ]]]
+sema notNil and:[sema waitingProcesses contains:[:p | p notNil and:[p isUserProcess] ]]]
 ) ifTrue:[
-	wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+^ true.
-	^ true.
 ].
 (timeoutSemaphoreArray contains:[:sema |
-	sema notNil and:[sema waitingProcesses contains:[:p | p notNil and:[p isUserProcess] ]]]
+sema notNil and:[sema waitingProcesses contains:[:p | p notNil and:[p isUserProcess] ]]]
 ) ifTrue:[
-	wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+^ true.
-	^ true.
 ].
 (timeoutProcessArray contains:[:p | p notNil and:[p isUserProcess] ]
 ) ifTrue:[
-	wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+^ true.
-	^ true.
+].
-].
-wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
 ^ false
 "
 Processor anyUserProcessAtAll
 "
 |pri id l wasBlocked|
 aProcess isNil ifTrue:[^ self].
-'terminate: ' errorPrint. aProcess errorPrintCR.
 aProcess == scheduler ifTrue:[
 InvalidProcessSignal raiseWith:aProcess errorString:'attempt to terminate scheduler'.
 ^ self
 ].
 wasBlocked := OperatingSystem blockInterrupts.
 id := aProcess id.
 id isNil ifTrue:[   "already dead"
+self checkForEndOfDispatch.
 wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-self checkForEndOfDispatch.
 ^ self
 ].
 aProcess setId:nil state:#dead.
 ].
 self unRemember:aProcess.
 zombie := id.
+self checkForEndOfDispatch.
 wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-'checking2' errorPrintCR.
-self checkForEndOfDispatch.
 self threadSwitch:scheduler.
 "not reached"
 ^ self
 ].
 self unRemember:aProcess.
 self class threadDestroy:id.
+self checkForEndOfDispatch.
 wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-'checking3' errorPrintCR.
-self checkForEndOfDispatch.
 "Modified: / 23-09-1996 / 13:50:24 / stefan"
 "Modified: / 20-03-1997 / 16:03:39 / cg"
 "Modified (comment): / 10-08-2011 / 19:57:08 / cg"
 !
 "Modified: 23.9.1996 / 14:34:18 / cg"
 !
 addTimedBlock:aBlock for:aProcess atMilliseconds:aMillisecondTime
-"add the argument, aBlock to the list of time-scheduled-blocks; to be
+"add the argument, aBlock to the list of time-scheduled-blocks;
-evaluated by aProcess when the millisecondClock value passes
+to be evaluated by aProcess when the millisecondClock value passes
 aMillisecondTime.
-If that block is already in the timeout list,
+If that block is already in the timeout list, its trigger-time is changed.
-its trigger-time is changed.
+The process specified by the argument, aProcess
-The process specified by the argument, aProcess will be interrupted
+will be interrupted for execution of the block.
-for execution of the block.
 If aProcess is nil, the block will be evaluated by the scheduler itself
-(which is dangerous - the block should not raise any error conditions).
+(which is dangerous: the block should not raise any error conditions).
 If the process is active at trigger time, the interrupt will occur in
-whatever method it is executing; if suspended at trigger time, it will be
+whatever method it is executing;
-resumed.
+if suspended at trigger time, 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:"
 |index "{ Class: SmallInteger }"
 wasBlocked|
 wasBlocked := OperatingSystem blockInterrupts.
 index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
 index ~~ 0 ifTrue:[
-	timeoutArray at:index put:aMillisecondTime
+timeoutArray at:index put:aMillisecondTime
 ] ifFalse:[
-	index := timeoutArray indexOf:nil.
+index := timeoutArray indexOf:nil.
-	index ~~ 0 ifTrue:[
+index ~~ 0 ifTrue:[
-	    timeoutArray at:index put:aMillisecondTime.
+timeoutArray at:index put:aMillisecondTime.
-	    timeoutActionArray at:index put:aBlock.
+timeoutActionArray at:index put:aBlock.
-	    timeoutSemaphoreArray at:index put:nil.
+timeoutSemaphoreArray at:index put:nil.
-	    timeoutProcessArray at:index put:aProcess
+timeoutProcessArray at:index put:aProcess
-	] ifFalse:[
+] ifFalse:[
-	    timeoutArray := timeoutArray copyWith:aMillisecondTime.
+timeoutArray := timeoutArray copyWith:aMillisecondTime.
-	    timeoutActionArray := timeoutActionArray copyWith:aBlock.
+timeoutActionArray := timeoutActionArray copyWith:aBlock.
-	    timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:nil.
+timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:nil.
-	    timeoutProcessArray := timeoutProcessArray copyWith:aProcess.
+timeoutProcessArray := timeoutProcessArray copyWith:aProcess.
-	    index := timeoutArray size.
+index := timeoutArray size.
-	].
+].
 ].
 anyTimeouts := true.
 wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
 ^ index
 "/ looks ugly, but as this is called very often, reduces idle allocation by a lot.
 now := OperatingSystem getMillisecondTime.
 n := timeoutArray size.
 1 to:n do:[:index |
-	aTime := timeoutArray at:index.
+aTime := timeoutArray at:index.
-	aTime notNil ifTrue:[
+aTime notNil ifTrue:[
-	    (OperatingSystem millisecondTime:now isAfter:aTime) ifTrue:[
+(OperatingSystem millisecondTime:now isAfter:aTime) ifTrue:[
-		"this one should be triggered"
+"this one should be triggered"
-		sema := timeoutSemaphoreArray at:index.
+sema := timeoutSemaphoreArray at:index.
-		sema notNil ifTrue:[
+sema notNil ifTrue:[
-		    timeoutSemaphoreArray at:index put:nil.
+timeoutSemaphoreArray at:index put:nil.
-		    timedActionCounter := (timedActionCounter + 1 bitAnd:SmallInteger maxVal).
+timedActionCounter := (timedActionCounter + 1 bitAnd:SmallInteger maxVal).
-		    sema signalOnce.
+sema signalOnce.
-		] ifFalse:[
+] ifFalse:[
-		    "to support pure-events"
+"to support pure-events"
-		    block := timeoutActionArray at:index.
+block := timeoutActionArray at:index.
-		    block notNil ifTrue:[
+block notNil ifTrue:[
-			"/ usually (>99%), there is only one single timeout action to call;
+"/ usually (>99%), there is only one single timeout action to call;
-			"/ avoid creation of an OrderedCollection
+"/ avoid creation of an OrderedCollection
-			firstBlockToEvaluate isNil ifTrue:[
+firstBlockToEvaluate isNil ifTrue:[
-			    firstBlockToEvaluate := block.
+firstBlockToEvaluate := block.
-			    firstProcess := timeoutProcessArray at:index.
+firstProcess := timeoutProcessArray at:index.
-			] ifFalse:[
+] ifFalse:[
-			    blocksAndProcessesToEvaluate isNil ifTrue:[
+blocksAndProcessesToEvaluate isNil ifTrue:[
-				blocksAndProcessesToEvaluate := OrderedCollection
+blocksAndProcessesToEvaluate := OrderedCollection
-								    with:firstBlockToEvaluate
+with:firstBlockToEvaluate
-								    with:firstProcess.
+with:firstProcess.
-			    ].
+].
-			    blocksAndProcessesToEvaluate add:block.
+blocksAndProcessesToEvaluate add:block.
-			    blocksAndProcessesToEvaluate add:(timeoutProcessArray at:index).
+blocksAndProcessesToEvaluate add:(timeoutProcessArray at:index).
-			].
+].
-			timeoutActionArray at:index put:nil.
+timeoutActionArray at:index put:nil.
-			timeoutProcessArray at:index put:nil.
+timeoutProcessArray at:index put:nil.
-		    ]
+]
-		].
+].
-		timeoutArray at:index put:nil.
+timeoutArray at:index put:nil.
-	    ] ifFalse:[
+] ifFalse:[
-		"there are still pending timeouts"
+"there are still pending timeouts"
-		anyTimeouts := true.
+anyTimeouts := true.
-		indexOfLastTimeout := index.
+indexOfLastTimeout := index.
-	    ]
+]
-	]
+]
 ].
 "shrink the arrays, if they are 50% free"
 n > 20 ifTrue:[
-	halfSize := n // 2.
+halfSize := n // 2.
-	(indexOfLastTimeout ~~ 0 and:[indexOfLastTimeout < halfSize]) ifTrue:[
+(indexOfLastTimeout ~~ 0 and:[indexOfLastTimeout < halfSize]) ifTrue:[
-	    wasBlocked := OperatingSystem blockInterrupts.
+wasBlocked := OperatingSystem blockInterrupts.
-	    (timeoutArray at:indexOfLastTimeout+1) isNil ifTrue:[   "/ no new timeouts arrived
+(timeoutArray at:indexOfLastTimeout+1) isNil ifTrue:[   "/ no new timeouts arrived
-		timeoutArray := timeoutArray copyTo:halfSize.
+timeoutArray := timeoutArray copyTo:halfSize.
-		timeoutSemaphoreArray := timeoutSemaphoreArray copyTo:halfSize.
+timeoutSemaphoreArray := timeoutSemaphoreArray copyTo:halfSize.
-		timeoutActionArray := timeoutActionArray copyTo:halfSize.
+timeoutActionArray := timeoutActionArray copyTo:halfSize.
-		timeoutProcessArray := timeoutProcessArray copyTo:halfSize.
+timeoutProcessArray := timeoutProcessArray copyTo:halfSize.
-	    ].
+].
-	    wasBlocked ifFalse:[ OperatingSystem unblockInterrupts ].
+wasBlocked ifFalse:[ OperatingSystem unblockInterrupts ].
-	].
+].
 ].
 "/ usually (>99%), there is only one single timeout action to call;
 "/ above code avoided the creation of an OrderedCollection
 blocksAndProcessesToEvaluate isNil ifTrue:[
-	firstBlockToEvaluate notNil ifTrue:[
+firstBlockToEvaluate notNil ifTrue:[
-	    timedActionCounter := (timedActionCounter + 1 bitAnd:SmallInteger maxVal).
+timedActionCounter := (timedActionCounter + 1 bitAnd:SmallInteger maxVal).
-	    (firstProcess isNil or:[firstProcess == scheduler or:[PureEventDriven]]) ifTrue:[
+(firstProcess isNil or:[firstProcess == scheduler or:[PureEventDriven]]) ifTrue:[
-		firstBlockToEvaluate value
+firstBlockToEvaluate value
-	    ] ifFalse:[
+] ifFalse:[
-		firstProcess isDead ifTrue:[
+firstProcess isDead ifTrue:[
-		    "/ a timedBlock for a process which has already terminated
+"/ a timedBlock for a process which has already terminated
-		    "/ issue a warning and do not execute it.
+"/ issue a warning and do not execute it.
-		    "/ (exeuting here may be dangerous, since it would run at scheduler priority here,
+"/ (executing here may be dangerous, since it would run at scheduler priority here,
-		    "/  and thereby could block the whole smalltalk system.
+"/  and thereby could block the whole smalltalk system.
-		    "/  For this reason is it IGNORED here.)
+"/  For this reason is it IGNORED here.)
-"/ Could handle it in timeoutProcess, but we don't,
-"/ because otherwise timeouts might be reissued forever...
+"/ Could handle it in timeoutProcess, but we don't,
-"/                    (timeoutHandlerProcess notNil and:[timeoutHandlerProcess isDead not]) ifTrue:[
+"/ because otherwise timeouts might be reissued forever...
-"/                        timeoutHandlerProcess interruptWith:block.
+"/      (timeoutHandlerProcess notNil and:[timeoutHandlerProcess isDead not]) ifTrue:[
-"/                    ] ifFalse:[
+"/          timeoutHandlerProcess interruptWith:block.
-			('ProcessorScheduler [warning]: cannot evaluate timedBlock (', firstBlockToEvaluate displayString, ') for dead process: ''' , firstProcess name , '''') infoPrintCR.
+"/      ] ifFalse:[
-"/                    ].
+('ProcessorScheduler [warning]: cannot evaluate timedBlock (', firstBlockToEvaluate displayString, ') for dead process: ''' , firstProcess name , '''') infoPrintCR.
-		] ifFalse:[
+"/      ].
-		    firstProcess interruptWith:firstBlockToEvaluate
+] ifFalse:[
-		]
+firstProcess interruptWith:firstBlockToEvaluate
-	    ]
+]
-	].
+]
+].
 ] ifFalse:[
-	n := blocksAndProcessesToEvaluate size.
+n := blocksAndProcessesToEvaluate size.
-	1 to:n by:2 do:[:index |
+1 to:n by:2 do:[:index |
-	    block := blocksAndProcessesToEvaluate at:index.
+block := blocksAndProcessesToEvaluate at:index.
-	    p := blocksAndProcessesToEvaluate at:index+1.
+p := blocksAndProcessesToEvaluate at:index+1.
-	    (p isNil or:[p == scheduler or:[PureEventDriven]]) ifTrue:[
+(p isNil or:[p == scheduler or:[PureEventDriven]]) ifTrue:[
-		block value.
+block value.
-		timedActionCounter := (timedActionCounter + 1 bitAnd:SmallInteger maxVal).
+timedActionCounter := (timedActionCounter + 1 bitAnd:SmallInteger maxVal).
-	    ] ifFalse:[
+] ifFalse:[
-		p isDead ifTrue:[
+p isDead ifTrue:[
-		    "/ a timedBlock for a process which has already terminated
+"/ a timedBlock for a process which has already terminated
-		    "/ issue a warning and do not execute it.
+"/ issue a warning and do not execute it.
-		    "/ (exeuting here may be dangerous, since it would run at scheduler priority here,
+"/ (executing here may be dangerous, since it would run at scheduler priority here,
-		    "/  and thereby could block the whole smalltalk system.
+"/  and thereby could block the whole smalltalk system.
-		    "/  For this reason is it IGNORED here.)
+"/  For this reason is it IGNORED here.)
-"/ Could handle it in timeoutProcess, but we don't,
-"/ because otherwise timeouts might be reissued forever...
+"/ Could handle it in timeoutProcess, but we don't,
-"/                    (timeoutHandlerProcess notNil and:[timeoutHandlerProcess isDead not]) ifTrue:[
+"/ because otherwise timeouts might be reissued forever...
-"/                        timeoutHandlerProcess interruptWith:block.
+"/      (timeoutHandlerProcess notNil and:[timeoutHandlerProcess isDead not]) ifTrue:[
-"/                    ] ifFalse:[
+"/          timeoutHandlerProcess interruptWith:block.
-			('ProcessorScheduler [warning]: cannot evaluate timedBlock (', block displayString, ') for dead process: ''' , p name , '''') infoPrintCR.
+"/      ] ifFalse:[
-"/                    ].
+('ProcessorScheduler [warning]: cannot evaluate timedBlock (', block displayString, ') for dead process: ''' , p name , '''') infoPrintCR.
-		] ifFalse:[
+"/      ].
-		    timedActionCounter := (timedActionCounter + 1 bitAnd:SmallInteger maxVal).
+] ifFalse:[
-		    p interruptWith:block
+timedActionCounter := (timedActionCounter + 1 bitAnd:SmallInteger maxVal).
-		]
+p interruptWith:block
-	    ]
+]
-	]
+]
+]
 ].
 "Modified: / 30-07-2013 / 19:33:24 / cg"
 !
 wasBlocked|
 wasBlocked := OperatingSystem blockInterrupts.
 index := 0.
-[index := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:index+1.
+[
-index ~~ 0] whileTrue:[
+index := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:index+1.
-	timeoutArray at:index put:nil.
+index ~~ 0
-	timeoutSemaphoreArray at:index put:nil.
+] whileTrue:[
-	timeoutActionArray at:index put:nil.
+timeoutArray at:index put:nil.
-	timeoutProcessArray at:index put:nil.
+timeoutSemaphoreArray at:index put:nil.
+timeoutActionArray at:index put:nil.
+timeoutProcessArray at:index put:nil.
 ].
 wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
 !
 ! !
 !ProcessorScheduler methodsFor:'waiting'!
 checkForEndOfDispatch
+|wasBlocked|
 exitWhenNoMoreUserProcesses ifTrue:[
 "/ check if there are any processes at all
 "/ stop dispatching if there is none
 "/ (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
-self noMoreUserProcesses ifTrue:[
+wasBlocked := OperatingSystem blockInterrupts.
-'end of dispatch' errorPrintCR.
+self anyUserProcessAtAll ifFalse:[
+'end of dispatch' errorPrintCR.
 dispatching := false.
-^ self
 ].
+wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
 ].
 !
 checkForIOWithTimeout:millis
 "this is called, when there is absolutely nothing to do;
 "Modified: 21.12.1995 / 16:17:40 / stefan"
 "Modified: 4.8.1997 / 14:23:08 / cg"
 !
-noMoreUserProcesses
-"/ check if there are any processes at all
-"/ stop dispatching if there is none
-"/ (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
-anyTimeouts ifFalse:[
-^ self anyUserProcessAtAll not.
-].
-^ false
-"/    |anySema|
-"/
-"/
-"/    anyTimeouts ifFalse:[
-"/        anySema := (readSemaphoreArray findFirst:[:sema | sema notNil]) ~~ 0.
-"/        anySema ifFalse:[
-"/            anySema := (writeSemaphoreArray findFirst:[:sema | sema notNil]) ~~ 0.
-"/            anySema ifFalse:[
-"/                self anyUserProcessAtAll ifFalse:[
-"/                    ^ true
-"/                ]
-"/            ].
-"/        ].
-"/    ].
-"/    ^ false
-"
-Processor noMoreUserProcesses
-"
-!
 removeCorruptedFds
 "this is sent when select returns an error due to some invalid
 fileDescriptor. May happen, if someone does a readWait/writeWait on a
 socket connection, which somehow got corrupted
 (shutdown by partner, or closed by another thread, while being in a read/write-wait).

changeset 20736	56ec188751e7
parent 20726	2736c31593ec
child 20745	2f29774fd342