(* SYSTEM.mod provides access to COROUTINE primitives and underlying system.

Copyright (C) 2002-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 SYSTEM ;

FROM RTco IMPORT init, initThread, transfer, currentThread, turnInterrupts ;

FROM RTint IMPORT Listen, AttachVector,
                  IncludeVector, ExcludeVector ;

IMPORT RTint ;

FROM Storage IMPORT ALLOCATE ;
FROM M2RTS IMPORT Halt ;
FROM libc IMPORT printf, memcpy, memset ;


CONST
   BitsPerBitset = MAX (BITSET) +1 ;

TYPE
   PtrToIOTransferState = POINTER TO IOTransferState ;
   IOTransferState      = RECORD
                             ptrToFirst,
                             ptrToSecond: POINTER TO PROCESS ;
                             next       : PtrToIOTransferState ;
                          END ;

VAR
   initMain,
   initGTh : BOOLEAN ;


(*
   TRANSFER - save the current volatile environment into, p1.
              Restore the volatile environment from, p2.
*)

PROCEDURE TRANSFER (VAR p1: PROCESS; p2: PROCESS) ;
VAR
   r: INTEGER ;
BEGIN
   localMain (p1) ;
   IF p1.context=p2.context
   THEN
      Halt('error when attempting to context switch to the same process',
           __FILE__, __FUNCTION__, __LINE__)
   END ;
   transfer (p1.context, p2.context)
END TRANSFER ;


(*
   NEWPROCESS - p is a parameterless procedure, a, is the origin of
                the workspace used for the process stack and containing
                the volatile environment of the process.  StackSize, is
                the maximum size of the stack in bytes which can be used
                by this process.  new, is the new process.
*)

PROCEDURE NEWPROCESS (p: PROC; a: ADDRESS; StackSize: CARDINAL; VAR new: PROCESS) ;
BEGIN
   localInit ;
   WITH new DO
      context := initThread (p, StackSize, MAX(PROTECTION))
   END
END NEWPROCESS ;


(*
   IOTRANSFER - saves the current volatile environment into, First,
                and restores volatile environment, Second.
                When an interrupt, InterruptNo, is encountered then
                the reverse takes place. (The then current volatile
                environment is shelved onto Second and First is resumed).

                NOTE: that upon interrupt the Second might not be the
                      same process as that before the original call to
                      IOTRANSFER.
*)

PROCEDURE IOTRANSFER (VAR First, Second: PROCESS; InterruptNo: CARDINAL) ;
VAR
   p: IOTransferState ;
   l: POINTER TO IOTransferState ;
BEGIN
   localMain (First) ;
   WITH p DO
      ptrToFirst  := ADR (First) ;
      ptrToSecond := ADR (Second) ;
      next        := AttachVector (InterruptNo, ADR (p))
   END ;
   IncludeVector (InterruptNo) ;
   TRANSFER (First, Second)
END IOTRANSFER ;


(*
   IOTransferHandler - handles interrupts related to a pending IOTRANSFER.
*)

PROCEDURE IOTransferHandler (InterruptNo: CARDINAL;
                             Priority: CARDINAL ;
                             l: PtrToIOTransferState) ;
VAR
   old: PtrToIOTransferState ;
BEGIN
   IF l=NIL
   THEN
      Halt ('no processes attached to this interrupt vector which is associated with IOTRANSFER',
            __FILE__, __FUNCTION__, __LINE__)
   ELSE
      WITH l^ DO
         old := AttachVector (InterruptNo, next) ;
         IF old#l
         THEN
            Halt ('inconsistancy of return result',
                  __FILE__, __FUNCTION__, __LINE__)
         END ;
         IF next=NIL
         THEN
            ExcludeVector (InterruptNo)
         ELSE
            printf ('odd vector has been chained\n')
         END ;
         TRANSFER (ptrToSecond^, ptrToFirst^)
      END
   END
END IOTransferHandler ;


(*
   LISTEN - briefly listen for any interrupts.
*)

PROCEDURE LISTEN ;
BEGIN
   localInit ;
   Listen (FALSE, IOTransferHandler, MIN (PROTECTION))
END LISTEN ;


(*
   ListenLoop - should be called instead of users writing:

                LOOP
                   LISTEN
                END

                It performs the same function but yields
                control back to the underlying operating system.
                It also checks for deadlock.
                This function returns when an interrupt occurs.
                (File descriptor becomes ready or time event expires).
*)

PROCEDURE ListenLoop ;
BEGIN
   localInit ;
   LOOP
      Listen (TRUE, IOTransferHandler, MIN (PROTECTION))
   END
END ListenLoop ;


(*
   TurnInterrupts - switches processor interrupts to the
                    protection level, to.  It returns the old value.
*)

PROCEDURE TurnInterrupts (to: PROTECTION) : PROTECTION ;
VAR
   old: PROTECTION ;
BEGIN
   localInit ;
   old := VAL (PROTECTION, turnInterrupts (VAL (CARDINAL, to))) ;
   Listen (FALSE, IOTransferHandler, to) ;
   (* printf ("interrupt level is %d\n", currentIntValue); *)
   RETURN old
END TurnInterrupts ;


(*
   Finished - generates an error message. Modula-2 processes should never
              terminate.
*)

PROCEDURE Finished (p: ADDRESS) ;
BEGIN
   Halt ('process terminated illegally',
         __FILE__, __FUNCTION__, __LINE__)
END Finished ;


(*
   localInit - checks to see whether we need to initialize pthread
*)

PROCEDURE localInit ;
BEGIN
   IF NOT initGTh
   THEN
      initGTh := TRUE ;
      IF init () # 0
      THEN
         Halt ("gthr did not initialize",
               __FILE__, __FUNCTION__, __LINE__)
      END ;
      RTint.Init
   END
END localInit ;


(*
   localMain - creates the holder for the main process.
*)

PROCEDURE localMain (VAR mainProcess: PROCESS) ;
BEGIN
   IF NOT initMain
   THEN
      initMain := TRUE ;
      WITH mainProcess DO
         context := currentThread ()
      END
   END
END localMain ;


(*
   Max - returns the maximum of a and b.
*)

PROCEDURE Max (a, b: CARDINAL) : CARDINAL ;
BEGIN
   IF a > b
   THEN
      RETURN a
   ELSE
      RETURN b
   END
END Max ;


(*
   Min - returns the minimum of a and b.
*)

PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
BEGIN
   IF a < b
   THEN
      RETURN a
   ELSE
      RETURN b
   END
END Min ;


(*
   ShiftVal - is a runtime procedure whose job is to implement
              the SHIFT procedure of ISO SYSTEM. GNU Modula-2 will
              inline a SHIFT of a single WORD sized set and will only
              call this routine for larger sets.
*)

PROCEDURE ShiftVal (VAR s, d: ARRAY OF BITSET;
                    SetSizeInBits: CARDINAL;
                    ShiftCount: INTEGER) ;
VAR
   a: ADDRESS ;
BEGIN
   IF ShiftCount>0
   THEN
      ShiftCount := ShiftCount MOD VAL(INTEGER, SetSizeInBits) ;
      ShiftLeft (s, d, SetSizeInBits, ShiftCount)
   ELSIF ShiftCount<0
   THEN
      ShiftCount := (-ShiftCount) MOD VAL(INTEGER, SetSizeInBits) ;
      ShiftRight (s, d, SetSizeInBits, ShiftCount)
   ELSE
      a := memcpy (ADR (d), ADR (s), (HIGH (d) + 1) * SIZE (BITSET))
   END
END ShiftVal ;


(*
   ShiftLeft - performs the shift left for a multi word set.
               This procedure might be called by the back end of
               GNU Modula-2 depending whether amount is known at compile
               time.
*)

PROCEDURE ShiftLeft (VAR s, d: ARRAY OF BITSET;
                     SetSizeInBits: CARDINAL;
                     ShiftCount: CARDINAL) ;
VAR
   lo, hi : BITSET ;
   i, j, h: CARDINAL ;
   a      : ADDRESS ;
BEGIN
   h := HIGH(s)+1 ;
   IF ShiftCount MOD BitsPerBitset=0
   THEN
      i := ShiftCount DIV BitsPerBitset ;
      a := ADR (d[i]) ;
      a := memcpy (a, ADR (s), (h-i) * SIZE (BITSET)) ;
      a := memset (ADR (d), 0, i * SIZE (BITSET))
   ELSE
      i := h ;
      WHILE i>0 DO
         DEC (i) ;
         lo := SHIFT (s[i], ShiftCount MOD BitsPerBitset) ;
         hi := SHIFT (s[i], -(BitsPerBitset - (ShiftCount MOD BitsPerBitset))) ;
         d[i] := BITSET{} ;
         j := i + ShiftCount DIV BitsPerBitset ;
         IF j<h
         THEN
            d[j] := d[j] + lo ;
            INC(j) ;
            IF j<h
            THEN
               d[j] := d[j] + hi
            END
         END
      END
   END
END ShiftLeft ;


(*
   ShiftRight - performs the shift left for a multi word set.
                This procedure might be called by the back end of
                GNU Modula-2 depending whether amount is known at compile
                time.
*)

PROCEDURE ShiftRight (VAR s, d: ARRAY OF BITSET;
                      SetSizeInBits: CARDINAL;
                      ShiftCount: CARDINAL) ;
VAR
   lo, hi : BITSET ;
   j, i, h: INTEGER ;
   a      : ADDRESS ;
BEGIN
   h := HIGH (s) + 1 ;
   IF ShiftCount MOD BitsPerBitset=0
   THEN
      i := ShiftCount DIV BitsPerBitset ;
      a := ADR (s[i]) ;
      j := h-i ;
      a := memcpy (ADR (d), a, j * VAL (INTEGER, SIZE(BITSET))) ;
      a := ADR (d[j]) ;
      a := memset (a, 0, i * VAL (INTEGER, SIZE(BITSET)))
   ELSE
      i := 0 ;
      WHILE i<h DO
         lo := SHIFT(s[i], BitsPerBitset - (ShiftCount MOD BitsPerBitset)) ;
         hi := SHIFT(s[i], -(ShiftCount MOD BitsPerBitset)) ;
         d[i] := BITSET{} ;
         j := i - VAL(INTEGER, ShiftCount DIV BitsPerBitset) ;
         IF j>=0
         THEN
            d[j] := d[j] + hi ;
            DEC(j) ;
            IF j>=0
            THEN
               d[j] := d[j] + lo
            END
         END ;
         INC(i)
      END
   END
END ShiftRight ;


(*
   RotateVal - is a runtime procedure whose job is to implement
               the ROTATE procedure of ISO SYSTEM. GNU Modula-2 will
               inline a ROTATE of a single WORD (or less)
               sized set and will only call this routine for larger sets.
*)

PROCEDURE RotateVal (VAR s, d: ARRAY OF BITSET;
                     SetSizeInBits: CARDINAL;
                     RotateCount: INTEGER) ;
VAR
   a: ADDRESS ;
BEGIN
   IF RotateCount>0
   THEN
      RotateLeft(s, d, SetSizeInBits, RotateCount)
   ELSIF RotateCount<0
   THEN
      RotateRight(s, d, SetSizeInBits, -RotateCount)
   ELSE
      a := memcpy(ADR(d), ADR(s), (HIGH(d)+1)*SIZE(BITSET))
   END
END RotateVal ;


(*
   RotateLeft - performs the rotate left for a multi word set.
                This procedure might be called by the back end of
                GNU Modula-2 depending whether amount is known at compile
                time.
*)

PROCEDURE RotateLeft (VAR s, d: ARRAY OF BITSET;
                      SetSizeInBits: CARDINAL;
                      RotateCount: CARDINAL) ;
VAR
   lo, hi : BITSET ;
   b, i, j, h: CARDINAL ;
BEGIN
   h := HIGH(s) ;
   (* firstly we set d := {} *)
   i := 0 ;
   WHILE i<=h DO
      d[i] := BITSET{} ;
      INC(i)
   END ;
   i := h+1 ;
   RotateCount := RotateCount MOD SetSizeInBits ;
   b := SetSizeInBits MOD BitsPerBitset ;
   IF b=0
   THEN
      b := BitsPerBitset
   END ;
   WHILE i>0 DO
      DEC(i) ;
      lo := SHIFT(s[i], RotateCount MOD BitsPerBitset) ;
      hi := SHIFT(s[i], -(b - (RotateCount MOD BitsPerBitset))) ;
      j := ((i*BitsPerBitset + RotateCount) MOD
            SetSizeInBits) DIV BitsPerBitset ;
      d[j] := d[j] + lo ;
      j := (((i+1)*BitsPerBitset + RotateCount) MOD
            SetSizeInBits) DIV BitsPerBitset ;
      d[j] := d[j] + hi ;
      b := BitsPerBitset
   END
END RotateLeft ;


(*
   RotateRight - performs the rotate right for a multi word set.
                 This procedure might be called by the back end of
                 GNU Modula-2 depending whether amount is known at compile
                 time.
*)

PROCEDURE RotateRight (VAR s, d: ARRAY OF BITSET;
                       SetSizeInBits: CARDINAL;
                       RotateCount: CARDINAL) ;
BEGIN
   RotateLeft(s, d, SetSizeInBits, SetSizeInBits-RotateCount)
END RotateRight ;


BEGIN
   initGTh := FALSE ;
   initMain := FALSE
END SYSTEM.