[Back to MISC SWAG index] [Back to Main SWAG index] [Original]

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

[Back to MISC SWAG index] [Back to Main SWAG index] [Original]