path: root/gcc/m2/gm2-libs/RTint.mod

(* RTint.mod provides users of the COROUTINES library with the.

Copyright (C) 2009-2025 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.

This file is part of GNU Modula-2.

GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  *)

IMPLEMENTATION MODULE RTint ;


FROM M2RTS IMPORT Halt ;
FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM RTco IMPORT select, initSemaphore, wait, signal ;
FROM COROUTINES IMPORT PROTECTION ;
FROM libc IMPORT printf, perror ;
FROM Assertion IMPORT Assert ;

FROM Selective IMPORT InitSet, FdSet, Timeval, InitTime, KillTime, KillSet,
                      SetOfFd, FdIsSet, GetTime, FdZero, GetTimeOfDay, SetTime,
                      FdClr;

CONST
   Microseconds = 1000000 ;
   DebugTime    = 0 ;
   Debugging    = FALSE ;

TYPE
   VectorType = (input, output, time) ;
   Vector     = POINTER TO RECORD
                              type    : VectorType ;
                              priority: CARDINAL ;
                              arg     : ADDRESS ;
                              pending,
                              exists  : Vector ;
                              no      : CARDINAL ;
                              File    : INTEGER ;
                              rel,
                              abs     : Timeval ;
                              queued  : BOOLEAN ;
                           END ;

VAR
   VecNo      : CARDINAL ;
   Exists     : Vector ;
   Pending    : ARRAY [MIN(PROTECTION)..MAX(PROTECTION)] OF Vector ;
   lock       : INTEGER ;
   initialized: BOOLEAN ;


(*
   Max - returns the maximum: i or j.
*)

PROCEDURE Max (i, j: INTEGER) : INTEGER ;
BEGIN
   IF i>j
   THEN
      RETURN i
   ELSE
      RETURN j
   END
END Max ;


(*
   Max - returns the minimum: i or j.
*)

PROCEDURE Min (i, j: INTEGER) : INTEGER ;
BEGIN
   IF i<j
   THEN
      RETURN i
   ELSE
      RETURN j
   END
END Min ;


(*
   FindVector - searches the exists list for a vector of type
                which is associated with file descriptor, fd.
*)

PROCEDURE FindVector (fd: INTEGER; type: VectorType) : Vector ;
VAR
   vec: Vector ;
BEGIN
   vec := Exists ;
   WHILE vec#NIL DO
      IF (vec^.type=type) AND (vec^.File=fd)
      THEN
         RETURN vec
      END ;
      vec := vec^.exists
   END ;
   RETURN NIL
END FindVector ;


(*
   InitInputVector - returns an interrupt vector which is associated
                     with the file descriptor, fd.
*)

PROCEDURE InitInputVector (fd: INTEGER; pri: CARDINAL) : CARDINAL ;
VAR
   vptr: Vector ;
BEGIN
   IF Debugging
   THEN
      printf("InitInputVector fd = %d priority = %d\n", fd, pri)
   END ;
   wait (lock) ;
   vptr := FindVector(fd, input) ;
   IF vptr = NIL
   THEN
      NEW (vptr) ;
      INC (VecNo) ;
      WITH vptr^ DO
         type     := input ;
         priority := pri ;
         arg      := NIL ;
         pending  := NIL ;
         exists   := Exists ;
         no       := VecNo ;
         File     := fd
      END ;
      Exists := vptr ;
      signal (lock) ;
      RETURN VecNo
   ELSE
      signal (lock) ;
      RETURN vptr^.no
   END
END InitInputVector ;


(*
   InitOutputVector - returns an interrupt vector which is associated
                      with the file descriptor, fd.
*)

PROCEDURE InitOutputVector (fd: INTEGER; pri: CARDINAL) : CARDINAL ;
VAR
   vptr: Vector ;
BEGIN
   wait (lock) ;
   vptr := FindVector (fd, output) ;
   IF vptr = NIL
   THEN
      NEW (vptr) ;
      IF vptr = NIL
      THEN
         HALT
      ELSE
         INC (VecNo) ;
         WITH vptr^ DO
            type     := output ;
            priority := pri ;
            arg      := NIL ;
            pending  := NIL ;
            exists   := Exists ;
            no       := VecNo ;
            File     := fd
         END ;
         Exists := vptr ;
         signal (lock) ;
         RETURN VecNo
      END
   ELSE
      signal (lock) ;
      RETURN vptr^.no
   END
END InitOutputVector ;


(*
   InitTimeVector - returns an interrupt vector associated with
                    the relative time.
*)

PROCEDURE InitTimeVector (micro, secs: CARDINAL; pri: CARDINAL) : CARDINAL ;
VAR
   vptr: Vector ;
BEGIN
   wait (lock) ;
   NEW (vptr) ;
   IF vptr = NIL
   THEN
      HALT
   ELSE
      INC (VecNo) ;
      Assert (micro<Microseconds) ;
      WITH vptr^ DO
         type     := time ;
         priority := pri ;
         arg      := NIL ;
         pending  := NIL ;
         exists   := Exists ;
         no       := VecNo ;
         rel      := InitTime (secs+DebugTime, micro) ;
         abs      := InitTime (0, 0) ;
         queued   := FALSE
      END ;
      Exists := vptr
   END ;
   signal (lock) ;
   RETURN VecNo
END InitTimeVector ;


(*
   FindVectorNo - searches the Exists list for vector vec.
*)

PROCEDURE FindVectorNo (vec: CARDINAL) : Vector ;
VAR
   vptr: Vector ;
BEGIN
   vptr := Exists ;
   WHILE (vptr#NIL) AND (vptr^.no#vec) DO
      vptr := vptr^.exists
   END ;
   RETURN vptr
END FindVectorNo ;


(*
   FindPendingVector - searches the pending list for vector, vec.
*)

PROCEDURE FindPendingVector (vec: CARDINAL) : Vector ;
VAR
   pri : CARDINAL ;
   vptr: Vector ;
BEGIN
   FOR pri := MIN(PROTECTION) TO MAX(PROTECTION) DO
      vptr := Pending[pri] ;
      WHILE (vptr#NIL) AND (vptr^.no#vec) DO
         vptr := vptr^.pending
      END ;
      IF (vptr#NIL) AND (vptr^.no=vec)
      THEN
         RETURN vptr
      END
   END ;
   RETURN NIL
END FindPendingVector ;


(*
   ReArmTimeVector - reprimes the vector, vec, to deliver an interrupt
                     at the new relative time.
*)

PROCEDURE ReArmTimeVector (vec: CARDINAL;
                           micro, secs: CARDINAL) ;
VAR
   vptr: Vector ;
BEGIN
   Assert (micro<Microseconds) ;
   wait (lock) ;
   vptr := FindVectorNo (vec) ;
   IF vptr = NIL
   THEN
      Halt ('cannot find vector supplied',
            __FILE__, __FUNCTION__, __LINE__)
   ELSE
      WITH vptr^ DO
         SetTime (rel, secs + DebugTime, micro)
      END
   END ;
   signal (lock)
END ReArmTimeVector ;


(*
   GetTimeVector - assigns, micro, and, secs, with the remaining
                   time before this interrupt will expire.
                   This value is only updated when a Listen
                   occurs.
*)

PROCEDURE GetTimeVector (vec: CARDINAL; VAR micro, secs: CARDINAL) ;
VAR
   vptr: Vector ;
BEGIN
   wait (lock) ;
   vptr := FindVectorNo (vec) ;
   IF vptr=NIL
   THEN
      Halt ('cannot find vector supplied',
            __FILE__, __FUNCTION__, __LINE__)
   ELSE
      WITH vptr^ DO
         GetTime (rel, secs, micro) ;
         Assert (micro < Microseconds)
      END
   END ;
   signal (lock)
END GetTimeVector ;


(*
   AttachVector - adds the pointer ptr to be associated with the interrupt
                  vector. It returns the previous value attached to this
                  vector.
*)

PROCEDURE AttachVector (vec: CARDINAL; ptr: ADDRESS) : ADDRESS ;
VAR
   vptr   : Vector ;
   prevArg: ADDRESS ;
BEGIN
   wait (lock) ;
   vptr := FindVectorNo (vec) ;
   IF vptr = NIL
   THEN
      Halt ( 'cannot find vector supplied',
            __FILE__, __FUNCTION__, __LINE__)
   ELSE
      prevArg := vptr^.arg ;
      vptr^.arg := ptr ;
      IF Debugging
      THEN
         printf ("AttachVector %d with %p\n", vec, ptr);
         DumpPendingQueue ;
      END ;
      signal (lock) ;
      RETURN prevArg
   END
END AttachVector ;


(*
   IncludeVector - includes, vec, into the dispatcher list of
                   possible interrupt causes.
*)

PROCEDURE IncludeVector (vec: CARDINAL) ;
VAR
   vptr      : Vector ;
   micro, sec: CARDINAL ;
   result    : INTEGER ;
BEGIN
   wait (lock) ;
   vptr := FindPendingVector (vec) ;
   IF vptr = NIL
   THEN
      vptr := FindVectorNo (vec) ;
      IF vptr = NIL
      THEN
         Halt ('cannot find vector supplied',
               __FILE__, __FUNCTION__, __LINE__)
      ELSE
         (* printf('including vector %d  (fd = %d)\n', vec, v^.File) ; *)
         vptr^.pending := Pending[vptr^.priority] ;
         Pending[vptr^.priority] := vptr ;
         IF (vptr^.type = time) AND (NOT vptr^.queued)
         THEN
            vptr^.queued := TRUE ;
            result := GetTimeOfDay (vptr^.abs) ;
            Assert (result=0) ;
            GetTime (vptr^.abs, sec, micro) ;
            Assert (micro<Microseconds) ;
            AddTime (vptr^.abs, vptr^.rel) ;
            GetTime (vptr^.abs, sec, micro) ;
            Assert (micro<Microseconds)
         END
      END
   ELSE
      IF Debugging
      THEN
         printf ('odd vector (%d) type (%d) arg (%p) is already attached to the pending queue\n',
                 vec, vptr^.type, vptr^.arg)
      END
   END ;
   signal (lock)
END IncludeVector ;


(*
   ExcludeVector - excludes, vec, from the dispatcher list of
                   possible interrupt causes.
*)

PROCEDURE ExcludeVector (vec: CARDINAL) ;
VAR
   vptr, uptr: Vector ;
BEGIN
   wait (lock) ;
   vptr := FindPendingVector (vec) ;
   IF vptr = NIL
   THEN
      Halt ('cannot find pending vector supplied',
            __FILE__, __FUNCTION__, __LINE__)
   ELSE
      (* printf('excluding vector %d\n', vec) ; *)
      IF Pending[vptr^.priority] = vptr
      THEN
         Pending[vptr^.priority] := Pending[vptr^.priority]^.pending
      ELSE
         uptr := Pending[vptr^.priority] ;
         WHILE uptr^.pending#vptr DO
            uptr := uptr^.pending
         END ;
         uptr^.pending := vptr^.pending
      END ;
      IF vptr^.type=time
      THEN
         vptr^.queued := FALSE
      END
   END ;
   signal (lock)
END ExcludeVector ;


(*
   AddFd - adds the file descriptor fd to set updating max.
*)

PROCEDURE AddFd (VAR set: SetOfFd; VAR max: INTEGER; fd: INTEGER) ;
BEGIN
   IF (fd<0)
   THEN
      RETURN
   END ;
   max := Max (fd, max) ;
   IF set = NIL
   THEN
      set := InitSet () ;
      FdZero (set)
   END ;
   FdSet (fd, set)
   (* printf('%d, ', fd) *)
END AddFd ;


(*
   DumpPendingQueue - displays the pending queue.
*)

PROCEDURE DumpPendingQueue ;
VAR
   pri  : PROTECTION ;
   vptr : Vector ;
   sec,
   micro: CARDINAL ;
BEGIN
   printf ("Pending queue\n");
   FOR pri := MIN (PROTECTION) TO MAX (PROTECTION) DO
      printf ("[%d]  ", pri);
      vptr := Pending[pri] ;
      WHILE vptr # NIL DO
         IF (vptr^.type=input) OR (vptr^.type=output)
         THEN
            printf ("(fd=%d) (vec=%d)", vptr^.File, vptr^.no)
         ELSIF vptr^.type=time
         THEN
            GetTime (vptr^.rel, sec, micro) ;
            Assert (micro < Microseconds) ;
            printf ("time (%u.%06u secs) (arg = %p)\n",
                    sec, micro, vptr^.arg)
         END ;
         vptr := vptr^.pending
      END ;
      printf (" \n")
   END
END DumpPendingQueue ;


(*
   AddTime - t1 := t1 + t2
*)

PROCEDURE AddTime (t1, t2: Timeval) ;
VAR
   a, b, s, m: CARDINAL ;
BEGIN
   GetTime (t1, s, m) ;
   Assert (m < Microseconds) ;
   GetTime (t2, a, b) ;
   Assert (b < Microseconds) ;
   INC (a, s) ;
   INC (b, m) ;
   IF b >= Microseconds
   THEN
      DEC (b, Microseconds) ;
      INC (a)
   END ;
   SetTime (t1, a, b)
END AddTime ;


(*
   IsGreaterEqual - returns TRUE if, a>=b
*)

PROCEDURE IsGreaterEqual (a, b: Timeval) : BOOLEAN ;
VAR
   as, am, bs, bm: CARDINAL ;
BEGIN
   GetTime (a, as, am) ;
   Assert (am < Microseconds) ;
   GetTime (b, bs, bm) ;
   Assert (bm < Microseconds) ;
   RETURN (as > bs) OR ((as = bs) AND (am >= bm))
END IsGreaterEqual ;


(*
   SubTime - assigns, s and m, to a - b.
*)

PROCEDURE SubTime (VAR s, m: CARDINAL; a, b: Timeval) ;
VAR
   as, am,
   bs, bm: CARDINAL ;
BEGIN
   GetTime (a, as, am) ;
   Assert (am < Microseconds) ;
   GetTime (b, bs, bm) ;
   Assert (bm < Microseconds) ;
   IF IsGreaterEqual (a, b)
   THEN
      s := as - bs ;
      IF am >= bm
      THEN
         m := am - bm ;
         Assert (m < Microseconds) ;
      ELSE
         Assert (s > 0) ;
         DEC (s) ;
         m := (Microseconds + am) - bm ;
         Assert (m < Microseconds)
      END
   ELSE
      s := 0 ;
      m := 0
   END
END SubTime ;


(*
   activatePending - activates the first interrupt pending and clears it.
*)

PROCEDURE activatePending (untilInterrupt: BOOLEAN; call: DispatchVector; pri: CARDINAL;
                           maxFd: INTEGER; VAR inSet, outSet: SetOfFd; VAR timeval: Timeval; b4, after: Timeval) : BOOLEAN ;
VAR
   result: INTEGER ;
   p     : CARDINAL ;
   vec   : Vector ;
   b4s,
   b4m,
   afs,
   afm,
   sec,
   micro : CARDINAL ;
BEGIN
   wait (lock) ;
   p := MAX (PROTECTION) ;
   WHILE p > pri DO
      vec := Pending[p] ;
      WHILE vec # NIL DO
         WITH vec^ DO
            CASE type OF

            input :  IF (File < maxFd) AND (inSet # NIL) AND FdIsSet (File, inSet)
                     THEN
                        IF Debugging
                        THEN
                           printf ('read (fd=%d) is ready (vec=%d)\n', File, no) ;
                           DumpPendingQueue
                        END ;
                        FdClr (File, inSet) ;  (* so we dont activate this again from our select.  *)
                        signal (lock) ;
                        call (no, priority, arg) ;
                        RETURN TRUE
                     END |
            output:  IF (File < maxFd) AND (outSet#NIL) AND FdIsSet (File, outSet)
                     THEN
                        IF Debugging
                        THEN
                           printf ('write (fd=%d) is ready (vec=%d)\n', File, no) ;
                           DumpPendingQueue
                        END ;
                        FdClr (File, outSet) ;  (* so we dont activate this again from our select.  *)
                        signal (lock) ;
                        call (no, priority, arg) ;
                        RETURN TRUE
                     END |
            time  :  IF untilInterrupt AND (timeval # NIL)
                     THEN
                        result := GetTimeOfDay (after) ;
                        Assert (result=0) ;
                        IF Debugging
                        THEN
                           GetTime (timeval, sec, micro) ;
                           Assert (micro < Microseconds) ;
                           GetTime (after, afs, afm) ;
                           Assert (afm < Microseconds) ;
                           GetTime (b4, b4s, b4m) ;
                           Assert (b4m < Microseconds) ;
                           printf ("waited %u.%06u + %u.%06u now is %u.%06u\n",
                                   sec, micro, b4s, b4m, afs, afm) ;
                        END ;
                        IF IsGreaterEqual (after, abs)
                        THEN
                           IF Debugging
                           THEN
                              DumpPendingQueue ;
                              printf ("time has expired calling dispatcher\n")
                           END ;
                           timeval := KillTime (timeval) ;  (* so we dont activate this again from our select.  *)
                           signal (lock) ;
                           IF Debugging
                           THEN
                              printf ("call (%d, %d, 0x%x)\n", no, priority, arg)
                           END ;
                           call (no, priority, arg) ;
                           RETURN TRUE
                        ELSIF Debugging
                        THEN
                           printf ("must wait longer as time has not expired\n")
                        END
                     END
            END
         END ;
         vec := vec^.pending
      END ;
      DEC (p)
   END ;
   signal (lock) ;
   RETURN FALSE
END activatePending ;


(*
   Listen - will either block indefinitely (until an interrupt)
            or alteratively will test to see whether any interrupts
            are pending.
            If a pending interrupt was found then, call, is called
            and then this procedure returns.
            It only listens for interrupts > pri.
*)

PROCEDURE Listen (untilInterrupt: BOOLEAN;
                  call: DispatchVector;
                  pri: CARDINAL) ;
VAR
   found  : BOOLEAN ;
   result : INTEGER ;
   zero,
   after,
   b4,
   timeval: Timeval ;
   vec    : Vector ;
   inSet,
   outSet : SetOfFd ;
   sec,
   micro  : CARDINAL ;
   maxFd  : INTEGER ;
   p      : CARDINAL ;
BEGIN
   wait (lock) ;
   IF pri < MAX (PROTECTION)
   THEN
      IF Debugging
      THEN
         DumpPendingQueue
      END ;
      maxFd := -1 ;
      timeval := NIL ;
      inSet := NIL ;
      outSet := NIL ;
      timeval := InitTime (MAX (INTEGER), 0) ;
      p := MAX (PROTECTION) ;
      found := FALSE ;
      WHILE p>pri DO
         vec := Pending[p] ;
         WHILE vec#NIL DO
            WITH vec^ DO
               CASE type OF

               input :  AddFd (inSet, maxFd, File) |
               output:  AddFd (outSet, maxFd, File) |
               time  :  IF IsGreaterEqual (timeval, abs)
                        THEN
                           GetTime (abs, sec, micro) ;
                           Assert (micro < Microseconds) ;
                           IF Debugging
                           THEN
                              printf ("shortest delay is %u.%06u\n", sec, micro)
                           END ;
                           SetTime (timeval, sec, micro) ;
                           found := TRUE
                        END

               END
            END ;
            vec := vec^.pending
         END ;
         DEC (p)
      END ;
      IF NOT untilInterrupt
      THEN
         SetTime (timeval, 0, 0)
      END ;
      IF untilInterrupt AND (((inSet=NIL) AND (outSet=NIL)) OR (maxFd=-1)) AND (NOT found)
      THEN
         Halt ('deadlock found, no more processes to run and no interrupts active',
               __FILE__, __FUNCTION__, __LINE__)
      END ;
      (* printf('timeval = 0x%x\n', timeval) ; *)
      (* printf('}\n') ; *)
      IF (NOT found) AND (maxFd=-1)
      THEN
         (* no file descriptors to be selected upon.  *)
         timeval := KillTime (timeval) ;
         signal (lock) ;
         RETURN
      ELSE
         GetTime (timeval, sec, micro) ;
         Assert (micro < Microseconds) ;
         zero := InitTime (0, 0) ;
         b4 := InitTime (0, 0) ;
         after := InitTime (0, 0) ;
         result := GetTimeOfDay (b4) ;
         Assert (result=0) ;
         SubTime (sec, micro, timeval, b4) ;
         SetTime (timeval, sec, micro) ;
         IF Debugging
         THEN
            printf ("select waiting for %u.%06u seconds\n", sec, micro)
         END ;
         signal (lock) ;
         REPEAT
            IF Debugging
            THEN
               printf ("select (.., .., .., %u.%06u)\n", sec, micro)
            END ;
            IF maxFd<0
            THEN
               result := select (0, NIL, NIL, NIL, timeval)
            ELSE
               result := select (maxFd+1, inSet, outSet, NIL, timeval)
            END ;
            IF result=-1
            THEN
               IF Debugging
               THEN
                  perror ("select failed : ") ;
               END ;
               result := select (maxFd+1, inSet, outSet, NIL, zero) ;
               IF result#-1
               THEN
                   GetTime (timeval, sec, micro) ;
                   IF Debugging
                   THEN
                     printf ("(nfds : %d timeval: %u.%06u) : \n", maxFd, sec, micro) ;
                   END ;
                   perror ("select timeout argument was faulty : ")
               ELSE
                  result := select (maxFd+1, inSet, NIL, NIL, timeval) ;
                  IF result#-1
                  THEN
                     perror ("select output fd argument was faulty : ")
                  ELSE
                     result := select (maxFd+1, NIL, outSet, NIL, timeval) ;
                     IF result#-1
                     THEN
                        perror ("select input fd argument was faulty : ")
                     ELSE
                        IF maxFd=-1
                        THEN
                           result := select (0, NIL, NIL, NIL, timeval) ;
                           IF result=-1
                           THEN
                              IF Debugging
                              THEN
                                 perror ("select does not accept nfds == 0 ") ;
                              END ;
                              result := 0
                           END
                        ELSE
                           perror ("select maxFD+1 argument was faulty : ") ;
                        END
                     END
                  END
               END
            END
         UNTIL result#-1
      END ;
      WHILE activatePending (untilInterrupt, call, pri,
                             maxFd+1, inSet, outSet, timeval, b4, after) DO
      END ;
      IF timeval#NIL
      THEN
         timeval := KillTime (timeval)
      END ;
      IF zero#NIL
      THEN
         zero := KillTime (zero)
      END ;
      IF after#NIL
      THEN
         after := KillTime (after)
      END ;
      IF b4#NIL
      THEN
         b4 := KillTime (b4)
      END ;
      IF inSet#NIL
      THEN
         inSet := KillSet (inSet)
      END ;
      IF outSet#NIL
      THEN
         outSet := KillSet (outSet)
      END
   END ;
   signal (lock)
END Listen ;


(*
   init -
*)

PROCEDURE init ;
VAR
   p: PROTECTION ;
BEGIN
   lock := initSemaphore (1) ;
   wait (lock) ;
   Exists := NIL ;
   FOR p := MIN(PROTECTION) TO MAX(PROTECTION) DO
      Pending[p] := NIL
   END ;
   initialized := TRUE ;
   signal (lock)
END init ;


(*
   Init -
*)

PROCEDURE Init ;
BEGIN
   IF NOT initialized
   THEN
      init
   END
END Init ;


BEGIN
   Init
END RTint.