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