--- a/ProcessorScheduler.st Thu Dec 07 22:24:46 1995 +0100
+++ b/ProcessorScheduler.st Thu Dec 07 22:32:39 1995 +0100
@@ -11,28 +11,18 @@
"
Object subclass:#ProcessorScheduler
- instanceVariableNames:'quiescentProcessLists scheduler
- zombie
- activeProcess currentPriority
- readFdArray readSemaphoreArray readCheckArray
- writeFdArray writeSemaphoreArray
- timeoutArray timeoutActionArray timeoutProcessArray timeoutSemaphoreArray
- idleActions anyTimeouts dispatching interruptedProcess
- useIOInterrupts'
- classVariableNames:'KnownProcesses KnownProcessIds
- PureEventDriven
- UserSchedulingPriority
- UserInterruptPriority
- TimingPriority
- HighestPriority
- SchedulingPriority
- MaxNumberOfProcesses'
+ instanceVariableNames:'quiescentProcessLists scheduler zombie activeProcess
+ currentPriority readFdArray readSemaphoreArray readCheckArray
+ writeFdArray writeSemaphoreArray timeoutArray timeoutActionArray
+ timeoutProcessArray timeoutSemaphoreArray idleActions anyTimeouts
+ dispatching interruptedProcess useIOInterrupts'
+ classVariableNames:'KnownProcesses KnownProcessIds PureEventDriven
+ UserSchedulingPriority UserInterruptPriority TimingPriority
+ HighestPriority SchedulingPriority MaxNumberOfProcesses'
poolDictionaries:''
category:'Kernel-Processes'
!
-Smalltalk at:#Processor put:nil!
-
!ProcessorScheduler class methodsFor:'documentation'!
copyright
@@ -49,10 +39,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.52 1995-11-24 19:19:45 cg Exp $'
-!
-
documentation
"
This class has only one instance, which is bound to the global
@@ -192,85 +178,8 @@
]
! !
-!ProcessorScheduler class methodsFor:'queries'!
-
-isPureEventDriven
- "this is temporary - (maybe not :-).
- you can run ST/X either with or without processes.
- Without, there is conceptionally a single process handling all
- outside events and timeouts. This has some negative implications
- (Debugger is ugly), but allows a fully portable ST/X without any
- assembler support - i.e. quick portability.
- The PureEvent flag will automatically be set if the runtime system
- does not support threads - otherwise, it can be set manually
- (from rc-file).
- "
-
- ^ PureEventDriven
-!
-
-pureEventDriven
- "turn on pure-event driven mode - no processes, single dispatch loop"
-
- PureEventDriven := true
-!
-
-processDriven
- "turn on process driven mode"
-
- PureEventDriven := false
-!
-
-knownProcesses
- "return a collection of all (living) processes in the system"
-
- ^ KnownProcesses select:[:p | p notNil]
-!
-
-maxNumberOfProcesses
- "return the limit on the number of processes;
- the default is nil (i.e. unlimited)."
-
- ^ MaxNumberOfProcesses
-!
-
-maxNumberOfProcesses:aNumber
- "set the limit on the number of processes.
- This helps if you have a program which (by error) creates countless
- subprocesses. Without this limit, you may have a hard time to find
- this error (and repairing it). If nil (the default), the number of
- processes is unlimited."
-
- MaxNumberOfProcesses := aNumber
-! !
-
!ProcessorScheduler class methodsFor:'primitive process primitives'!
-threadsAvailable
- "return true, if the runtime system supports threads (i.e. processes);
- false otherwise."
-
-%{ /* NOCONTEXT */
- extern OBJ __threadsAvailable();
-
- RETURN (__threadsAvailable());
-%}
-!
-
-threadInterrupt:id
- "make the process evaluate an interrupt. This sets a flag in the VMs
- threadSwitcher, to let the process perform a #interrupt when its set to
- run the next time. The process itself can decide how to react on this
- interrupt (currently, it looks for interruptBlocks to evaluate)."
-
-%{ /* NOCONTEXT */
-
- if (__isSmallInteger(id)) {
- __threadInterrupt(_intVal(id));
- }
-%}
-!
-
threadCreate:aProcess withId:id
"physical creation of a process.
(warning: low level entry, no administration done).
@@ -322,656 +231,123 @@
__threadDestroy(_intVal(id));
}
%}
+!
+
+threadInterrupt:id
+ "make the process evaluate an interrupt. This sets a flag in the VMs
+ threadSwitcher, to let the process perform a #interrupt when its set to
+ run the next time. The process itself can decide how to react on this
+ interrupt (currently, it looks for interruptBlocks to evaluate)."
+
+%{ /* NOCONTEXT */
+
+ if (__isSmallInteger(id)) {
+ __threadInterrupt(_intVal(id));
+ }
+%}
+!
+
+threadsAvailable
+ "return true, if the runtime system supports threads (i.e. processes);
+ false otherwise."
+
+%{ /* NOCONTEXT */
+ extern OBJ __threadsAvailable();
+
+ RETURN (__threadsAvailable());
+%}
! !
-!ProcessorScheduler methodsFor:'primitive process primitives'!
+!ProcessorScheduler class methodsFor:'queries'!
+
+isPureEventDriven
+ "this is temporary - (maybe not :-).
+ you can run ST/X either with or without processes.
+ Without, there is conceptionally a single process handling all
+ outside events and timeouts. This has some negative implications
+ (Debugger is ugly), but allows a fully portable ST/X without any
+ assembler support - i.e. quick portability.
+ The PureEvent flag will automatically be set if the runtime system
+ does not support threads - otherwise, it can be set manually
+ (from rc-file).
+ "
+
+ ^ PureEventDriven
+!
+
+knownProcesses
+ "return a collection of all (living) processes in the system"
+
+ ^ KnownProcesses select:[:p | p notNil]
+!
+
+maxNumberOfProcesses
+ "return the limit on the number of processes;
+ the default is nil (i.e. unlimited)."
+
+ ^ MaxNumberOfProcesses
+!
-threadSwitch:aProcess
- "continue execution in aProcess.
- (warning: low level entry, no administration is done here)"
+maxNumberOfProcesses:aNumber
+ "set the limit on the number of processes.
+ This helps if you have a program which (by error) creates countless
+ subprocesses. Without this limit, you may have a hard time to find
+ this error (and repairing it). If nil (the default), the number of
+ processes is unlimited."
+
+ MaxNumberOfProcesses := aNumber
+!
+
+processDriven
+ "turn on process driven mode"
- |id pri ok oldProcess oldPri p singleStep wasBlocked|
+ PureEventDriven := false
+!
+
+pureEventDriven
+ "turn on pure-event driven mode - no processes, single dispatch loop"
+
+ PureEventDriven := true
+! !
- (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+!ProcessorScheduler methodsFor:'I/O event actions'!
+
+disableFd:aFileDescriptor
+ "disable block events on aFileDescriptor.
+ This is a leftover support for pure-event systems and may vanish."
+
+ |idx "{Class: SmallInteger }"
+ wasBlocked|
wasBlocked := OperatingSystem blockInterrupts.
-
- oldProcess := activeProcess.
- oldPri := currentPriority.
-
- id := aProcess id.
- pri := aProcess priority.
- singleStep := aProcess isSingleStepping.
- aProcess state:#active.
- oldProcess setStateTo:#run if:#active.
-
- "
- no interrupts now - activeProcess has already been changed
- (dont add any message sends here)
- "
- activeProcess := aProcess.
- currentPriority := pri.
-%{
- extern OBJ ___threadSwitch();
-
- if (__isSmallInteger(id)) {
- ok = ___threadSwitch(__context, _intVal(id), (singleStep == true) ? 1 : 0);
- } else {
- ok = false;
- }
-%}.
- "time passes spent in some other process ...
- ... here again"
-
- p := activeProcess.
- activeProcess := oldProcess.
- currentPriority := oldProcess priority.
-
- ok ifFalse:[
- "
- switch failed for some reason -
- destroy the bad process
- "
- p id ~~ 0 ifTrue:[
- 'SCHEDULER: problem with process ' errorPrint.
- p id errorPrint.
- p name notNil ifTrue:[
- ' (' errorPrint. p name errorPrint. ')' errorPrint.
- ].
- '; hard-terminate it.' errorPrintNL.
- p state:#suspended.
- self terminateNoSignal:p.
- ]
- ].
- zombie notNil ifTrue:[
- self class threadDestroy:zombie.
- zombie := nil
+ idx := readFdArray identityIndexOf:aFileDescriptor startingAt:1.
+ idx ~~ 0 ifTrue:[
+ readFdArray at:idx put:nil.
+ readCheckArray at:idx put:nil.
+ readSemaphoreArray at:idx put:nil
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
-scheduleForInterrupt:aProcess
- "make aProcess evaluate its pushed interrupt block(s)"
-
- |id|
-
- aProcess isNil ifTrue:[^ self].
- aProcess == activeProcess ifTrue:[^ self].
-
- id := aProcess id.
- self class threadInterrupt:id.
- "
- and, make the process runnable
- "
- aProcess state ~~ #stopped ifTrue:[
- "
- and, make the process runnable
- "
- aProcess resume
- ]
-! !
-
-!ProcessorScheduler methodsFor:'constants'!
-
-lowestPriority
- "return the lowest priority value"
-
- ^ 1 "do not change this - its not variable"
-!
-
-highestPriority
- "return the highest priority value (normal) processes can have."
-
- "must be below schedulingPriority -
- otherwise scheduler could be blocked ...
- "
- ^ HighestPriority
-!
-
-schedulingPriority
- "return the priority at which the scheduler runs."
-
- "must be above highestPriority -
- otherwise scheduler could be blocked ...
- "
- ^ SchedulingPriority
-!
-
-userInterruptPriority
- "return the priority, at which the event scheduler runs - i.e.
- all processes running at a lower priority are interruptable by Cntl-C
- or the timer. Processes running at higher prio will not be interrupted."
-
- ^ UserInterruptPriority
-!
-
-timingPriority
- "return the priority, at which all timing takes place (messageTally,
- delay etc.)"
-
- ^ TimingPriority
-!
-
-userSchedulingPriority
- "return the priority, at which all normal user (interactive) processing
- takes place"
-
- ^ UserSchedulingPriority
-!
-
-userBackgroundPriority
- "return the priority, at which background user (non-interactive) processing
- should take place.
- Not currently used - for ST80 compatibility only"
-
- ^ 6
-!
-
-systemBackgroundPriority
- "return the priority, at which background system processing
- should take place.
- Not currently used - for ST80 compatibility only"
-
- ^ 4
-!
-
-lowIOPriority
- "not currently used - for ST80 compatibility only"
-
- ^ 2 "claus: is this ok ?"
-! !
-
-!ProcessorScheduler methodsFor:'private initializing'!
-
-initialize
- "initialize the one-and-only ProcessorScheduler"
-
- |nPrios "{ Class: SmallInteger }"
- l p|
-
- KnownProcesses isNil ifTrue:[
- KnownProcesses := WeakArray new:10.
- KnownProcesses watcher:self class.
- KnownProcessIds := OrderedCollection new.
- ].
-
- "
- create a collection with process lists; accessed using the priority as key
- "
- nPrios := SchedulingPriority.
- quiescentProcessLists := Array new:nPrios.
- 1 to:nPrios do:[:pri |
- quiescentProcessLists at:pri put:(LinkedList new)
- ].
+enableIOAction:aBlock onInput:aFileDescriptor
+ "half-obsolete event support: arrange for aBlock to be
+ evaluated when input on aFileDescriptor arrives.
+ This is a leftover support for pure-event systems and may vanish."
- readFdArray := Array with:nil.
- readCheckArray := Array with:nil.
- readSemaphoreArray := Array with:nil.
- writeFdArray := Array with:nil.
- writeSemaphoreArray := Array with:nil.
- timeoutArray := Array with:nil.
- timeoutSemaphoreArray := Array with:nil.
- timeoutActionArray := Array with:nil.
- timeoutProcessArray := Array with:nil.
- anyTimeouts := false.
- dispatching := false.
- useIOInterrupts := OperatingSystem supportsIOInterrupts.
-
- "
- handcraft the first (dispatcher-) process - this one will never
- block, but go into a select if there is nothing to do.
- Also, it has a prio of max+1 - thus, it comes first when looking
- for a runnable process.
- "
- currentPriority := SchedulingPriority.
- p := Process new.
- p setId:0 state:#run.
- p setPriority:currentPriority.
- p name:'scheduler'.
-
- scheduler := activeProcess := p.
-
- (quiescentProcessLists at:currentPriority) add:p.
-
- "
- let me handle IO and timer interrupts
- "
- ObjectMemory ioInterruptHandler:self.
- ObjectMemory timerInterruptHandler:self.
-!
-
-reinitialize
- "all previous processes (except those marked as restartable) are made dead
- - each object should reinstall its process(s) upon restart;
- especially, windowgroups have to.
- In contrast to ST-80, restartable processes are restarted at the beginning
- NOT continued where left. This is a consequence of the portable implementation
- of ST/X, since in order to continue a process, we needed to know the
- internals of the machines (and C-compilers) stack layout.
- This was not done, favouring portability for process continuation.
- In praxis, this is not much of a problem, since in almost every case,
- the computation state can be saved in some object, and processing be
- restarted from scratch, reinitializing things from this saved state."
-
- |processesToRestart|
-
- "
- lay all processes to rest, collect restartable ones
- "
- processesToRestart := OrderedCollection new.
- KnownProcesses do:[:p |
- p notNil ifTrue:[
- "how, exactly should this be done ?"
-
- p isRestartable == true ifTrue:[
- p nextLink:nil.
- processesToRestart add:p
- ] ifFalse:[
- p setId:nil state:#dead
- ]
- ].
- ].
- scheduler setId:nil state:#dead.
-
- "
- now, start from scratch
- "
- KnownProcesses := nil.
- self initialize.
-
- "
- ... and restart those that can be.
- "
- processesToRestart do:[:p |
-"/ 'process restart not implemented' errorPrintNL.
- p restart
- ]
-! !
-
-!ProcessorScheduler methodsFor:'private'!
-
-remember:aProcess
- "remember aProcess for later disposal (where the underlying
- system resources have to be freed)."
-
- |newShadow oldId wasBlocked
- oldSize "{ Class: SmallInteger }"
- index "{ Class: SmallInteger }"
- sz "{ Class: SmallInteger }" |
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := 1.
- sz := KnownProcessIds size.
- [index <= sz] whileTrue:[
- (KnownProcesses at:index) isNil ifTrue:[
- oldId := KnownProcessIds at:index.
- oldId notNil ifTrue:[
- self class threadDestroy:oldId.
- ].
- KnownProcesses at:index put:aProcess.
- KnownProcessIds at:index put:aProcess id.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ].
- index := index + 1
- ].
-
- KnownProcessIds grow:index.
- KnownProcessIds at:index put:aProcess id.
-
- oldSize := KnownProcesses size.
- (index > oldSize) ifTrue:[
- newShadow := WeakArray new:(oldSize * 2).
- newShadow watcher:self class.
- newShadow replaceFrom:1 with:KnownProcesses.
- KnownProcesses := newShadow
- ].
- KnownProcesses at:index put:aProcess.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-unRemember:aProcess
- "forget aProcess - dispose processing will not consider this one"
-
- |index wasBlocked|
+ |idx "{Class: SmallInteger }"
+ wasBlocked|
wasBlocked := OperatingSystem blockInterrupts.
- index := KnownProcesses identityIndexOf:aProcess.
- index ~~ 0 ifTrue:[
- KnownProcessIds at:index put:nil.
- KnownProcesses at:index put:nil.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-! !
-
-!ProcessorScheduler methodsFor:'process creation'!
-
-newProcessFor:aProcess withId:idWant
- "private entry for Process restart - do not use in your program"
-
- (self class threadCreate:aProcess withId:idWant) ~~ idWant ifTrue:[
- ^ false
- ].
-
- aProcess state:#light. "meaning: has no stack yet"
- self remember:aProcess.
- ^ true
-!
-
-newProcessFor:aProcess
- "create a physical (VM-) process for aProcess.
- Return true if ok, false if something went wrong.
- The process is not scheduled; to start it running,
- it needs a Process>>resume. Once resumed, the process will later
- get control in its #start method."
-
- |id|
-
- id := self class threadCreate:aProcess withId:nil.
- id isNil ifTrue:[^ false].
-
- aProcess setId:id state:#light. "meaning: has no stack yet"
- self remember:aProcess.
- ^ true
-! !
-
-!ProcessorScheduler methodsFor:'scheduling'!
-
-reschedule
- "switch to the highest prio runnable process.
- The scheduler itself is always runnable, so we can do an unconditional switch
- to that one. This method is a historical left-over and will vanish."
-
- ^ self threadSwitch:scheduler
-!
-
-yield
- "move the currently running process to the end of the currentList
- and reschedule to the first in the list, thus switching to the
- next same-prio-process."
-
- |l wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- "
- debugging consistency check - will be removed later
- "
- activeProcess priority ~~ currentPriority ifTrue:[
- 'oops process changed priority' errorPrintNL.
- currentPriority := activeProcess priority.
- ].
-
- l := quiescentProcessLists at:currentPriority.
-
- "
- debugging consistency checks - will be removed later
- "
- l isEmpty ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - empty runnable list' errorPrintNL.
- ^ self
- ].
-
- "
- check if the running process is not the only one
- "
- l size ~~ 1 ifTrue:[
- "
- bring running process to the end
- "
- l removeFirst.
- l addLast:activeProcess.
-
- "
- and switch to first in the list
- "
- self threadSwitch:(l first).
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-suspend:aProcess
- "remove the argument, aProcess from the list of runnable processes.
- If the process is the current one, reschedule."
-
- |pri l p wasBlocked|
-
- "
- some debugging stuff
- "
- aProcess isNil ifTrue:[
- MiniDebugger enterWithMessage:'nil suspend'.
- ^ self
- ].
- aProcess id isNil ifTrue:[
- MiniDebugger enterWithMessage:'bad suspend: already dead'.
- self threadSwitch:scheduler.
- ^ self
- ].
- aProcess == scheduler ifTrue:[
- 'scheduler should never be suspended' errorPrintNL.
- MiniDebugger enterWithMessage:'scheduler should never be suspended'.
- ^ self
- ].
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- pri := aProcess priority.
- l := quiescentProcessLists at:pri.
-
- "notice: this is slightly faster than putting the if-code into
- the ifAbsent block, because [] is a shared cheap block
- "
- (l remove:aProcess ifAbsent:[]) isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'bad suspend: not on run list' errorPrintNL.
- "/ MiniDebugger enterWithMessage:'bad suspend: not on run list'.
- self threadSwitch:scheduler.
- ^ self
- ].
-
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- "
- this is a bit of a kludge: allow someone else to
- set the state to something like #ioWait etc.
- In this case, do not set to #suspend.
- All of this to enhance the output of the process monitor ...
- "
- aProcess setStateTo:#suspended if:#active or:#run.
-
- (aProcess == activeProcess) ifTrue:[
- "we can immediately switch sometimes"
- l notEmpty ifTrue:[
- p := l first
+ (readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
+ idx := readFdArray identityIndexOf:nil startingAt:1.
+ idx ~~ 0 ifTrue:[
+ readFdArray at:idx put:aFileDescriptor.
+ readCheckArray at:idx put:aBlock.
+ readSemaphoreArray at:idx put:nil
] ifFalse:[
- p := scheduler
- ].
- self threadSwitch:p
- ].
-!
-
-resume:aProcess
- "set aProcess runnable -
- if its prio is higher than the currently running prio, switch to it."
-
- |l pri wasBlocked|
-
- (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
-
- "ignore, if process is already dead"
- aProcess id isNil ifTrue:[^ self].
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- pri := aProcess priority.
-
- l := quiescentProcessLists at:pri.
- "if already running, ignore"
- (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ].
- l addLast:aProcess.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- (pri > currentPriority) ifTrue:[
- "
- its prio is higher; immediately transfer control to it
- "
- self threadSwitch:aProcess
- ] ifFalse:[
- "
- its prio is lower; it will have to wait for a while ...
- "
- aProcess state:#run
- ]
-!
-
-resumeForSingleSend:aProcess
- "like resume, but let the process execute a single send only.
- This will be used by the (new, not yet released) debugger
- for single stepping."
-
- (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
- aProcess singleStep:true.
- self resume:aProcess
-!
-
-terminateNoSignal:aProcess
- "hard terminate aProcess without sending the terminate signal, thus
- no unwind blocks or exitAction are performed in the process..
- If its not the current process, it is simply removed from its list
- and physically destroyed. Otherwise (since we can't take away the chair
- we are sitting on), a switch is forced and the process
- will be physically destroyed by the next running process.
- (see zombie handling)"
-
- |pri id l wasBlocked|
-
- aProcess isNil ifTrue:[^ self].
- id := aProcess id.
- id isNil ifTrue:[^ self]. "already dead"
-
- aProcess setId:nil state:#dead.
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- "remove the process from the runnable list"
-
- pri := aProcess priority.
- l := quiescentProcessLists at:pri.
- (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
- l remove:aProcess.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-
- aProcess == activeProcess ifTrue:[
- "
- hard case - its the currently running process
- we must have the next active process destroy this one
- (we cannot destroy the chair we are sitting on ... :-)
- "
- zombie := id.
- self unRemember:aProcess.
- self threadSwitch:scheduler.
- "not reached"
- ^ self
- ].
- self class threadDestroy:id.
- self unRemember:aProcess.
- ^ self
-!
-
-terminateActiveNoSignal
- "hard terminate the active process, without sending any
- terminate signal thus no unwind blocks are evaluated."
-
- self terminateNoSignal:activeProcess
-!
-
-processTermination
- "sent by VM if the current process finished its startup block
- without proper process termination. Lay him to rest now.
- This can only happen, if something went wrong in Block>>newProcess,
- since the block defined there always terminates itself."
-
- self terminateNoSignal:activeProcess.
- self threadSwitch:scheduler
-!
-
-terminate:aProcess
- "terminate aProcess. This is donen by sending aProcess the terminateSignal,
- which will evaluate any unwind blocks and finally do a hard terminate."
-
- aProcess terminate
-!
-
-terminateActive
- "terminate the current process (i.e. the running process kills itself).
- The active process is sent the terminateSignal so it will evaluate any
- unwind blocks and finally do a hard terminate.
- This is sent for regular termination and by the VM, if the hard-stack limit
- is reached. (i.e. a process did not repair things in a recursionInterrupt and
- continued to grow its stack)"
-
- activeProcess terminate
-!
-
-interruptActive
- "interrupt the current process"
-
- activeProcess interrupt
-!
-
-changePriority:prio for:aProcess
- "change the priority of aProcess"
-
- |oldList newList oldPrio newPrio wasBlocked|
-
- oldPrio := aProcess priority.
- oldPrio == prio ifTrue:[^ self].
-
- "
- check for valid argument
- "
- newPrio := prio.
- newPrio < 1 ifTrue:[
- newPrio := 1.
- ] ifFalse:[
- aProcess == scheduler ifTrue:[^ self].
- newPrio > HighestPriority ifTrue:[
- newPrio := HighestPriority
- ]
- ].
-
- wasBlocked := OperatingSystem blockInterrupts.
-
- aProcess setPriority:newPrio.
-
- oldList := quiescentProcessLists at:oldPrio.
- (oldList identityIndexOf:aProcess) == 0 ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ].
-
- oldList remove:aProcess.
-
- newList := quiescentProcessLists at:newPrio.
- newList addLast:aProcess.
-
- "if its the current process lowering its prio
- or another one raising, we have to reschedule"
-
- aProcess == activeProcess ifTrue:[
- currentPriority := newPrio.
- newPrio < oldPrio ifTrue:[
- self threadSwitch:scheduler.
- ]
- ] ifFalse:[
- newPrio > currentPriority ifTrue:[
- self threadSwitch:aProcess.
+ readFdArray := readFdArray copyWith:aFileDescriptor.
+ readCheckArray := readCheckArray copyWith:aBlock.
+ readSemaphoreArray := readSemaphoreArray copyWith:nil.
]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -979,14 +355,6 @@
!ProcessorScheduler methodsFor:'accessing'!
-currentPriority
- "return the priority of the currently running process"
-
- ^ currentPriority
-
- "Processor currentPriority"
-!
-
activePriority
"return the priority of the currently running process.
GNU-ST & ST-80 compatibility; this is the same as currentPriority"
@@ -1002,92 +370,127 @@
"Processor activeProcess"
!
+currentPriority
+ "return the priority of the currently running process"
+
+ ^ currentPriority
+
+ "Processor currentPriority"
+!
+
interruptedProcess
"returns the process which was interrupted by the active one"
^ interruptedProcess
! !
-!ProcessorScheduler methodsFor:'queries'!
+!ProcessorScheduler methodsFor:'background processing'!
-highestPriorityRunnableProcess
- "return the highest prio runnable process"
+addIdleBlock:aBlock
+ "add the argument, aBlock to the list of idle-actions.
+ Idle blocks are evaluated whenever no other process is runnable,
+ and no events are pending.
+ Use of idle blocks is not recommended, use a low priority processes
+ instead, which has the same effect. Idle blcoks are still included
+ to support background actions in pure-event systems, where no processes
+ are available.
+ Support for idle-blocks may vanish."
- |listArray l p prio "{ Class: SmallInteger }" |
+ |wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ idleActions isNil ifTrue:[
+ idleActions := OrderedCollection new
+ ].
+ idleActions add:aBlock.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
- prio := HighestPriority.
- listArray := quiescentProcessLists.
- [prio >= 1] whileTrue:[
- l := listArray at:prio.
- l notEmpty ifTrue:[
- p := l first.
- "
- if it got corrupted somehow ...
- "
- p id isNil ifTrue:[
- 'process with nil id removed' errorPrintNL.
- l removeFirst.
- ^ nil.
- ].
- ^ p
- ].
- prio := prio - 1
+removeIdleBlock:aBlock
+ "remove the argument, aBlock from the list of idle-blocks.
+ Support for idle-blocks may vanish - use low prio processes instead."
+
+ |wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ idleActions notNil ifTrue:[
+ idleActions remove:aBlock
].
- ^ nil
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'constants'!
+
+highestPriority
+ "return the highest priority value (normal) processes can have."
+
+ "must be below schedulingPriority -
+ otherwise scheduler could be blocked ...
+ "
+ ^ HighestPriority
+!
+
+lowIOPriority
+ "not currently used - for ST80 compatibility only"
+
+ ^ 2 "claus: is this ok ?"
!
-isSystemProcess:aProcess
- "return true if aProcess is a system process,
- which should not be suspended/terminated etc.."
+lowestPriority
+ "return the lowest priority value"
+
+ ^ 1 "do not change this - its not variable"
+!
+
+schedulingPriority
+ "return the priority at which the scheduler runs."
- (self class isPureEventDriven
- or:[aProcess id == 0
- or:[(Display notNil and:[Display dispatchProcess == aProcess])
- " nameOrId endsWith:'dispatcher' "
- ]]) ifTrue:[
- ^ true
- ].
- ^ false
+ "must be above highestPriority -
+ otherwise scheduler could be blocked ...
+ "
+ ^ SchedulingPriority
+!
- "
- Processor activeProcessIsSystemProcess
- "
+systemBackgroundPriority
+ "return the priority, at which background system processing
+ should take place.
+ Not currently used - for ST80 compatibility only"
+
+ ^ 4
!
-activeProcessIsSystemProcess
- "return true if the active process is a system process,
- which should not be suspended."
+timingPriority
+ "return the priority, at which all timing takes place (messageTally,
+ delay etc.)"
+
+ ^ TimingPriority
+!
+
+userBackgroundPriority
+ "return the priority, at which background user (non-interactive) processing
+ should take place.
+ Not currently used - for ST80 compatibility only"
- ^ self isSystemProcess:activeProcess
+ ^ 6
+!
+
+userInterruptPriority
+ "return the priority, at which the event scheduler runs - i.e.
+ all processes running at a lower priority are interruptable by Cntl-C
+ or the timer. Processes running at higher prio will not be interrupted."
- "
- Processor activeProcessIsSystemProcess
- "
+ ^ UserInterruptPriority
+!
+
+userSchedulingPriority
+ "return the priority, at which all normal user (interactive) processing
+ takes place"
+
+ ^ UserSchedulingPriority
! !
!ProcessorScheduler methodsFor:'dispatching'!
-dispatchLoop
- "central dispatch loop; the scheduler process is always staying in
- this method, looping forever."
-
- "avoid confusion if entered twice"
-
- dispatching == true ifTrue:[^ self].
- dispatching := true.
-
- "I made this an extra call to dispatch; this allows recompilation
- of the dispatch-handling code in the running system.
- "
- [true] whileTrue:[
- AbortSignal handle:[:ex |
- ex return
- ] do:[
- self dispatch
- ]
- ]
-!
-
dispatch
"It handles timeouts and switches to the highest prio runnable process"
@@ -1211,10 +614,1027 @@
OperatingSystem disableTimer.
self checkForInputWithTimeout:0.
]
+!
+
+dispatchLoop
+ "central dispatch loop; the scheduler process is always staying in
+ this method, looping forever."
+
+ "avoid confusion if entered twice"
+
+ dispatching == true ifTrue:[^ self].
+ dispatching := true.
+
+ "I made this an extra call to dispatch; this allows recompilation
+ of the dispatch-handling code in the running system.
+ "
+ [true] whileTrue:[
+ AbortSignal handle:[:ex |
+ ex return
+ ] do:[
+ self dispatch
+ ]
+ ]
+! !
+
+!ProcessorScheduler methodsFor:'primitive process primitives'!
+
+scheduleForInterrupt:aProcess
+ "make aProcess evaluate its pushed interrupt block(s)"
+
+ |id|
+
+ aProcess isNil ifTrue:[^ self].
+ aProcess == activeProcess ifTrue:[^ self].
+
+ id := aProcess id.
+ self class threadInterrupt:id.
+ "
+ and, make the process runnable
+ "
+ aProcess state ~~ #stopped ifTrue:[
+ "
+ and, make the process runnable
+ "
+ aProcess resume
+ ]
+!
+
+threadSwitch:aProcess
+ "continue execution in aProcess.
+ (warning: low level entry, no administration is done here)"
+
+ |id pri ok oldProcess oldPri p singleStep wasBlocked|
+
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ oldProcess := activeProcess.
+ oldPri := currentPriority.
+
+ id := aProcess id.
+ pri := aProcess priority.
+ singleStep := aProcess isSingleStepping.
+ aProcess state:#active.
+ oldProcess setStateTo:#run if:#active.
+
+ "
+ no interrupts now - activeProcess has already been changed
+ (dont add any message sends here)
+ "
+ activeProcess := aProcess.
+ currentPriority := pri.
+%{
+ extern OBJ ___threadSwitch();
+
+ if (__isSmallInteger(id)) {
+ ok = ___threadSwitch(__context, _intVal(id), (singleStep == true) ? 1 : 0);
+ } else {
+ ok = false;
+ }
+%}.
+ "time passes spent in some other process ...
+ ... here again"
+
+ p := activeProcess.
+ activeProcess := oldProcess.
+ currentPriority := oldProcess priority.
+
+ ok ifFalse:[
+ "
+ switch failed for some reason -
+ destroy the bad process
+ "
+ p id ~~ 0 ifTrue:[
+ 'SCHEDULER: problem with process ' errorPrint.
+ p id errorPrint.
+ p name notNil ifTrue:[
+ ' (' errorPrint. p name errorPrint. ')' errorPrint.
+ ].
+ '; hard-terminate it.' errorPrintNL.
+ p state:#suspended.
+ self terminateNoSignal:p.
+ ]
+ ].
+ zombie notNil ifTrue:[
+ self class threadDestroy:zombie.
+ zombie := nil
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'private'!
+
+remember:aProcess
+ "remember aProcess for later disposal (where the underlying
+ system resources have to be freed)."
+
+ |newShadow oldId wasBlocked
+ oldSize "{ Class: SmallInteger }"
+ index "{ Class: SmallInteger }"
+ sz "{ Class: SmallInteger }" |
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := 1.
+ sz := KnownProcessIds size.
+ [index <= sz] whileTrue:[
+ (KnownProcesses at:index) isNil ifTrue:[
+ oldId := KnownProcessIds at:index.
+ oldId notNil ifTrue:[
+ self class threadDestroy:oldId.
+ ].
+ KnownProcesses at:index put:aProcess.
+ KnownProcessIds at:index put:aProcess id.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
+ ].
+ index := index + 1
+ ].
+
+ KnownProcessIds grow:index.
+ KnownProcessIds at:index put:aProcess id.
+
+ oldSize := KnownProcesses size.
+ (index > oldSize) ifTrue:[
+ newShadow := WeakArray new:(oldSize * 2).
+ newShadow watcher:self class.
+ newShadow replaceFrom:1 with:KnownProcesses.
+ KnownProcesses := newShadow
+ ].
+ KnownProcesses at:index put:aProcess.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+unRemember:aProcess
+ "forget aProcess - dispose processing will not consider this one"
+
+ |index wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := KnownProcesses identityIndexOf:aProcess.
+ index ~~ 0 ifTrue:[
+ KnownProcessIds at:index put:nil.
+ KnownProcesses at:index put:nil.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'private initializing'!
+
+initialize
+ "initialize the one-and-only ProcessorScheduler"
+
+ |nPrios "{ Class: SmallInteger }"
+ l p|
+
+ KnownProcesses isNil ifTrue:[
+ KnownProcesses := WeakArray new:10.
+ KnownProcesses watcher:self class.
+ KnownProcessIds := OrderedCollection new.
+ ].
+
+ "
+ create a collection with process lists; accessed using the priority as key
+ "
+ nPrios := SchedulingPriority.
+ quiescentProcessLists := Array new:nPrios.
+ 1 to:nPrios do:[:pri |
+ quiescentProcessLists at:pri put:(LinkedList new)
+ ].
+
+ readFdArray := Array with:nil.
+ readCheckArray := Array with:nil.
+ readSemaphoreArray := Array with:nil.
+ writeFdArray := Array with:nil.
+ writeSemaphoreArray := Array with:nil.
+ timeoutArray := Array with:nil.
+ timeoutSemaphoreArray := Array with:nil.
+ timeoutActionArray := Array with:nil.
+ timeoutProcessArray := Array with:nil.
+ anyTimeouts := false.
+ dispatching := false.
+ useIOInterrupts := OperatingSystem supportsIOInterrupts.
+
+ "
+ handcraft the first (dispatcher-) process - this one will never
+ block, but go into a select if there is nothing to do.
+ Also, it has a prio of max+1 - thus, it comes first when looking
+ for a runnable process.
+ "
+ currentPriority := SchedulingPriority.
+ p := Process new.
+ p setId:0 state:#run.
+ p setPriority:currentPriority.
+ p name:'scheduler'.
+
+ scheduler := activeProcess := p.
+
+ (quiescentProcessLists at:currentPriority) add:p.
+
+ "
+ let me handle IO and timer interrupts
+ "
+ ObjectMemory ioInterruptHandler:self.
+ ObjectMemory timerInterruptHandler:self.
+!
+
+reinitialize
+ "all previous processes (except those marked as restartable) are made dead
+ - each object should reinstall its process(s) upon restart;
+ especially, windowgroups have to.
+ In contrast to ST-80, restartable processes are restarted at the beginning
+ NOT continued where left. This is a consequence of the portable implementation
+ of ST/X, since in order to continue a process, we needed to know the
+ internals of the machines (and C-compilers) stack layout.
+ This was not done, favouring portability for process continuation.
+ In praxis, this is not much of a problem, since in almost every case,
+ the computation state can be saved in some object, and processing be
+ restarted from scratch, reinitializing things from this saved state."
+
+ |processesToRestart|
+
+ "
+ lay all processes to rest, collect restartable ones
+ "
+ processesToRestart := OrderedCollection new.
+ KnownProcesses do:[:p |
+ p notNil ifTrue:[
+ "how, exactly should this be done ?"
+
+ p isRestartable == true ifTrue:[
+ p nextLink:nil.
+ processesToRestart add:p
+ ] ifFalse:[
+ p setId:nil state:#dead
+ ]
+ ].
+ ].
+ scheduler setId:nil state:#dead.
+
+ "
+ now, start from scratch
+ "
+ KnownProcesses := nil.
+ self initialize.
+
+ "
+ ... and restart those that can be.
+ "
+ processesToRestart do:[:p |
+"/ 'process restart not implemented' errorPrintNL.
+ p restart
+ ]
+! !
+
+!ProcessorScheduler methodsFor:'process creation'!
+
+newProcessFor:aProcess
+ "create a physical (VM-) process for aProcess.
+ Return true if ok, false if something went wrong.
+ The process is not scheduled; to start it running,
+ it needs a Process>>resume. Once resumed, the process will later
+ get control in its #start method."
+
+ |id|
+
+ id := self class threadCreate:aProcess withId:nil.
+ id isNil ifTrue:[^ false].
+
+ aProcess setId:id state:#light. "meaning: has no stack yet"
+ self remember:aProcess.
+ ^ true
+!
+
+newProcessFor:aProcess withId:idWant
+ "private entry for Process restart - do not use in your program"
+
+ (self class threadCreate:aProcess withId:idWant) ~~ idWant ifTrue:[
+ ^ false
+ ].
+
+ aProcess state:#light. "meaning: has no stack yet"
+ self remember:aProcess.
+ ^ true
+! !
+
+!ProcessorScheduler methodsFor:'queries'!
+
+activeProcessIsSystemProcess
+ "return true if the active process is a system process,
+ which should not be suspended."
+
+ ^ self isSystemProcess:activeProcess
+
+ "
+ Processor activeProcessIsSystemProcess
+ "
+!
+
+highestPriorityRunnableProcess
+ "return the highest prio runnable process"
+
+ |listArray l p prio "{ Class: SmallInteger }" |
+
+ prio := HighestPriority.
+ listArray := quiescentProcessLists.
+ [prio >= 1] whileTrue:[
+ l := listArray at:prio.
+ l notEmpty ifTrue:[
+ p := l first.
+ "
+ if it got corrupted somehow ...
+ "
+ p id isNil ifTrue:[
+ 'process with nil id removed' errorPrintNL.
+ l removeFirst.
+ ^ nil.
+ ].
+ ^ p
+ ].
+ prio := prio - 1
+ ].
+ ^ nil
+!
+
+isSystemProcess:aProcess
+ "return true if aProcess is a system process,
+ which should not be suspended/terminated etc.."
+
+ (self class isPureEventDriven
+ or:[aProcess id == 0
+ or:[(Display notNil and:[Display dispatchProcess == aProcess])
+ " nameOrId endsWith:'dispatcher' "
+ ]]) ifTrue:[
+ ^ true
+ ].
+ ^ false
+
+ "
+ Processor activeProcessIsSystemProcess
+ "
+! !
+
+!ProcessorScheduler methodsFor:'scheduling'!
+
+changePriority:prio for:aProcess
+ "change the priority of aProcess"
+
+ |oldList newList oldPrio newPrio wasBlocked|
+
+ oldPrio := aProcess priority.
+ oldPrio == prio ifTrue:[^ self].
+
+ "
+ check for valid argument
+ "
+ newPrio := prio.
+ newPrio < 1 ifTrue:[
+ newPrio := 1.
+ ] ifFalse:[
+ aProcess == scheduler ifTrue:[^ self].
+ newPrio > HighestPriority ifTrue:[
+ newPrio := HighestPriority
+ ]
+ ].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ aProcess setPriority:newPrio.
+
+ oldList := quiescentProcessLists at:oldPrio.
+ (oldList identityIndexOf:aProcess) == 0 ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
+ ].
+
+ oldList remove:aProcess.
+
+ newList := quiescentProcessLists at:newPrio.
+ newList addLast:aProcess.
+
+ "if its the current process lowering its prio
+ or another one raising, we have to reschedule"
+
+ aProcess == activeProcess ifTrue:[
+ currentPriority := newPrio.
+ newPrio < oldPrio ifTrue:[
+ self threadSwitch:scheduler.
+ ]
+ ] ifFalse:[
+ newPrio > currentPriority ifTrue:[
+ self threadSwitch:aProcess.
+ ]
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+interruptActive
+ "interrupt the current process"
+
+ activeProcess interrupt
+!
+
+processTermination
+ "sent by VM if the current process finished its startup block
+ without proper process termination. Lay him to rest now.
+ This can only happen, if something went wrong in Block>>newProcess,
+ since the block defined there always terminates itself."
+
+ self terminateNoSignal:activeProcess.
+ self threadSwitch:scheduler
+!
+
+reschedule
+ "switch to the highest prio runnable process.
+ The scheduler itself is always runnable, so we can do an unconditional switch
+ to that one. This method is a historical left-over and will vanish."
+
+ ^ self threadSwitch:scheduler
+!
+
+resume:aProcess
+ "set aProcess runnable -
+ if its prio is higher than the currently running prio, switch to it."
+
+ |l pri wasBlocked|
+
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+
+ "ignore, if process is already dead"
+ aProcess id isNil ifTrue:[^ self].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ pri := aProcess priority.
+
+ l := quiescentProcessLists at:pri.
+ "if already running, ignore"
+ (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
+ ].
+ l addLast:aProcess.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+
+ (pri > currentPriority) ifTrue:[
+ "
+ its prio is higher; immediately transfer control to it
+ "
+ self threadSwitch:aProcess
+ ] ifFalse:[
+ "
+ its prio is lower; it will have to wait for a while ...
+ "
+ aProcess state:#run
+ ]
+!
+
+resumeForSingleSend:aProcess
+ "like resume, but let the process execute a single send only.
+ This will be used by the (new, not yet released) debugger
+ for single stepping."
+
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
+ aProcess singleStep:true.
+ self resume:aProcess
+!
+
+suspend:aProcess
+ "remove the argument, aProcess from the list of runnable processes.
+ If the process is the current one, reschedule."
+
+ |pri l p wasBlocked|
+
+ "
+ some debugging stuff
+ "
+ aProcess isNil ifTrue:[
+ MiniDebugger enterWithMessage:'nil suspend'.
+ ^ self
+ ].
+ aProcess id isNil ifTrue:[
+ MiniDebugger enterWithMessage:'bad suspend: already dead'.
+ self threadSwitch:scheduler.
+ ^ self
+ ].
+ aProcess == scheduler ifTrue:[
+ 'scheduler should never be suspended' errorPrintNL.
+ MiniDebugger enterWithMessage:'scheduler should never be suspended'.
+ ^ self
+ ].
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ pri := aProcess priority.
+ l := quiescentProcessLists at:pri.
+
+ "notice: this is slightly faster than putting the if-code into
+ the ifAbsent block, because [] is a shared cheap block
+ "
+ (l remove:aProcess ifAbsent:[]) isNil ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'bad suspend: not on run list' errorPrintNL.
+ "/ MiniDebugger enterWithMessage:'bad suspend: not on run list'.
+ self threadSwitch:scheduler.
+ ^ self
+ ].
+
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+
+ "
+ this is a bit of a kludge: allow someone else to
+ set the state to something like #ioWait etc.
+ In this case, do not set to #suspend.
+ All of this to enhance the output of the process monitor ...
+ "
+ aProcess setStateTo:#suspended if:#active or:#run.
+
+ (aProcess == activeProcess) ifTrue:[
+ "we can immediately switch sometimes"
+ l notEmpty ifTrue:[
+ p := l first
+ ] ifFalse:[
+ p := scheduler
+ ].
+ self threadSwitch:p
+ ].
+!
+
+terminate:aProcess
+ "terminate aProcess. This is donen by sending aProcess the terminateSignal,
+ which will evaluate any unwind blocks and finally do a hard terminate."
+
+ aProcess terminate
+!
+
+terminateActive
+ "terminate the current process (i.e. the running process kills itself).
+ The active process is sent the terminateSignal so it will evaluate any
+ unwind blocks and finally do a hard terminate.
+ This is sent for regular termination and by the VM, if the hard-stack limit
+ is reached. (i.e. a process did not repair things in a recursionInterrupt and
+ continued to grow its stack)"
+
+ activeProcess terminate
+!
+
+terminateActiveNoSignal
+ "hard terminate the active process, without sending any
+ terminate signal thus no unwind blocks are evaluated."
+
+ self terminateNoSignal:activeProcess
+!
+
+terminateNoSignal:aProcess
+ "hard terminate aProcess without sending the terminate signal, thus
+ no unwind blocks or exitAction are performed in the process..
+ If its not the current process, it is simply removed from its list
+ and physically destroyed. Otherwise (since we can't take away the chair
+ we are sitting on), a switch is forced and the process
+ will be physically destroyed by the next running process.
+ (see zombie handling)"
+
+ |pri id l wasBlocked|
+
+ aProcess isNil ifTrue:[^ self].
+ id := aProcess id.
+ id isNil ifTrue:[^ self]. "already dead"
+
+ aProcess setId:nil state:#dead.
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ "remove the process from the runnable list"
+
+ pri := aProcess priority.
+ l := quiescentProcessLists at:pri.
+ (l identityIndexOf:aProcess) ~~ 0 ifTrue:[
+ l remove:aProcess.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+
+ aProcess == activeProcess ifTrue:[
+ "
+ hard case - its the currently running process
+ we must have the next active process destroy this one
+ (we cannot destroy the chair we are sitting on ... :-)
+ "
+ zombie := id.
+ self unRemember:aProcess.
+ self threadSwitch:scheduler.
+ "not reached"
+ ^ self
+ ].
+ self class threadDestroy:id.
+ self unRemember:aProcess.
+ ^ self
+!
+
+yield
+ "move the currently running process to the end of the currentList
+ and reschedule to the first in the list, thus switching to the
+ next same-prio-process."
+
+ |l wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+
+ "
+ debugging consistency check - will be removed later
+ "
+ activeProcess priority ~~ currentPriority ifTrue:[
+ 'oops process changed priority' errorPrintNL.
+ currentPriority := activeProcess priority.
+ ].
+
+ l := quiescentProcessLists at:currentPriority.
+
+ "
+ debugging consistency checks - will be removed later
+ "
+ l isEmpty ifTrue:[
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'oops - empty runnable list' errorPrintNL.
+ ^ self
+ ].
+
+ "
+ check if the running process is not the only one
+ "
+ l size ~~ 1 ifTrue:[
+ "
+ bring running process to the end
+ "
+ l removeFirst.
+ l addLast:activeProcess.
+
+ "
+ and switch to first in the list
+ "
+ self threadSwitch:(l first).
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'semaphore signalling'!
+
+disableSemaphore:aSemaphore
+ "disable triggering of a semaphore"
+
+ |idx "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ [idx ~~ 0] whileTrue:[
+ readFdArray at:idx put:nil.
+ readSemaphoreArray at:idx put:nil.
+ readCheckArray at:idx put:nil.
+ idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
+ ].
+ idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ [idx ~~ 0] whileTrue:[
+ writeFdArray at:idx put:nil.
+ writeSemaphoreArray at:idx put:nil.
+ idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
+ ].
+ idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ [idx ~~ 0] whileTrue:[
+ timeoutArray at:idx put:nil.
+ timeoutSemaphoreArray at:idx put:nil.
+ timeoutActionArray at:idx put:nil.
+ timeoutProcessArray at:idx put:nil.
+ idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore afterMilliseconds:millis
+ "arrange for a semaphore to be triggered after some milliseconds"
+
+ |now then wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ now := OperatingSystem getMillisecondTime.
+ then := OperatingSystem millisecondTimeAdd:now and:millis rounded.
+ self signal:aSemaphore atMilliseconds:then.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore afterSeconds:seconds
+ "arrange for a semaphore to be triggered after some seconds"
+
+ self signal:aSemaphore afterMilliseconds:(seconds * 1000)
+!
+
+signal:aSemaphore atMilliseconds:aMillisecondTime
+ "arrange for a semaphore to be triggered at a specific millisecond time.
+ If there is already a pending trigger time, the time is changed."
+
+ |index "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
+ index ~~ 0 ifTrue:[
+ timeoutArray at:index put:aMillisecondTime
+ ] ifFalse:[
+ index := timeoutArray identityIndexOf:nil startingAt:1.
+ index ~~ 0 ifTrue:[
+ timeoutSemaphoreArray at:index put:aSemaphore.
+ timeoutArray at:index put:aMillisecondTime.
+ timeoutActionArray at:index put:nil.
+ timeoutProcessArray at:index put:nil
+ ] ifFalse:[
+ timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:aSemaphore.
+ timeoutArray := timeoutArray copyWith:aMillisecondTime.
+ timeoutActionArray := timeoutActionArray copyWith:nil.
+ timeoutProcessArray := timeoutProcessArray copyWith:nil
+ ].
+ ].
+
+ anyTimeouts := true.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore onInput:aFileDescriptor
+ "arrange for a semaphore to be triggered when input on aFileDescriptor
+ arrives."
+
+ self signal:aSemaphore onInput:aFileDescriptor orCheck:nil
+!
+
+signal:aSemaphore onInput:aFileDescriptor orCheck:aBlock
+ "arrange for a semaphore to be triggered when input on aFileDescriptor
+ arrives OR checkblock evaluates to true.
+ (checkBlock is used for buffered input, where a select may not detect
+ data already read into a buffer - as in Xlib)"
+
+ |idx "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ (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.
+ ]
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+signal:aSemaphore onOutput:aFileDescriptor
+ "arrange for a semaphore to be triggered when output on aFileDescriptor
+ is possible. (i.e. can be written without blocking)"
+
+ |idx "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ (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.
+ ] ifFalse:[
+ writeFdArray := writeFdArray copyWith:aFileDescriptor.
+ writeSemaphoreArray := writeSemaphoreArray copyWith:aSemaphore.
+ ]
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+! !
+
+!ProcessorScheduler methodsFor:'timeout handling'!
+
+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
+ 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)."
+
+ ^ self addTimedBlock:aBlock for:activeProcess afterMilliseconds:delta
+!
+
+addTimedBlock:aBlock afterSeconds:delta
+ "add the argument, aBlock to the list of time-scheduled-blocks.
+ to be evaluated after delta seconds. 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)."
+
+ self addTimedBlock:aBlock for:activeProcess afterMilliseconds:(delta * 1000) rounded
+!
+
+addTimedBlock:aBlock atMilliseconds:aMillisecondTime
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated when the millisecondClock value passes aMillisecondTime.
+ 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)."
+
+ self addTimedBlock:aBlock for:activeProcess atMilliseconds:aMillisecondTime
+!
+
+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,
+ 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)."
+
+ |now then wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ now := OperatingSystem getMillisecondTime.
+ then := OperatingSystem millisecondTimeAdd:now and:delta.
+ self addTimedBlock:aBlock for:aProcess atMilliseconds:then.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+addTimedBlock:aBlock for:aProcess afterSeconds:delta
+ "add the argument, aBlock to the list of time-scheduled-blocks.
+ to be evaluated after delta seconds. 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)."
+
+ self addTimedBlock:aBlock for:aProcess afterMilliseconds:(delta * 1000) rounded
+!
+
+addTimedBlock:aBlock for:aProcess atMilliseconds:aMillisecondTime
+ "add the argument, aBlock to the list of time-scheduled-blocks; to be
+ evaluated by aProcess when the millisecondClock value passes
+ aMillisecondTime.
+ If that block is already in the timeout list,
+ its trigger-time is changed.
+ The process specified by the argument, aProcess will be interrupted
+ 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).
+ 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
+ resumed.
+ The block will be removed from the timed-block list after evaluation
+ (i.e. it will trigger only once)."
+
+ |index "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
+ index ~~ 0 ifTrue:[
+ timeoutArray at:index put:aMillisecondTime
+ ] ifFalse:[
+ index := timeoutArray indexOf:nil.
+ index ~~ 0 ifTrue:[
+ timeoutArray at:index put:aMillisecondTime.
+ timeoutActionArray at:index put:aBlock.
+ timeoutSemaphoreArray at:index put:nil.
+ timeoutProcessArray at:index put:aProcess
+ ] ifFalse:[
+ timeoutArray := timeoutArray copyWith:aMillisecondTime.
+ timeoutActionArray := timeoutActionArray copyWith:aBlock.
+ timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:nil.
+ timeoutProcessArray := timeoutProcessArray copyWith:aProcess.
+ ].
+ ].
+
+ anyTimeouts := true.
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+!
+
+evaluateTimeouts
+ "walk through timeouts and evaluate blocks or signal semas that need to be .."
+
+ |sema now aTime block blocksToEvaluate
+ processes n "{ Class: SmallInteger }"|
+
+ anyTimeouts ifFalse:[ ^ self].
+
+ "have to collect the blocks first, then evaluate them. This avoids
+ problems due to newly inserted blocks."
+
+ now := OperatingSystem getMillisecondTime.
+ blocksToEvaluate := nil.
+ n := timeoutArray size.
+ anyTimeouts := false.
+ 1 to:n do:[:index |
+ aTime := timeoutArray at:index.
+ aTime notNil ifTrue:[
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
+ "this one should be triggered"
+
+ sema := timeoutSemaphoreArray at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ timeoutSemaphoreArray at:index put:nil
+ ] ifFalse:[
+ "to support pure-events"
+ block := timeoutActionArray at:index.
+ block notNil ifTrue:[
+ blocksToEvaluate isNil ifTrue:[
+ blocksToEvaluate := OrderedCollection new:10.
+ processes := OrderedCollection new:10.
+ ].
+ blocksToEvaluate add:block.
+ processes add:(timeoutProcessArray at:index).
+ timeoutActionArray at:index put:nil.
+ timeoutProcessArray at:index put:nil.
+ ]
+ ].
+ timeoutArray at:index put:nil.
+ ] ifTrue:[
+ anyTimeouts := true
+ ]
+ ]
+ ].
+
+ blocksToEvaluate notNil ifTrue:[
+ blocksToEvaluate keysAndValuesDo:[:index :block |
+ |p|
+
+ p := processes at:index.
+ (p isNil or:[p == scheduler or:[PureEventDriven]]) ifTrue:[
+ block value
+ ] ifFalse:[
+ p interruptWith:block
+ ]
+ ]
+ ]
+!
+
+removeTimedBlock:aBlock
+ "remove the argument, aBlock from the list of time-sceduled-blocks."
+
+ |index "{ Class: SmallInteger }"
+ wasBlocked|
+
+ wasBlocked := OperatingSystem blockInterrupts.
+ index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
+ (index ~~ 0) ifTrue:[
+ timeoutArray at:index put:nil.
+ timeoutActionArray at:index put:nil.
+ timeoutSemaphoreArray at:index put:nil.
+ timeoutProcessArray at:index put:nil.
+ ].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
!ProcessorScheduler methodsFor:'waiting'!
+checkForInputWithTimeout:millis
+ "this is called, when there is absolutely nothing to do;
+ hard wait for either input to arrive or a timeout to occur."
+
+ |fd index sema action|
+
+ fd := OperatingSystem
+ selectOnAnyReadable:readFdArray
+ writable:writeFdArray
+ exception:nil
+ withTimeOut:millis.
+ fd notNil ifTrue:[
+ index := readFdArray indexOf:fd.
+ index ~~ 0 ifTrue:[
+ sema := readSemaphoreArray at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ ^ true
+ ] ifFalse:[
+ action := readCheckArray at:index.
+ action notNil ifTrue:[
+ action value.
+ ^ true
+ ]
+ ]
+ ]
+ ].
+ ^ false
+!
+
ioInterrupt
"data arrived while waiting - switch to scheduler process which will decide
what to do now."
@@ -1223,14 +1643,6 @@
self threadSwitch:scheduler
!
-timerInterrupt
- "timer expired while waiting - switch to scheduler process which will decide
- what to do now."
-
- interruptedProcess := activeProcess.
- self threadSwitch:scheduler
-!
-
timeToNextTimeout
"return the delta-T (in millis) to next timeout, or nil if
there is none"
@@ -1261,6 +1673,14 @@
^ minDelta
!
+timerInterrupt
+ "timer expired while waiting - switch to scheduler process which will decide
+ what to do now."
+
+ interruptedProcess := activeProcess.
+ self threadSwitch:scheduler
+!
+
waitForEventOrTimeout
"entered when no process is runnable - wait for either input on
any file descriptors to arrive or a timeout to happen.
@@ -1325,438 +1745,11 @@
millis := millis rounded
].
self checkForInputWithTimeout:millis
-!
-
-checkForInputWithTimeout:millis
- "this is called, when there is absolutely nothing to do;
- hard wait for either input to arrive or a timeout to occur."
-
- |fd index sema action|
-
- fd := OperatingSystem
- selectOnAnyReadable:readFdArray
- writable:writeFdArray
- exception:nil
- withTimeOut:millis.
- fd notNil ifTrue:[
- index := readFdArray indexOf:fd.
- index ~~ 0 ifTrue:[
- sema := readSemaphoreArray at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ^ true
- ] ifFalse:[
- action := readCheckArray at:index.
- action notNil ifTrue:[
- action value.
- ^ true
- ]
- ]
- ]
- ].
- ^ false
-! !
-
-!ProcessorScheduler methodsFor:'semaphore signalling'!
-
-signal:aSemaphore onInput:aFileDescriptor
- "arrange for a semaphore to be triggered when input on aFileDescriptor
- arrives."
-
- self signal:aSemaphore onInput:aFileDescriptor orCheck:nil
-!
-
-signal:aSemaphore onInput:aFileDescriptor orCheck:aBlock
- "arrange for a semaphore to be triggered when input on aFileDescriptor
- arrives OR checkblock evaluates to true.
- (checkBlock is used for buffered input, where a select may not detect
- data already read into a buffer - as in Xlib)"
-
- |idx "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- (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.
- ]
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-signal:aSemaphore onOutput:aFileDescriptor
- "arrange for a semaphore to be triggered when output on aFileDescriptor
- is possible. (i.e. can be written without blocking)"
-
- |idx "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- (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.
- ] ifFalse:[
- writeFdArray := writeFdArray copyWith:aFileDescriptor.
- writeSemaphoreArray := writeSemaphoreArray copyWith:aSemaphore.
- ]
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-signal:aSemaphore afterSeconds:seconds
- "arrange for a semaphore to be triggered after some seconds"
-
- self signal:aSemaphore afterMilliseconds:(seconds * 1000)
-!
-
-signal:aSemaphore afterMilliseconds:millis
- "arrange for a semaphore to be triggered after some milliseconds"
-
- |now then wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- now := OperatingSystem getMillisecondTime.
- then := OperatingSystem millisecondTimeAdd:now and:millis rounded.
- self signal:aSemaphore atMilliseconds:then.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-signal:aSemaphore atMilliseconds:aMillisecondTime
- "arrange for a semaphore to be triggered at a specific millisecond time.
- If there is already a pending trigger time, the time is changed."
-
- |index "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- index ~~ 0 ifTrue:[
- timeoutArray at:index put:aMillisecondTime
- ] ifFalse:[
- index := timeoutArray identityIndexOf:nil startingAt:1.
- index ~~ 0 ifTrue:[
- timeoutSemaphoreArray at:index put:aSemaphore.
- timeoutArray at:index put:aMillisecondTime.
- timeoutActionArray at:index put:nil.
- timeoutProcessArray at:index put:nil
- ] ifFalse:[
- timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:aSemaphore.
- timeoutArray := timeoutArray copyWith:aMillisecondTime.
- timeoutActionArray := timeoutActionArray copyWith:nil.
- timeoutProcessArray := timeoutProcessArray copyWith:nil
- ].
- ].
-
- anyTimeouts := true.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-disableSemaphore:aSemaphore
- "disable triggering of a semaphore"
-
- |idx "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- [idx ~~ 0] whileTrue:[
- readFdArray at:idx put:nil.
- readSemaphoreArray at:idx put:nil.
- readCheckArray at:idx put:nil.
- idx := readSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
- ].
- idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- [idx ~~ 0] whileTrue:[
- writeFdArray at:idx put:nil.
- writeSemaphoreArray at:idx put:nil.
- idx := writeSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
- ].
- idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:1.
- [idx ~~ 0] whileTrue:[
- timeoutArray at:idx put:nil.
- timeoutSemaphoreArray at:idx put:nil.
- timeoutActionArray at:idx put:nil.
- timeoutProcessArray at:idx put:nil.
- idx := timeoutSemaphoreArray identityIndexOf:aSemaphore startingAt:idx.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-! !
-
-!ProcessorScheduler methodsFor:'background processing'!
-
-addIdleBlock:aBlock
- "add the argument, aBlock to the list of idle-actions.
- Idle blocks are evaluated whenever no other process is runnable,
- and no events are pending.
- Use of idle blocks is not recommended, use a low priority processes
- instead, which has the same effect. Idle blcoks are still included
- to support background actions in pure-event systems, where no processes
- are available.
- Support for idle-blocks may vanish."
-
- |wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idleActions isNil ifTrue:[
- idleActions := OrderedCollection new
- ].
- idleActions add:aBlock.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-removeIdleBlock:aBlock
- "remove the argument, aBlock from the list of idle-blocks.
- Support for idle-blocks may vanish - use low prio processes instead."
-
- |wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idleActions notNil ifTrue:[
- idleActions remove:aBlock
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
-!ProcessorScheduler methodsFor:'I/O event actions'!
-
-enableIOAction:aBlock onInput:aFileDescriptor
- "half-obsolete event support: arrange for aBlock to be
- evaluated when input on aFileDescriptor arrives.
- This is a leftover support for pure-event systems and may vanish."
-
- |idx "{Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- (readFdArray identityIndexOf:aFileDescriptor startingAt:1) == 0 ifTrue:[
- idx := readFdArray identityIndexOf:nil startingAt:1.
- idx ~~ 0 ifTrue:[
- readFdArray at:idx put:aFileDescriptor.
- readCheckArray at:idx put:aBlock.
- readSemaphoreArray at:idx put:nil
- ] ifFalse:[
- readFdArray := readFdArray copyWith:aFileDescriptor.
- readCheckArray := readCheckArray copyWith:aBlock.
- readSemaphoreArray := readSemaphoreArray copyWith:nil.
- ]
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-disableFd:aFileDescriptor
- "disable block events on aFileDescriptor.
- This is a leftover support for pure-event systems and may vanish."
-
- |idx "{Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- idx := readFdArray identityIndexOf:aFileDescriptor startingAt:1.
- idx ~~ 0 ifTrue:[
- readFdArray at:idx put:nil.
- readCheckArray at:idx put:nil.
- readSemaphoreArray at:idx put:nil
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-! !
-
-!ProcessorScheduler methodsFor:'timeout handling'!
-
-addTimedBlock:aBlock afterSeconds:delta
- "add the argument, aBlock to the list of time-scheduled-blocks.
- to be evaluated after delta seconds. 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)."
-
- self addTimedBlock:aBlock for:activeProcess afterMilliseconds:(delta * 1000) rounded
-!
-
-addTimedBlock:aBlock for:aProcess afterSeconds:delta
- "add the argument, aBlock to the list of time-scheduled-blocks.
- to be evaluated after delta seconds. 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)."
-
- self addTimedBlock:aBlock for:aProcess afterMilliseconds:(delta * 1000) rounded
-!
-
-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
- 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)."
-
- ^ self addTimedBlock:aBlock for:activeProcess afterMilliseconds:delta
-!
-
-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,
- 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)."
-
- |now then wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- now := OperatingSystem getMillisecondTime.
- then := OperatingSystem millisecondTimeAdd:now and:delta.
- self addTimedBlock:aBlock for:aProcess atMilliseconds:then.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-addTimedBlock:aBlock atMilliseconds:aMillisecondTime
- "add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated when the millisecondClock value passes aMillisecondTime.
- 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)."
-
- self addTimedBlock:aBlock for:activeProcess atMilliseconds:aMillisecondTime
-!
+!ProcessorScheduler class methodsFor:'documentation'!
-addTimedBlock:aBlock for:aProcess atMilliseconds:aMillisecondTime
- "add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated by aProcess when the millisecondClock value passes
- aMillisecondTime.
- If that block is already in the timeout list,
- its trigger-time is changed.
- The process specified by the argument, aProcess will be interrupted
- 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).
- 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
- resumed.
- The block will be removed from the timed-block list after evaluation
- (i.e. it will trigger only once)."
-
- |index "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
- index ~~ 0 ifTrue:[
- timeoutArray at:index put:aMillisecondTime
- ] ifFalse:[
- index := timeoutArray indexOf:nil.
- index ~~ 0 ifTrue:[
- timeoutArray at:index put:aMillisecondTime.
- timeoutActionArray at:index put:aBlock.
- timeoutSemaphoreArray at:index put:nil.
- timeoutProcessArray at:index put:aProcess
- ] ifFalse:[
- timeoutArray := timeoutArray copyWith:aMillisecondTime.
- timeoutActionArray := timeoutActionArray copyWith:aBlock.
- timeoutSemaphoreArray := timeoutSemaphoreArray copyWith:nil.
- timeoutProcessArray := timeoutProcessArray copyWith:aProcess.
- ].
- ].
-
- anyTimeouts := true.
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-removeTimedBlock:aBlock
- "remove the argument, aBlock from the list of time-sceduled-blocks."
-
- |index "{ Class: SmallInteger }"
- wasBlocked|
-
- wasBlocked := OperatingSystem blockInterrupts.
- index := timeoutActionArray identityIndexOf:aBlock startingAt:1.
- (index ~~ 0) ifTrue:[
- timeoutArray at:index put:nil.
- timeoutActionArray at:index put:nil.
- timeoutSemaphoreArray at:index put:nil.
- timeoutProcessArray at:index put:nil.
- ].
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
-!
-
-evaluateTimeouts
- "walk through timeouts and evaluate blocks or signal semas that need to be .."
-
- |sema now aTime block blocksToEvaluate
- processes n "{ Class: SmallInteger }"|
-
- anyTimeouts ifFalse:[ ^ self].
-
- "have to collect the blocks first, then evaluate them. This avoids
- problems due to newly inserted blocks."
-
- now := OperatingSystem getMillisecondTime.
- blocksToEvaluate := nil.
- n := timeoutArray size.
- anyTimeouts := false.
- 1 to:n do:[:index |
- aTime := timeoutArray at:index.
- aTime notNil ifTrue:[
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
- "this one should be triggered"
-
- sema := timeoutSemaphoreArray at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- timeoutSemaphoreArray at:index put:nil
- ] ifFalse:[
- "to support pure-events"
- block := timeoutActionArray at:index.
- block notNil ifTrue:[
- blocksToEvaluate isNil ifTrue:[
- blocksToEvaluate := OrderedCollection new:10.
- processes := OrderedCollection new:10.
- ].
- blocksToEvaluate add:block.
- processes add:(timeoutProcessArray at:index).
- timeoutActionArray at:index put:nil.
- timeoutProcessArray at:index put:nil.
- ]
- ].
- timeoutArray at:index put:nil.
- ] ifTrue:[
- anyTimeouts := true
- ]
- ]
- ].
-
- blocksToEvaluate notNil ifTrue:[
- blocksToEvaluate keysAndValuesDo:[:index :block |
- |p|
-
- p := processes at:index.
- (p isNil or:[p == scheduler or:[PureEventDriven]]) ifTrue:[
- block value
- ] ifFalse:[
- p interruptWith:block
- ]
- ]
- ]
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/ProcessorScheduler.st,v 1.53 1995-12-07 21:29:55 cg Exp $'
! !
+ProcessorScheduler initialize!