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

   1 (* Semaphores.mod implement the ISO Semaphores specification.
   2
   3 Copyright (C) 2010-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 Semaphores ;
  28
  29 (* Provides mutual exclusion facilities for use by processes. *)
  30
  31 FROM Storage IMPORT ALLOCATE ;
  32 FROM Processes IMPORT ProcessId, Me, SuspendMe, Activate, UrgencyOf ;
  33
  34
  35 TYPE
  36    SEMAPHORE = POINTER TO RECORD
  37                              value: CARDINAL ;
  38                              next : SEMAPHORE ;
  39                              head : ProcessList ;
  40                           END ;
  41
  42    ProcessList = POINTER TO RECORD
  43                                waiting: ProcessId ;
  44                                right,
  45                                left   : ProcessList ;
  46                             END ;
  47
  48 VAR
  49    freeSem        :  SEMAPHORE ;
  50    freeProcessList:  ProcessList ;
  51
  52
  53 (*
  54    Create - creates and returns s as the identity of a new
  55             semaphore that has its associated count initialized
  56             to initialCount, and has no processes yet waiting on it.
  57 *)
  58
  59 PROCEDURE Create (VAR s: SEMAPHORE; initialCount: CARDINAL) ;
  60 BEGIN
  61    s := newSemaphore () ;
  62    WITH s^ DO
  63       value := initialCount ;
  64       next  := NIL ;
  65       head  := NIL
  66    END
  67 END Create ;
  68
  69
  70 (*
  71    Destroy - recovers the resources used to implement the semaphore s,
  72              provided that no process is waiting for s to become free.
  73 *)
  74
  75 PROCEDURE Destroy (VAR s: SEMAPHORE) ;
  76 BEGIN
  77    WITH s^ DO
  78       IF head=NIL
  79       THEN
  80          next := freeSem ;
  81          freeSem := s
  82       ELSE
  83          (* raise exception? *)
  84       END
  85    END
  86 END Destroy ;
  87
  88
  89 (*
  90    newSemaphore -
  91 *)
  92
  93 PROCEDURE newSemaphore () : SEMAPHORE ;
  94 VAR
  95    s: SEMAPHORE ;
  96 BEGIN
  97    IF freeSem=NIL
  98    THEN
  99       NEW (s)
 100    ELSE
 101       s := freeSem ;
 102       freeSem := freeSem^.next
 103    END ;
 104    RETURN s
 105 END newSemaphore ;
 106
 107
 108 (*
 109    newProcessList - returns a new ProcessList.
 110 *)
 111
 112 PROCEDURE newProcessList () : ProcessList ;
 113 VAR
 114    l: ProcessList ;
 115 BEGIN
 116    IF freeProcessList=NIL
 117    THEN
 118       NEW (l)
 119    ELSE
 120       l := freeProcessList ;
 121       freeProcessList := freeProcessList^.right
 122    END ;
 123    RETURN l
 124 END newProcessList ;
 125
 126
 127 (*
 128    add - adds process, p, to queue, head.
 129 *)
 130
 131 PROCEDURE add (VAR head: ProcessList; p: ProcessList) ;
 132 BEGIN
 133    IF head=NIL
 134    THEN
 135       head := p ;
 136       p^.left := p ;
 137       p^.right := p
 138    ELSE
 139       p^.right := head ;
 140       p^.left := head^.left ;
 141       head^.left^.right := p ;
 142       head^.left := p
 143    END
 144 END add ;
 145
 146
 147 (*
 148    sub - subtracts process, p, from queue, head.
 149 *)
 150
 151 PROCEDURE sub (VAR head: ProcessList; p: ProcessList) ;
 152 BEGIN
 153    IF (p^.left=head) AND (p=head)
 154    THEN
 155       head := NIL
 156    ELSE
 157       IF head=p
 158       THEN
 159          head := head^.right
 160       END ;
 161       p^.left^.right := p^.right ;
 162       p^.right^.left := p^.left
 163    END
 164 END sub ;
 165
 166
 167 (*
 168    addProcess - adds the current process to the semaphore list.
 169                 Remove the current process from the ready queue.
 170 *)
 171
 172 PROCEDURE addProcess (VAR head: ProcessList) ;
 173 VAR
 174    l: ProcessList ;
 175 BEGIN
 176    l := newProcessList() ;
 177    WITH l^ DO
 178       waiting := Me () ;
 179       right := NIL ;
 180       left := NIL
 181    END ;
 182    add (head, l) ;
 183    SuspendMe
 184 END addProcess ;
 185
 186
 187 (*
 188    chooseProcess -
 189 *)
 190
 191 PROCEDURE chooseProcess (head: ProcessList) : ProcessList ;
 192 VAR
 193    best, l: ProcessList ;
 194 BEGIN
 195    best := head ;
 196    l := head^.right ;
 197    WHILE l#head DO
 198       IF UrgencyOf (l^.waiting) > UrgencyOf (best^.waiting)
 199       THEN
 200          best := l
 201       END ;
 202       l := l^.right
 203    END ;
 204    RETURN best
 205 END chooseProcess ;
 206
 207
 208 (*
 209    removeProcess - removes process, l, from the list and adds it to the
 210                    ready queue.
 211 *)
 212
 213 PROCEDURE removeProcess (VAR head: ProcessList; l: ProcessList) ;
 214 BEGIN
 215    sub (head, l) ;
 216    WITH l^ DO
 217       right := freeProcessList ;
 218       freeProcessList := l ;
 219       Activate (waiting)
 220    END
 221 END removeProcess ;
 222
 223
 224 (*
 225    Claim - if the count associated with the semaphore s is non-zero,
 226            decrements this count and allows the calling process to
 227            continue; otherwise suspends the calling process until
 228            s is released.
 229 *)
 230
 231 PROCEDURE Claim (s: SEMAPHORE) ;
 232 BEGIN
 233    WITH s^ DO
 234       IF value>0
 235       THEN
 236          DEC (value)
 237       ELSE
 238          addProcess (head)
 239       END
 240    END
 241 END Claim ;
 242
 243
 244 (*
 245    Release - if there are any processes waiting on the semaphore s,
 246              allows one of them to enter the ready state; otherwise
 247              increments the count associated with s.
 248 *)
 249
 250 PROCEDURE Release (s: SEMAPHORE) ;
 251 BEGIN
 252    WITH s^ DO
 253       IF head=NIL
 254       THEN
 255          INC (value)
 256       ELSE
 257          removeProcess (head, chooseProcess (head))
 258       END
 259    END
 260 END Release ;
 261
 262
 263 (*
 264    CondClaim - returns FALSE if the call Claim(s) would cause the calling
 265                process to be suspended; in this case the count associated
 266                with s is not changed. Otherwise returns TRUE and the
 267                associated count is decremented.
 268 *)
 269
 270 PROCEDURE CondClaim (s: SEMAPHORE) : BOOLEAN ;
 271 BEGIN
 272    WITH s^ DO
 273       IF value>0
 274       THEN
 275          DEC (value) ;
 276          RETURN TRUE
 277       ELSE
 278          RETURN FALSE
 279       END
 280    END
 281 END CondClaim ;
 282
 283
 284 BEGIN
 285    freeSem := NIL ;
 286    freeProcessList := NIL
 287 END Semaphores.