gcc/m2/gm2-libs-iso/COROUTINES.mod

   1 (* COROUTINES.mod implement the ISO COROUTINES specification.
   2
   3 Copyright (C) 2002-2024 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   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)
  11 any later version.
  12
  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.
  17
  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.
  21
  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/>.  *)
  26
  27 IMPLEMENTATION MODULE COROUTINES ;
  28
  29 FROM RTco IMPORT init, initThread, transfer, initSemaphore,
  30                  wait, signal, currentThread, turnInterrupts,
  31                  currentInterruptLevel ;
  32
  33 FROM RTExceptions IMPORT EHBlock, InitExceptionBlock,
  34                          SetExceptionBlock, GetExceptionBlock,
  35                          SetExceptionState, IsInExceptionState,
  36                          SetExceptionSource, GetExceptionSource ;
  37
  38 FROM SYSTEM IMPORT ADDRESS, ADR ;
  39 FROM EXCEPTIONS IMPORT ExceptionSource ;
  40 FROM RTint IMPORT Listen, AttachVector, IncludeVector, ExcludeVector ;
  41 FROM Storage IMPORT ALLOCATE ;
  42 FROM Assertion IMPORT Assert ;
  43 FROM M2RTS IMPORT Halt ;
  44 FROM libc IMPORT printf ;
  45 FROM Processes IMPORT displayProcesses ;
  46
  47 IMPORT RTint ;
  48
  49
  50 CONST
  51    MinStack  = 16 * 1024 * 1024 ;
  52    Debugging = FALSE ;
  53
  54 TYPE
  55    Status = (suspended, ready, new, running) ;
  56
  57    COROUTINE = POINTER TO RECORD
  58                              context   : INTEGER ;
  59                              ehblock   : EHBlock ;
  60                              inexcept  : BOOLEAN ;
  61                              source    : ExceptionSource ;
  62                              wspace    : SYSTEM.ADDRESS ;
  63                              nLocs     : CARDINAL ;
  64                              status    : Status ;
  65                              attached  : SourceList ;
  66                              next      : COROUTINE ;
  67                           END ;
  68
  69    SourceList = POINTER TO RECORD
  70                               next     : SourceList ;    (* next in the list of vectors which are      *)
  71                                                          (* attached to this coroutine.                *)
  72                               vec      : INTERRUPTSOURCE ;  (* the interrupt vector (source)           *)
  73                               curco    : COROUTINE ;     (* the coroutine which is waiting on this vec *)
  74                               chain    : SourceList ;    (* the next coroutine waiting on this vec     *)
  75                               ptrToTo,
  76                               ptrToFrom: POINTER TO COROUTINE ;
  77                            END ;
  78
  79
  80 VAR
  81    freeList         : SourceList ;
  82    head             : COROUTINE ;
  83    previous,
  84    currentCoRoutine : COROUTINE ;
  85    illegalFinish    : ADDRESS ;
  86    initMain,
  87    initCo           : BOOLEAN ;
  88    lock             : INTEGER ;    (* semaphore protecting module data structures.  *)
  89
  90
  91 PROCEDURE NEWCOROUTINE (procBody: PROC;
  92                         workspace: SYSTEM.ADDRESS;
  93                         size: CARDINAL;
  94                         VAR cr: COROUTINE;
  95                         [initProtection: PROTECTION]);
  96
  97   (* Creates a new coroutine whose body is given by procBody, and
  98      returns the identity of the coroutine in cr. workspace is a
  99      pointer to the work space allocated to the coroutine; size
 100      specifies the size of this workspace in terms of SYSTEM.LOC.
 101
 102      The optarg, initProtection, may contain a single parameter
 103      which specifies the initial protection level of the coroutine.
 104   *)
 105 VAR
 106    tp : INTEGER ;
 107    old: PROTECTION ;
 108 BEGIN
 109    localInit ;
 110    old := TurnInterrupts (MAX (PROTECTION)) ;
 111    IF initProtection = UnassignedPriority
 112    THEN
 113       initProtection := PROT ()
 114    END ;
 115    tp := initThread (procBody, size, initProtection) ;
 116    IF tp = -1
 117    THEN
 118       Halt ('unable to create a new thread', __FILE__, __FUNCTION__, __LINE__)
 119    END ;
 120    NEW (cr) ;
 121    WITH cr^ DO
 122       context    := tp ;
 123       ehblock    := InitExceptionBlock () ;
 124       inexcept   := FALSE ;
 125       source     := NIL ;
 126       wspace     := workspace ;
 127       nLocs      := size ;
 128       status     := new ;
 129       attached   := NIL ;
 130       next       := head
 131    END ;
 132    head := cr ;
 133    old := TurnInterrupts (old)
 134 END NEWCOROUTINE ;
 135
 136
 137 PROCEDURE TRANSFER (VAR from: COROUTINE; to: COROUTINE);
 138   (* Returns the identity of the calling coroutine in from, and
 139      transfers control to the coroutine specified by to.
 140   *)
 141 VAR
 142    old: PROTECTION ;
 143 BEGIN
 144    localInit ;
 145    old := TurnInterrupts (MAX (PROTECTION)) ;
 146    (* wait (lock) ; *)
 147    Transfer (from, to) ;
 148    (* signal (lock) ; *)
 149    old := TurnInterrupts (old)
 150 END TRANSFER ;
 151
 152
 153 (*
 154    Transfer -
 155 *)
 156
 157 PROCEDURE Transfer (VAR from: COROUTINE; to: COROUTINE) ;
 158 BEGIN
 159    IF Debugging
 160    THEN
 161       printf ("TRANSFER\n");
 162       printf ("current coroutine is: %d\n", currentCoRoutine^.context);
 163       IF previous # NIL
 164       THEN
 165          printf ("previous coroutine is: %d\n", previous^.context)
 166       END ;
 167       printf ("wishes to context switch to: %d\n", to^.context);
 168    END ;
 169    previous := currentCoRoutine ;
 170    from := currentCoRoutine ;
 171    IF to^.context = from^.context
 172    THEN
 173       Halt ('error when attempting to context switch to the same process',
 174             __FILE__, __FUNCTION__, __LINE__)
 175    END ;
 176    from^.inexcept := SetExceptionState (to^.inexcept) ;
 177    from^.source := GetExceptionSource () ;
 178    currentCoRoutine := to ;
 179    SetExceptionBlock (currentCoRoutine^.ehblock) ;
 180    SetExceptionSource (currentCoRoutine^.source) ;
 181    transfer (from^.context, to^.context)
 182 END Transfer ;
 183
 184
 185 (*
 186    localMain - creates the holder for the main process.
 187 *)
 188
 189 PROCEDURE localMain ;
 190 VAR
 191    old: PROTECTION ;
 192 BEGIN
 193    IF NOT initMain
 194    THEN
 195       initMain := TRUE ;
 196       lock := initSemaphore (1) ;
 197       wait (lock) ;
 198       NEW (currentCoRoutine) ;
 199       WITH currentCoRoutine^ DO
 200          context    := currentThread () ;
 201          ehblock    := GetExceptionBlock () ;
 202          inexcept   := IsInExceptionState () ;
 203          source     := GetExceptionSource () ;
 204          wspace     := NIL ;
 205          nLocs      := 0 ;
 206          status     := running ;
 207          attached   := NIL ;
 208          next       := head
 209       END ;
 210       head := currentCoRoutine ;
 211       old := turnInterrupts (MAX (PROTECTION)) ;    (* was UnassignedPriority *)
 212       signal (lock)
 213    END
 214 END localMain ;
 215
 216
 217 (*
 218    localInit - checks to see whether we need to initialize our interface to pthreads.
 219 *)
 220
 221 PROCEDURE localInit ;
 222 BEGIN
 223    IF NOT initCo
 224    THEN
 225       Init ;
 226       IF init () # 0
 227       THEN
 228          Halt ('failed to initialize RTco',
 229                __FILE__, __FUNCTION__, __LINE__)
 230       END ;
 231       RTint.Init ;
 232       initCo := TRUE
 233    END ;
 234    localMain
 235 END localInit ;
 236
 237
 238 PROCEDURE IOTRANSFER (VAR from: COROUTINE; to: COROUTINE);
 239   (* Returns the identity of the calling coroutine in from and
 240      transfers control to the coroutine specified by to.  On
 241      occurrence of an interrupt, associated with the caller, control
 242      is transferred back to the caller, and the identity of the
 243      interrupted coroutine is returned in from.  The calling coroutine
 244      must be associated with a source of interrupts.
 245   *)
 246 VAR
 247    prev,
 248    l   : SourceList ;
 249    old : PROTECTION ;
 250 BEGIN
 251    localInit ;
 252    old := TurnInterrupts (MAX (PROTECTION)) ;
 253    IF from = to
 254    THEN
 255       Halt ("error IOTRANSFER cannot transfer control to the running COROUTINE",
 256             __FILE__, __FUNCTION__, __LINE__)
 257    END ;
 258    wait (lock) ;
 259    l := currentCoRoutine^.attached ;
 260    IF l=NIL
 261    THEN
 262       printf ("no source of interrupts associated with coroutine\n")
 263    END ;
 264    WHILE l # NIL DO
 265       WITH l^ DO
 266          ptrToFrom := ADR (from) ;
 267          ptrToTo   := ADR (to) ;
 268          curco := currentCoRoutine ;
 269          Assert (currentCoRoutine # NIL) ;
 270          prev := AttachVector (vec, l) ;
 271          Assert (from # to) ;
 272          IF (prev # NIL) AND (prev # l)
 273          THEN
 274             printf ("not expecting multiple COROUTINES to be waiting on a single interrupt source\n")
 275          END ;
 276          IncludeVector (vec)
 277       END ;
 278       l := l^.next
 279    END ;
 280    signal (lock) ;
 281    Transfer (from, to) ;
 282    from := previous ;
 283    old := TurnInterrupts (old)
 284 END IOTRANSFER ;
 285
 286
 287 (*
 288    New - assigns, l, to a new SourceList.
 289 *)
 290
 291 PROCEDURE New (VAR l: SourceList) ;
 292 BEGIN
 293    IF freeList=NIL
 294    THEN
 295       NEW (l)
 296    ELSE
 297       l := freeList ;
 298       freeList := freeList^.next
 299    END
 300 END New ;
 301
 302
 303 (*
 304    Dispose - returns, l, to the freeList.
 305 *)
 306
 307 PROCEDURE Dispose (l: SourceList) ;
 308 BEGIN
 309    l^.next := freeList ;
 310    freeList := l
 311 END Dispose ;
 312
 313
 314 PROCEDURE ATTACH (source: INTERRUPTSOURCE);
 315   (* Associates the specified source of interrupts with the calling
 316      coroutine. *)
 317 VAR
 318    l: SourceList ;
 319 BEGIN
 320    localInit ;
 321    wait (lock) ;
 322    l := currentCoRoutine^.attached ;
 323    WHILE l#NIL DO
 324       IF l^.vec = source
 325       THEN
 326          l^.curco := currentCoRoutine ;
 327          signal (lock) ;
 328          RETURN
 329       ELSE
 330          l := l^.next
 331       END
 332    END ;
 333    New (l) ;
 334    WITH l^ DO
 335       next := currentCoRoutine^.attached ;
 336       vec := source ;
 337       curco := currentCoRoutine ;
 338       chain := NIL ;
 339    END ;
 340    currentCoRoutine^.attached := l ;
 341    IF AttachVector (source, l) # NIL
 342    THEN
 343       printf ("ATTACH implementation restriction only one coroutine may be attached to a specific interrupt source\n")
 344    END ;
 345    signal (lock)
 346 END ATTACH ;
 347
 348
 349 PROCEDURE DETACH (source: INTERRUPTSOURCE);
 350   (* Dissociates the specified source of interrupts from the calling
 351      coroutine. *)
 352 VAR
 353    l, prev: SourceList ;
 354 BEGIN
 355    localInit ;
 356    wait (lock) ;
 357    l := currentCoRoutine^.attached ;
 358    prev := NIL ;
 359    WHILE l # NIL DO
 360       IF l^.vec = source
 361       THEN
 362          IF prev = NIL
 363          THEN
 364             Assert (l = currentCoRoutine^.attached) ;
 365             currentCoRoutine^.attached := currentCoRoutine^.attached^.next ;
 366          ELSE
 367             prev^.next := l^.next
 368          END ;
 369          Dispose (l) ;
 370          signal (lock) ;
 371          RETURN
 372       ELSE
 373          prev := l ;
 374          l := l^.next
 375       END
 376    END ;
 377    signal (lock)
 378 END DETACH ;
 379
 380
 381 (*
 382    getAttached - returns the first COROUTINE associated with, source.
 383                  It returns NIL is no COROUTINE is associated with, source.
 384 *)
 385
 386 PROCEDURE getAttached (source: INTERRUPTSOURCE) : COROUTINE ;
 387 VAR
 388    l: SourceList ;
 389    c: COROUTINE ;
 390 BEGIN
 391    localInit ;
 392    c := head ;
 393    WHILE c # NIL DO
 394       l := c^.attached ;
 395       WHILE l#NIL DO
 396          IF l^.vec = source
 397          THEN
 398             RETURN c
 399          ELSE
 400             l := l^.next
 401          END
 402       END ;
 403       c := c^.next
 404    END ;
 405    RETURN NIL
 406 END getAttached ;
 407
 408
 409 PROCEDURE IsATTACHED (source: INTERRUPTSOURCE): BOOLEAN;
 410   (* Returns TRUE if and only if the specified source of interrupts is
 411      currently associated with a coroutine; otherwise returns FALSE.
 412   *)
 413 VAR
 414    result: BOOLEAN ;
 415 BEGIN
 416    localInit ;
 417    wait (lock) ;
 418    result := getAttached (source) # NIL ;
 419    signal (lock) ;
 420    RETURN result
 421 END IsATTACHED ;
 422
 423
 424 PROCEDURE HANDLER (source: INTERRUPTSOURCE) : COROUTINE;
 425   (* Returns the coroutine, if any, that is associated with the source
 426      of interrupts. The result is undefined if IsATTACHED(source) =
 427      FALSE.
 428   *)
 429 VAR
 430    co: COROUTINE ;
 431 BEGIN
 432    localInit ;
 433    wait (lock) ;
 434    co := getAttached (source) ;
 435    signal (lock) ;
 436    RETURN co
 437 END HANDLER ;
 438
 439
 440 PROCEDURE CURRENT () : COROUTINE ;
 441   (* Returns the identity of the calling coroutine. *)
 442 BEGIN
 443    localInit ;
 444    RETURN currentCoRoutine
 445 END CURRENT ;
 446
 447
 448 PROCEDURE LISTEN (p: PROTECTION) ;
 449   (* Momentarily changes the protection of the calling coroutine to p. *)
 450 BEGIN
 451    localInit ;
 452    Listen (FALSE, IOTransferHandler, p)
 453 END LISTEN ;
 454
 455
 456 (*
 457    ListenLoop - should be called instead of users writing:
 458
 459                 LOOP
 460                    LISTEN
 461                 END
 462
 463                 It performs the same function but yields
 464                 control back to the underlying operating system.
 465                 It also checks for deadlock.
 466                 This function returns when an interrupt occurs.
 467                 (File descriptor becomes ready or time event expires).
 468 *)
 469
 470 PROCEDURE ListenLoop ;
 471 BEGIN
 472    localInit ;
 473    Listen (TRUE, IOTransferHandler, MIN (PROTECTION))
 474 END ListenLoop ;
 475
 476
 477 (*
 478    removeAttached - removes all sources of interrupt from COROUTINE, c.
 479 *)
 480
 481 PROCEDURE removeAttached (c: COROUTINE) ;
 482 VAR
 483    l: SourceList ;
 484 BEGIN
 485    localInit ;
 486    l := c^.attached ;
 487    WHILE l#NIL DO
 488       ExcludeVector (l^.vec) ;
 489       l := l^.next
 490    END
 491 END removeAttached ;
 492
 493
 494 (*
 495    IOTransferHandler - handles interrupts related to a pending IOTRANSFER.
 496 *)
 497
 498 PROCEDURE IOTransferHandler (InterruptNo: CARDINAL;
 499                              Priority: CARDINAL ;
 500                              l: SourceList) ;
 501 VAR
 502    ourself: SourceList ;
 503 BEGIN
 504    IF Debugging
 505    THEN
 506       printf ("IOTransferHandler called\n") ;
 507       displayProcesses ("IOTransferHandler") ;
 508       printf ("IOTransferHandler vec %d coroutine: %d\n", l^.vec, l^.curco^.context);
 509       printf ("localInit\n");
 510    END ;
 511    localInit ;
 512    IF l = NIL
 513    THEN
 514       Halt ('no coroutine attached to this interrupt vector which was initiated by IOTRANSFER',
 515             __FILE__, __FUNCTION__, __LINE__)
 516    ELSE
 517       IF Debugging
 518       THEN
 519          printf ("IOTransferHandler called\n");
 520          printf ("before wait (lock)\n");
 521       END ;
 522       wait (lock) ;
 523       IF Debugging
 524       THEN
 525          printf ("IOTransferHandler vec %d coroutine 0x%x\n", l^.vec, l^.curco);
 526          printf ("current coroutine is: %d\n", currentCoRoutine^.context);
 527          IF previous # NIL
 528          THEN
 529             printf ("previous coroutine is: %d\n", previous^.context)
 530          END ;
 531          printf ("handler wants to context switch to:  %d\n", l^.curco^.context);
 532          displayProcesses ("IOTransferHandler")
 533       END ;
 534       WITH l^ DO
 535          (*
 536          ourself := AttachVector (InterruptNo, chain) ;
 537          IF ourself # l
 538          THEN
 539             Halt ('inconsistancy of return result',
 540                   __FILE__, __FUNCTION__, __LINE__)
 541          END ;
 542          IF chain = NIL
 543          THEN
 544             removeAttached (curco)
 545          ELSE
 546             printf ('odd vector has been chained\n')
 547          END ;
 548          *)
 549          removeAttached (curco) ;   (* remove all sources of interrupt for l^.curco.  *)
 550          ptrToFrom^ := currentCoRoutine ;
 551          previous := currentCoRoutine ;
 552          previous^.inexcept := SetExceptionState (curco^.inexcept) ;
 553          previous^.source := GetExceptionSource () ;
 554          currentCoRoutine := curco ;
 555          SetExceptionBlock (currentCoRoutine^.ehblock) ;
 556          SetExceptionSource (currentCoRoutine^.source) ;
 557          signal (lock) ;
 558          transfer (previous^.context, currentCoRoutine^.context)
 559       END
 560    END
 561 END IOTransferHandler ;
 562
 563
 564 PROCEDURE PROT () : PROTECTION;
 565   (* Returns the protection of the calling coroutine. *)
 566 BEGIN
 567    localInit ;
 568    RETURN currentInterruptLevel ()
 569 END PROT ;
 570
 571
 572 (*
 573    TurnInterrupts - switches processor interrupts to the protection
 574                     level, to.  It returns the old value.
 575 *)
 576
 577 PROCEDURE TurnInterrupts (to: PROTECTION) : PROTECTION ;
 578 VAR
 579    old: PROTECTION ;
 580 BEGIN
 581    localInit ;
 582    old := turnInterrupts (to) ;
 583    Listen (FALSE, IOTransferHandler, to) ;
 584    RETURN old
 585 END TurnInterrupts ;
 586
 587
 588 (*
 589    Init - initialize the global data structures.
 590 *)
 591
 592 PROCEDURE Init ;
 593 BEGIN
 594    freeList := NIL ;
 595    initMain := FALSE ;
 596    currentCoRoutine := NIL
 597 END Init ;
 598
 599
 600 END COROUTINES.