1 (* RTint.mod provides users of the COROUTINES library with the.
3 Copyright (C) 2009-2024 Free Software Foundation, Inc.
4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
6 This file is part of GNU Modula-2.
8 GNU Modula-2 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 GNU Modula-2 is distributed in the hope that it will be useful, but
14 WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. *)
27 IMPLEMENTATION MODULE RTint
;
30 FROM M2RTS
IMPORT Halt
;
31 FROM Storage
IMPORT ALLOCATE
, DEALLOCATE
;
32 FROM RTco
IMPORT select
, initSemaphore
, wait
, signal
;
33 FROM COROUTINES
IMPORT PROTECTION
;
34 FROM libc
IMPORT printf
, perror
;
35 FROM Assertion
IMPORT Assert
;
37 FROM Selective
IMPORT InitSet
, FdSet
, Timeval
, InitTime
, KillTime
, KillSet
,
38 SetOfFd
, FdIsSet
, GetTime
, FdZero
, GetTimeOfDay
, SetTime
,
42 Microseconds
= 1000000 ;
47 VectorType
= (input
, output
, time
) ;
48 Vector
= POINTER TO RECORD
64 Pending
: ARRAY [MIN(PROTECTION
)..
MAX(PROTECTION
)] OF Vector
;
66 initialized
: BOOLEAN ;
70 Max - returns the maximum: i or j.
73 PROCEDURE Max (i
, j
: INTEGER) : INTEGER ;
85 Max - returns the minimum: i or j.
88 PROCEDURE Min (i
, j
: INTEGER) : INTEGER ;
100 FindVector - searches the exists list for a vector of type
101 which is associated with file descriptor, fd.
104 PROCEDURE FindVector (fd
: INTEGER; type
: VectorType
) : Vector
;
110 IF (vec^.type
=type
) AND (vec^.File
=fd
)
121 InitInputVector - returns an interrupt vector which is associated
122 with the file descriptor, fd.
125 PROCEDURE InitInputVector (fd
: INTEGER; pri
: CARDINAL) : CARDINAL ;
131 printf("InitInputVector fd = %d priority = %d\n", fd
, pri
)
134 vptr
:= FindVector(fd
, input
) ;
155 END InitInputVector
;
159 InitOutputVector - returns an interrupt vector which is associated
160 with the file descriptor, fd.
163 PROCEDURE InitOutputVector (fd
: INTEGER; pri
: CARDINAL) : CARDINAL ;
168 vptr
:= FindVector (fd
, output
) ;
194 END InitOutputVector
;
198 InitTimeVector - returns an interrupt vector associated with
202 PROCEDURE InitTimeVector (micro
, secs
: CARDINAL; pri
: CARDINAL) : CARDINAL ;
213 Assert (micro
<Microseconds
) ;
221 rel
:= InitTime (secs
+DebugTime
, micro
) ;
222 abs
:= InitTime (0, 0) ;
233 FindVectorNo - searches the Exists list for vector vec.
236 PROCEDURE FindVectorNo (vec
: CARDINAL) : Vector
;
241 WHILE (vptr#
NIL) AND (vptr^.no#vec
) DO
249 FindPendingVector - searches the pending list for vector, vec.
252 PROCEDURE FindPendingVector (vec
: CARDINAL) : Vector
;
257 FOR pri
:= MIN(PROTECTION
) TO MAX(PROTECTION
) DO
258 vptr
:= Pending
[pri
] ;
259 WHILE (vptr#
NIL) AND (vptr^.no#vec
) DO
260 vptr
:= vptr^.pending
262 IF (vptr#
NIL) AND (vptr^.no
=vec
)
268 END FindPendingVector
;
272 ReArmTimeVector - reprimes the vector, vec, to deliver an interrupt
273 at the new relative time.
276 PROCEDURE ReArmTimeVector (vec
: CARDINAL;
277 micro
, secs
: CARDINAL) ;
281 Assert (micro
<Microseconds
) ;
283 vptr
:= FindVectorNo (vec
) ;
286 Halt ('cannot find vector supplied',
287 __FILE__
, __FUNCTION__
, __LINE__
)
290 SetTime (rel
, secs
+ DebugTime
, micro
)
294 END ReArmTimeVector
;
298 GetTimeVector - assigns, micro, and, secs, with the remaining
299 time before this interrupt will expire.
300 This value is only updated when a Listen
304 PROCEDURE GetTimeVector (vec
: CARDINAL; VAR micro
, secs
: CARDINAL) ;
309 vptr
:= FindVectorNo (vec
) ;
312 Halt ('cannot find vector supplied',
313 __FILE__
, __FUNCTION__
, __LINE__
)
316 GetTime (rel
, secs
, micro
) ;
317 Assert (micro
< Microseconds
)
325 AttachVector - adds the pointer ptr to be associated with the interrupt
326 vector. It returns the previous value attached to this
330 PROCEDURE AttachVector (vec
: CARDINAL; ptr
: ADDRESS
) : ADDRESS
;
336 vptr
:= FindVectorNo (vec
) ;
339 Halt ( 'cannot find vector supplied',
340 __FILE__
, __FUNCTION__
, __LINE__
)
342 prevArg
:= vptr^.arg
;
346 printf ("AttachVector %d with %p\n", vec
, ptr
);
356 IncludeVector - includes, vec, into the dispatcher list of
357 possible interrupt causes.
360 PROCEDURE IncludeVector (vec
: CARDINAL) ;
363 micro
, sec
: CARDINAL ;
367 vptr
:= FindPendingVector (vec
) ;
370 vptr
:= FindVectorNo (vec
) ;
373 Halt ('cannot find vector supplied',
374 __FILE__
, __FUNCTION__
, __LINE__
)
376 (* printf('including vector %d (fd = %d)\n', vec, v^.File) ; *)
377 vptr^.pending
:= Pending
[vptr^.priority
] ;
378 Pending
[vptr^.priority
] := vptr
;
379 IF (vptr^.type
= time
) AND (NOT vptr^.queued
)
381 vptr^.queued
:= TRUE ;
382 result
:= GetTimeOfDay (vptr^.abs
) ;
384 GetTime (vptr^.abs
, sec
, micro
) ;
385 Assert (micro
<Microseconds
) ;
386 AddTime (vptr^.abs
, vptr^.rel
) ;
387 GetTime (vptr^.abs
, sec
, micro
) ;
388 Assert (micro
<Microseconds
)
394 printf ('odd vector (%d) type (%d) arg (%p) is already attached to the pending queue\n',
395 vec
, vptr^.type
, vptr^.arg
)
403 ExcludeVector - excludes, vec, from the dispatcher list of
404 possible interrupt causes.
407 PROCEDURE ExcludeVector (vec
: CARDINAL) ;
412 vptr
:= FindPendingVector (vec
) ;
415 Halt ('cannot find pending vector supplied',
416 __FILE__
, __FUNCTION__
, __LINE__
)
418 (* printf('excluding vector %d\n', vec) ; *)
419 IF Pending
[vptr^.priority
] = vptr
421 Pending
[vptr^.priority
] := Pending
[vptr^.priority
]^.pending
423 uptr
:= Pending
[vptr^.priority
] ;
424 WHILE uptr^.pending#vptr
DO
425 uptr
:= uptr^.pending
427 uptr^.pending
:= vptr^.pending
431 vptr^.queued
:= FALSE
439 AddFd - adds the file descriptor fd to set updating max.
442 PROCEDURE AddFd (VAR set
: SetOfFd
; VAR max
: INTEGER; fd
: INTEGER) ;
448 max
:= Max (fd
, max
) ;
455 (* printf('%d, ', fd) *)
460 DumpPendingQueue - displays the pending queue.
463 PROCEDURE DumpPendingQueue
;
470 printf ("Pending queue\n");
471 FOR pri
:= MIN (PROTECTION
) TO MAX (PROTECTION
) DO
472 printf ("[%d] ", pri
);
473 vptr
:= Pending
[pri
] ;
475 IF (vptr^.type
=input
) OR (vptr^.type
=output
)
477 printf ("(fd=%d) (vec=%d)", vptr^.File
, vptr^.no
)
478 ELSIF vptr^.type
=time
480 GetTime (vptr^.rel
, sec
, micro
) ;
481 Assert (micro
< Microseconds
) ;
482 printf ("time (%u.%06u secs) (arg = %p)\n",
483 sec
, micro
, vptr^.arg
)
485 vptr
:= vptr^.pending
489 END DumpPendingQueue
;
493 AddTime - t1 := t1 + t2
496 PROCEDURE AddTime (t1
, t2
: Timeval
) ;
498 a
, b
, s
, m
: CARDINAL ;
501 Assert (m
< Microseconds
) ;
503 Assert (b
< Microseconds
) ;
508 DEC (b
, Microseconds
) ;
516 IsGreaterEqual - returns TRUE if, a>=b
519 PROCEDURE IsGreaterEqual (a
, b
: Timeval
) : BOOLEAN ;
521 as
, am
, bs
, bm
: CARDINAL ;
523 GetTime (a
, as
, am
) ;
524 Assert (am
< Microseconds
) ;
525 GetTime (b
, bs
, bm
) ;
526 Assert (bm
< Microseconds
) ;
527 RETURN (as
> bs
) OR ((as
= bs
) AND (am
>= bm
))
532 SubTime - assigns, s and m, to a - b.
535 PROCEDURE SubTime (VAR s
, m
: CARDINAL; a
, b
: Timeval
) ;
540 GetTime (a
, as
, am
) ;
541 Assert (am
< Microseconds
) ;
542 GetTime (b
, bs
, bm
) ;
543 Assert (bm
< Microseconds
) ;
544 IF IsGreaterEqual (a
, b
)
550 Assert (m
< Microseconds
) ;
554 m
:= (Microseconds
+ am
) - bm
;
555 Assert (m
< Microseconds
)
565 activatePending - activates the first interrupt pending and clears it.
568 PROCEDURE activatePending (untilInterrupt
: BOOLEAN; call
: DispatchVector
; pri
: CARDINAL;
569 maxFd
: INTEGER; VAR inSet
, outSet
: SetOfFd
; VAR timeval
: Timeval
; b4
, after
: Timeval
) : BOOLEAN ;
582 p
:= MAX (PROTECTION
) ;
589 input
: IF (File
< maxFd
) AND (inSet #
NIL) AND FdIsSet (File
, inSet
)
593 printf ('read (fd=%d) is ready (vec=%d)\n', File
, no
) ;
596 FdClr (File
, inSet
) ; (* so we dont activate this again from our select. *)
598 call (no
, priority
, arg
) ;
601 output
: IF (File
< maxFd
) AND (outSet#
NIL) AND FdIsSet (File
, outSet
)
605 printf ('write (fd=%d) is ready (vec=%d)\n', File
, no
) ;
608 FdClr (File
, outSet
) ; (* so we dont activate this again from our select. *)
610 call (no
, priority
, arg
) ;
613 time
: IF untilInterrupt
AND (timeval #
NIL)
615 result
:= GetTimeOfDay (after
) ;
619 GetTime (timeval
, sec
, micro
) ;
620 Assert (micro
< Microseconds
) ;
621 GetTime (after
, afs
, afm
) ;
622 Assert (afm
< Microseconds
) ;
623 GetTime (b4
, b4s
, b4m
) ;
624 Assert (b4m
< Microseconds
) ;
625 printf ("waited %u.%06u + %u.%06u now is %u.%06u\n",
626 sec
, micro
, b4s
, b4m
, afs
, afm
) ;
628 IF IsGreaterEqual (after
, abs
)
633 printf ("time has expired calling dispatcher\n")
635 timeval
:= KillTime (timeval
) ; (* so we dont activate this again from our select. *)
639 printf ("call (%d, %d, 0x%x)\n", no
, priority
, arg
)
641 call (no
, priority
, arg
) ;
645 printf ("must wait longer as time has not expired\n")
656 END activatePending
;
660 Listen - will either block indefinitely (until an interrupt)
661 or alteratively will test to see whether any interrupts
663 If a pending interrupt was found then, call, is called
664 and then this procedure returns.
665 It only listens for interrupts > pri.
668 PROCEDURE Listen (untilInterrupt
: BOOLEAN;
669 call
: DispatchVector
;
687 IF pri
< MAX (PROTECTION
)
697 timeval
:= InitTime (MAX (INTEGER), 0) ;
698 p
:= MAX (PROTECTION
) ;
706 input
: AddFd (inSet
, maxFd
, File
) |
707 output
: AddFd (outSet
, maxFd
, File
) |
708 time
: IF IsGreaterEqual (timeval
, abs
)
710 GetTime (abs
, sec
, micro
) ;
711 Assert (micro
< Microseconds
) ;
714 printf ("shortest delay is %u.%06u\n", sec
, micro
)
716 SetTime (timeval
, sec
, micro
) ;
726 IF NOT untilInterrupt
728 SetTime (timeval
, 0, 0)
730 IF untilInterrupt
AND (((inSet
=NIL) AND (outSet
=NIL)) OR (maxFd
=-1)) AND (NOT found
)
732 Halt ('deadlock found, no more processes to run and no interrupts active',
733 __FILE__
, __FUNCTION__
, __LINE__
)
735 (* printf('timeval = 0x%x\n', timeval) ; *)
736 (* printf('}\n') ; *)
737 IF (NOT found
) AND (maxFd
=-1)
739 (* no file descriptors to be selected upon. *)
740 timeval
:= KillTime (timeval
) ;
744 GetTime (timeval
, sec
, micro
) ;
745 Assert (micro
< Microseconds
) ;
746 zero
:= InitTime (0, 0) ;
747 b4
:= InitTime (0, 0) ;
748 after
:= InitTime (0, 0) ;
749 result
:= GetTimeOfDay (b4
) ;
751 SubTime (sec
, micro
, timeval
, b4
) ;
752 SetTime (timeval
, sec
, micro
) ;
755 printf ("select waiting for %u.%06u seconds\n", sec
, micro
)
761 printf ("select (.., .., .., %u.%06u)\n", sec
, micro
)
765 result
:= select (0, NIL, NIL, NIL, timeval
)
767 result
:= select (maxFd
+1, inSet
, outSet
, NIL, timeval
)
773 perror ("select failed : ") ;
775 result
:= select (maxFd
+1, inSet
, outSet
, NIL, zero
) ;
778 GetTime (timeval
, sec
, micro
) ;
781 printf ("(nfds : %d timeval: %u.%06u) : \n", maxFd
, sec
, micro
) ;
783 perror ("select timeout argument was faulty : ")
785 result
:= select (maxFd
+1, inSet
, NIL, NIL, timeval
) ;
788 perror ("select output fd argument was faulty : ")
790 result
:= select (maxFd
+1, NIL, outSet
, NIL, timeval
) ;
793 perror ("select input fd argument was faulty : ")
797 result
:= select (0, NIL, NIL, NIL, timeval
) ;
802 perror ("select does not accept nfds == 0 ") ;
807 perror ("select maxFD+1 argument was faulty : ") ;
815 WHILE activatePending (untilInterrupt
, call
, pri
,
816 maxFd
+1, inSet
, outSet
, timeval
, b4
, after
) DO
820 timeval
:= KillTime (timeval
)
824 zero
:= KillTime (zero
)
828 after
:= KillTime (after
)
836 inSet
:= KillSet (inSet
)
840 outSet
:= KillSet (outSet
)
855 lock
:= initSemaphore (1) ;
858 FOR p
:= MIN(PROTECTION
) TO MAX(PROTECTION
) DO
861 initialized
:= TRUE ;