gcc/ada/s-taprop-os2.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
   4 --                                                                          --
   5 --    S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S     --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2005, Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is an OS/2 version of this package
  35
  36 --  This package contains all the GNULL primitives that interface directly
  37 --  with the underlying OS.
  38
  39 pragma Polling (Off);
  40 --  Turn off polling, we do not want ATC polling to take place during
  41 --  tasking operations. It causes infinite loops and other problems.
  42
  43 with System.Tasking.Debug;
  44 --  used for Known_Tasks
  45
  46 with System.OS_Primitives;
  47 --  used for Delay_Modes
  48 --           Clock
  49
  50 with Interfaces.OS2Lib.Errors;
  51 with Interfaces.OS2Lib.Threads;
  52 with Interfaces.OS2Lib.Synchronization;
  53
  54 with Interfaces.C;
  55 --  used for size_t
  56
  57 with Interfaces.C.Strings;
  58 --  used for Null_Ptr
  59
  60 with System.Parameters;
  61 --  used for Size_Type
  62
  63 with Unchecked_Conversion;
  64 with Unchecked_Deallocation;
  65
  66 package body System.Task_Primitives.Operations is
  67
  68    package IC  renames Interfaces.C;
  69    package ICS renames Interfaces.C.Strings;
  70    package OSP renames System.OS_Primitives;
  71
  72    use Interfaces.OS2Lib;
  73    use Interfaces.OS2Lib.Errors;
  74    use Interfaces.OS2Lib.Threads;
  75    use Interfaces.OS2Lib.Synchronization;
  76    use System.Parameters;
  77    use System.Tasking.Debug;
  78    use System.Tasking;
  79    use System.OS_Interface;
  80    use Interfaces.C;
  81    use System.OS_Primitives;
  82
  83    ---------------------
  84    -- Local Constants --
  85    ---------------------
  86
  87    Max_Locks_Per_Task   : constant := 100;
  88    Suppress_Owner_Check : constant Boolean := False;
  89
  90    -----------------
  91    -- Local Types --
  92    -----------------
  93
  94    subtype Lock_Range is Integer range 0 .. Max_Locks_Per_Task;
  95
  96    -----------------
  97    -- Local Data  --
  98    -----------------
  99
 100    --  The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr
 101
 102    --  This API reserves a small range of virtual addresses that is backed
 103    --  by different physical memory for each running thread. In this case we
 104    --  create a pointer at a fixed address that points to the TCB_Ptr for the
 105    --  running thread. So all threads will be able to query and update their
 106    --  own TCB_Ptr without destroying the TCB_Ptr of other threads.
 107
 108    type Thread_Local_Data is record
 109       Self_ID           : Task_Id;    --  ID of the current thread
 110       Lock_Prio_Level   : Lock_Range; --  Nr of priority changes due to locks
 111
 112       --  ... room for expansion here, if we decide to make access to
 113       --  jump-buffer and exception stack more efficient in future
 114    end record;
 115
 116    type Access_Thread_Local_Data is access all Thread_Local_Data;
 117
 118    --  Pointer to Thread Local Data
 119    Thread_Local_Data_Ptr : aliased Access_Thread_Local_Data;
 120
 121    type PPTLD is access all Access_Thread_Local_Data;
 122
 123    Single_RTS_Lock : aliased RTS_Lock;
 124    --  This is a lock to allow only one thread of control in the RTS at
 125    --  a time; it is used to execute in mutual exclusion from all other tasks.
 126    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
 127
 128    Environment_Task_Id : Task_Id;
 129    --  A variable to hold Task_Id for the environment task
 130
 131    -----------------------
 132    -- Local Subprograms --
 133    -----------------------
 134
 135    function To_PPVOID is new Unchecked_Conversion (PPTLD, PPVOID);
 136    function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
 137    function To_PFNTHREAD is
 138      new Unchecked_Conversion (System.Address, PFNTHREAD);
 139
 140    function To_MS (D : Duration) return ULONG;
 141
 142    procedure Set_Temporary_Priority
 143      (T            : in Task_Id;
 144       New_Priority : in System.Any_Priority);
 145
 146    -----------
 147    -- To_MS --
 148    -----------
 149
 150    function To_MS (D : Duration) return ULONG is
 151    begin
 152       return ULONG (D * 1_000);
 153    end To_MS;
 154
 155    -----------
 156    -- Clock --
 157    -----------
 158
 159    function Monotonic_Clock return Duration renames OSP.Monotonic_Clock;
 160
 161    -------------------
 162    -- RT_Resolution --
 163    -------------------
 164
 165    function RT_Resolution return Duration is
 166    begin
 167       return 10#1.0#E-6;
 168    end RT_Resolution;
 169
 170    -------------------
 171    -- Abort_Handler --
 172    -------------------
 173
 174    --  OS/2 only has limited support for asynchronous signals.
 175    --  It seems not to be possible to jump out of an exception
 176    --  handler or to change the execution context of the thread.
 177    --  So asynchonous transfer of control is not supported.
 178
 179    -----------------
 180    -- Stack_Guard --
 181    -----------------
 182
 183    --  The underlying thread system sets a guard page at the
 184    --  bottom of a thread stack, so nothing is needed.
 185    --  ??? Check the comment above
 186
 187    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 188       pragma Unreferenced (T);
 189       pragma Unreferenced (On);
 190    begin
 191       null;
 192    end Stack_Guard;
 193
 194    --------------------
 195    -- Get_Thread_Id  --
 196    --------------------
 197
 198    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 199    begin
 200       return OSI.Thread_Id (T.Common.LL.Thread);
 201    end Get_Thread_Id;
 202
 203    ----------
 204    -- Self --
 205    ----------
 206
 207    function Self return Task_Id is
 208       Self_ID : Task_Id renames Thread_Local_Data_Ptr.Self_ID;
 209
 210    begin
 211       --  Check that the thread local data has been initialized
 212
 213       pragma Assert
 214         ((Thread_Local_Data_Ptr /= null
 215           and then Thread_Local_Data_Ptr.Self_ID /= null));
 216
 217       return Self_ID;
 218    end Self;
 219
 220    ---------------------
 221    -- Initialize_Lock --
 222    ---------------------
 223
 224    procedure Initialize_Lock
 225      (Prio : System.Any_Priority;
 226       L    : access Lock)
 227    is
 228    begin
 229       if DosCreateMutexSem
 230         (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
 231       then
 232          raise Storage_Error;
 233       end if;
 234
 235       pragma Assert (L.Mutex /= 0, "Error creating Mutex");
 236       L.Priority := Prio;
 237       L.Owner_ID := Null_Address;
 238    end Initialize_Lock;
 239
 240    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 241       pragma Unreferenced (Level);
 242
 243    begin
 244       if DosCreateMutexSem
 245         (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
 246       then
 247          raise Storage_Error;
 248       end if;
 249
 250       pragma Assert (L.Mutex /= 0, "Error creating Mutex");
 251
 252       L.Priority := System.Any_Priority'Last;
 253       L.Owner_ID := Null_Address;
 254    end Initialize_Lock;
 255
 256    -------------------
 257    -- Finalize_Lock --
 258    -------------------
 259
 260    procedure Finalize_Lock (L : access Lock) is
 261    begin
 262       Must_Not_Fail (DosCloseMutexSem (L.Mutex));
 263    end Finalize_Lock;
 264
 265    procedure Finalize_Lock (L : access RTS_Lock) is
 266    begin
 267       Must_Not_Fail (DosCloseMutexSem (L.Mutex));
 268    end Finalize_Lock;
 269
 270    ----------------
 271    -- Write_Lock --
 272    ----------------
 273
 274    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 275       Self_ID      : constant Task_Id := Thread_Local_Data_Ptr.Self_ID;
 276       Old_Priority : constant Any_Priority :=
 277                        Self_ID.Common.LL.Current_Priority;
 278
 279    begin
 280       if L.Priority < Old_Priority then
 281          Ceiling_Violation := True;
 282          return;
 283       end if;
 284
 285       Ceiling_Violation := False;
 286
 287       --  Increase priority before getting the lock
 288       --  to prevent priority inversion
 289
 290       Thread_Local_Data_Ptr.Lock_Prio_Level :=
 291         Thread_Local_Data_Ptr.Lock_Prio_Level + 1;
 292       if L.Priority > Old_Priority then
 293          Set_Temporary_Priority (Self_ID, L.Priority);
 294       end if;
 295
 296       --  Request the lock and then update the lock owner data
 297
 298       Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT));
 299       L.Owner_Priority := Old_Priority;
 300       L.Owner_ID := Self_ID.all'Address;
 301    end Write_Lock;
 302
 303    procedure Write_Lock
 304      (L           : access RTS_Lock;
 305       Global_Lock : Boolean := False)
 306    is
 307       Self_ID      : Task_Id;
 308       Old_Priority : Any_Priority;
 309
 310    begin
 311       if not Single_Lock or else Global_Lock then
 312          Self_ID := Thread_Local_Data_Ptr.Self_ID;
 313          Old_Priority := Self_ID.Common.LL.Current_Priority;
 314
 315          --  Increase priority before getting the lock
 316          --  to prevent priority inversion
 317
 318          Thread_Local_Data_Ptr.Lock_Prio_Level :=
 319            Thread_Local_Data_Ptr.Lock_Prio_Level + 1;
 320
 321          if L.Priority > Old_Priority then
 322             Set_Temporary_Priority (Self_ID, L.Priority);
 323          end if;
 324
 325          --  Request the lock and then update the lock owner data
 326
 327          Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT));
 328          L.Owner_Priority := Old_Priority;
 329          L.Owner_ID := Self_ID.all'Address;
 330       end if;
 331    end Write_Lock;
 332
 333    procedure Write_Lock (T : Task_Id) is
 334    begin
 335       if not Single_Lock then
 336
 337          --  Request the lock and then update the lock owner data
 338
 339          Must_Not_Fail
 340            (DosRequestMutexSem (T.Common.LL.L.Mutex, SEM_INDEFINITE_WAIT));
 341          T.Common.LL.L.Owner_ID := Null_Address;
 342       end if;
 343    end Write_Lock;
 344
 345    ---------------
 346    -- Read_Lock --
 347    ---------------
 348
 349    procedure Read_Lock
 350      (L : access Lock; Ceiling_Violation : out Boolean) renames Write_Lock;
 351
 352    ------------
 353    -- Unlock --
 354    ------------
 355
 356    procedure Unlock (L : access Lock) is
 357       Self_ID      : constant Task_Id := Thread_Local_Data_Ptr.Self_ID;
 358       Old_Priority : constant Any_Priority := L.Owner_Priority;
 359
 360    begin
 361       --  Check that this task holds the lock
 362
 363       pragma Assert (Suppress_Owner_Check
 364         or else L.Owner_ID = Self_ID.all'Address);
 365
 366       --  Upate the owner data
 367
 368       L.Owner_ID := Null_Address;
 369
 370       --  Do the actual unlocking. No more references
 371       --  to owner data of L after this point.
 372
 373       Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
 374
 375       --  Reset priority after unlocking to avoid priority inversion
 376
 377       Thread_Local_Data_Ptr.Lock_Prio_Level :=
 378         Thread_Local_Data_Ptr.Lock_Prio_Level - 1;
 379       if L.Priority /= Old_Priority then
 380          Set_Temporary_Priority (Self_ID, Old_Priority);
 381       end if;
 382    end Unlock;
 383
 384    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 385       Self_ID      : Task_Id;
 386       Old_Priority : Any_Priority;
 387
 388    begin
 389       if not Single_Lock or else Global_Lock then
 390          Self_ID := Thread_Local_Data_Ptr.Self_ID;
 391          Old_Priority := L.Owner_Priority;
 392          --  Check that this task holds the lock
 393
 394          pragma Assert (Suppress_Owner_Check
 395            or else L.Owner_ID = Self_ID.all'Address);
 396
 397          --  Upate the owner data
 398
 399          L.Owner_ID := Null_Address;
 400
 401          --  Do the actual unlocking. No more references
 402          --  to owner data of L after this point.
 403
 404          Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
 405
 406          --  Reset priority after unlocking to avoid priority inversion
 407
 408          Thread_Local_Data_Ptr.Lock_Prio_Level :=
 409            Thread_Local_Data_Ptr.Lock_Prio_Level - 1;
 410
 411          if L.Priority /= Old_Priority then
 412             Set_Temporary_Priority (Self_ID, Old_Priority);
 413          end if;
 414       end if;
 415    end Unlock;
 416
 417    procedure Unlock (T : Task_Id) is
 418    begin
 419       if not Single_Lock then
 420
 421          --  Check the owner data
 422
 423          pragma Assert (Suppress_Owner_Check
 424            or else T.Common.LL.L.Owner_ID = Null_Address);
 425
 426          --  Do the actual unlocking. No more references
 427          --  to owner data of T.Common.LL.L after this point.
 428
 429          Must_Not_Fail (DosReleaseMutexSem (T.Common.LL.L.Mutex));
 430       end if;
 431    end Unlock;
 432
 433    -----------
 434    -- Sleep --
 435    -----------
 436
 437    procedure Sleep
 438      (Self_ID : Task_Id;
 439       Reason  : System.Tasking.Task_States)
 440    is
 441       pragma Unreferenced (Reason);
 442
 443       Count : aliased ULONG; -- Used to store dummy result
 444
 445    begin
 446       --  Must reset Cond BEFORE L is unlocked
 447
 448       Sem_Must_Not_Fail
 449         (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access));
 450
 451       if Single_Lock then
 452          Unlock_RTS;
 453       else
 454          Unlock (Self_ID);
 455       end if;
 456
 457       --  No problem if we are interrupted here.
 458       --  If the condition is signaled, DosWaitEventSem will simply not block.
 459
 460       Sem_Must_Not_Fail
 461         (DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT));
 462
 463       --  Since L was previously accquired, lock operation should not fail
 464
 465       if Single_Lock then
 466          Lock_RTS;
 467       else
 468          Write_Lock (Self_ID);
 469       end if;
 470    end Sleep;
 471
 472    -----------------
 473    -- Timed_Sleep --
 474    -----------------
 475
 476    --  This is for use within the run-time system, so abort is
 477    --  assumed to be already deferred, and the caller should be
 478    --  holding its own ATCB lock.
 479
 480    --  Pre-assertion: Cond is posted
 481    --                 Self is locked.
 482
 483    --  Post-assertion: Cond is posted
 484    --                  Self is locked.
 485
 486    procedure Timed_Sleep
 487      (Self_ID  : Task_Id;
 488       Time     : Duration;
 489       Mode     : ST.Delay_Modes;
 490       Reason   : System.Tasking.Task_States;
 491       Timedout : out Boolean;
 492       Yielded  : out Boolean)
 493    is
 494       pragma Unreferenced (Reason);
 495
 496       Check_Time : constant Duration := OSP.Monotonic_Clock;
 497       Rel_Time   : Duration;
 498       Abs_Time   : Duration;
 499       Time_Out   : ULONG;
 500       Result    : APIRET;
 501       Count      : aliased ULONG;  --  Used to store dummy result
 502
 503    begin
 504       --  Must reset Cond BEFORE Self_ID is unlocked
 505
 506       Sem_Must_Not_Fail
 507         (DosResetEventSem (Self_ID.Common.LL.CV,
 508          Count'Unchecked_Access));
 509
 510       if Single_Lock then
 511          Unlock_RTS;
 512       else
 513          Unlock (Self_ID);
 514       end if;
 515
 516       Timedout := True;
 517       Yielded := False;
 518
 519       if Mode = Relative then
 520          Rel_Time := Time;
 521          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 522       else
 523          Rel_Time := Time - Check_Time;
 524          Abs_Time := Time;
 525       end if;
 526
 527       if Rel_Time > 0.0 then
 528          loop
 529             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 530               or else Self_ID.Pending_Priority_Change;
 531
 532             Time_Out := To_MS (Rel_Time);
 533             Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out);
 534             pragma Assert
 535              ((Result = NO_ERROR or Result = ERROR_TIMEOUT
 536                 or Result = ERROR_INTERRUPT));
 537
 538             --  ???
 539             --  What to do with error condition ERROR_NOT_ENOUGH_MEMORY? Can
 540             --  we raise an exception here?  And what about ERROR_INTERRUPT?
 541             --  Should that be treated as a simple timeout?
 542             --  For now, consider only ERROR_TIMEOUT to be a timeout.
 543
 544             exit when Abs_Time <= OSP.Monotonic_Clock;
 545
 546             if Result /= ERROR_TIMEOUT then
 547                --  somebody may have called Wakeup for us
 548                Timedout := False;
 549                exit;
 550             end if;
 551
 552             Rel_Time := Abs_Time - OSP.Monotonic_Clock;
 553          end loop;
 554       end if;
 555
 556       --  Ensure post-condition
 557
 558       if Single_Lock then
 559          Lock_RTS;
 560       else
 561          Write_Lock (Self_ID);
 562       end if;
 563
 564       if Timedout then
 565          Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV));
 566       end if;
 567    end Timed_Sleep;
 568
 569    -----------------
 570    -- Timed_Delay --
 571    -----------------
 572
 573    procedure Timed_Delay
 574      (Self_ID  : Task_Id;
 575       Time     : Duration;
 576       Mode     : ST.Delay_Modes)
 577    is
 578       Check_Time : constant Duration := OSP.Monotonic_Clock;
 579       Rel_Time   : Duration;
 580       Abs_Time   : Duration;
 581       Timedout   : Boolean := True;
 582       Time_Out   : ULONG;
 583       Result     : APIRET;
 584       Count      : aliased ULONG;  --  Used to store dummy result
 585
 586    begin
 587       if Single_Lock then
 588          Lock_RTS;
 589       else
 590          Write_Lock (Self_ID);
 591       end if;
 592
 593       --  Must reset Cond BEFORE Self_ID is unlocked
 594
 595       Sem_Must_Not_Fail
 596         (DosResetEventSem (Self_ID.Common.LL.CV,
 597          Count'Unchecked_Access));
 598
 599       if Single_Lock then
 600          Unlock_RTS;
 601       else
 602          Unlock (Self_ID);
 603       end if;
 604
 605       if Mode = Relative then
 606          Rel_Time := Time;
 607          Abs_Time := Time + Check_Time;
 608       else
 609          Rel_Time := Time - Check_Time;
 610          Abs_Time := Time;
 611       end if;
 612
 613       if Rel_Time > 0.0 then
 614          Self_ID.Common.State := Delay_Sleep;
 615
 616          loop
 617             if Self_ID.Pending_Priority_Change then
 618                Self_ID.Pending_Priority_Change := False;
 619                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 620                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 621             end if;
 622
 623             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 624
 625             Time_Out := To_MS (Rel_Time);
 626             Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out);
 627
 628             exit when Abs_Time <= OSP.Monotonic_Clock;
 629
 630             Rel_Time := Abs_Time - OSP.Monotonic_Clock;
 631          end loop;
 632
 633          Self_ID.Common.State := Runnable;
 634          Timedout := Result = ERROR_TIMEOUT;
 635       end if;
 636
 637       if Single_Lock then
 638          Lock_RTS;
 639       else
 640          Write_Lock (Self_ID);
 641       end if;
 642
 643       if Timedout then
 644          Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV));
 645       end if;
 646
 647       if Single_Lock then
 648          Unlock_RTS;
 649       else
 650          Unlock (Self_ID);
 651       end if;
 652
 653       System.OS_Interface.Yield;
 654    end Timed_Delay;
 655
 656    ------------
 657    -- Wakeup --
 658    ------------
 659
 660    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 661       pragma Unreferenced (Reason);
 662    begin
 663       Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV));
 664    end Wakeup;
 665
 666    -----------
 667    -- Yield --
 668    -----------
 669
 670    procedure Yield (Do_Yield : Boolean := True) is
 671    begin
 672       if Do_Yield then
 673          System.OS_Interface.Yield;
 674       end if;
 675    end Yield;
 676
 677    ----------------------------
 678    -- Set_Temporary_Priority --
 679    ----------------------------
 680
 681    procedure Set_Temporary_Priority
 682      (T            : Task_Id;
 683       New_Priority : System.Any_Priority)
 684    is
 685       use Interfaces.C;
 686       Delta_Priority : Integer;
 687
 688    begin
 689       --  When Lock_Prio_Level = 0, we always need to set the
 690       --  Active_Priority. In this way we can make priority changes
 691       --  due to locking independent of those caused by calling
 692       --  Set_Priority.
 693
 694       if Thread_Local_Data_Ptr.Lock_Prio_Level = 0
 695         or else New_Priority < T.Common.Current_Priority
 696       then
 697          Delta_Priority := T.Common.Current_Priority -
 698            T.Common.LL.Current_Priority;
 699       else
 700          Delta_Priority := New_Priority - T.Common.LL.Current_Priority;
 701       end if;
 702
 703       if Delta_Priority /= 0 then
 704          --  ??? There is a race-condition here
 705          --  The TCB is updated before the system call to make
 706          --  pre-emption in the critical section less likely.
 707
 708          T.Common.LL.Current_Priority :=
 709            T.Common.LL.Current_Priority + Delta_Priority;
 710          Must_Not_Fail
 711            (DosSetPriority (Scope   => PRTYS_THREAD,
 712                             Class   => PRTYC_NOCHANGE,
 713                             Delta_P => IC.long (Delta_Priority),
 714                             PorTid  => T.Common.LL.Thread));
 715       end if;
 716    end Set_Temporary_Priority;
 717
 718    ------------------
 719    -- Set_Priority --
 720    ------------------
 721
 722    procedure Set_Priority
 723      (T                   : Task_Id;
 724       Prio                : System.Any_Priority;
 725       Loss_Of_Inheritance : Boolean := False)
 726    is
 727       pragma Unreferenced (Loss_Of_Inheritance);
 728    begin
 729       T.Common.Current_Priority := Prio;
 730       Set_Temporary_Priority (T, Prio);
 731    end Set_Priority;
 732
 733    ------------------
 734    -- Get_Priority --
 735    ------------------
 736
 737    function Get_Priority (T : Task_Id) return System.Any_Priority is
 738    begin
 739       return T.Common.Current_Priority;
 740    end Get_Priority;
 741
 742    ----------------
 743    -- Enter_Task --
 744    ----------------
 745
 746    procedure Enter_Task (Self_ID : Task_Id) is
 747    begin
 748       --  Initialize thread local data. Must be done first
 749
 750       Thread_Local_Data_Ptr.Self_ID := Self_ID;
 751       Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
 752
 753       Lock_RTS;
 754
 755       for J in Known_Tasks'Range loop
 756          if Known_Tasks (J) = null then
 757             Known_Tasks (J) := Self_ID;
 758             Self_ID.Known_Tasks_Index := J;
 759             exit;
 760          end if;
 761       end loop;
 762
 763       Unlock_RTS;
 764
 765       --  For OS/2, we can set Self_ID.Common.LL.Thread in
 766       --  Create_Task, since the thread is created suspended.
 767       --  That is, there is no danger of the thread racing ahead
 768       --  and trying to reference Self_ID.Common.LL.Thread before it
 769       --  has been initialized.
 770
 771       --  .... Do we need to do anything with signals for OS/2 ???
 772    end Enter_Task;
 773
 774    --------------
 775    -- New_ATCB --
 776    --------------
 777
 778    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 779    begin
 780       return new Ada_Task_Control_Block (Entry_Num);
 781    end New_ATCB;
 782
 783    -------------------
 784    -- Is_Valid_Task --
 785    -------------------
 786
 787    function Is_Valid_Task return Boolean is
 788    begin
 789       return False;
 790    end Is_Valid_Task;
 791
 792    -----------------------------
 793    -- Register_Foreign_Thread --
 794    -----------------------------
 795
 796    function Register_Foreign_Thread return Task_Id is
 797    begin
 798       return null;
 799    end Register_Foreign_Thread;
 800
 801    --------------------
 802    -- Initialize_TCB --
 803    --------------------
 804
 805    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 806    begin
 807       if DosCreateEventSem (ICS.Null_Ptr,
 808         Self_ID.Common.LL.CV'Unchecked_Access, 0, True32) = NO_ERROR
 809       then
 810          if not Single_Lock
 811            and then DosCreateMutexSem
 812              (ICS.Null_Ptr,
 813               Self_ID.Common.LL.L.Mutex'Unchecked_Access,
 814               0,
 815               False32) /= NO_ERROR
 816          then
 817             Succeeded := False;
 818             Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV));
 819          else
 820             Succeeded := True;
 821          end if;
 822
 823          --  We now want to do the equivalent of:
 824
 825          --  Initialize_Lock
 826          --    (Self_ID.Common.LL.L'Unchecked_Access, ATCB_Level);
 827
 828          --  But we avoid that because the Initialize_TCB routine has an
 829          --  exception handler, and it is too early for us to deal with
 830          --  installing handlers (see comment below), so we do our own
 831          --  Initialize_Lock operation manually.
 832
 833          Self_ID.Common.LL.L.Priority := System.Any_Priority'Last;
 834          Self_ID.Common.LL.L.Owner_ID := Null_Address;
 835
 836       else
 837          Succeeded := False;
 838       end if;
 839
 840       --  Note: at one time we had an exception handler here, whose code
 841       --  was as follows:
 842
 843       --  exception
 844
 845       --     Assumes any failure must be due to insufficient resources
 846
 847       --     when Storage_Error =>
 848       --        Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV));
 849       --        Succeeded := False;
 850
 851       --  but that won't work with the old exception scheme, since it would
 852       --  result in messing with Jmpbuf values too early. If and when we get
 853       --  switched entirely to the new zero-cost exception scheme, we could
 854       --  put this handler back in!
 855    end Initialize_TCB;
 856
 857    -----------------
 858    -- Create_Task --
 859    -----------------
 860
 861    procedure Create_Task
 862      (T          : Task_Id;
 863       Wrapper    : System.Address;
 864       Stack_Size : System.Parameters.Size_Type;
 865       Priority   : System.Any_Priority;
 866       Succeeded  : out Boolean)
 867    is
 868       Result              : aliased APIRET;
 869       Adjusted_Stack_Size : System.Parameters.Size_Type;
 870       use System.Parameters;
 871
 872    begin
 873       --  In OS/2 the allocated stack size should be based on the
 874       --  amount of address space that should be reserved for the stack.
 875       --  Actual memory will only be used when the stack is touched anyway.
 876
 877       --  The new minimum size is 12 kB, although the EMX docs
 878       --  recommend a minimum size of 32 kB.  (The original was 4 kB)
 879       --  Systems that use many tasks (say > 30) and require much
 880       --  memory may run out of virtual address space, since OS/2
 881       --  has a per-proces limit of 512 MB, of which max. 300 MB is
 882       --  usable in practise.
 883
 884       if Stack_Size = Unspecified_Size then
 885          Adjusted_Stack_Size := Default_Stack_Size;
 886
 887       elsif Stack_Size < Minimum_Stack_Size then
 888          Adjusted_Stack_Size := Minimum_Stack_Size;
 889
 890       else
 891          Adjusted_Stack_Size := Stack_Size;
 892       end if;
 893
 894       --  GB970222:
 895       --    Because DosCreateThread is called directly here, the
 896       --    C RTL doesn't get initialized for the new thead. EMX by
 897       --    default uses per-thread local heaps in addition to the
 898       --    global heap. There might be other effects of by-passing the
 899       --    C library here.
 900
 901       --    When using _beginthread the newly created thread is not
 902       --    blocked initially. Does this matter or can I create the
 903       --    thread running anyway? The LL.Thread variable will be set
 904       --    anyway because the variable is passed by reference to OS/2.
 905
 906       T.Common.LL.Wrapper := To_PFNTHREAD (Wrapper);
 907
 908       --  The OS implicitly gives the new task the priority of this task
 909
 910       T.Common.LL.Current_Priority := Self.Common.LL.Current_Priority;
 911
 912       --  If task was locked before activator task was
 913       --  initialized, assume it has OS standard priority
 914
 915       if T.Common.LL.L.Owner_Priority not in Any_Priority'Range then
 916          T.Common.LL.L.Owner_Priority := 1;
 917       end if;
 918
 919       --  Create the thread, in blocked mode
 920
 921       Result := DosCreateThread
 922         (F_ptid   => T.Common.LL.Thread'Unchecked_Access,
 923          pfn      => T.Common.LL.Wrapper,
 924          param    => To_Address (T),
 925          flag     => Block_Child + Commit_Stack,
 926          cbStack  => ULONG (Adjusted_Stack_Size));
 927
 928       Succeeded := (Result = NO_ERROR);
 929
 930       if not Succeeded then
 931          return;
 932       end if;
 933
 934       --  Set the new thread's priority
 935       --  (child has inherited priority from parent)
 936
 937       Set_Priority (T, Priority);
 938
 939       --  Start the thread executing
 940
 941       Must_Not_Fail (DosResumeThread (T.Common.LL.Thread));
 942
 943    end Create_Task;
 944
 945    ------------------
 946    -- Finalize_TCB --
 947    ------------------
 948
 949    procedure Finalize_TCB (T : Task_Id) is
 950       Tmp    : Task_Id := T;
 951
 952       procedure Free is new
 953         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 954
 955    begin
 956       Must_Not_Fail (DosCloseEventSem (T.Common.LL.CV));
 957
 958       if not Single_Lock then
 959          Finalize_Lock (T.Common.LL.L'Unchecked_Access);
 960       end if;
 961
 962       if T.Known_Tasks_Index /= -1 then
 963          Known_Tasks (T.Known_Tasks_Index) := null;
 964       end if;
 965
 966       Free (Tmp);
 967    end Finalize_TCB;
 968
 969    ---------------
 970    -- Exit_Task --
 971    ---------------
 972
 973    procedure Exit_Task is
 974    begin
 975       Thread_Local_Data_Ptr := null;
 976    end Exit_Task;
 977
 978    ----------------
 979    -- Abort_Task --
 980    ----------------
 981
 982    procedure Abort_Task (T : Task_Id) is
 983       pragma Unreferenced (T);
 984
 985    begin
 986       null;
 987
 988       --  Task abort not implemented yet.
 989       --  Should perform other action ???
 990
 991    end Abort_Task;
 992
 993    ----------------
 994    -- Initialize --
 995    ----------------
 996
 997    procedure Initialize (S : in out Suspension_Object) is
 998       Result : Interfaces.C.int;
 999    begin
1000       --  Initialize internal state. It is always initialized to False (ARM
1001       --  D.10 par. 6).
1002
1003       S.State := False;
1004       S.Waiting := False;
1005
1006       --  Initialize internal mutex
1007       if DosCreateMutexSem
1008         (ICS.Null_Ptr, S.L'Unchecked_Access, 0, False32) /= NO_ERROR
1009       then
1010          raise Storage_Error;
1011       end if;
1012
1013       pragma Assert (S.L /= 0, "Error creating Mutex");
1014
1015       --  Initialize internal condition variable
1016
1017       if DosCreateEventSem
1018         (ICS.Null_Ptr, S.CV'Unchecked_Access, 0, True32) /= NO_ERROR
1019       then
1020          Must_Not_Fail (DosCloseMutexSem (S.L));
1021
1022          raise Storage_Error;
1023       end if;
1024
1025       pragma Assert (S.CV /= 0, "Error creating Condition Variable");
1026    end Initialize;
1027
1028    --------------
1029    -- Finalize --
1030    --------------
1031
1032    procedure Finalize (S : in out Suspension_Object) is
1033    begin
1034       --  Destroy internal mutex
1035
1036       Must_Not_Fail (DosCloseMutexSem (S.L'Access));
1037
1038       --  Destroy internal condition variable
1039
1040       Must_Not_Fail (DosCloseEventSem (S.CV'Access));
1041    end Finalize;
1042
1043    -------------------
1044    -- Current_State --
1045    -------------------
1046
1047    function Current_State (S : Suspension_Object) return Boolean is
1048    begin
1049       --  We do not want to use lock on this read operation. State is marked
1050       --  as Atomic so that we ensure that the value retrieved is correct.
1051
1052       return S.State;
1053    end Current_State;
1054
1055    ---------------
1056    -- Set_False --
1057    ---------------
1058
1059    procedure Set_False (S : in out Suspension_Object) is
1060    begin
1061       Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT));
1062
1063       S.State := False;
1064
1065       Must_Not_Fail (DosReleaseMutexSem (S.L));
1066    end Set_False;
1067
1068    --------------
1069    -- Set_True --
1070    --------------
1071
1072    procedure Set_True (S : in out Suspension_Object) is
1073    begin
1074       Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT));
1075
1076       --  If there is already a task waiting on this suspension object then
1077       --  we resume it, leaving the state of the suspension object to False,
1078       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1079       --  the state to True.
1080
1081       if S.Waiting then
1082          S.Waiting := False;
1083          S.State := False;
1084
1085          Sem_Must_Not_Fail (DosPostEventSem (S.CV));
1086       else
1087          S.State := True;
1088       end if;
1089
1090       Must_Not_Fail (DosReleaseMutexSem (S.L));
1091    end Set_True;
1092
1093    ------------------------
1094    -- Suspend_Until_True --
1095    ------------------------
1096
1097    procedure Suspend_Until_True (S : in out Suspension_Object) is
1098       Count : aliased ULONG; -- Used to store dummy result
1099    begin
1100       Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT));
1101
1102       if S.Waiting then
1103          --  Program_Error must be raised upon calling Suspend_Until_True
1104          --  if another task is already waiting on that suspension object
1105          --  (ARM D.10 par. 10).
1106
1107          Must_Not_Fail (DosReleaseMutexSem (S.L));
1108
1109          raise Program_Error;
1110       else
1111          --  Suspend the task if the state is False. Otherwise, the task
1112          --  continues its execution, and the state of the suspension object
1113          --  is set to False (ARM D.10 par. 9).
1114
1115          if S.State then
1116             S.State := False;
1117
1118             Must_Not_Fail (DosReleaseMutexSem (S.L));
1119          else
1120             S.Waiting := True;
1121
1122             --  Must reset Cond BEFORE L is unlocked
1123
1124             Sem_Must_Not_Fail
1125               (DosResetEventSem (S.CV, Count'Unchecked_Access));
1126
1127             Must_Not_Fail (DosReleaseMutexSem (S.L));
1128
1129             Sem_Must_Not_Fail
1130               (DosWaitEventSem (S.CV, SEM_INDEFINITE_WAIT));
1131          end if;
1132       end if;
1133    end Suspend_Until_True;
1134
1135    ----------------
1136    -- Check_Exit --
1137    ----------------
1138
1139    --  Dummy version
1140
1141    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1142    begin
1143       return Check_No_Locks (Self_ID);
1144    end Check_Exit;
1145
1146    --------------------
1147    -- Check_No_Locks --
1148    --------------------
1149
1150    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1151       TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr;
1152    begin
1153       return Self_ID = TLD.Self_ID
1154         and then TLD.Lock_Prio_Level = 0;
1155    end Check_No_Locks;
1156
1157    ----------------------
1158    -- Environment_Task --
1159    ----------------------
1160
1161    function Environment_Task return Task_Id is
1162    begin
1163       return Environment_Task_Id;
1164    end Environment_Task;
1165
1166    --------------
1167    -- Lock_RTS --
1168    --------------
1169
1170    procedure Lock_RTS is
1171    begin
1172       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1173    end Lock_RTS;
1174
1175    ----------------
1176    -- Unlock_RTS --
1177    ----------------
1178
1179    procedure Unlock_RTS is
1180    begin
1181       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1182    end Unlock_RTS;
1183
1184    ------------------
1185    -- Suspend_Task --
1186    ------------------
1187
1188    function Suspend_Task
1189      (T           : ST.Task_Id;
1190       Thread_Self : Thread_Id) return Boolean
1191    is
1192    begin
1193       if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
1194          return DosSuspendThread (T.Common.LL.Thread) = NO_ERROR;
1195       else
1196          return True;
1197       end if;
1198    end Suspend_Task;
1199
1200    -----------------
1201    -- Resume_Task --
1202    -----------------
1203
1204    function Resume_Task
1205      (T           : ST.Task_Id;
1206       Thread_Self : Thread_Id) return Boolean
1207    is
1208    begin
1209       if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
1210          return DosResumeThread (T.Common.LL.Thread) = NO_ERROR;
1211       else
1212          return True;
1213       end if;
1214    end Resume_Task;
1215
1216    ----------------
1217    -- Initialize --
1218    ----------------
1219
1220    procedure Initialize (Environment_Task : Task_Id) is
1221       Succeeded : Boolean;
1222    begin
1223       Environment_Task_Id := Environment_Task;
1224
1225       OS_Primitives.Initialize;
1226
1227       --  Initialize pointer to task local data.
1228       --  This is done once, for all tasks.
1229
1230       Must_Not_Fail (DosAllocThreadLocalMemory
1231          ((Thread_Local_Data'Size + 31) / 32,  --  nr of 32-bit words
1232           To_PPVOID (Thread_Local_Data_Ptr'Access)));
1233
1234       --  Initialize thread local data for main thread
1235
1236       Thread_Local_Data_Ptr.Self_ID := null;
1237       Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
1238
1239       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1240       --  Initialize the lock used to synchronize chain of all ATCBs
1241
1242       --  Set ID of environment task
1243
1244       Thread_Local_Data_Ptr.Self_ID := Environment_Task;
1245       Environment_Task.Common.LL.Thread := 1; --  By definition
1246
1247       --  This priority is unknown in fact.
1248       --  If actual current priority is different,
1249       --  it will get synchronized later on anyway.
1250
1251       Environment_Task.Common.LL.Current_Priority :=
1252         Environment_Task.Common.Current_Priority;
1253
1254       --  Initialize TCB for this task.
1255       --  This includes all the normal task-external initialization.
1256       --  This is also done by Initialize_ATCB, why ???
1257
1258       Initialize_TCB (Environment_Task, Succeeded);
1259
1260       --  Consider raising Storage_Error,
1261       --  if propagation can be tolerated ???
1262
1263       pragma Assert (Succeeded);
1264
1265       --  Do normal task-internal initialization,
1266       --  which depends on an initialized TCB.
1267
1268       Enter_Task (Environment_Task);
1269
1270       --  Insert here any other special
1271       --  initialization needed for the environment task.
1272    end Initialize;
1273
1274 end System.Task_Primitives.Operations;