(* SYSTEM.mod provides access to COROUTINE primitives and underlying system.
Copyright (C) 2002-2023 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, 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.