gcc/ada/5otaprop.adb

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