"
 COPYRIGHT (c) 1993 by Claus Gittinger
              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
 inclusion of the above copyright notice.   This software may not
 be provided or otherwise made available to, or used by, any
 other person.  No title to or ownership of the software is
 hereby transferred.
"

Object subclass:#ProcessorScheduler
         instanceVariableNames:'runnable zombie
                                currentProcess currentPriority
                                fileDescriptors fileHandlers fileSelectors
                                timeoutTimes timeHandlers timeSelectors'
         classVariableNames:'KnownProcesses KnownProcessIds'
         poolDictionaries:''
         category:'Kernel-Processes'
!

ProcessorScheduler comment:'

COPYRIGHT (c) 1993 by Claus Gittinger
             All Rights Reserved

%W% %E%
'!

Smalltalk at:#Processor put:nil!

!ProcessorScheduler class methodsFor:'initialization'!

initialize
    KnownProcesses isNil ifTrue:[
        KnownProcesses := ShadowArray new:5.
        KnownProcesses watcher:self.
        KnownProcessIds := OrderedCollection new.

        "want to get informed when returning from snapshot"
        ObjectMemory addDependent:self
    ].

    "create the one and only processor"

    Processor := self new
!

update:something
    something == #returnFromSnapshot ifTrue:[
        self reinstallProcesses
    ]
!

reinstallProcesses
    "recreate all processes after a snapShot load"

   KnownProcesses do:[:p |
        p notNil ifTrue:[
            "how, exactly should this be done ?"

            p id ~~ 0 ifTrue:[
                Transcript showCr:'process restart in preparation'
            ]
        ]
    ]
! !

!ProcessorScheduler class methodsFor:'private process primitives'!

threadCreate:aBlock
    "physical creation of a process executing aBlock.
     (warning: low level entry, no administration done)"
%{
    int tid;
    extern int __threadCreate();

    tid = __threadCreate(aBlock);
    if (tid != 0) {
        RETURN ( _MKSMALLINT(tid));
    }
    RETURN (nil);
%}
!

threadDestroy:id
    "physical destroy other process ...
     (warning: low level entry, no administration done)"

%{
    if (_isSmallInteger(id)) {
        __threadDestroy(_intVal(id));
    }
%}
.
    self primitiveFailed
! !

!ProcessorScheduler class methodsFor:'instance release'!

informDispose
    "some Process has been collected - terminate the underlying thread"

    |id
     index "<SmallInteger>"
     sz    "<SmallInteger>"|

    index := 1.
    sz := KnownProcessIds size.
    [index <= sz] whileTrue:[
        (KnownProcesses at:index) isNil ifTrue:[
            id := KnownProcessIds at:index.
            id notNil ifTrue:[
                Transcript showCr:('terminate thread (no longer refd) ', id printString).
                self threadDestroy:id.
                KnownProcessIds at:index put:nil.
            ]
        ].
        index := index + 1
    ]
! !

!ProcessorScheduler class methodsFor:'instance creation'!

new
    "there is (currently) only one processor ..."

    Processor notNil ifTrue:[^ Processor].
    ^ self basicNew initialize.
! !

!ProcessorScheduler methodsFor:'constants'!

minPriority
    ^ 1
!

maxPriority
    ^ 31
!

userInterruptPriority
    ^ 24
!

timingPriority
    ^ 16
!

userSchedulingPriority
    ^ 8
!

userBackgroundPriority
    ^ 6
!

systemBackgroundPriority
    ^ 4
! !

!ProcessorScheduler methodsFor:'private initializing'!

initialize
    "initialize the one-and-only ProcessorScheduler"

    |nPrios l|

    nPrios := self maxPriority - self minPriority + 1.

    runnable := Array new:nPrios.

    "setup the first (init-) process"
    currentProcess := Process new.
    currentProcess id:0.
    currentProcess state:#running.
    currentPriority := self userSchedulingPriority.
    currentProcess setPriority:currentPriority.

    l := LinkedList new.
    l add:currentProcess.

    runnable at:currentPriority put:l.

    IOInterruptHandler := self.
    OperatingSystem enableIOInterrupts.
! !

!ProcessorScheduler methodsFor:'private'!

remember:aProcess
    |newShadow newSize oldSize oldId
     index "<SmallInteger>"
     sz    "<SmallInteger>" |

    index := 1.
    sz := KnownProcessIds size.
    [index <= sz] whileTrue:[
        (KnownProcesses at:index) isNil ifTrue:[
            oldId := KnownIds at:index.
            oldId notNil ifTrue:[
                self class terminateProcess:oldId
            ].
            KnownProcesses at:index put:aProcess.
            KnownProcessIds at:index put:aProcess id.
            ^ self
        ].
        index := index + 1
    ].

    KnownProcessIds grow:index.
    KnownProcessIds at:index put:aProcess id.

    oldSize := KnownProcesses size.
    (index > oldSize) ifTrue:[
        newShadow := ShadowArray new:(oldSize * 2).
        newShadow watcher:(KnownProcesses watcher).
        newShadow replaceFrom:1 with:KnownProcesses.
        KnownProcesses := newShadow
    ].
    KnownProcesses at:index put:aProcess 
! !

!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."

    |id p|

    id := self class threadCreate:aBlock.
    id notNil ifTrue:[
        p := Process new.
        p id:id.
        p startBlock:aBlock.
        p state:#suspended.
        p setPriority:currentPriority.
        self remember:p.
    ].
    ^ p
! !

!ProcessorScheduler methodsFor:'scheduling'!

switchTo:aProcess
    "continue execution in aProcess."

    |id pri|

    aProcess isNil ifTrue:[^ self].
    aProcess == currentProcess ifTrue:[^ self].

    id := aProcess id.
    pri := aProcess priority.
    currentProcess state:#runnable.

    "no interrupts now ..."
    currentProcess := aProcess.
    currentProcess state:#running.
    currentPriority := pri.
%{
    __threadSwitch(__context, _intVal(id));
%}
.
    zombie notNil ifTrue:[
        self class threadDestroy:zombie.
        zombie := nil
    ]
!

reschedule
    "switch to the highest prio runnable process"

    |l|

    self maxPriority to:self minPriority by:-1 do:[:prio |
        l := runnable at:prio.
        l notNil ifTrue:[
            ^ self switchTo:(l first)
        ]
    ].
    "no process to run - wait to next time event"

    'wait' printNewline.
    self waitForNextTimeout
!

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|

    l := runnable at:currentPriority.
    l isNil ifTrue:[
        'oops - nil runnable list' printNewline.
        ^ self
    ].
    l removeFirst.
    l addLast:currentProcess.
    self reschedule
!

suspend:aProcess
    "remove the argument, aProcess from the list of runnable processes
     and put it to the list of suspended ones. If the process is the 
     currentProcess, reschedule."

    |pri l|

    aProcess isNil ifTrue:[self error:'nil suspend'. ^ self].
    pri := aProcess priority.

    l := runnable at:pri.
    l isNil ifTrue:[self error:'bad suspend'. ^ self].

    aProcess state:#suspended.
    l remove:aProcess ifAbsent:[self error:'bad suspend'. ^ self].

    (aProcess == currentProcess) ifTrue:[
        self reschedule
    ]
!

resume:aProcess
    "set aProcess runnable - if its prio is higher than the currently running prio,
     reschedule."

    |l pri|

    aProcess == currentProcess ifTrue:[^ self].
    aProcess isNil ifTrue:[^ self].
    pri := aProcess priority.

    aProcess state:#runnable.
    l := runnable at:pri.
    l isNil ifTrue:[
        l := LinkedList new.
        runnable at:pri put:l
    ].
    l addLast:aProcess.

    (pri > currentPriority) ifTrue:[
        self reschedule
    ]
!

processTermination
    "current process finished its startup block without termination,
     lay him to rest now"

    self terminate:currentProcess
!

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."

    |pri id l|

    aProcess isNil ifTrue:[^ self].
    id := aProcess id.
    id isNil ifTrue:[^ self].   "already dead"

    pri := aProcess priority.

    "easy, if currently suspended"
    ((aProcess state ~~ #runnable) and:[aProcess state ~~ #running]) ifTrue:[
         aProcess id:nil.
         aProcess state:#dead.
         aProcess startBlock:nil.
         self class threadDestroy:id.
         ^ self
    ].

    (aProcess state ~~ #runnable) ifTrue:[
        l := runnable at:pri.
        (l notNil and:[l includes:aProcess]) ifTrue:[
            l remove:aProcess.
            aProcess state:#dead.
            l isEmpty ifTrue:[runnable at:pri put:nil].
            aProcess == currentProcess ifFalse:[
                self class threadDestroy:id.
            ]
        ].
        ^ self
    ].

    (aProcess state ~~ #running) ifTrue:[
        "hard case - its the currently running process
         we must have the next active process destroy this one
        "
        aProcess state:#dead.
        zombie := id.
        self reschedule
    ]
!

changePriority:newPrio for:aProcess
    "change the priority of aProcess"

    |oldList newList oldPrio s|

    oldPrio := aProcess priority.
    oldPrio == newPrio ifTrue:[^ self].
    aProcess setPriority:newPrio.
    s := aProcess state.
    s == #runnable ifTrue:[
        oldList := runnable at:oldPrio.
        (oldList includes:aProcess) ifTrue:[
            oldList remove:aProcess
        ].

        newList := runnable at:newPrio.
        newList isNil ifTrue:[
            newList := LinkedList new.
            runnable at:newPrio put:newList
        ].
        newList addLast:aProcess.
        (aProcess ~~ currentProcess and:[newPrio > currentPriority]) ifTrue:[
            self reschedule.
        ].
        ^ self
    ]
! !

!ProcessorScheduler class methodsFor:'testing'!

test1
    |scheduler|

    scheduler := ProcessorScheduler new.
    scheduler addFileDescriptor:(Stdin fileDescriptor) withHandler:self selector:#inputAvailable.
    scheduler addFileDescriptor:(Display displayFileDescriptor) withHandler:self selector:#xInputAvailable.
    scheduler loop

    "ProcessorScheduler test1"
!

inputAvailable
    Transcript showCr:(Stdin nextLine)
!

xInputAvailable
    Transcript showCr:'x event'.
    Display dispatchEvent
! !

!ProcessorScheduler methodsFor:'scheduling'!

loop
    |looping nextTime waitTime fd index|

    looping := true.
    [looping] whileTrue:[
        "look if any timeouts are due to be evaluated"

        nextTime := nil.
        timeoutTimes notNil ifTrue:[
            nextTime := self evaluateTimeouts
        ].

        nextTime notNil ifTrue:[
            waitTime := OperatingSystem millisecondTimeDeltaBetween:nextTime
                                                                and:OperatingSystem getMillisecondTime
        ] ifFalse:[
            waitTime := nil
        ].

        (fileDescriptors size == 0) ifTrue:[
            waitTime isNil ifTrue:[
                Transcript showCr:'nothing to schedule'.
                ^ self
            ].

            "no fd to wait for - hard wait till next timeout has to come"
            OperatingSystem millisecondDelay:waitTime
        ] ifFalse:[
            "wait for any fd to become ready or next timeout has to come"
            waitTime isNil ifTrue:[waitTime := 10000].
            fd := OperatingSystem selectOnAnyReadable:fileDescriptors withTimeOut:(waitTime / 1000).
            fd isNil ifTrue:[
                "an interrupt or timeout occured"
                Transcript showCr:'interrupt or timeout'
            ] ifFalse:[
                "notify the handler"
                index := fileDescriptors identityIndexOf:fd.
                (fileHandlers at:index) perform:(fileSelectors at:index)
            ]
        ]
    ]
!

evaluateTimeouts
    "evaluate all timeouts that need to be .. and return the time of the
     next pending timeout"

    |now thisTime index endIndex handler selector nextTime|

    nextTime := nil.
    endIndex := timeoutTimes size.
    (endIndex ~~ 0) ifTrue:[
        now := OperatingSystem getMillisecondTime.
        index := 1.
        [index <= endIndex] whileTrue:[
            thisTime := timeoutTimes at:index.
            (OperatingSystem millisecondTime:thisTime isAfter:now) ifFalse:[
                handler := timeHandlers at:index.
                selector := timeSelectors at:index.
                timeoutTimes at:index put:nil.
                timeHandlers at:index put:nil.
                timeSelectors at:index put:nil.
                handler perform:selector
            ] ifTrue:[
                nextTime isNil ifTrue:[
                    nextTime := thisTime
                ] ifFalse:[
                    (OperatingSystem millisecondTime:nextTime isAfter:thisTime) ifTrue:[
                        nextTime := thisTime
                    ]
                ]
            ].
            index := index + 1
        ]
    ].
    ^ nextTime
! !

!ProcessorScheduler methodsFor:'accessing'!

currentPriority
    ^ currentPriority

    "Processor currentPriority"
!

currentProcess
    ^ currentProcess

    "Processor currentProcess"
!

addFileDescriptor:fd withHandler:handler selector:selector
    |index|

    fileDescriptors isNil ifTrue:[
        fileDescriptors := Array with:fd.
        fileHandlers := Array with:handler.
        fileSelectors := Array with:selector
    ] ifFalse:[
        index := fileDescriptors indexOf:nil.
        (index ~~ 0) ifTrue:[
            fileDescriptors at:index put:fd.
            fileHandlers at:index put:handler.
            fileSelectors at:index put:selector
        ] ifFalse:[
            fileDescriptors := fileDescriptors copyWith:fd.
            fileHandlers := fileHandlers copyWith:handler.
            fileSelectors := fileSelectors copyWith:selector
        ]
    ]
!

addTimeoutAfter:millis withHandler:handler selector:selector
    |index|

    fileDescriptors isNil ifTrue:[
        timeoutTimes := Array with:millis.
        timeHandlers := Array with:handler.
        timeSelectors := Array with:selector
    ] ifFalse:[
        index := timeoutTimes indexOf:nil.
        (index ~~ 0) ifTrue:[
            timeoutTimes at:index put:millis.
            timeHandlers at:index put:handler.
            timeSelectors at:index put:selector
        ] ifFalse:[
            timeoutTimes := fileDescriptors copyWith:millis.
            timeHandlers := fileHandlers copyWith:handler.
            timeSelectors := fileSelectors copyWith:selector
        ]
    ]
!

removeFileDescriptor:fd
    |index|

    index := fileDescriptors indexOf:nil.
    (index ~~ 0) ifTrue:[
        fileDescriptors at:index put:nil.
        fileHandlers at:index put:nil.
        fileSelectors at:index put:nil
    ]
! !