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