"

 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:'quiescentProcessLists

                                zombie

                                activeProcess currentPriority

                                readFds readSemaphores readChecks

                                writeFds writeSemaphores writeChecks

                                timeouts timeoutActions timeoutSemaphores

                                idleActions anyTimeouts dispatching

				timeoutProcess'

         classVariableNames:'KnownProcesses KnownProcessIds

                             PureEventDriven

                             UserSchedulingPriority TimingPriority'

         poolDictionaries:''

         category:'Kernel-Processes'

!

ProcessorScheduler comment:'

COPYRIGHT (c) 1993 by Claus Gittinger

             All Rights Reserved

'!

Smalltalk at:#Processor put:nil!

!ProcessorScheduler class methodsFor:'initialization'!

initialize

    "class setup: create the one-and-only instance of myself and

     setup some priority values."

    KnownProcesses isNil ifTrue:[

        KnownProcesses := WeakArray new:10.

        KnownProcesses watcher:self.

        KnownProcessIds := OrderedCollection new.

        "want to get informed when returning from snapshot"

        ObjectMemory addDependent:self

    ].

    Processor isNil ifTrue:[

        "create the one and only processor"

        Processor := self new.

    ].

    "

     allow configurations without processes

    "

    PureEventDriven := self threadsAvailable not.

    PureEventDriven ifTrue:[

        'no process support - running event driven' errorPrintNewline

    ].

    UserSchedulingPriority := 8.

    TimingPriority := 16.

!

update:something

    "being a dependent of the ObjectMemory, this is the notification

     that something happened"

    something == #returnFromSnapshot 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' errorPrintNewline

            ]

        ]

    ]

! !

!ProcessorScheduler class methodsFor:'instance creation'!

new

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

    Processor isNil ifTrue:[

        Processor := self basicNew initialize

    ].

    ^ Processor.

! !

!ProcessorScheduler class methodsFor:'instance release'!

informDispose

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

    |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 (no longer refd) ', id printString).

                self threadDestroy:id.

                KnownProcessIds at:index put:nil.

            ]

        ]

    ]

! !

!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

! !

!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 with:aBlock

    "make the process evaluate aBlock when it awakes the next time"

%{  /* NOCONTEXT */

    if (_isSmallInteger(id) && __isBlock(aBlock)) {

        __threadInterrupt(_intVal(id), aBlock);

    }

%}

!

threadCreate:aBlock

    "physical creation of a process executing aBlock.

     (warning: low level entry, no administration done).

     This may return nil, if process could not be created."

%{  /* NOCONTEXT */

    int tid;

    extern int __threadCreate();

    tid = __threadCreate(aBlock, 0 /* stackSize no longer needed */);

    if (tid != 0) {

        RETURN ( _MKSMALLINT(tid));

    }

%}

.

    "

     arrive here, if creation of process in VM failed.

     (no memory for process)

    "

    ObjectMemory allocationFailureSignal raise.

    ^ nil

!

threadDestroy:id

    "physical destroy other process ...

     (warning: low level entry, no administration done)"

%{  /* NOCONTEXT */

    if (_isSmallInteger(id)) {

        __threadDestroy(_intVal(id));

    }

%}

! !

!ProcessorScheduler methodsFor:'primitive process primitives'!

threadSwitch:aProcess

    "continue execution in aProcess.

     (warning: low level entry, no administration is done here)"

    |id pri ok oldProcess oldPri p|

    aProcess isNil ifTrue:[^ self].

    aProcess == activeProcess ifTrue:[^ self].

    oldProcess := activeProcess.

    oldPri := currentPriority.

    id := aProcess id.

    pri := aProcess priority.

    aProcess state:#active.

    "no interrupts now - activeProcess has already been changed

     (dont add any message sends here)"

    activeProcess := aProcess.

    currentPriority := pri.

%{

    extern OBJ __threadSwitch();

    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.

	]

    ].

    zombie notNil ifTrue:[

        self class threadDestroy:zombie.

        zombie := nil

    ]

!

scheduleForInterrupt:aProcess

    "make aProcess evaluate its pushedInterrupt block(s)"

    |id|

    aProcess isNil ifTrue:[^ self].

    aProcess == activeProcess ifTrue:[^ self].

    id := aProcess id.

    self class threadInterrupt:id with:[aProcess interrupt].

    "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 processes can have"

    "must be below schedulingPriority - otherwise scheduler

     could be blocked ..."

    ^ 30  

!

schedulingPriority

    "return the priority at which the scheduler runs"

    "must be above highestPriority - otherwise scheduler

     could be blocked ..."

    ^ 31

!

userInterruptPriority

    "not currently used - for ST80 compatibility only"

    ^ 24

!

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

    "not currently used - for ST80 compatibility only"

    ^ 6

!

systemBackgroundPriority

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

    nPrios := self schedulingPriority.

    quiescentProcessLists := Array new:nPrios.

    readFds := Array with:nil.

    readChecks := Array with:nil.

    readSemaphores := Array with:nil.

    writeFds := Array with:nil.

    writeChecks := Array with:nil.

    writeSemaphores := Array with:nil.

    timeouts := Array with:nil.

    timeoutSemaphores := Array with:nil.

    timeoutActions := Array with:nil.

    anyTimeouts := false.

    dispatching := false.

    "

     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.

    "

    activeProcess := Process new.

    activeProcess setId:0.

    activeProcess name:'scheduler'.

    activeProcess state:#run.

    currentPriority := self schedulingPriority.

    activeProcess setPriority:currentPriority.

    l := LinkedList new.

    l add:activeProcess.

    quiescentProcessLists at:currentPriority put:l.

    ObjectMemory ioInterruptHandler:self.

    ObjectMemory timerInterruptHandler:self.

!

reInitialize

    "all previous stuff is obsolete - each object should reinstall itself

     upon restart."

    |l|

    KnownProcesses := WeakArray new:5.

    KnownProcesses watcher:self class.

    KnownProcessIds := OrderedCollection new.

    "for now (cannot snapin processes)"

    quiescentProcessLists := Array new:self schedulingPriority.

    readFds := Array with:nil.

    readChecks := Array with:nil.

    readSemaphores := Array with:nil.

    writeFds := Array with:nil.

    writeChecks := Array with:nil.

    writeSemaphores := Array with:nil.

    dispatching := false.

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

    activeProcess := Process new.

    activeProcess setId:0.

    activeProcess name:'scheduler'.

    activeProcess state:#run.

    currentPriority := self schedulingPriority.

    activeProcess setPriority:currentPriority.

    l := LinkedList new.

    l add:activeProcess.

    quiescentProcessLists at:currentPriority put:l.

    ObjectMemory ioInterruptHandler:self.

    ObjectMemory timerInterruptHandler:self.

! !

!ProcessorScheduler methodsFor:'private'!

remember:aProcess

    "remember aProcess for later disposal (where the underlying

     system resources have to be freed)."

    |newShadow oldSize oldId

     index "{ Class: SmallInteger }"

     sz    "{ Class: SmallInteger }" |

    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.

            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.

    OperatingSystem unblockInterrupts.

!