<* MAIN + *>
MODULE TestRun;
<* procinline + *>
<* ioverflow - *>
<* checknil - *>
<* checktype - *>
<* gendebug - *>

IMPORT 
   Packet, Scheduler,
   Out, WholeStr, SeqFile, TextIO, IOResult,
   WholeIO, ProgEnv, WinBase, WinNT, WinDef;

VAR
   count: LONGINT;
   wkq: Packet.Packet;
   s: Scheduler.Scheduler;
   arg: ARRAY 32 OF CHAR;
   result: WholeStr.ConvResults;

   startTicks, stopTicks, frequency: WinNT.LARGE_INTEGER;
   flags: SeqFile.FlagSet;
   cid: SeqFile.ChanId;
   fResults: SeqFile.OpenResults;

BEGIN
   count := 10000;
   ProgEnv.GetArg(0, arg);
   WholeStr.StrToInt(arg, count, result);

   (* Timing *)
   WinBase.QueryPerformanceCounter(startTicks);

   s := Scheduler.NewScheduler();

   Scheduler.AddIdleTask(s, Scheduler.IDLE, 0, NIL, count);

   wkq := Packet.NewPacket(NIL, Scheduler.WORKER, Packet.WORK);
   wkq := Packet.NewPacket(wkq, Scheduler.WORKER, Packet.WORK);
   Scheduler.AddWorkerTask(s, Scheduler.WORKER, 1000, wkq);

   wkq := Packet.NewPacket(NIL, Scheduler.DEVICEA, Packet.DEVICE);
   wkq := Packet.NewPacket(wkq, Scheduler.DEVICEA, Packet.DEVICE);
   wkq := Packet.NewPacket(wkq, Scheduler.DEVICEA, Packet.DEVICE);
   Scheduler.AddHandlerTask(s, Scheduler.HANDLERA, 2000, wkq);

   wkq := Packet.NewPacket(NIL, Scheduler.DEVICEB, Packet.DEVICE);
   wkq := Packet.NewPacket(wkq, Scheduler.DEVICEB, Packet.DEVICE);
   wkq := Packet.NewPacket(wkq, Scheduler.DEVICEB, Packet.DEVICE);
   Scheduler.AddHandlerTask(s, Scheduler.HANDLERB, 3000, wkq);

   Scheduler.AddDeviceTask(s, Scheduler.DEVICEA, 4000, NIL);
   Scheduler.AddDeviceTask(s, Scheduler.DEVICEB, 5000, NIL);

   Scheduler.Schedule(s);

   (* Timing *)
   WinBase.QueryPerformanceCounter(stopTicks);
   WinBase.QueryPerformanceFrequency(frequency);

   flags := SeqFile.write + SeqFile.text;
   SeqFile.OpenAppend(cid, "testrun-times.xml", flags, fResults);
   IF fResults # SeqFile.opened THEN
      Out.String("Error opening file"); Out.Ln; HALT;
   END;

   TextIO.WriteString(cid, "<ExternalStat>");
   TextIO.WriteString(cid, "<size>");
   WholeIO.WriteInt(cid, count, 1);
   TextIO.WriteString(cid, "</size>");
   TextIO.WriteString(cid, "<ticks>");
   WholeIO.WriteInt(cid, stopTicks.LowPart - startTicks.LowPart, 1);
   TextIO.WriteString(cid, "</ticks>");
   TextIO.WriteString(cid, "<ticksPerSecond>");
   WholeIO.WriteInt(cid, frequency.LowPart, 1);
   TextIO.WriteString(cid, "</ticksPerSecond>");
   TextIO.WriteString(cid, "</ExternalStat>");
   TextIO.WriteLn(cid);
   SeqFile.Close(cid);

   Out.String("QueueCount = "); Out.Int(s.queueCount,1); Out.Ln;
   Out.String("HoldCount = "); Out.Int(s.holdCount,1); Out.Ln;
END TestRun.




(* --------------------------------------- *)

MODULE Scheduler;
<* procinline + *>
<* ioverflow - *>
<* checknil - *>
<* checktype - *>
<* gendebug - *>

IMPORT Out, Packet, SYSTEM, Tcb;

CONST
   TraceOn* = FALSE;
   MaxTasks = 10;

   (* TaskId *)
   IDLE* = 0;
   WORKER* = 1;
   HANDLERA* = 2;
   HANDLERB* = 3;
   DEVICEA* = 4;
   DEVICEB* = 5;


TYPE
   Scheduler* = POINTER TO SchedulerRec;
   SchedulerRec = RECORD
      table: ARRAY MaxTasks OF Tcb.Tcb;
      list: Tcb.Tcb;
      currentTcb: Tcb.Tcb;
      currentId: Packet.TaskId;
      queueCount*, holdCount*: LONGINT;
      layout: LONGINT;
   END;


   IdleTask = POINTER TO IdleTaskRec;
   IdleTaskRec = RECORD (Tcb.TaskRec)
      scheduler: Scheduler;
      v1, v2: LONGINT;
   END;


   WorkerTask = POINTER TO WorkerTaskRec;
   WorkerTaskRec = RECORD (Tcb.TaskRec)
      scheduler: Scheduler;
      v1: Packet.TaskId; v2: LONGINT;
   END;


   HandlerTask = POINTER TO HandlerTaskRec;
   HandlerTaskRec = RECORD (Tcb.TaskRec)
      scheduler: Scheduler;
      v1, v2: Packet.Packet;
   END;


   DeviceTask = POINTER TO DeviceTaskRec;
   DeviceTaskRec = RECORD (Tcb.TaskRec)
      scheduler: Scheduler;
      v1: Packet.Packet;
   END;


VAR
   D008: LONGINT;
   SHORT_ZERO: SHORTINT;


PROCEDURE NewScheduler*(): Scheduler;
VAR s: Scheduler;
BEGIN
   NEW(s); s.layout := 0; s.queueCount := 0; s.holdCount := 0;
   RETURN s;
END NewScheduler;


PROCEDURE Trace(s: Scheduler; byte: SHORTINT);
BEGIN
   DEC(s.layout);
   IF s.layout <= 0 THEN Out.Ln; s.layout := 50; END;
   Out.Char(CHR(byte));
END Trace;


PROCEDURE AddTask(VAR s: Scheduler; id: Packet.TaskId; pri: LONGINT;
                      q: Packet.Packet; t: Tcb.Task);
BEGIN
    s.currentTcb := Tcb.NewTcb(s.list, id, pri, q, t);
    s.list := s.currentTcb;
    s.table[id] := s.currentTcb;
END AddTask;


PROCEDURE AddRunningTask(VAR s: Scheduler; id: Packet.TaskId; pri: LONGINT;
                             q: Packet.Packet; t: Tcb.Task);
BEGIN
    AddTask(s, id, pri, q, t);
    Tcb.SetRunning(s.currentTcb);
END AddRunningTask;


PROCEDURE NewIdleTask(s: Scheduler; v1, v2: LONGINT): IdleTask;
VAR t: IdleTask;
BEGIN
   NEW(t); t.scheduler := s; t.v1 := v1; t.v2 := v2; RETURN t;
END NewIdleTask;


PROCEDURE NewWorkerTask(s: Scheduler; v1: Packet.TaskId; v2: LONGINT): WorkerTask;
VAR t: WorkerTask;			
BEGIN
   NEW(t); t.scheduler := s; t.v1 := v1; t.v2 := v2; RETURN t;
END NewWorkerTask;


PROCEDURE NewHandlerTask(s: Scheduler): HandlerTask;
VAR t: HandlerTask;
BEGIN
   NEW(t); t.scheduler := s; t.v1 := NIL; t.v2 := NIL; RETURN t;
END NewHandlerTask;


PROCEDURE NewDeviceTask(s: Scheduler): DeviceTask;
VAR t: DeviceTask;
BEGIN
   NEW(t); t.scheduler := s; t.v1 := NIL; RETURN t;
END NewDeviceTask;


PROCEDURE AddIdleTask*(VAR s: Scheduler; id: Packet.TaskId; pri: LONGINT;
                          q: Packet.Packet; count: LONGINT);
BEGIN
    AddRunningTask(s, id, pri, q, NewIdleTask(s,1,count));
END AddIdleTask;


PROCEDURE AddWorkerTask*(VAR s: Scheduler; id: Packet.TaskId; pri: LONGINT; 
                          q: Packet.Packet);
BEGIN
    AddTask(s, id, pri, q, NewWorkerTask(s,HANDLERA,0));
END AddWorkerTask;


PROCEDURE AddHandlerTask*(VAR s: Scheduler; id: Packet.TaskId; pri: LONGINT; 
                          q: Packet.Packet);
BEGIN
    AddTask(s, id, pri, q, NewHandlerTask(s));
END AddHandlerTask;


PROCEDURE AddDeviceTask*(VAR s: Scheduler; id: Packet.TaskId; pri: LONGINT; 
                          q: Packet.Packet);
BEGIN
    AddTask(s, id, pri, q, NewDeviceTask(s));
END AddDeviceTask;


PROCEDURE Schedule*(VAR s: Scheduler);
VAR nextTcb: Tcb.Tcb;
BEGIN
   s.currentTcb := s.list;
   WHILE s.currentTcb # NIL DO
      IF Tcb.IsHeldOrSuspended(s.currentTcb) THEN
         s.currentTcb := Tcb.GetLink(s.currentTcb);	 	
      ELSE
         s.currentId := Tcb.GetId(s.currentTcb);	 	
	 IF TraceOn THEN Trace(s, SHORT(ORD("0")) + s.currentId + 1); END; 	 	
	 nextTcb := Tcb.Run(s.currentTcb);	
         s.currentTcb := nextTcb;	 		
      END;
   END;
END Schedule;


PROCEDURE Queue(VAR s: Scheduler; packet: Packet.Packet): Tcb.Tcb;
VAR t: Tcb.Tcb;
BEGIN
   t := s.table[Packet.GetId(packet)];
   IF t = NIL THEN RETURN t; END;
   INC(s.queueCount);
   Packet.SetLink(packet,Packet.Nil);
   Packet.SetId(packet,s.currentId);
   RETURN Tcb.CheckPriorityAdd(t, s.currentTcb, packet);
END Queue;


PROCEDURE Release(VAR s: Scheduler; id: Packet.TaskId): Tcb.Tcb;
VAR t: Tcb.Tcb;
BEGIN
   t := s.table[id];
   IF t = NIL THEN RETURN t; END;
   Tcb.NotHeld(t);
   IF Tcb.GetPriority(t) > Tcb.GetPriority(s.currentTcb)
      THEN RETURN t;
   ELSE RETURN s.currentTcb; END;
END Release;


PROCEDURE HoldCurrent(VAR s: Scheduler): Tcb.Tcb;
BEGIN
   INC(s.holdCount);
   Tcb.Held(s.currentTcb);
   RETURN Tcb.GetLink(s.currentTcb);
END HoldCurrent;


PROCEDURE SuspendCurrent(VAR s: Scheduler): Tcb.Tcb;
BEGIN
   Tcb.Suspended(s.currentTcb);
   RETURN s.currentTcb;
END SuspendCurrent;


PROCEDURE (self: IdleTask) Run(VAR packet: Packet.Packet): Tcb.Tcb;
BEGIN
   DEC(self.v2);
   IF self.v2 = 0 THEN RETURN HoldCurrent(self.scheduler); END;

   IF ~(0 IN SYSTEM.VAL(SET,self.v1) ) THEN
      self.v1 := ASH(self.v1, -1);
      RETURN Release(self.scheduler, DEVICEA);
   ELSE
      self.v1 := ASH(self.v1, -1);
      self.v1 := SYSTEM.VAL(
         LONGINT,
	 SYSTEM.VAL(SET,self.v1) / SYSTEM.VAL(SET, D008));
      RETURN Release(self.scheduler, DEVICEB);
   END;
END Run;


PROCEDURE (self: WorkerTask) Run(VAR packet: Packet.Packet): Tcb.Tcb;
VAR
   i: LONGINT;
   a2: Packet.Data;
BEGIN
   IF packet = NIL THEN
      RETURN SuspendCurrent(self.scheduler);
   ELSE
      IF self.v1 = HANDLERA THEN
         self.v1 := HANDLERB;
      ELSE
         self.v1 := HANDLERA;
      END;
      Packet.SetId(packet,self.v1);
      Packet.SetA1(packet,SHORT_ZERO);
      FOR i := 0 TO Packet.DataSize - 1 DO
         INC(self.v2);	
	 IF self.v2 > 26 THEN self.v2 := 1; END;
	 a2 := Packet.GetA2(packet);	
	 a2[i] := SYSTEM.VAL(SHORTINT, ORD("A") + self.v2 - 1);	
      END;
      RETURN Queue(self.scheduler, packet);
   END;
END Run;


PROCEDURE (self: HandlerTask) Run(VAR packet: Packet.Packet): Tcb.Tcb;
VAR
   count: SHORTINT;
   v: Packet.Packet;
   a2: Packet.Data;
BEGIN
   IF packet # NIL THEN
      IF Packet.GetKind(packet) = Packet.WORK THEN
         self.v1 := Packet.AddTo(packet, self.v1);
      ELSE
         self.v2 := Packet.AddTo(packet, self.v2);
      END;
   END;
   IF self.v1 # NIL THEN
      count := Packet.GetA1(self.v1);
      IF count < Packet.DataSize THEN
         IF self.v2 # NIL THEN
	    v := self.v2;
	    self.v2 := Packet.GetLink(self.v2);
	    a2 := Packet.GetA2(self.v1);
	    Packet.SetA1(v,a2[count]);
	    INC(count);
	    Packet.SetA1(self.v1, count);	
	    RETURN Queue(self.scheduler, v);
	 END;	
      ELSE
         v := self.v1;
	 self.v1 := Packet.GetLink(self.v1);
	 RETURN Queue(self.scheduler, v);
      END;
   END;
   RETURN SuspendCurrent(self.scheduler);
END Run;


PROCEDURE (self: DeviceTask) Run(VAR packet: Packet.Packet): Tcb.Tcb;
VAR v: Packet.Packet;
BEGIN
   IF packet = NIL THEN
      IF self.v1 = NIL THEN RETURN SuspendCurrent(self.scheduler); END;
      v := self.v1;
      self.v1 := NIL;
      RETURN Queue(self.scheduler, v);
   ELSE
      self.v1 := packet;
      IF TraceOn THEN Trace(self.scheduler, Packet.GetA1(packet)); END;
      RETURN HoldCurrent(self.scheduler);
   END;
END Run;


BEGIN
   D008 := 0D008H; (* Unable to define a CONST of particular storage size? *)
   SHORT_ZERO := 0;
END Scheduler.




(* --------------------------------------- *)

MODULE Tcb;
<* procinline + *>
<* ioverflow - *>
<* checknil - *>
<* checktype - *>
<* gendebug - *>

IMPORT Packet;

CONST
   RUNNING = {};
   RUNNABLE = 0;
   SUSPENDED = 1;
   HELD = 2;

TYPE
   Task* = POINTER TO TaskRec;
   TaskRec* = RECORD END;

   Tcb* = POINTER TO TcbRec;
   TcbRec = RECORD
      link: Tcb;
      id: Packet.TaskId;
      pri: LONGINT;
      wkq: Packet.Packet;
      state: SET;
      task: Task;
   END;


PROCEDURE (task: Task) Run*(VAR packet: Packet.Packet): Tcb;
BEGIN
   RETURN NIL;
END Run;


PROCEDURE NewTcb*(
   link: Tcb;
   id: Packet.TaskId;
   pri: LONGINT;
   q: Packet.Packet;
   task: Task): Tcb;
VAR t: Tcb;
BEGIN
   NEW(t);
   t.link := link;
   t.id := id;
   t.pri := pri;
   t.wkq := q;
   t.task := task;
   IF q = NIL THEN t.state := {SUSPENDED};
              ELSE t.state := {SUSPENDED, RUNNABLE}; END;
   RETURN t;
END NewTcb;


PROCEDURE SetRunning*(VAR t: Tcb);
BEGIN
   t.state := RUNNING;
END SetRunning;


PROCEDURE Suspended*(VAR t: Tcb);
BEGIN
   INCL(t.state, SUSPENDED);
END Suspended;


PROCEDURE Held*(VAR t: Tcb);
BEGIN
   INCL(t.state, HELD);
END Held;


PROCEDURE NotHeld*(VAR t: Tcb);
BEGIN
   EXCL(t.state, HELD);
END NotHeld;


PROCEDURE IsHeldOrSuspended*(VAR t: Tcb): BOOLEAN;
BEGIN
   RETURN (HELD IN t.state) OR (t.state = {SUSPENDED});
END IsHeldOrSuspended;



PROCEDURE CheckPriorityAdd*(
   VAR t: Tcb;
   tcb: Tcb;
   packet: Packet.Packet): Tcb;	
BEGIN
   IF t.wkq = NIL THEN
      t.wkq := packet;
      INCL(t.state, RUNNABLE);
      IF t.pri > tcb.pri THEN RETURN t; END;
   ELSE
      t.wkq := Packet.AddTo(packet, t.wkq);
   END;
   RETURN tcb;
END CheckPriorityAdd;


PROCEDURE Run*(VAR t: Tcb): Tcb;
VAR packet: Packet.Packet;
BEGIN
   IF t.state = {SUSPENDED, RUNNABLE} THEN
      packet := t.wkq;
      t.wkq := Packet.GetLink(packet);
      IF t.wkq = NIL THEN
         t.state := RUNNING;
      ELSE
         t.state := {RUNNABLE};
      END;
   ELSE
      packet := NIL;
   END;
   RETURN t.task.Run(packet);
END Run;

(* accessors *)

PROCEDURE GetLink*(VAR t: Tcb): Tcb;
BEGIN RETURN t.link; END GetLink;

PROCEDURE GetId*(VAR t: Tcb): Packet.TaskId;
BEGIN RETURN t.id; END GetId;

PROCEDURE GetPriority*(VAR t: Tcb): LONGINT;
BEGIN RETURN t.pri; END GetPriority;

END Tcb.



(* --------------------------------------- *)

MODULE Packet;
<* procinline + *>
<* ioverflow - *>
<* checknil - *>
<* checktype - *>
<* gendebug - *>

IMPORT SYSTEM;

CONST
   DEVICE* = 0;
   WORK* = 1;
   DataSize* = 4;

TYPE
   TaskId* = SHORTINT;
   Kind = LONGINT;

   Data* = POINTER TO DataArray;
   DataArray = ARRAY DataSize OF SHORTINT;

   Packet* = POINTER TO PacketRec;
   PacketRec = RECORD
      link: Packet;
      id: TaskId;
      kind: Kind;
      a1: SHORTINT;
      a2: DataArray;
   END;

VAR
   Nil-: Packet;


PROCEDURE NewPacket*(link: Packet; id: TaskId; kind: Kind): Packet;
VAR p: Packet;
BEGIN
   NEW(p); p.link := link; p.id := id; p.kind := kind; RETURN p;
END NewPacket;


PROCEDURE AddTo*(VAR p, queue: Packet): Packet;
VAR next, peek: Packet;
BEGIN
   p.link := NIL;
   IF queue = NIL THEN RETURN p; END;
   next := queue;
   LOOP
      peek := next.link;
      IF peek = NIL THEN EXIT; END;
      next := peek;
   END;
   next.link := p;
   RETURN queue;
END AddTo;


(* accessors *)

PROCEDURE GetLink*(VAR p: Packet): Packet;
BEGIN RETURN p.link; END GetLink;

PROCEDURE SetLink*(VAR p: Packet; link: Packet);
BEGIN p.link := link; END SetLink;

PROCEDURE GetId*(VAR p: Packet): TaskId;
BEGIN RETURN p.id; END GetId;

PROCEDURE SetId*(VAR p: Packet; VAR id: TaskId);
BEGIN p.id := id; END SetId;

PROCEDURE GetKind*(VAR p: Packet): Kind;
BEGIN RETURN p.kind; END GetKind;

PROCEDURE GetA1*(VAR p: Packet): SHORTINT;
BEGIN RETURN p.a1; END GetA1;

PROCEDURE SetA1*(VAR p: Packet; VAR a1: SHORTINT);
BEGIN p.a1 := a1; END SetA1;

PROCEDURE GetA2*(VAR p: Packet): Data;
BEGIN
   RETURN SYSTEM.VAL(Data, SYSTEM.ADR(p.a2));
END GetA2;


BEGIN
   Nil := SYSTEM.VAL(Packet, NIL);
END Packet.