--- a/ProcSched.st Mon Oct 10 01:29:01 1994 +0100
+++ b/ProcSched.st Mon Oct 10 01:29:28 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -11,28 +11,28 @@
"
Object subclass:#ProcessorScheduler
- instanceVariableNames:'quiescentProcessLists scheduler
- zombie
- activeProcess currentPriority
- readFds readSemaphores readChecks
- writeFds writeSemaphores
- timeouts timeoutActions timeoutProcesses timeoutSemaphores
- idleActions anyTimeouts dispatching'
- classVariableNames:'KnownProcesses KnownProcessIds
- PureEventDriven
- UserSchedulingPriority
- UserInterruptPriority
- TimingPriority
- SchedulingPriority'
- poolDictionaries:''
- category:'Kernel-Processes'
+ instanceVariableNames:'quiescentProcessLists scheduler
+ zombie
+ activeProcess currentPriority
+ readFds readSemaphores readChecks
+ writeFds writeSemaphores
+ timeouts timeoutActions timeoutProcesses timeoutSemaphores
+ idleActions anyTimeouts dispatching'
+ classVariableNames:'KnownProcesses KnownProcessIds
+ PureEventDriven
+ UserSchedulingPriority
+ UserInterruptPriority
+ TimingPriority
+ SchedulingPriority'
+ poolDictionaries:''
+ category:'Kernel-Processes'
!
ProcessorScheduler comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.20 1994-08-23 23:11:00 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.21 1994-10-10 00:27:28 claus Exp $
'!
Smalltalk at:#Processor put:nil!
@@ -42,7 +42,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
@@ -55,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.20 1994-08-23 23:11:00 claus Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/ProcSched.st,v 1.21 1994-10-10 00:27:28 claus Exp $
"
!
@@ -67,11 +67,12 @@
Scheduling is fully done in smalltalk (the always runnable scheduler-
process, running at highest priority does this).
- The main primitive support is used in threadSwitch, which passes
+ The main primitive to support this is found in threadSwitch, which passes
control to another process (usually selected by the scheduler).
- Thus it is possible to modify the schedulers policy.
+ Thus it is possible to modify the schedulers policy and implementation
+ at the smalltalk level.
(To answer a frequently asked question:
- dont add preemtive round-robin here; this can be implemented without
+ dont add preemptive round-robin here; this can be implemented without
any need to change the scheduler. See goodies/timeslicing.st for how
this is done in a very elegant way).
@@ -88,38 +89,38 @@
class variables:
- KnownProcesses <Collection> all known processes
- KnownProcessIds <Collection> and their IDs
- PureEventDriven <Boolean> true, if no process support
- is available
- UserSchedulingPriority <Integer> the priority at which normal
- user interfaces run
- UserInterruptPriority the priority at which user-
- interrupts (Cntl-C) processing
- takes place. Processes with
- a greater or equal priority are
- not interruptable.
- TimingPriority the priority used for timing.
- Processes with a greater or
- equal priority are not interrupted
- by timers.
- SchedulingPriority The priority of the scheduler (must
- me higher than any other).
+ KnownProcesses <Collection> all known processes
+ KnownProcessIds <Collection> and their IDs
+ PureEventDriven <Boolean> true, if no process support
+ is available
+ UserSchedulingPriority <Integer> the priority at which normal
+ user interfaces run
+ UserInterruptPriority the priority at which user-
+ interrupts (Cntl-C) processing
+ takes place. Processes with
+ a greater or equal priority are
+ not interruptable.
+ TimingPriority the priority used for timing.
+ Processes with a greater or
+ equal priority are not interrupted
+ by timers.
+ SchedulingPriority The priority of the scheduler (must
+ me higher than any other).
most interresting methods:
- Processor>>suspend: (see also Process>>suspend)
- Processor>>resume: (see also Process>>resume)
- Processor>>terminate: (see also Process>>terminate)
- Processor>>yield
- Processor>>changePriority:for: (see also Process>>priority:
+ Processor>>suspend: (see also Process>>suspend)
+ Processor>>resume: (see also Process>>resume)
+ Processor>>terminate: (see also Process>>terminate)
+ Processor>>yield
+ Processor>>changePriority:for: (see also Process>>priority:
- Processor>>signal:afterSeconds: (see also Delay>>forSeconds:)
- Processor>>signal:afterMilliseconds: (see also Delay>>forMilliseconds:)
- Processor>>signal:onInput: (see also ExternalStream>>readWait)
- Processor>>signal:onOutput: (see also ExternalStream>>writeWait)
- Processor>>disableSemaphore:
+ Processor>>signal:afterSeconds: (see also Delay>>forSeconds:)
+ Processor>>signal:afterMilliseconds: (see also Delay>>forMilliseconds:)
+ Processor>>signal:onInput: (see also ExternalStream>>readWait)
+ Processor>>signal:onOutput: (see also ExternalStream>>writeWait)
+ Processor>>disableSemaphore:
"
! !
@@ -134,19 +135,10 @@
TimingPriority := 16.
SchedulingPriority := 31.
- KnownProcesses isNil ifTrue:[
- KnownProcesses := WeakArray new:10.
- KnownProcesses watcher:self.
- KnownProcessIds := OrderedCollection new.
+ Processor isNil ifTrue:[
+ "create the one and only processor"
- "want to get informed when returning from snapshot"
- ObjectMemory addDependent:self
- ].
-
- Processor isNil ifTrue:[
- "create the one and only processor"
-
- Processor := self new.
+ Processor := self basicNew initialize.
].
"
@@ -154,33 +146,8 @@
"
PureEventDriven := self threadsAvailable not.
PureEventDriven ifTrue:[
- 'no process support - running event driven' errorPrintNL
+ 'no process support - running event driven' errorPrintNL
].
-!
-
-update:something
- "being a dependent of the ObjectMemory, this is the notification
- that something happened"
-
- something == #restarted ifTrue:[
- self reinstallProcesses
- ]
-!
-
-reinstallProcesses
- "recreate all processes after a snapShot load.
- This is currently not implemented (and might never be).
- All we could do is to restart the processes. Time will show."
-
- KnownProcesses do:[:p |
- p notNil ifTrue:[
- "how, exactly should this be done ?"
-
- p id ~~ 0 ifTrue:[
- 'process restart not implemented' errorPrintNL
- ]
- ]
- ]
! !
!ProcessorScheduler class methodsFor:'instance creation'!
@@ -188,31 +155,31 @@
new
"there is (currently) only one processor ..."
- Processor isNil ifTrue:[
- Processor := self basicNew initialize
- ].
- ^ Processor.
+ self error:'only one processor is allowed in the system'
! !
!ProcessorScheduler class methodsFor:'instance release'!
informDispose
- "some Process has been collected - terminate the underlying thread"
+ "some Process has been garbage collected
+ - terminate the underlying thread. Usually this does not happen,
+ but the thread terminates itself by using #terminate."
|id sz "{ Class: SmallInteger }"|
sz := KnownProcessIds size.
1 to:sz do:[:index |
- (KnownProcesses at:index) isNil ifTrue:[
- id := KnownProcessIds at:index.
- id notNil ifTrue:[
- Transcript showCr:('terminate thread ',
- id printString,
- ' (no longer refd)').
- self threadDestroy:id.
- KnownProcessIds at:index put:nil.
- ]
- ]
+ (KnownProcesses at:index) isNil ifTrue:[
+ id := KnownProcessIds at:index.
+ id notNil ifTrue:[
+ 'PROCESSOR: terminating thread ' errorPrint.
+ id errorPrint.
+ ' (no longer refd)' errorPrintNL.
+
+ self threadDestroy:id.
+ KnownProcessIds at:index put:nil.
+ ]
+ ]
]
! !
@@ -270,13 +237,13 @@
%{ /* NOCONTEXT */
if (_isSmallInteger(id)) {
- __threadInterrupt(_intVal(id));
+ __threadInterrupt(_intVal(id));
}
%}
!
-threadCreate:aBlock
- "physical creation of a process executing aBlock.
+threadCreate:aProcess
+ "physical creation of a process.
(warning: low level entry, no administration done).
This may return nil, if process could not be created."
@@ -284,15 +251,17 @@
int tid;
extern int __threadCreate();
- tid = __threadCreate(aBlock, 0 /* stackSize no longer needed */);
+ tid = __threadCreate(aProcess, 0 /* stackSize no longer needed */);
if (tid != 0) {
- RETURN ( _MKSMALLINT(tid));
+ RETURN ( _MKSMALLINT(tid));
}
%}
.
"
arrive here, if creation of process in VM failed.
- (no memory for process)
+ This may happen, if the VM does not support more processes,
+ or if it ran out of memory, when allocating internal data
+ structures.
"
^ ObjectMemory allocationFailureSignal raise.
!
@@ -304,7 +273,7 @@
%{ /* NOCONTEXT */
if (_isSmallInteger(id)) {
- __threadDestroy(_intVal(id));
+ __threadDestroy(_intVal(id));
}
%}
! !
@@ -317,8 +286,7 @@
|id pri ok oldProcess oldPri p singleStep wasBlocked|
- aProcess isNil ifTrue:[^ self].
- aProcess == activeProcess ifTrue:[^ self].
+ (aProcess isNil or:[aProcess == activeProcess]) ifTrue:[^ self].
wasBlocked := OperatingSystem blockInterrupts.
@@ -329,9 +297,7 @@
pri := aProcess priority.
singleStep := aProcess isSingleStepping.
aProcess state:#active.
- oldProcess state == #active ifTrue:[
- oldProcess state:#run.
- ].
+ oldProcess setStateTo:#run if:#active.
"no interrupts now - activeProcess has already been changed
(dont add any message sends here)"
@@ -341,29 +307,30 @@
extern OBJ __threadSwitch(), __threadSwitchWithSingleStep();
if (singleStep == true)
- ok = __threadSwitchWithSingleStep(__context, _intVal(id));
+ ok = __threadSwitchWithSingleStep(__context, _intVal(id));
else
- ok = __threadSwitch(__context, _intVal(id));
+ ok = __threadSwitch(__context, _intVal(id));
%}.
"time passes ...
... here again"
ok ifFalse:[
- "
- switch failed for some reason -
- destroy the bad process
- "
- p := activeProcess.
- activeProcess := oldProcess.
- currentPriority := oldPri.
- p id ~~ 0 ifTrue:[
- p state:#suspended.
- p terminate.
- ]
+ "
+ switch failed for some reason -
+ destroy the bad process
+ "
+ p := activeProcess.
+ activeProcess := oldProcess.
+ currentPriority := oldPri.
+ p id ~~ 0 ifTrue:[
+ 'process switch failed' errorPrintNL.
+ p state:#suspended.
+ self terminateNoSignal:p.
+ ]
].
zombie notNil ifTrue:[
- self class threadDestroy:zombie.
- zombie := nil
+ self class threadDestroy:zombie.
+ zombie := nil
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -457,6 +424,12 @@
|nPrios l p|
+ KnownProcesses isNil ifTrue:[
+ KnownProcesses := WeakArray new:10.
+ KnownProcesses watcher:self class.
+ KnownProcessIds := OrderedCollection new.
+ ].
+
nPrios := SchedulingPriority.
quiescentProcessLists := Array new:nPrios.
@@ -481,10 +454,9 @@
currentPriority := SchedulingPriority.
p := Process new.
- p setId:0.
+ p setId:0 state:#run.
+ p setPriority:currentPriority.
p name:'scheduler'.
- p state:#run.
- p setPriority:currentPriority.
l := LinkedList new.
l add:p.
@@ -496,13 +468,24 @@
ObjectMemory timerInterruptHandler:self.
!
-reInitialize
- "all previous stuff is obsolete - each object should reinstall itself
- upon restart."
+reinitialize
+ "all previous processes are dead - each object should reinstall its
+ process(s) upon restart - especially, windowgroups have to."
+
+ KnownProcesses do:[:p |
+ p notNil ifTrue:[
+ "how, exactly should this be done ?"
- KnownProcesses := WeakArray new:5.
- KnownProcesses watcher:self class.
- KnownProcessIds := OrderedCollection new.
+ 'process restart not implemented' errorPrintNL.
+ p setId:nil state:#dead
+ ].
+ scheduler setId:nil state:#dead
+ ].
+
+ "
+ now, start from scratch
+ "
+ KnownProcesses := nil.
self initialize
! !
@@ -520,17 +503,17 @@
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
+ (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.
@@ -538,10 +521,10 @@
oldSize := KnownProcesses size.
(index > oldSize) ifTrue:[
- newShadow := WeakArray new:(oldSize * 2).
- newShadow watcher:self class.
- newShadow replaceFrom:1 with:KnownProcesses.
- KnownProcesses := newShadow
+ 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].
@@ -555,82 +538,37 @@
wasBlocked := OperatingSystem blockInterrupts.
index := KnownProcesses identityIndexOf:aProcess.
index ~~ 0 ifTrue:[
- KnownProcessIds at:index put:nil.
- KnownProcesses at:index put:nil.
+ KnownProcessIds at:index put:nil.
+ KnownProcesses at:index put:nil.
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
!ProcessorScheduler methodsFor:'process creation'!
-newProcessFor:aBlock
- "create a new process executing aBlock.
- Return a process (or nil if fail). The new process is not scheduled.
- To start it running, it needs a Process>>resume."
+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."
- |id p|
+ |id|
- id := self class threadCreate:aBlock.
- id isNil ifTrue:[
- "
- this may happen, if the VM does not support more processes,
- or if it ran out of memory, when allocating internal data
- structures
- "
- self error:'cannot create new Process'.
- ^ nil
- ].
- p := Process new.
- p setId:id.
- p startBlock:aBlock.
- p state:#light. "meaning: has no stack yet"
- p setPriority:currentPriority.
- "
- give it a user-friendly name
- "
- activeProcess name notNil ifTrue:[
- p name:(activeProcess name , ' (sub)')
- ].
- self remember:p.
- ^ p
+ id := self class threadCreate:aProcess.
+ 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 there is always a switch.
- (if you want to implement your own scheduler stuff, uncomment below)"
+ "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
-
-"/ |l p maxPri "{ Class: SmallInteger }"|
-"/
-"/ maxPri := SchedulingPriority.
-"/ maxPri to:1 by:-1 do:[:prio |
-"/ l := quiescentProcessLists at:prio.
-"/ l notNil ifTrue:[
-"/ p := l first.
-"/ p notNil ifTrue:[
-"/ activeProcess state == #active ifTrue:[
-"/ activeProcess state:#run.
-"/ ].
-"/ ^ self threadSwitch:p
-"/ ].
-"/ quiescentProcessLists at:prio put:nil
-"/ ]
-"/ ].
-"/ "
-"/ no process to run - this 'cannot' happen
-"/ (well, not quite: it may happen if the scheduler process is
-"/ suspended - which btw. should be avoided, since noone is there
-"/ to schedule processes then)
-"/ "
-"/
-"/ MiniDebugger enterWithMessage:'fatal dispatcher should never be suspended'.
-"/
-"/ "try to repair by just resuming ..."
-"/ activeProcess resume
!
yield
@@ -647,22 +585,22 @@
debugging consistency checks - will be removed later
"
l isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - nil runnable list' errorPrintNL.
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'oops - nil runnable list' errorPrintNL.
+ ^ self
].
l isEmpty ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'oops - empty runnable list' errorPrintNL.
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'oops - empty runnable list' errorPrintNL.
+ ^ self
].
l size == 1 ifTrue:[
- "
- the running one is the only one
- "
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
+ "
+ the running one is the only one
+ "
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
].
"
@@ -690,17 +628,18 @@
some debugging stuff
"
aProcess isNil ifTrue:[
- MiniDebugger enterWithMessage:'nil suspend'.
- ^ self
+ MiniDebugger enterWithMessage:'nil suspend'.
+ ^ self
].
aProcess id isNil ifTrue:[
- MiniDebugger enterWithMessage:'bad suspend: already dead'.
- self reschedule.
- ^ self
+ MiniDebugger enterWithMessage:'bad suspend: already dead'.
+ self threadSwitch:scheduler.
+ ^ self
].
aProcess == scheduler ifTrue:[
- MiniDebugger enterWithMessage:'scheduler should never be suspended'.
- ^ self
+ 'scheduler should never be suspended' printNL.
+ "/ MiniDebugger enterWithMessage:'scheduler should never be suspended'.
+ ^ self
].
wasBlocked := OperatingSystem blockInterrupts.
@@ -712,45 +651,44 @@
debugging consisteny checks - will be removed later
"
l isNil ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- 'bad suspend: empty run list' printNL.
- "/ MiniDebugger enterWithMessage:'bad suspend: empty run list'.
- self reschedule.
- ^ self
+ 'bad suspend: empty run list' printNL.
+ "/ MiniDebugger enterWithMessage:'bad suspend: empty run list'.
+ self threadSwitch:scheduler.
+ ^ self
].
l remove:aProcess ifAbsent:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- MiniDebugger enterWithMessage:'bad suspend: not on run list'.
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ 'bad suspend: not on run list' printNL.
+ "/ MiniDebugger enterWithMessage:'bad suspend: not on run list'.
+ self threadSwitch:scheduler.
+ ^ self
].
l isEmpty ifTrue:[
- quiescentProcessLists at:pri put:nil.
- l := nil
+ quiescentProcessLists at:pri put:nil.
+ l := nil
].
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.
+ 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 ...
"
- s := aProcess state.
- ((s == #active) or:[s == #run]) ifTrue:[
- aProcess state:#suspended.
- ].
+ aProcess setStateTo:#suspended if:#active or:#run.
+
(aProcess == activeProcess) ifTrue:[
- "we can immediately switch sometimes"
- l notNil ifTrue:[
- p := l first
- ] ifFalse:[
- p := scheduler
- ].
- self threadSwitch:p
-"/ self reschedule
+ "we can immediately switch sometimes"
+ l notNil ifTrue:[
+ p := l first
+ ] ifFalse:[
+ p := scheduler
+ ].
+ self threadSwitch:p
].
!
@@ -772,28 +710,28 @@
l := quiescentProcessLists at:pri.
l isNil ifTrue:[
- l := LinkedList new.
- quiescentProcessLists at:pri put:l
+ l := LinkedList new.
+ quiescentProcessLists at:pri put:l
] ifFalse:[
- "if already running, ignore"
- (l includes:aProcess) ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ]
+ "if already running, ignore"
+ (l includes:aProcess) 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
+ "
+ 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
+ "
+ its prio is lower; it will have to wait for a while ...
+ "
+ aProcess state:#run
]
!
@@ -816,36 +754,40 @@
l := quiescentProcessLists at:pri.
l isNil ifTrue:[
- l := LinkedList new.
- quiescentProcessLists at:pri put:l
+ l := LinkedList new.
+ quiescentProcessLists at:pri put:l
] ifFalse:[
- "if already running, ignore"
- (l includes:aProcess) ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
- ]
+ "if already running, ignore"
+ (l includes:aProcess) 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
- "
+ "
+ its prio is higher; immediately transfer control to it
+ "
"/ activeProcess state:#run.
- self threadSwitch:aProcess
+ self threadSwitch:aProcess
] ifFalse:[
- "
- its prio is lower; it will have to wait for a while ...
- "
- aProcess state:#suspended
+ "
+ its prio is lower; it will have to wait for a while ...
+ "
+ aProcess state:#suspended
]
!
-terminate:aProcess
- "terminate aProcess. If its not the current process, its simply
- removed from its list and destroyed. Otherwise, a switch is forced
- and the process is destroyed by the next running process."
+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|
@@ -853,8 +795,8 @@
id := aProcess id.
id isNil ifTrue:[^ self]. "already dead"
- aProcess setId:nil.
- aProcess startBlock:nil.
+ aProcess setId:nil state:#dead.
+"/ aProcess setStartBlock:nil.
wasBlocked := OperatingSystem blockInterrupts.
@@ -863,48 +805,58 @@
pri := aProcess priority.
l := quiescentProcessLists at:pri.
(l notNil and:[l includes:aProcess]) ifTrue:[
- l remove:aProcess.
- l isEmpty ifTrue:[quiescentProcessLists at:pri put:nil].
+ l remove:aProcess.
+ l isEmpty ifTrue:[quiescentProcessLists at:pri put:nil].
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- aProcess exitAction notNil ifTrue:[
- aProcess exitAction value.
- aProcess exitAction:nil
- ].
-
- aProcess state:#dead.
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.
-"/ self reschedule.
- ^ self
+ "
+ 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
!
-processTermination
- "current process finished its startup block without termination,
- lay him to rest now."
+terminateActiveNoSignal
+ "hard terminate the active process, without sending any
+ terminate signal thus no unwind blocks are evaluated."
+
+ self terminateNoSignal:activeProcess
+!
- self terminate: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
-"/ self reschedule
+!
+
+terminate:aProcess
+ "terminate aProcess. This is deon 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 currently running process kills itself)"
+ "terminate the current process (i.e. the currently running process kills itself).
+ The active process is sent the terminateSignal so it will evaluate any
+ unwind blocks."
- self terminate:activeProcess
+ activeProcess terminate
!
interruptActive
@@ -926,11 +878,11 @@
"
newPrio := prio.
newPrio < 1 ifTrue:[
- newPrio := 1.
+ newPrio := 1.
] ifFalse:[
- newPrio >= SchedulingPriority ifTrue:[
- newPrio := SchedulingPriority - 1
- ]
+ newPrio >= SchedulingPriority ifTrue:[
+ newPrio := SchedulingPriority - 1
+ ]
].
wasBlocked := OperatingSystem blockInterrupts.
@@ -939,8 +891,8 @@
oldList := quiescentProcessLists at:oldPrio.
(oldList isNil or:[(oldList includes:aProcess) not]) ifTrue:[
- wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
- ^ self
+ wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
+ ^ self
].
oldList remove:aProcess.
@@ -948,8 +900,8 @@
newList := quiescentProcessLists at:newPrio.
newList isNil ifTrue:[
- newList := LinkedList new.
- quiescentProcessLists at:newPrio put:newList
+ newList := LinkedList new.
+ quiescentProcessLists at:newPrio put:newList
].
newList addLast:aProcess.
@@ -957,16 +909,15 @@
or another one raising, we have to reschedule"
aProcess == activeProcess ifTrue:[
- currentPriority := newPrio.
- newPrio < oldPrio ifTrue:[
- self threadSwitch:scheduler.
-"/ self reschedule.
- ]
+ currentPriority := newPrio.
+ newPrio < oldPrio ifTrue:[
+ self threadSwitch:scheduler.
+ ]
] ifFalse:[
- newPrio > currentPriority ifTrue:[
+ newPrio > currentPriority ifTrue:[
"/ activeProcess state:#run.
- self threadSwitch:aProcess.
- ]
+ self threadSwitch:aProcess.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
@@ -983,7 +934,7 @@
activePriority
"return the priority of the currently running process.
- GNU-ST compatibility; this is the same as currentPriority"
+ GNU-ST & ST-80 compatibility; this is the same as currentPriority"
^ currentPriority
!
@@ -1005,26 +956,26 @@
maxPri := self highestPriority.
maxPri to:1 by:-1 do:[:prio |
- l := quiescentProcessLists at:prio.
- l notNil ifTrue:[
- l isEmpty ifTrue:[
- "
- on the fly clear out empty lists
- "
- quiescentProcessLists at:prio put:nil
- ] ifFalse:[
- p := l first.
- "
- if it got corrupted somehow
- "
- p id isNil ifTrue:[
- 'process with nil id removed' printNL.
- l removeFirst.
- ^ nil.
- ].
- ^ p
- ].
- ]
+ l := quiescentProcessLists at:prio.
+ l notNil ifTrue:[
+ l isEmpty ifTrue:[
+ "
+ on the fly clear out empty lists
+ "
+ quiescentProcessLists at:prio put:nil
+ ] ifFalse:[
+ p := l first.
+ "
+ if it got corrupted somehow
+ "
+ p id isNil ifTrue:[
+ 'process with nil id removed' printNL.
+ l removeFirst.
+ ^ nil.
+ ].
+ ^ p
+ ].
+ ]
].
^ nil
! !
@@ -1042,7 +993,7 @@
of the dispatch-handling code in the running system.
"
[true] whileTrue:[
- self dispatch
+ self dispatch
]
!
@@ -1057,7 +1008,7 @@
handle all timeout actions
"
anyTimeouts ifTrue:[
- self evaluateTimeouts
+ self evaluateTimeouts
].
"first do a quick check using checkActions - this is needed for
@@ -1067,26 +1018,26 @@
any := false.
nActions := readChecks size.
1 to:nActions do:[:index |
- |checkBlock sema action|
+ |checkBlock sema action|
- checkBlock := readChecks at:index.
- (checkBlock notNil and:[checkBlock value]) ifTrue:[
- sema := readSemaphores at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ].
- any := true.
- ]
+ checkBlock := readChecks at:index.
+ (checkBlock notNil and:[checkBlock value]) ifTrue:[
+ sema := readSemaphores at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ ].
+ any := true.
+ ]
].
"now, someone might be runnable:"
p := self highestPriorityRunnableProcess.
p isNil ifTrue:[
- "no one runnable, hard wait for event or timeout"
+ "no one runnable, hard wait for event or timeout"
- self waitForEventOrTimeout.
- ^ self
+ self waitForEventOrTimeout.
+ ^ self
].
pri := p priority.
@@ -1113,10 +1064,10 @@
"
pri < TimingPriority ifTrue:[
- anyTimeouts ifTrue:[
- millis := self timeToNextTimeout.
- millis == 0 ifTrue:[^ self].
- ]
+ anyTimeouts ifTrue:[
+ millis := self timeToNextTimeout.
+ millis == 0 ifTrue:[^ self].
+ ]
].
"
@@ -1129,30 +1080,30 @@
pri < UserInterruptPriority ifTrue:[
"comment out this if above is uncommented"
- anyTimeouts ifTrue:[
- millis := self timeToNextTimeout.
- millis == 0 ifTrue:[^ self].
- ].
+ anyTimeouts ifTrue:[
+ millis := self timeToNextTimeout.
+ millis == 0 ifTrue:[^ self].
+ ].
"---"
- OperatingSystem supportsIOInterrupts ifTrue:[
- readFds do:[:fd |
- fd notNil ifTrue:[
- OperatingSystem enableIOInterruptsOn:fd
- ].
- ].
- ] ifFalse:[
- millis notNil ifTrue:[
- millis := millis min:50
- ] ifFalse:[
- millis := 50
- ]
- ]
+ OperatingSystem supportsIOInterrupts ifTrue:[
+ readFds do:[:fd |
+ fd notNil ifTrue:[
+ OperatingSystem enableIOInterruptsOn:fd
+ ].
+ ].
+ ] ifFalse:[
+ millis notNil ifTrue:[
+ millis := millis min:50
+ ] ifFalse:[
+ millis := 50
+ ]
+ ]
].
millis notNil ifTrue:[
- "schedule a clock interrupt after millis milliseconds"
- OperatingSystem enableTimer:millis rounded.
+ "schedule a clock interrupt after millis milliseconds"
+ OperatingSystem enableTimer:millis rounded.
].
"now let the process run - will come back here by reschedule
@@ -1164,25 +1115,25 @@
"... when we arrive here, we are back on stage"
millis notNil ifTrue:[
- OperatingSystem disableTimer.
- self checkForInputWithTimeout:0.
+ OperatingSystem disableTimer.
+ self checkForInputWithTimeout:0.
]
! !
!ProcessorScheduler methodsFor:'waiting'!
ioInterrupt
- "data arrived while waiting - reschedule to bring dispatcher into play"
+ "data arrived while waiting - switch to scheduler process which will decide
+ what to do now."
self threadSwitch:scheduler
-"/ self reschedule
!
timerInterrupt
- "timer expired while waiting - reschedule to bring dispatcher into play"
+ "timer expired while waiting - switch to scheduler process which will decide
+ what to do now."
self threadSwitch:scheduler
-"/ self reschedule
!
timeToNextTimeout
@@ -1197,17 +1148,17 @@
n := timeouts size.
1 to:n do:[:index |
- aTime := timeouts at:index.
- aTime notNil ifTrue:[
- minDelta isNil ifTrue:[
- now := OperatingSystem getMillisecondTime.
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
- minDelta := OperatingSystem millisecondTimeDeltaBetween:aTime and:now.
- ] ifFalse:[
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
- minDelta := minDelta min:(OperatingSystem millisecondTimeDeltaBetween:aTime and:now)
- ]
- ]
+ aTime := timeouts at:index.
+ aTime notNil ifTrue:[
+ minDelta isNil ifTrue:[
+ now := OperatingSystem getMillisecondTime.
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
+ minDelta := OperatingSystem millisecondTimeDeltaBetween:aTime and:now.
+ ] ifFalse:[
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[^ 0].
+ minDelta := minDelta min:(OperatingSystem millisecondTimeDeltaBetween:aTime and:now)
+ ]
+ ]
].
^ minDelta
@@ -1224,54 +1175,54 @@
doingGC := true.
[doingGC] whileTrue:[
- anyTimeouts ifTrue:[
- millis := self timeToNextTimeout.
- (millis notNil and:[millis <= 0]) ifTrue:[
- ^ self "oops - hurry up checking"
- ].
- ].
+ anyTimeouts ifTrue:[
+ millis := self timeToNextTimeout.
+ (millis notNil and:[millis <= 0]) ifTrue:[
+ ^ self "oops - hurry up checking"
+ ].
+ ].
- "if its worth doing, collect a bit of garbage"
- limit := ObjectMemory incrementalGCLimit.
- doingGC := limit notNil and:[ObjectMemory oldSpaceAllocatedSinceLastGC > limit].
- doingGC ifTrue:[
- ObjectMemory gcStep.
- ].
+ "if its worth doing, collect a bit of garbage"
+ limit := ObjectMemory incrementalGCLimit.
+ doingGC := limit notNil and:[ObjectMemory oldSpaceAllocatedSinceLastGC > limit].
+ doingGC ifTrue:[
+ ObjectMemory gcStep.
+ ].
- "then do idle actions"
- (idleActions size ~~ 0) ifTrue:[
- idleActions do:[:aBlock |
- aBlock value.
- ].
- ^ self "go back checking"
- ].
+ "then do idle actions"
+ (idleActions size ~~ 0) ifTrue:[
+ idleActions do:[:aBlock |
+ aBlock value.
+ ].
+ ^ self "go back checking"
+ ].
- doingGC ifTrue:[
- (self checkForInputWithTimeout:0) ifTrue:[
- ^ self "go back checking"
- ]
- ]
+ doingGC ifTrue:[
+ (self checkForInputWithTimeout:0) ifTrue:[
+ ^ self "go back checking"
+ ]
+ ]
].
(self checkForInputWithTimeout:0) ifTrue:[
- ^ self "go back checking"
+ ^ self "go back checking"
].
"no, really nothing to do - simply wait"
OperatingSystem supportsSelect ifFalse:[
- "SCO instant ShitStation has a bug here,
- waiting always 1 sec in the select - therefore we delay a bit and
- return - effectively polling in 50ms cycles
- "
- OperatingSystem millisecondDelay:50.
- ^ self
+ "SCO instant ShitStation has a bug here,
+ waiting always 1 sec in the select - therefore we delay a bit and
+ return - effectively polling in 50ms cycles
+ "
+ OperatingSystem millisecondDelay:50.
+ ^ self
].
millis isNil ifTrue:[
- millis := 9999.
+ millis := 9999.
] ifFalse:[
- millis := millis rounded
+ millis := millis rounded
].
self checkForInputWithTimeout:millis
!
@@ -1283,84 +1234,27 @@
|fd index sema action|
fd := OperatingSystem
- selectOnAnyReadable:readFds
- writable:writeFds
- exception:nil
- withTimeOut:millis.
+ selectOnAnyReadable:readFds
+ writable:writeFds
+ exception:nil
+ withTimeOut:millis.
fd notNil ifTrue:[
- index := readFds indexOf:fd.
- index ~~ 0 ifTrue:[
- sema := readSemaphores at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- ^ true
- ] ifFalse:[
- action := readChecks at:index.
- action notNil ifTrue:[
- action value.
- ^ true
- ]
- ]
- ]
+ index := readFds indexOf:fd.
+ index ~~ 0 ifTrue:[
+ sema := readSemaphores at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ ^ true
+ ] ifFalse:[
+ action := readChecks at:index.
+ action notNil ifTrue:[
+ action value.
+ ^ true
+ ]
+ ]
+ ]
].
^ false
-!
-
-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 := timeouts size.
- anyTimeouts := false.
- 1 to:n do:[:index |
- aTime := timeouts at:index.
- aTime notNil ifTrue:[
- (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
- "this one should be triggered"
-
- sema := timeoutSemaphores at:index.
- sema notNil ifTrue:[
- sema signalOnce.
- timeoutSemaphores at:index put:nil
- ] ifFalse:[
- "to support pure-events"
- block := timeoutActions at:index.
- block notNil ifTrue:[
- blocksToEvaluate isNil ifTrue:[
- blocksToEvaluate := OrderedCollection new:10.
- processes := OrderedCollection new:10.
- ].
- blocksToEvaluate add:block.
- processes add:(timeoutProcesses at:index).
- timeoutActions at:index put:nil.
- timeoutProcesses at:index put:nil.
- ]
- ].
- timeouts at:index put:nil.
- ] ifTrue:[
- anyTimeouts := true
- ]
- ]
- ].
-
- blocksToEvaluate notNil ifTrue:[
- 1 to:blocksToEvaluate size do:[:index |
- PureEventDriven ifTrue:[
- (blocksToEvaluate at:index) value
- ] ifFalse:[
- (processes at:index) interruptWith:(blocksToEvaluate at:index)
- ]
- ]
- ]
! !
!ProcessorScheduler methodsFor:'semaphore signalling'!
@@ -1382,16 +1276,16 @@
wasBlocked := OperatingSystem blockInterrupts.
(readFds includes:aFileDescriptor) ifFalse:[
- idx := readFds indexOf:nil.
- idx ~~ 0 ifTrue:[
- readFds at:idx put:aFileDescriptor.
- readSemaphores at:idx put:aSemaphore.
- readChecks at:idx put:aBlock
- ] ifFalse:[
- readFds := readFds copyWith:aFileDescriptor.
- readSemaphores := readSemaphores copyWith:aSemaphore.
- readChecks := readChecks copyWith:aBlock.
- ]
+ idx := readFds indexOf:nil.
+ idx ~~ 0 ifTrue:[
+ readFds at:idx put:aFileDescriptor.
+ readSemaphores at:idx put:aSemaphore.
+ readChecks at:idx put:aBlock
+ ] ifFalse:[
+ readFds := readFds copyWith:aFileDescriptor.
+ readSemaphores := readSemaphores copyWith:aSemaphore.
+ readChecks := readChecks copyWith:aBlock.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1404,14 +1298,14 @@
wasBlocked := OperatingSystem blockInterrupts.
(writeFds includes:aFileDescriptor) ifFalse:[
- idx := writeFds indexOf:nil.
- idx ~~ 0 ifTrue:[
- writeFds at:idx put:aFileDescriptor.
- writeSemaphores at:idx put:aSemaphore.
- ] ifFalse:[
- writeFds := writeFds copyWith:aFileDescriptor.
- writeSemaphores := writeSemaphores copyWith:aSemaphore.
- ]
+ idx := writeFds indexOf:nil.
+ idx ~~ 0 ifTrue:[
+ writeFds at:idx put:aFileDescriptor.
+ writeSemaphores at:idx put:aSemaphore.
+ ] ifFalse:[
+ writeFds := writeFds copyWith:aFileDescriptor.
+ writeSemaphores := writeSemaphores copyWith:aSemaphore.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1442,20 +1336,20 @@
wasBlocked := OperatingSystem blockInterrupts.
index := timeoutSemaphores identityIndexOf:aSemaphore.
index ~~ 0 ifTrue:[
- timeouts at:index put:aMillisecondTime
+ timeouts at:index put:aMillisecondTime
] ifFalse:[
- index := timeouts indexOf:nil.
- index ~~ 0 ifTrue:[
- timeoutSemaphores at:index put:aSemaphore.
- timeouts at:index put:aMillisecondTime.
- timeoutActions at:index put:nil.
- timeoutProcesses at:index put:nil
- ] ifFalse:[
- timeoutSemaphores := timeoutSemaphores copyWith:aSemaphore.
- timeouts := timeouts copyWith:aMillisecondTime.
- timeoutActions := timeoutActions copyWith:nil.
- timeoutProcesses := timeoutProcesses copyWith:nil
- ].
+ index := timeouts indexOf:nil.
+ index ~~ 0 ifTrue:[
+ timeoutSemaphores at:index put:aSemaphore.
+ timeouts at:index put:aMillisecondTime.
+ timeoutActions at:index put:nil.
+ timeoutProcesses at:index put:nil
+ ] ifFalse:[
+ timeoutSemaphores := timeoutSemaphores copyWith:aSemaphore.
+ timeouts := timeouts copyWith:aMillisecondTime.
+ timeoutActions := timeoutActions copyWith:nil.
+ timeoutProcesses := timeoutProcesses copyWith:nil
+ ].
].
anyTimeouts := true.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -1469,16 +1363,21 @@
wasBlocked := OperatingSystem blockInterrupts.
idx := readSemaphores identityIndexOf:aSemaphore.
idx ~~ 0 ifTrue:[
- readFds at:idx put:nil.
- readSemaphores at:idx put:nil.
- readChecks at:idx put:nil
+ readFds at:idx put:nil.
+ readSemaphores at:idx put:nil.
+ readChecks at:idx put:nil
+ ].
+ idx := writeSemaphores identityIndexOf:aSemaphore.
+ idx ~~ 0 ifTrue:[
+ writeFds at:idx put:nil.
+ writeSemaphores at:idx put:nil.
].
idx := timeoutSemaphores identityIndexOf:aSemaphore.
idx ~~ 0 ifTrue:[
- timeouts at:idx put:nil.
- timeoutSemaphores at:idx put:nil.
- timeoutActions at:idx put:nil.
- timeoutProcesses at:idx put:nil.
+ timeouts at:idx put:nil.
+ timeoutSemaphores at:idx put:nil.
+ timeoutActions at:idx put:nil.
+ timeoutProcesses at:idx put:nil.
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
@@ -1490,16 +1389,16 @@
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. They have been implemented to support
- background actions in pure-event systems, where no processes are
- available.
+ 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 := OrderedCollection new
].
idleActions add:aBlock.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -1520,7 +1419,7 @@
!ProcessorScheduler methodsFor:'I/O event actions'!
-enableIOAction:aBlock on:aFileDescriptor
+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."
@@ -1529,16 +1428,16 @@
wasBlocked := OperatingSystem blockInterrupts.
(readFds includes:aFileDescriptor) ifFalse:[
- idx := readFds indexOf:nil.
- idx ~~ 0 ifTrue:[
- readFds at:idx put:aFileDescriptor.
- readChecks at:idx put:aBlock.
- readSemaphores at:idx put:nil
- ] ifFalse:[
- readFds := readFds copyWith:aFileDescriptor.
- readChecks := readChecks copyWith:aBlock.
- readSemaphores := readSemaphores copyWith:nil.
- ]
+ idx := readFds indexOf:nil.
+ idx ~~ 0 ifTrue:[
+ readFds at:idx put:aFileDescriptor.
+ readChecks at:idx put:aBlock.
+ readSemaphores at:idx put:nil
+ ] ifFalse:[
+ readFds := readFds copyWith:aFileDescriptor.
+ readChecks := readChecks copyWith:aBlock.
+ readSemaphores := readSemaphores copyWith:nil.
+ ]
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
!
@@ -1552,21 +1451,21 @@
wasBlocked := OperatingSystem blockInterrupts.
idx := readFds indexOf:aFileDescriptor.
idx ~~ 0 ifTrue:[
- readFds at:idx put:nil.
- readChecks at:idx put:nil.
- readSemaphores at:idx put:nil
+ readFds at:idx put:nil.
+ readChecks at:idx put:nil.
+ readSemaphores at:idx put:nil
].
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
! !
-!ProcessorScheduler methodsFor:'timed block'!
+!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 for the execution).
+ 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)."
@@ -1578,7 +1477,9 @@
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 for the execution).
+ 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)."
@@ -1590,7 +1491,7 @@
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 for the execution).
+ 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)."
@@ -1599,10 +1500,12 @@
addTimedBlock:aBlock for:aProcess afterMilliseconds:delta
"add the argument, aBlock to the list of time-scheduled-blocks; to be
- evaluated after delta milliseconds. aProcess will be interrupted for
- execution of the block.
+ 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 for the execution).
+ 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)."
@@ -1621,7 +1524,7 @@
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 for the execution).
+ 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)."
@@ -1631,10 +1534,12 @@
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.
- aProcess will be interrupted for execution of the block.
+ aMillisecondTime. 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 it is running, the interrupt will occur in whatever method it is
- executing; if it is suspended, it will be resumed for the execution).
+ 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)."
@@ -1643,20 +1548,20 @@
wasBlocked := OperatingSystem blockInterrupts.
index := timeoutActions identityIndexOf:aBlock.
index ~~ 0 ifTrue:[
- timeouts at:index put:aMillisecondTime
+ timeouts at:index put:aMillisecondTime
] ifFalse:[
- index := timeouts indexOf:nil.
- index ~~ 0 ifTrue:[
- timeouts at:index put:aMillisecondTime.
- timeoutActions at:index put:aBlock.
- timeoutSemaphores at:index put:nil.
- timeoutProcesses at:index put:aProcess
- ] ifFalse:[
- timeouts := timeouts copyWith:aMillisecondTime.
- timeoutActions := timeoutActions copyWith:aBlock.
- timeoutSemaphores := timeoutSemaphores copyWith:nil.
- timeoutProcesses := timeoutProcesses copyWith:aProcess.
- ].
+ index := timeouts indexOf:nil.
+ index ~~ 0 ifTrue:[
+ timeouts at:index put:aMillisecondTime.
+ timeoutActions at:index put:aBlock.
+ timeoutSemaphores at:index put:nil.
+ timeoutProcesses at:index put:aProcess
+ ] ifFalse:[
+ timeouts := timeouts copyWith:aMillisecondTime.
+ timeoutActions := timeoutActions copyWith:aBlock.
+ timeoutSemaphores := timeoutSemaphores copyWith:nil.
+ timeoutProcesses := timeoutProcesses copyWith:aProcess.
+ ].
].
anyTimeouts := true.
wasBlocked ifFalse:[OperatingSystem unblockInterrupts].
@@ -1670,10 +1575,70 @@
wasBlocked := OperatingSystem blockInterrupts.
index := timeoutActions identityIndexOf:aBlock.
(index ~~ 0) ifTrue:[
- timeouts at:index put:nil.
- timeoutActions at:index put:nil.
- timeoutSemaphores at:index put:nil.
- timeoutProcesses at:index put:nil.
+ timeouts at:index put:nil.
+ timeoutActions at:index put:nil.
+ timeoutSemaphores at:index put:nil.
+ timeoutProcesses 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 := timeouts size.
+ anyTimeouts := false.
+ 1 to:n do:[:index |
+ aTime := timeouts at:index.
+ aTime notNil ifTrue:[
+ (OperatingSystem millisecondTime:aTime isAfter:now) ifFalse:[
+ "this one should be triggered"
+
+ sema := timeoutSemaphores at:index.
+ sema notNil ifTrue:[
+ sema signalOnce.
+ timeoutSemaphores at:index put:nil
+ ] ifFalse:[
+ "to support pure-events"
+ block := timeoutActions at:index.
+ block notNil ifTrue:[
+ blocksToEvaluate isNil ifTrue:[
+ blocksToEvaluate := OrderedCollection new:10.
+ processes := OrderedCollection new:10.
+ ].
+ blocksToEvaluate add:block.
+ processes add:(timeoutProcesses at:index).
+ timeoutActions at:index put:nil.
+ timeoutProcesses at:index put:nil.
+ ]
+ ].
+ timeouts at:index put:nil.
+ ] ifTrue:[
+ anyTimeouts := true
+ ]
+ ]
+ ].
+
+ blocksToEvaluate notNil ifTrue:[
+ blocksToEvaluate keysAndValuesDo:[:index :block |
+ |p|
+
+ p := processes at:index.
+ (p isNil or:[PureEventDriven]) ifTrue:[
+ block value
+ ] ifFalse:[
+ p interruptWith:block
+ ]
+ ]
+ ]
! !