Contributor: MIKE WAROT
{
From: ka9dgx@interaccess.com (Mike Warot)
Here is the code I wrote to do cooperative multitasking in TP4, and have
since used in TP5, TP6, TP7. This version works with TP7, I make no
guarantees for earlier versions.
}
Unit Tasker;
{
Non-Preemptive MultiTasking Unit
for Turbo Pascal Version 4
Author : Michael Warot - Blue Star Systems
Date : November 1987
Purpose : Simple multi-tasking for turbo pascal 4.0
Version : 1.10
V1.10 August 1988 MAW - After much modification, added LastP to
point to the highest numbered active process.
With MaxProc set to 30 and 2 tasks, took
effective yield time down from 240 uS to 38 uS
V1.04 March 1988 MAW - Modify record used to save process, now
use a pointer instead of 2 words to save
the stack frame.
Eliminate redundant variable NextP
V1.03 March, 1988 MAW - Modify code to save video state for a given
process. A flag Video_Save toggles this.
V1.02 March, 1988 MAW - Modify code to support Sleep Function
Added procedures LOCK and UNLOCK to permit
use of non-reentrant procedures in programs
V1.01 January, 1988 MAW - Remove obsolete startup function Init_Tasking.
Put in some documentation. Clean up code.
V1.00 November, 1987 MAW - Initial version, simple and crude, but it works.
}
{$F+ Force FAR calls - must be on}
Interface
Uses
Crt,Timer2; { For saving screen status, etc }
Type
FlagPtr = ^Boolean; { Pointer to a flag }
Var
Save_Video : Boolean; { True for cursor saving }
Function Fork:Boolean; { Call this procedure to spawn a new process. The
procedure will return to your program twice. The
first time it will be the root process, and will
return a value of false, the second time it will
return a value of true }
Procedure Raw_Yield;
Procedure Yield; { Call this procedure often in your code. This is the
heart of the Multi-Tasking, it will return after all
of the other processes have a crack at it. }
Procedure Sleep(Flag : FlagPtr);
{ Call this procedure with an address of a flag which
when TRUE, will re-awaken the process. Upon entry
this procedure will test the value of this flag, and
if FALSE, will mark the process HIBER.
This procedure makes a call to YIELD in all cases.
Note : Don't let all of you processes Sleep, or
you could put things into a deadlock. }
Procedure Lock(Resource : Byte);
{ This procedure allows the programmer to insure that
a procedure is not entered twice, it does this by
having the second call yield until the resource is
free, using Sleep }
Procedure UnLock(Resource : Byte);
{ This procedure unlocks a resource, allowing it to be
used by other processes }
Procedure KillProc; { This procedure is intended to be called by a process
that has done all of it's work. It marks the process
as one that is 'DEAD' and thus never re-awakens }
Function Child_Process:Boolean;
{ This function returns True if the calling procedure
is a child process. This test should be used to branch
into a specific procedure for a given task. }
Procedure SetPriority(P : Integer);
Function ProcessCount:Integer;
Procedure Wait(TicksToWait : Longint);
{ This procedure causes a task to wait by calling
yield until DT(timer2 unit) deterimes that
TicksToWait timer ticks have elapsed }
Implementation
{
Hide this from the users....
These procedures work on the following basis:
1> For each process, there is an amount of memory reserved for
a machine stack, this is called a Stack Frame. This holds
the current state of a given process.
2> The process table (Procs) contains pointers to all of the
Stack Frames. When a task is to be swapped out, it's state
is saved in it's own stack, then the frame pointer is placed
in (Procs) until the process is to be swapped back in.
3> Every one in a while, when a task has some time to share,
it makes a call to Yield, which does all of the swapping.
}
Const
MaxProc = 100; { Maximum number of processes
Adjust for your purposes.. }
Type
ProcState = (Dead,
Kill,
Live,
Slow, { Running, but in background }
Pause, { Waiting for above }
Hiber); { What is the process doing? }
Task_Rec = Record
Frame : Pointer; { Frame save area}
ID : Word; { Process Number }
FrameBlk : Pointer; { Frame block }
FrameSiz : Word; { Amount of memory user }
State : ProcState; { Is it a live process ? }
HiberPtr : FlagPtr; { Pointer to "WAKE" flag }
Priority : LongInt; { priority (0=Real Time) }
NextTime : Longint; { Next wake up call @ }
End; { Record }
Var
MaxStack : Word;
SFrame : Pointer;
Procs : Array[0..MaxProc] of Task_Rec; { Keeps the process pointers }
NextP, { Last live process number }
ThisP, { Current process }
LastP : Word; { Last Process number }
LiveCount : Word; { How many thing happening? }
Locks : Array[0..255] of Boolean; { Resource locks }
Function Ticks:Longint;
Begin
Inline($FA); { CLI - Interupts off }
Ticks := MemL[$0040:$006c];
Inline($FB); { STI - back on again }
End; { Ticks }
{
Here are the inline macros to handle the frame pointers for a task swap
}
Procedure SaveFrame;
Inline( $89/$2E/SFrame { MOV [0000],BP }
/$8C/$16/SFrame+2 { MOV [0002],SS } );
Procedure LoadFrame;
Inline( $8B/$2E/SFrame { MOV BP,[0000] }
/$8E/$16/SFrame+2 { MOV SS,[0002] } );
Function Fork:Boolean; { Create a new process }
Var
Tmp : Boolean;
Begin
SaveFrame; { Save current frame pointer }
Tmp := True; { Assume child process }
NextP := 0; { Search the process table for an }
While (NextP <= MaxProc) AND { open entry for the new process }
(Procs[NextP].State <> Dead) do
Inc(NextP);
If (NextP <= MaxProc) then { If table not full, then }
begin
If NextP > LastP then { If We past it, bump it }
LastP := NextP;
With Procs[NextP] do
begin
FrameSiz := MaxStack; { Set up size of area }
GetMem(FrameBlk,FrameSiz);
State := Live; { Note we're ready to go.... }
ID := NextP; { Set up the new task }
Frame :=
Ptr(Seg(FrameBlk^),Ofs(SFrame^) ); { Setup stack }
Priority := 0;
Move(Mem[Seg(SFrame^) : Ofs(SFrame^)-2],
Mem[Seg(FrameBlk^) : Ofs(SFrame^)-2],
(MaxStack+2)-Ofs(SFrame^) );
end;
Inc(LiveCount); { Bump process counter }
Tmp := False;
end; { we can fork }
LoadFrame;
Fork := Tmp;
End; { Raw_Fork }
Procedure Raw_Yield; { Let the other task's go at it }
Begin
SaveFrame; { Save our current stack frame }
Procs[ThisP].Frame := SFrame; { in our entry in Procs }
If Procs[ThisP].State = Slow then
With Procs[ThisP] do
begin
State := Pause;
NextTime := Ticks+Priority;
If NextTime > $001800ae then
NextTime := NextTime - $001800ae;
End; { with }
If LiveCount >= 1 then { If we actually have a task to }
begin { swap to, then.... }
repeat { keep looking until we hit a }
If ThisP < LastP then { live one }
Inc(ThisP)
else
ThisP := 0;
With Procs[ThisP] do
Case State of
Dead,
Live : ;
Hiber : If HiberPtr^ then { Check to see if we should }
State := Live; { wake a sleeping process }
Pause : If (Priority = 0) OR
(Ticks > NextTime) then
begin
State := Slow; { handle slow task }
end;
Kill : If ThisP <> 0 then { Kill Off a process }
Begin
FreeMem(FrameBlk,FrameSiz);
State := Dead;
end;
End; { Case State }
until (Procs[ThisP].State = Live) or
(Procs[ThisP].State = Slow);
end;
SFrame := Procs[ThisP].Frame; { Load new stack frame }
LoadFrame;
End; { Raw_Yield }
Procedure Yield;
Var
ox,oy : byte;
wmax,
wmin : word;
attr : byte;
Begin
If Not Save_Video then { Implemented this way in case the value changes }
Raw_Yield
else
begin
attr := TextAttr; { Save current colors }
ox := WhereX; oy := WhereY; { save cursor position }
wmin := WindMin; wmax := WindMax; { save window size }
Raw_Yield; { actual Yield Call }
WindMin := wmin; WindMax := wmax; { restore window size }
GotoXY(ox,oy); { restore cursor }
TextAttr := attr; { restore colors }
end;
End; { Yield_Plus }
Procedure Sleep(Flag : FlagPtr); { Put a process to sleep }
Begin
If NOT Flag^ Then
Begin
Procs[ThisP].HiberPtr := Flag; { Set wake up pointer }
Procs[ThisP].State := Hiber; { Mark this process as hibernating }
End;
Yield; { Do a yield, either way, to keep
things going smoothly }
End; { Sleep }
Procedure Lock(Resource : Byte); { Lock a resource ID }
Begin
If NOT Locks[Resource] Then { If not open, then wait until }
Sleep(@Locks[Resource]); { the resource becomes available }
{ Resource MUST be available now! }
Locks[Resource] := FALSE; { Make it unavailable for use }
End; { Lock }
Procedure UnLock(Resource : Byte); { Unlock that resource }
Begin
Locks[Resource] := True; { Make the resource available }
End; { UnLock }
Procedure KillProc; { Stop a process in it's tracks }
Begin
If LiveCount > 1 then { if we are actually swapping then }
begin
Procs[ThisP].State := Kill; { mark us as dead }
Dec(LiveCount); { Bump process count }
Raw_Yield; { and yield. (Never returns) }
{$IFDEF DEBUG}
WriteLn('IN TASKER.PAS - FATAL ERROR, PROCESS EXCEPTION');
{$ENDIF}
end
else { if not swapping, then }
Halt(0); { exit to dos..... }
End; { KillProc }
Function Child_Process; { Returns true if not root process }
Begin
Child_Process := ThisP <> 0;
End;
Procedure SetPriority; { Set number of clicks between runs }
Begin
With Procs[ThisP] do
begin
Priority := P;
If P = 0 then
State := Live
else
State := Slow;
end;
End;
Function ProcessCount;
Begin
ProcessCount := LiveCount;
End;
Procedure Wait(TicksToWait : Longint);
var
t : longint;
begin
If TicksToWait <= 0 then EXIT;
StartTime(T);
While DT(T) < TicksToWait do Yield;
end;
{ Initialization code, called automatically by the user program,
like it or not! }
Procedure InitTasking;
Var
i : byte;
Begin
NextP := 0; { We are in the root process }
ThisP := 0;
LastP := 1; { Last Active process }
FillChar(Procs,SizeOf(Procs),#0);
Procs[0].State := Live;
LiveCount := 1; { And one task is running (this one) }
For i := 0 to 255 do
Locks[i] := True; { All resources available }
Save_Video := True;
End;
Begin
MaxStack := Sptr+4;
InitTasking;
End.