🚀 go-pugleaf

In article <newsmaster-1204962326460001@mochnet.demon.co.uk> newsmaster@mochnet.demon.co.uk writes:

>I am in the process of authoring a simple Real Time Scheduler using the
>TRANSFER, NEWPROCESS and COROUTINE features built into M2. I use 
>FST 3.1 and 3.5 on a PC 

Maybe you will find something to help you in this:

I have actually got a slightly different version of System from the supplied
one, but I don't know that this will make a difference.

I did this some time ago and am probably hazy on the details,
but let me know if I can help further.



DEFINITION MODULE Semaphores;

(* Simple Semaphore based multi-tasking kernel *)

  TYPE SEMAPHORE;

  PROCEDURE StartProcess (P : PROC; N : CARDINAL);
  (* Sets up a process with procedure P and workspace of size N
     The process is not given control until StartTasking is invoked *)

  PROCEDURE SIGNAL (VAR S : SEMAPHORE);
  (* Signals semaphore S, and either returns first process on S to
     ready status, or increases value associated with S  *)

  PROCEDURE WAIT (VAR S : SEMAPHORE);
  (* Suspends calling process on S if associated value of S is zero *)

  PROCEDURE SemInit (VAR S : SEMAPHORE; Count : CARDINAL);
  (* Initializes semaphore S to have the associated value Count *)

  PROCEDURE StartTasking (TimeSliced : BOOLEAN);
  (* Launches a sequence of started processes, possibly TimeSliced *)

  PROCEDURE EnterDos;
  (* Protects Dos calls *)

  PROCEDURE LeaveDos;
  (* Allows other procedures to enter DOS *)

END Semaphores.



IMPLEMENTATION MODULE Semaphores;

(* FST Modula-2 version.  P.D. Terry, Rhodes University, Sun  01-10-1993  *)

(* Simple Semaphore based multi-tasking kernel *)

  IMPORT SYSTEM, IBMPC, Storage, System;

  TYPE
    ProcPointer   = POINTER TO ProcessDescriptor;
    SEMAPHORE     = POINTER TO SemDescriptor;
    SemDescriptor = RECORD
                      Value   : CARDINAL;
                      Waiting : ProcPointer
                    END (* SemDescriptor *);
    ProcessDescriptor =
        RECORD
          Next    : ProcPointer    (* ring link *);
          Queue   : ProcPointer    (* condition queue links *);
          Routine : SYSTEM.ADDRESS (* internal to TRANSFER *);
          Ready   : BOOLEAN        (* status *);
          Area    : CARDINAL       (* workspace size *);
          Work    : SYSTEM.ADDRESS (* workspace address *);
          Process : PROC           (* routine to be executed *);
        END (* ProcessDescriptor *);
  VAR
    Main    : ProcPointer (* parent coroutine *);
    Current : ProcPointer (* active coroutine *);
    Dos     : SEMAPHORE   (* to allow protection of non-reentrant DOS *);

  MODULE CLOCK [0] (* NonInterruptible *);

    IMPORT SYSTEM, IBMPC, Current;
    EXPORT InitClock;

    CONST
      Clock1Vector = 1CH (* Clock interrupt vector - specific *);
    VAR
      CLKWSP : ARRAY [0 .. 500] OF SYSTEM.WORD (* process workspace *);
      UserProcess, ClockProcess : SYSTEM.ADDRESS;

    PROCEDURE ClockHandler;
    (* Clock Interrupt Handler *)
      BEGIN
        LOOP
          SYSTEM.IOTRANSFER(ClockProcess, UserProcess, Clock1Vector);
          Current^.Routine := UserProcess;
          (* Find the next ready-to-run process and activate it *)
          REPEAT Current := Current^.Next UNTIL Current^.Ready;
          UserProcess := Current^.Routine;
          (* you may need *) IBMPC.Reset8259;
        END
      END ClockHandler;

    PROCEDURE InitClock;
    (* Institute a clock interrupt handler process *)
      BEGIN
        SYSTEM.NEWPROCESS(ClockHandler, SYSTEM.ADR(CLKWSP),
                          SIZE(CLKWSP), ClockProcess);
        SYSTEM.TRANSFER(UserProcess, ClockProcess)
      END InitClock;

    BEGIN END CLOCK;

  MODULE Kernel [0] (* NonInterruptible *);

    IMPORT SYSTEM, System, Storage, Main, Current, Dos,
           ProcPointer, ProcessDescriptor, SEMAPHORE, InitClock;

    EXPORT LinkProcess, GetProcess, StopProcess,
           SIGNAL, WAIT, EnterDos, LeaveDos, StartTasking;

    VAR
      Leaving : SYSTEM.ADDRESS;
      NProcs  : CARDINAL;

    PROCEDURE LinkProcess (NewProc : ProcPointer; P : PROC);
    (* Link process descriptor into ring *)
      BEGIN
        INC(NProcs);
        WITH NewProc^ DO (* link into ring *)
          Next := Current^.Next; Current^.Next := NewProc; Process := P
        END;
      END LinkProcess;

    PROCEDURE Deadlock;
    (* Rudimentary error handling *)
      BEGIN
        System.ErrorMessage('Deadlock ******'); System.ErrorLn; HALT(7)
      END Deadlock;

    PROCEDURE StopProcess;
    (* Invoked to terminate a process normally *)
      VAR
        Last, Now : ProcPointer;
        NonReady  : BOOLEAN;
      BEGIN
        Now := Current; Last := Current;
        REPEAT (* find previous entry in ring *)
          Last := Last^.Next
        UNTIL Last^.Next = Now;
        REPEAT (* look for a process to resume *)
          Current := Current^.Next
        UNTIL Current^.Ready;
        NonReady := Current = Now (* potential deadlock *);
        Last^.Next := Now^.Next (* bypass descriptor *);
        Storage.DEALLOCATE(Now^.Work, Now^.Area);
        Storage.DEALLOCATE(Now, SIZE(ProcessDescriptor));
        DEC(NProcs);
        IF NProcs = 0
          THEN
            Current := Main; Current^.Ready := TRUE;
            SYSTEM.TRANSFER(Leaving, Main^.Routine)
          ELSIF NonReady THEN Deadlock
          ELSE  SYSTEM.TRANSFER(Leaving, Current^.Routine)
        END
      END StopProcess;

    PROCEDURE StartTasking (TimeSliced : BOOLEAN);
      BEGIN
        IF NProcs > 0
          THEN
            Main^.Ready := FALSE; Current := Main^.Next;
            IF TimeSliced THEN InitClock END;
            SYSTEM.TRANSFER(Main^.Routine, Current^.Routine);
            (* after it's all over, resume main process *)
          ELSE
            System.ErrorMessage('No processes specified');
            System.ErrorLn; HALT(7)
        END
      END StartTasking;

    PROCEDURE GetProcess (VAR P : PROC);
      BEGIN
        P := Current^.Process
      END GetProcess;

    PROCEDURE SIGNAL (VAR S : SEMAPHORE);
      VAR
        Old : ProcPointer;
      BEGIN
        IF S^.Waiting = NIL
          THEN INC(S^.Value)
          ELSE
            Old := Current;
            Current := S^.Waiting; S^.Waiting := Current^.Queue;
            Current^.Ready := TRUE; Current^.Queue := NIL;
            SYSTEM.TRANSFER(Old^.Routine, Current^.Routine)
        END
      END SIGNAL;

    PROCEDURE WAIT (VAR S : SEMAPHORE);
      VAR
        Old, Last : ProcPointer;
      BEGIN
        IF S^.Value > 0
          THEN
            DEC(S^.Value)
          ELSE
            IF S^.Waiting = NIL
              THEN
                S^.Waiting := Current
              ELSE
                Last := S^.Waiting;
                WHILE Last^.Queue # NIL DO Last := Last^.Queue END;
                Last^.Queue := Current
            END;
            Old := Current;
            REPEAT Current := Current^.Next UNTIL Current^.Ready;
            IF Current = Old THEN Deadlock END;
            Old^.Ready := FALSE;
            SYSTEM.TRANSFER(Old^.Routine, Current^.Routine)
        END
      END WAIT;

    PROCEDURE EnterDos;
      BEGIN
        WAIT(Dos);
      END EnterDos;

    PROCEDURE LeaveDos;
      BEGIN
        SIGNAL(Dos);
      END LeaveDos;

  BEGIN (* Kernel *)
    NProcs := 0;
  END Kernel;

  PROCEDURE SemInit (VAR S : SEMAPHORE; Count : CARDINAL);
    BEGIN
      Storage.ALLOCATE(S, SIZE(SemDescriptor));
      WITH S^ DO
        Waiting := NIL; Value := Count
      END
    END SemInit;

  PROCEDURE Task;
  (* All processes actually create an instance of this as a coroutine,
     to allow automatic addition of StopProcess *)
    VAR
      ActualProcess : PROC;
    BEGIN
      Kernel.GetProcess(ActualProcess); ActualProcess;
      Kernel.StopProcess
    END Task;

  PROCEDURE StartProcess (P : PROC; N : CARDINAL);
    VAR
      NewProc   : ProcPointer;
      WorkSpace : SYSTEM.ADDRESS;
    BEGIN
      Storage.ALLOCATE(WorkSpace, N);
      Storage.ALLOCATE(NewProc, SIZE(ProcessDescriptor));
      WITH NewProc^ DO (* link into ring *)
        Ready := TRUE; Queue := NIL;
        Work := WorkSpace; Area := N;
      END;
      SYSTEM.NEWPROCESS(Task, WorkSpace, N, NewProc^.Routine);
      Kernel.LinkProcess(NewProc, P);
    END StartProcess;

  PROCEDURE RestoreVectors;
    BEGIN
      IBMPC.RestoreAllVectors;
    END RestoreVectors;

  BEGIN  (* Semaphores *)
    Storage.ALLOCATE(Current, SIZE(ProcessDescriptor));
    WITH Current^ DO
      Next := Current; Ready := TRUE; Queue := NIL
    END;
    Main := Current;
    SemInit(Dos, 1);
    IBMPC.SaveAllVectors;
    System.TermProcedure(RestoreVectors);
  END Semaphores.


DEFINITION MODULE IBMPC;

(* Various utilities for handling the facilities specific to the IBM-PC
   and similar machines *)

  IMPORT SYSTEM;

  CONST
    carryFlag = 0;               (* carry flag IN FLAGS *)
    zeroFlag  = 6;               (* zero flag IN FLAGS *)
  TYPE
    Registers =
       RECORD
         CASE : BOOLEAN OF
           | TRUE  : AX, BX, CX, DX, BP, SI, DI, DS, ES : CARDINAL;
                     Flags                              : BITSET;
           | FALSE : AL, AH, BL, BH, CL, CH, DL, DH     : SYSTEM.BYTE;
         END;
       END;

  VAR
    InDosPtr : POINTER TO SYSTEM.BYTE;  (* Pointer to InDos flag *)

  PROCEDURE IsPC () : BOOLEAN;
  (* Returns TRUE if running on a vanilla PC, FALSE if AT or above *)

  PROCEDURE HasCoprocessor () : BOOLEAN;
  (* Returns TRUE if running on a machine with a maths coprocessor *)

  PROCEDURE Dos (VAR R : Registers);
  (* INT 21H function call *)

  PROCEDURE Intr (VAR R : Registers; IntNum : CARDINAL);
  (* INT IntNum call *)

  PROCEDURE InDos () : BOOLEAN;
  (* Returns TRUE if DOS currently in critical section *)

  PROCEDURE GetVector (IntNum : CARDINAL; VAR ISR : SYSTEM.ADDRESS);
  (* Loads in ISR the value of the interrupt vector IntNum *)

  PROCEDURE SetVector (IntNum : CARDINAL; ISR : PROC);
  (* Installs ISR to be executed when interrupt IntNum occurs.
     The address loaded in the interrupt vector is that of the
     start of the procedure ISR, skipping the compiler generated
     entry code.

     ISR must be compiled with stack checking disabled ($S-). *)

  PROCEDURE ResetVector (IntNum : CARDINAL; ISR : SYSTEM.ADDRESS);
  (* Loads the interrupt vector IntNum with the value in ISR *)

  PROCEDURE SaveAllVectors;
  (* Saves all interrupt vectors *)

  PROCEDURE RestoreAllVectors;
  (* Restores all interrupt vectors *)

  PROCEDURE Reset8259;
  (* Resets primary 8259A PIC *)

  PROCEDURE Get8259Mask (VAR Mask : BITSET);
  (* Returns current primary 8259A mask *)

  PROCEDURE Set8259Mask (Mask : BITSET);
  (* Sets primary 8259A mask *)

  PROCEDURE EnableInterrupts;
  (* Enables all interrupts *)

  PROCEDURE DisableInterrupts;
  (* Disables all interrupts *)

  PROCEDURE InByte (VAR Byte : SYSTEM.BYTE; Port : CARDINAL);
  (* Reads Byte from specified Port *)

  PROCEDURE OutByte (Byte : SYSTEM.BYTE; Port : CARDINAL);
  (* Writes Byte to specified Port *)

  PROCEDURE InWord (VAR Word : SYSTEM.WORD; Port : CARDINAL);
  (* Reads Word from specified Port *)

  PROCEDURE OutWord (Word : SYSTEM.WORD; Port : CARDINAL);
  (* Writes Word to specified Port *)

  PROCEDURE Move (Src : SYSTEM.ADDRESS; Dest : SYSTEM.ADDRESS;
                  Size : CARDINAL);
  (* Moves Size bytes from Src to Dest.
      IF Src > Dest
        THEN move from low to high address
        ELSE move from high to low address
      END
  *)

END IBMPC.


IMPLEMENTATION MODULE IBMPC;

(* FST Modula-2 version.  P.D. Terry, Rhodes University, Sun  01-10-1993  *)

(* Various utilities for handling the facilities specific to the IBM-PC
   and similar machines *)

  IMPORT SYSTEM, System;
  FROM SYSTEM IMPORT ASSEMBLER, SEG, OFS;

(* ==== From definition module
  CONST
    carryFlag = 0;               (* carry flag IN FLAGS *)
    zeroFlag  = 6;               (* zero flag IN FLAGS *)
  TYPE
    Registers =
      RECORD
        CASE : BOOLEAN OF
          | TRUE  : AX, BX, CX, DX, BP, SI, DI, DS, ES : CARDINAL;
                    Flags                              : BITSET;
          | FALSE : AL, AH, BL, BH, CL, CH, DL, DH     : SYSTEM.BYTE;
        END;
                END;
  VAR
    InDosPtr : POINTER TO SYSTEM.BYTE (* Pointer to InDos flag *);
==== *)

  VAR
    Vectors : ARRAY [0 .. 511] OF CARDINAL;

  PROCEDURE IsPC () : BOOLEAN;
    BEGIN
      RETURN System.IsPC
    END IsPC;

  PROCEDURE HasCoprocessor () : BOOLEAN;
    BEGIN
      RETURN System.Has8087
    END HasCoprocessor;

  PROCEDURE Dos (VAR R : Registers);
    BEGIN
      System.AX := R.AX;
      System.BX := R.BX;
      System.CX := R.CX;
      System.DX := R.DX;
      System.BP := R.BP;
      System.SI := R.SI;
      System.DI := R.DI;
      System.DS := R.DS;
      System.ES := R.ES;
      System.FLAGS := R.Flags;
      System.XTrap(21H);
      R.AX := System.AX;
      R.BX := System.BX;
      R.CX := System.CX;
      R.DX := System.DX;
      R.BP := System.BP;
      R.SI := System.SI;
      R.DI := System.DI;
      R.DS := System.DS;
      R.ES := System.ES;
      R.Flags := System.FLAGS;
    END Dos;

  PROCEDURE Intr (VAR R : Registers; IntNum : CARDINAL);
    BEGIN
      System.AX := R.AX;
      System.BX := R.BX;
      System.CX := R.CX;
      System.DX := R.DX;
      System.BP := R.BP;
      System.SI := R.SI;
      System.DI := R.DI;
      System.DS := R.DS;
      System.ES := R.ES;
      System.FLAGS := R.Flags;
      System.XTrap(IntNum);
      R.AX := System.AX;
      R.BX := System.BX;
      R.CX := System.CX;
      R.DX := System.DX;
      R.BP := System.BP;
      R.SI := System.SI;
      R.DI := System.DI;
      R.DS := System.DS;
      R.ES := System.ES;
      R.Flags := System.FLAGS;
    END Intr;

  PROCEDURE InDos () : BOOLEAN;
    BEGIN
      RETURN ORD(InDosPtr^) # 0
    END InDos;

  PROCEDURE GetVector (IntNum : CARDINAL; VAR ISR : SYSTEM.ADDRESS);
    BEGIN
      System.GetVector(IntNum, ISR)
    END GetVector;

  PROCEDURE SetVector (IntNum : CARDINAL; ISR : PROC);
    BEGIN
      System.SetVector(IntNum, ISR)
    END SetVector;

  PROCEDURE ResetVector (IntNum : CARDINAL; ISR : SYSTEM.ADDRESS);
    BEGIN
      System.ResetVector(IntNum, ISR)
    END ResetVector;

  MODULE Protected [0];

    IMPORT SYSTEM, System, Vectors;
    EXPORT SaveAllVectors, RestoreAllVectors;

    PROCEDURE SaveAllVectors;
      BEGIN
        System.Move(SYSTEM.PTR(0L), SYSTEM.ADR(Vectors), 1024);
      END SaveAllVectors;

    PROCEDURE RestoreAllVectors;
      BEGIN
        System.Move(SYSTEM.ADR(Vectors), SYSTEM.PTR(0L), 1024);
      END RestoreAllVectors;

    END Protected;

  PROCEDURE Reset8259;
    BEGIN
      ASM
        PUSH AX
        MOV  AL, 20H
        OUT  20H, AL
        POP  AX
      END
    END Reset8259;

  PROCEDURE Get8259Mask (VAR Mask : BITSET);
    BEGIN
      ASM
        LES  DI, Mask
        PUSH AX
        IN   AL, 21H
        MOV  BYTE ES:[DI], AL
        POP  AX
      END
    END Get8259Mask;

  PROCEDURE Set8259Mask (Mask : BITSET);
    BEGIN
      ASM
        PUSH AX
        MOV  AL, Mask
        OUT  21H, AL
        POP  AX
      END
    END Set8259Mask;

  PROCEDURE EnableInterrupts;
    BEGIN
      ASM
        STI
      END
    END EnableInterrupts;

  PROCEDURE DisableInterrupts;
    BEGIN
      ASM
        CLI
      END
    END DisableInterrupts;

  PROCEDURE InByte (VAR Byte : SYSTEM.BYTE; Port : CARDINAL);
    BEGIN
      ASM
        LES  DI, Byte
        MOV  DX, Port
        IN   AL, DX
        MOV  BYTE ES:[DI], AL
      END
    END InByte;

  PROCEDURE OutByte (Byte : SYSTEM.BYTE; Port : CARDINAL);
    BEGIN
      ASM
        MOV  DX, Port
        MOV  AL, Byte
        OUT  DX, AL
      END
    END OutByte;

  PROCEDURE InWord (VAR Word : SYSTEM.WORD; Port : CARDINAL);
    BEGIN
      ASM
        LES  DI, Word
        MOV  DX, Port
        IN   AX, DX
        MOV  ES:[DI], AX
      END
    END InWord;

  PROCEDURE OutWord (Word : SYSTEM.WORD; Port : CARDINAL);
    BEGIN
      ASM
        MOV  DX, Port
        MOV  AX, Word
        OUT  DX, AX
      END
    END OutWord;

  PROCEDURE Move (Src : SYSTEM.ADDRESS; Dest : SYSTEM.ADDRESS;
                  Size : CARDINAL);
    BEGIN
      System.Move(Src, Dest, Size)
    END Move;

  BEGIN
    System.AX := 3400H;
    System.XTrap(21H);
    InDosPtr.SEG := System.ES;
    InDosPtr.OFS := System.BX;
  END IBMPC.