gcc/m2/gm2-libs-coroutines/SYSTEM.mod

   1 (* SYSTEM.mod provides access to COROUTINE primitives and underlying system.
   2
   3 Copyright (C) 2002-2023 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 SYSTEM ;
  28
  29 FROM RTco IMPORT init, initThread, transfer, currentThread, turnInterrupts ;
  30
  31 FROM RTint IMPORT Listen, AttachVector,
  32                   IncludeVector, ExcludeVector ;
  33
  34 IMPORT RTint ;
  35
  36 FROM Storage IMPORT ALLOCATE ;
  37 FROM M2RTS IMPORT Halt ;
  38 FROM libc IMPORT printf, memcpy, memset ;
  39
  40
  41 CONST
  42    BitsPerBitset = MAX (BITSET) +1 ;
  43
  44 TYPE
  45    PtrToIOTransferState = POINTER TO IOTransferState ;
  46    IOTransferState      = RECORD
  47                              ptrToFirst,
  48                              ptrToSecond: POINTER TO PROCESS ;
  49                              next       : PtrToIOTransferState ;
  50                           END ;
  51
  52 VAR
  53    initMain,
  54    initGTh : BOOLEAN ;
  55
  56
  57 (*
  58    TRANSFER - save the current volatile environment into, p1.
  59               Restore the volatile environment from, p2.
  60 *)
  61
  62 PROCEDURE TRANSFER (VAR p1: PROCESS; p2: PROCESS) ;
  63 VAR
  64    r: INTEGER ;
  65 BEGIN
  66    localMain (p1) ;
  67    IF p1.context=p2.context
  68    THEN
  69       Halt('error when attempting to context switch to the same process',
  70            __FILE__, __FUNCTION__, __LINE__)
  71    END ;
  72    transfer (p1.context, p2.context)
  73 END TRANSFER ;
  74
  75
  76 (*
  77    NEWPROCESS - p is a parameterless procedure, a, is the origin of
  78                 the workspace used for the process stack and containing
  79                 the volatile environment of the process.  StackSize, is
  80                 the maximum size of the stack in bytes which can be used
  81                 by this process.  new, is the new process.
  82 *)
  83
  84 PROCEDURE NEWPROCESS (p: PROC; a: ADDRESS; StackSize: CARDINAL; VAR new: PROCESS) ;
  85 BEGIN
  86    localInit ;
  87    WITH new DO
  88       context := initThread (p, StackSize, MAX(PROTECTION))
  89    END
  90 END NEWPROCESS ;
  91
  92
  93 (*
  94    IOTRANSFER - saves the current volatile environment into, First,
  95                 and restores volatile environment, Second.
  96                 When an interrupt, InterruptNo, is encountered then
  97                 the reverse takes place. (The then current volatile
  98                 environment is shelved onto Second and First is resumed).
  99
 100                 NOTE: that upon interrupt the Second might not be the
 101                       same process as that before the original call to
 102                       IOTRANSFER.
 103 *)
 104
 105 PROCEDURE IOTRANSFER (VAR First, Second: PROCESS; InterruptNo: CARDINAL) ;
 106 VAR
 107    p: IOTransferState ;
 108    l: POINTER TO IOTransferState ;
 109 BEGIN
 110    localMain (First) ;
 111    WITH p DO
 112       ptrToFirst  := ADR (First) ;
 113       ptrToSecond := ADR (Second) ;
 114       next        := AttachVector (InterruptNo, ADR (p))
 115    END ;
 116    IncludeVector (InterruptNo) ;
 117    TRANSFER (First, Second)
 118 END IOTRANSFER ;
 119
 120
 121 (*
 122    IOTransferHandler - handles interrupts related to a pending IOTRANSFER.
 123 *)
 124
 125 PROCEDURE IOTransferHandler (InterruptNo: CARDINAL;
 126                              Priority: CARDINAL ;
 127                              l: PtrToIOTransferState) ;
 128 VAR
 129    old: PtrToIOTransferState ;
 130 BEGIN
 131    IF l=NIL
 132    THEN
 133       Halt ('no processes attached to this interrupt vector which is associated with IOTRANSFER',
 134             __FILE__, __FUNCTION__, __LINE__)
 135    ELSE
 136       WITH l^ DO
 137          old := AttachVector (InterruptNo, next) ;
 138          IF old#l
 139          THEN
 140             Halt ('inconsistancy of return result',
 141                   __FILE__, __FUNCTION__, __LINE__)
 142          END ;
 143          IF next=NIL
 144          THEN
 145             ExcludeVector (InterruptNo)
 146          ELSE
 147             printf ('odd vector has been chained\n')
 148          END ;
 149          TRANSFER (ptrToSecond^, ptrToFirst^)
 150       END
 151    END
 152 END IOTransferHandler ;
 153
 154
 155 (*
 156    LISTEN - briefly listen for any interrupts.
 157 *)
 158
 159 PROCEDURE LISTEN ;
 160 BEGIN
 161    localInit ;
 162    Listen (FALSE, IOTransferHandler, MIN (PROTECTION))
 163 END LISTEN ;
 164
 165
 166 (*
 167    ListenLoop - should be called instead of users writing:
 168
 169                 LOOP
 170                    LISTEN
 171                 END
 172
 173                 It performs the same function but yields
 174                 control back to the underlying operating system.
 175                 It also checks for deadlock.
 176                 This function returns when an interrupt occurs.
 177                 (File descriptor becomes ready or time event expires).
 178 *)
 179
 180 PROCEDURE ListenLoop ;
 181 BEGIN
 182    localInit ;
 183    LOOP
 184       Listen (TRUE, IOTransferHandler, MIN (PROTECTION))
 185    END
 186 END ListenLoop ;
 187
 188
 189 (*
 190    TurnInterrupts - switches processor interrupts to the
 191                     protection level, to.  It returns the old value.
 192 *)
 193
 194 PROCEDURE TurnInterrupts (to: PROTECTION) : PROTECTION ;
 195 VAR
 196    old: PROTECTION ;
 197 BEGIN
 198    localInit ;
 199    old := VAL (PROTECTION, turnInterrupts (VAL (CARDINAL, to))) ;
 200    Listen (FALSE, IOTransferHandler, to) ;
 201    (* printf ("interrupt level is %d\n", currentIntValue); *)
 202    RETURN old
 203 END TurnInterrupts ;
 204
 205
 206 (*
 207    Finished - generates an error message. Modula-2 processes should never
 208               terminate.
 209 *)
 210
 211 PROCEDURE Finished (p: ADDRESS) ;
 212 BEGIN
 213    Halt('process terminated illegally',
 214         __FILE__, __FUNCTION__, __LINE__)
 215 END Finished ;
 216
 217
 218 (*
 219    localInit - checks to see whether we need to initialize pthread
 220 *)
 221
 222 PROCEDURE localInit ;
 223 BEGIN
 224    IF NOT initGTh
 225    THEN
 226       initGTh := TRUE ;
 227       IF init () # 0
 228       THEN
 229          Halt ("gthr did not initialize",
 230                __FILE__, __FUNCTION__, __LINE__)
 231       END ;
 232       RTint.Init
 233    END
 234 END localInit ;
 235
 236
 237 (*
 238    localMain - creates the holder for the main process.
 239 *)
 240
 241 PROCEDURE localMain (VAR mainProcess: PROCESS) ;
 242 BEGIN
 243    IF NOT initMain
 244    THEN
 245       initMain := TRUE ;
 246       WITH mainProcess DO
 247          context := currentThread ()
 248       END
 249    END
 250 END localMain ;
 251
 252
 253 (*
 254    Max - returns the maximum of a and b.
 255 *)
 256
 257 PROCEDURE Max (a, b: CARDINAL) : CARDINAL ;
 258 BEGIN
 259    IF a > b
 260    THEN
 261       RETURN a
 262    ELSE
 263       RETURN b
 264    END
 265 END Max ;
 266
 267
 268 (*
 269    Min - returns the minimum of a and b.
 270 *)
 271
 272 PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
 273 BEGIN
 274    IF a < b
 275    THEN
 276       RETURN a
 277    ELSE
 278       RETURN b
 279    END
 280 END Min ;
 281
 282
 283 (*
 284    ShiftVal - is a runtime procedure whose job is to implement
 285               the SHIFT procedure of ISO SYSTEM. GNU Modula-2 will
 286               inline a SHIFT of a single WORD sized set and will only
 287               call this routine for larger sets.
 288 *)
 289
 290 PROCEDURE ShiftVal (VAR s, d: ARRAY OF BITSET;
 291                     SetSizeInBits: CARDINAL;
 292                     ShiftCount: INTEGER) ;
 293 VAR
 294    a: ADDRESS ;
 295 BEGIN
 296    IF ShiftCount>0
 297    THEN
 298       ShiftCount := ShiftCount MOD VAL(INTEGER, SetSizeInBits) ;
 299       ShiftLeft (s, d, SetSizeInBits, ShiftCount)
 300    ELSIF ShiftCount<0
 301    THEN
 302       ShiftCount := (-ShiftCount) MOD VAL(INTEGER, SetSizeInBits) ;
 303       ShiftRight (s, d, SetSizeInBits, ShiftCount)
 304    ELSE
 305       a := memcpy (ADR (d), ADR (s), (HIGH (d) + 1) * SIZE (BITSET))
 306    END
 307 END ShiftVal ;
 308
 309
 310 (*
 311    ShiftLeft - performs the shift left for a multi word set.
 312                This procedure might be called by the back end of
 313                GNU Modula-2 depending whether amount is known at compile
 314                time.
 315 *)
 316
 317 PROCEDURE ShiftLeft (VAR s, d: ARRAY OF BITSET;
 318                      SetSizeInBits: CARDINAL;
 319                      ShiftCount: CARDINAL) ;
 320 VAR
 321    lo, hi : BITSET ;
 322    i, j, h: CARDINAL ;
 323    a      : ADDRESS ;
 324 BEGIN
 325    h := HIGH(s)+1 ;
 326    IF ShiftCount MOD BitsPerBitset=0
 327    THEN
 328       i := ShiftCount DIV BitsPerBitset ;
 329       a := ADR (d[i]) ;
 330       a := memcpy (a, ADR (s), (h-i) * SIZE (BITSET)) ;
 331       a := memset (ADR (d), 0, i * SIZE (BITSET))
 332    ELSE
 333       i := h ;
 334       WHILE i>0 DO
 335          DEC (i) ;
 336          lo := SHIFT (s[i], ShiftCount MOD BitsPerBitset) ;
 337          hi := SHIFT (s[i], -(BitsPerBitset - (ShiftCount MOD BitsPerBitset))) ;
 338          d[i] := BITSET{} ;
 339          j := i + ShiftCount DIV BitsPerBitset ;
 340          IF j<h
 341          THEN
 342             d[j] := d[j] + lo ;
 343             INC(j) ;
 344             IF j<h
 345             THEN
 346                d[j] := d[j] + hi
 347             END
 348          END
 349       END
 350    END
 351 END ShiftLeft ;
 352
 353
 354 (*
 355    ShiftRight - performs the shift left for a multi word set.
 356                 This procedure might be called by the back end of
 357                 GNU Modula-2 depending whether amount is known at compile
 358                 time.
 359 *)
 360
 361 PROCEDURE ShiftRight (VAR s, d: ARRAY OF BITSET;
 362                       SetSizeInBits: CARDINAL;
 363                       ShiftCount: CARDINAL) ;
 364 VAR
 365    lo, hi : BITSET ;
 366    j, i, h: INTEGER ;
 367    a      : ADDRESS ;
 368 BEGIN
 369    h := HIGH (s) + 1 ;
 370    IF ShiftCount MOD BitsPerBitset=0
 371    THEN
 372       i := ShiftCount DIV BitsPerBitset ;
 373       a := ADR (s[i]) ;
 374       j := h-i ;
 375       a := memcpy (ADR (d), a, j * VAL (INTEGER, SIZE(BITSET))) ;
 376       a := ADR (d[j]) ;
 377       a := memset (a, 0, i * VAL (INTEGER, SIZE(BITSET)))
 378    ELSE
 379       i := 0 ;
 380       WHILE i<h DO
 381          lo := SHIFT(s[i], BitsPerBitset - (ShiftCount MOD BitsPerBitset)) ;
 382          hi := SHIFT(s[i], -(ShiftCount MOD BitsPerBitset)) ;
 383          d[i] := BITSET{} ;
 384          j := i - VAL(INTEGER, ShiftCount DIV BitsPerBitset) ;
 385          IF j>=0
 386          THEN
 387             d[j] := d[j] + hi ;
 388             DEC(j) ;
 389             IF j>=0
 390             THEN
 391                d[j] := d[j] + lo
 392             END
 393          END ;
 394          INC(i)
 395       END
 396    END
 397 END ShiftRight ;
 398
 399
 400 (*
 401    RotateVal - is a runtime procedure whose job is to implement
 402                the ROTATE procedure of ISO SYSTEM. GNU Modula-2 will
 403                inline a ROTATE of a single WORD (or less)
 404                sized set and will only call this routine for larger sets.
 405 *)
 406
 407 PROCEDURE RotateVal (VAR s, d: ARRAY OF BITSET;
 408                      SetSizeInBits: CARDINAL;
 409                      RotateCount: INTEGER) ;
 410 VAR
 411    a: ADDRESS ;
 412 BEGIN
 413    IF RotateCount>0
 414    THEN
 415       RotateLeft(s, d, SetSizeInBits, RotateCount)
 416    ELSIF RotateCount<0
 417    THEN
 418       RotateRight(s, d, SetSizeInBits, -RotateCount)
 419    ELSE
 420       a := memcpy(ADR(d), ADR(s), (HIGH(d)+1)*SIZE(BITSET))
 421    END
 422 END RotateVal ;
 423
 424
 425 (*
 426    RotateLeft - performs the rotate left for a multi word set.
 427                 This procedure might be called by the back end of
 428                 GNU Modula-2 depending whether amount is known at compile
 429                 time.
 430 *)
 431
 432 PROCEDURE RotateLeft (VAR s, d: ARRAY OF BITSET;
 433                       SetSizeInBits: CARDINAL;
 434                       RotateCount: CARDINAL) ;
 435 VAR
 436    lo, hi : BITSET ;
 437    b, i, j, h: CARDINAL ;
 438 BEGIN
 439    h := HIGH(s) ;
 440    (* firstly we set d := {} *)
 441    i := 0 ;
 442    WHILE i<=h DO
 443       d[i] := BITSET{} ;
 444       INC(i)
 445    END ;
 446    i := h+1 ;
 447    RotateCount := RotateCount MOD SetSizeInBits ;
 448    b := SetSizeInBits MOD BitsPerBitset ;
 449    IF b=0
 450    THEN
 451       b := BitsPerBitset
 452    END ;
 453    WHILE i>0 DO
 454       DEC(i) ;
 455       lo := SHIFT(s[i], RotateCount MOD BitsPerBitset) ;
 456       hi := SHIFT(s[i], -(b - (RotateCount MOD BitsPerBitset))) ;
 457       j := ((i*BitsPerBitset + RotateCount) MOD
 458             SetSizeInBits) DIV BitsPerBitset ;
 459       d[j] := d[j] + lo ;
 460       j := (((i+1)*BitsPerBitset + RotateCount) MOD
 461             SetSizeInBits) DIV BitsPerBitset ;
 462       d[j] := d[j] + hi ;
 463       b := BitsPerBitset
 464    END
 465 END RotateLeft ;
 466
 467
 468 (*
 469    RotateRight - performs the rotate right for a multi word set.
 470                  This procedure might be called by the back end of
 471                  GNU Modula-2 depending whether amount is known at compile
 472                  time.
 473 *)
 474
 475 PROCEDURE RotateRight (VAR s, d: ARRAY OF BITSET;
 476                        SetSizeInBits: CARDINAL;
 477                        RotateCount: CARDINAL) ;
 478 BEGIN
 479    RotateLeft(s, d, SetSizeInBits, SetSizeInBits-RotateCount)
 480 END RotateRight ;
 481
 482
 483 BEGIN
 484    initGTh := FALSE ;
 485    initMain := FALSE
 486 END SYSTEM.