gcc/ada/5ztaprop.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 the VxWorks 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 System.Interrupt_Management;
  48 --  used for Keep_Unmasked
  49 --           Abort_Task_Interrupt
  50 --           Interrupt_ID
  51 --           Initialize_Interrupts
  52
  53 with System.Soft_Links;
  54 --  used for Defer/Undefer_Abort
  55
  56 --  Note that we do not use System.Tasking.Initialization directly since
  57 --  this is a higher level package that we shouldn't depend on. For example
  58 --  when using the restricted run time, it is replaced by
  59 --  System.Tasking.Restricted.Initialization
  60
  61 with System.OS_Interface;
  62 --  used for various type, constant, and operations
  63
  64 with System.Parameters;
  65 --  used for Size_Type
  66
  67 with System.Tasking;
  68 --  used for Ada_Task_Control_Block
  69 --           Task_ID
  70 --           ATCB components and types
  71
  72 with System.Task_Info;
  73 --  used for Task_Image
  74
  75 with Interfaces.C;
  76
  77 with Unchecked_Conversion;
  78 with Unchecked_Deallocation;
  79
  80 package body System.Task_Primitives.Operations is
  81
  82    use System.Tasking.Debug;
  83    use System.Tasking;
  84    use System.Task_Info;
  85    use System.OS_Interface;
  86    use System.Parameters;
  87    use type Interfaces.C.int;
  88
  89    package SSL renames System.Soft_Links;
  90
  91    subtype int is System.OS_Interface.int;
  92
  93    Relative : constant := 0;
  94
  95    ----------------
  96    -- Local Data --
  97    ----------------
  98
  99    --  The followings are logically constants, but need to be initialized
 100    --  at run time.
 101
 102    Current_Task : aliased Task_ID;
 103    pragma Export (Ada, Current_Task);
 104    --  Task specific value used to store the Ada Task_ID.
 105
 106    Single_RTS_Lock : aliased RTS_Lock;
 107    --  This is a lock to allow only one thread of control in the RTS at
 108    --  a time; it is used to execute in mutual exclusion from all other tasks.
 109    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
 110
 111    Environment_Task_ID : Task_ID;
 112    --  A variable to hold Task_ID for the environment task.
 113
 114    Unblocked_Signal_Mask : aliased sigset_t;
 115    --  The set of signals that should unblocked in all tasks
 116
 117    --  The followings are internal configuration constants needed.
 118
 119    Time_Slice_Val : Integer;
 120    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
 121
 122    Locking_Policy : Character;
 123    pragma Import (C, Locking_Policy, "__gl_locking_policy");
 124
 125    Dispatching_Policy : Character;
 126    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 127
 128    FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
 129    --  Indicates whether FIFO_Within_Priorities is set.
 130
 131    Mutex_Protocol : Priority_Type;
 132
 133    -----------------------
 134    -- Local Subprograms --
 135    -----------------------
 136
 137    procedure Abort_Handler (signo : Signal);
 138
 139    function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
 140
 141    -------------------
 142    -- Abort_Handler --
 143    -------------------
 144
 145    procedure Abort_Handler (signo : Signal) is
 146       Self_ID : constant Task_ID := Self;
 147       Result  : int;
 148       Old_Set : aliased sigset_t;
 149
 150    begin
 151       if Self_ID.Deferral_Level = 0
 152         and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 153         and then not Self_ID.Aborting
 154       then
 155          Self_ID.Aborting := True;
 156
 157          --  Make sure signals used for RTS internal purpose are unmasked
 158
 159          Result := pthread_sigmask (SIG_UNBLOCK,
 160            Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
 161          pragma Assert (Result = 0);
 162
 163          raise Standard'Abort_Signal;
 164       end if;
 165    end Abort_Handler;
 166
 167    -----------------
 168    -- Stack_Guard --
 169    -----------------
 170
 171    procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
 172    begin
 173       --  Nothing needed.
 174       null;
 175    end Stack_Guard;
 176
 177    -------------------
 178    -- Get_Thread_Id --
 179    -------------------
 180
 181    function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
 182    begin
 183       return T.Common.LL.Thread;
 184    end Get_Thread_Id;
 185
 186    ----------
 187    -- Self --
 188    ----------
 189
 190    function Self return Task_ID is
 191    begin
 192       pragma Assert (Current_Task /= null);
 193       return Current_Task;
 194    end Self;
 195
 196    -----------------------------
 197    -- Install_Signal_Handlers --
 198    -----------------------------
 199
 200    procedure Install_Signal_Handlers;
 201    --  Install the default signal handlers for the current task.
 202
 203    procedure Install_Signal_Handlers is
 204       act       : aliased struct_sigaction;
 205       old_act   : aliased struct_sigaction;
 206       Tmp_Set   : aliased sigset_t;
 207       Result    : int;
 208
 209    begin
 210       act.sa_flags := 0;
 211       act.sa_handler := Abort_Handler'Address;
 212
 213       Result := sigemptyset (Tmp_Set'Access);
 214       pragma Assert (Result = 0);
 215       act.sa_mask := Tmp_Set;
 216
 217       Result :=
 218         sigaction
 219           (Signal (Interrupt_Management.Abort_Task_Interrupt),
 220            act'Unchecked_Access,
 221            old_act'Unchecked_Access);
 222       pragma Assert (Result = 0);
 223
 224       Interrupt_Management.Initialize_Interrupts;
 225    end Install_Signal_Handlers;
 226
 227    ---------------------
 228    -- Initialize_Lock --
 229    ---------------------
 230
 231    procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is
 232    begin
 233       L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
 234       L.Prio_Ceiling := int (Prio);
 235       L.Protocol := Mutex_Protocol;
 236       pragma Assert (L.Mutex /= 0);
 237    end Initialize_Lock;
 238
 239    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 240    begin
 241       L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
 242       L.Prio_Ceiling := int (System.Any_Priority'Last);
 243       L.Protocol := Mutex_Protocol;
 244       pragma Assert (L.Mutex /= 0);
 245    end Initialize_Lock;
 246
 247    -------------------
 248    -- Finalize_Lock --
 249    -------------------
 250
 251    procedure Finalize_Lock (L : access Lock) is
 252       Result : int;
 253    begin
 254       Result := semDelete (L.Mutex);
 255       pragma Assert (Result = 0);
 256    end Finalize_Lock;
 257
 258    procedure Finalize_Lock (L : access RTS_Lock) is
 259       Result : int;
 260    begin
 261       Result := semDelete (L.Mutex);
 262       pragma Assert (Result = 0);
 263    end Finalize_Lock;
 264
 265    ----------------
 266    -- Write_Lock --
 267    ----------------
 268
 269    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 270       Result : int;
 271    begin
 272       if L.Protocol = Prio_Protect
 273         and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
 274       then
 275          Ceiling_Violation := True;
 276          return;
 277       else
 278          Ceiling_Violation := False;
 279       end if;
 280
 281       Result := semTake (L.Mutex, WAIT_FOREVER);
 282       pragma Assert (Result = 0);
 283    end Write_Lock;
 284
 285    procedure Write_Lock
 286      (L : access RTS_Lock; Global_Lock : Boolean := False)
 287    is
 288       Result : int;
 289    begin
 290       if not Single_Lock or else Global_Lock then
 291          Result := semTake (L.Mutex, WAIT_FOREVER);
 292          pragma Assert (Result = 0);
 293       end if;
 294    end Write_Lock;
 295
 296    procedure Write_Lock (T : Task_ID) is
 297       Result : int;
 298    begin
 299       if not Single_Lock then
 300          Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
 301          pragma Assert (Result = 0);
 302       end if;
 303    end Write_Lock;
 304
 305    ---------------
 306    -- Read_Lock --
 307    ---------------
 308
 309    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 310    begin
 311       Write_Lock (L, Ceiling_Violation);
 312    end Read_Lock;
 313
 314    ------------
 315    -- Unlock --
 316    ------------
 317
 318    procedure Unlock (L : access Lock) is
 319       Result  : int;
 320    begin
 321       Result := semGive (L.Mutex);
 322       pragma Assert (Result = 0);
 323    end Unlock;
 324
 325    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 326       Result : int;
 327    begin
 328       if not Single_Lock or else Global_Lock then
 329          Result := semGive (L.Mutex);
 330          pragma Assert (Result = 0);
 331       end if;
 332    end Unlock;
 333
 334    procedure Unlock (T : Task_ID) is
 335       Result : int;
 336    begin
 337       if not Single_Lock then
 338          Result := semGive (T.Common.LL.L.Mutex);
 339          pragma Assert (Result = 0);
 340       end if;
 341    end Unlock;
 342
 343    -----------
 344    -- Sleep --
 345    -----------
 346
 347    procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is
 348       Result : int;
 349    begin
 350       pragma Assert (Self_ID = Self);
 351
 352       --  Disable task scheduling.
 353
 354       Result := taskLock;
 355
 356       --  Release the mutex before sleeping.
 357
 358       if Single_Lock then
 359          Result := semGive (Single_RTS_Lock.Mutex);
 360       else
 361          Result := semGive (Self_ID.Common.LL.L.Mutex);
 362       end if;
 363
 364       pragma Assert (Result = 0);
 365
 366       --  Indicate that there is another thread waiting on the CV.
 367
 368       Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1;
 369
 370       --  Perform a blocking operation to take the CV semaphore.
 371       --  Note that a blocking operation in VxWorks will reenable
 372       --  task scheduling. When we are no longer blocked and control
 373       --  is returned, task scheduling will again be disabled.
 374
 375       Result := semTake (Self_ID.Common.LL.CV.Sem, WAIT_FOREVER);
 376
 377       if Result /= 0 then
 378          Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting - 1;
 379          pragma Assert (False);
 380       end if;
 381
 382       --  Take the mutex back.
 383
 384       if Single_Lock then
 385          Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
 386       else
 387          Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
 388       end if;
 389
 390       pragma Assert (Result = 0);
 391
 392       --  Reenable task scheduling.
 393
 394       Result := taskUnlock;
 395    end Sleep;
 396
 397    -----------------
 398    -- Timed_Sleep --
 399    -----------------
 400
 401    --  This is for use within the run-time system, so abort is
 402    --  assumed to be already deferred, and the caller should be
 403    --  holding its own ATCB lock.
 404
 405    procedure Timed_Sleep
 406      (Self_ID  : Task_ID;
 407       Time     : Duration;
 408       Mode     : ST.Delay_Modes;
 409       Reason   : System.Tasking.Task_States;
 410       Timedout : out Boolean;
 411       Yielded  : out Boolean)
 412    is
 413       Ticks  : int;
 414       Result : int;
 415
 416    begin
 417       Timedout := True;
 418       Yielded := True;
 419
 420       if Mode = Relative then
 421          --  Systematically add one since the first tick will delay
 422          --  *at most* 1 / Rate_Duration seconds, so we need to add one to
 423          --  be on the safe side.
 424
 425          Ticks := To_Clock_Ticks (Time) + 1;
 426       else
 427          Ticks := To_Clock_Ticks (Time - Monotonic_Clock);
 428       end if;
 429
 430       if Ticks > 0 then
 431          --  Disable task scheduling.
 432
 433          Result := taskLock;
 434
 435          --  Release the mutex before sleeping.
 436
 437          if Single_Lock then
 438             Result := semGive (Single_RTS_Lock.Mutex);
 439          else
 440             Result := semGive (Self_ID.Common.LL.L.Mutex);
 441          end if;
 442
 443          pragma Assert (Result = 0);
 444
 445          --  Indicate that there is another thread waiting on the CV.
 446
 447          Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1;
 448
 449          --  Perform a blocking operation to take the CV semaphore.
 450          --  Note that a blocking operation in VxWorks will reenable
 451          --  task scheduling. When we are no longer blocked and control
 452          --  is returned, task scheduling will again be disabled.
 453
 454          Result := semTake (Self_ID.Common.LL.CV.Sem, Ticks);
 455
 456          if Result = 0 then
 457             --  Somebody may have called Wakeup for us
 458
 459             Timedout := False;
 460
 461          else
 462             Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting - 1;
 463
 464             if errno /= S_objLib_OBJ_TIMEOUT then
 465                Timedout := False;
 466             end if;
 467          end if;
 468
 469          --  Take the mutex back.
 470
 471          if Single_Lock then
 472             Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
 473          else
 474             Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
 475          end if;
 476
 477          pragma Assert (Result = 0);
 478
 479          --  Reenable task scheduling.
 480
 481          Result := taskUnlock;
 482
 483       else
 484          taskDelay (0);
 485       end if;
 486    end Timed_Sleep;
 487
 488    -----------------
 489    -- Timed_Delay --
 490    -----------------
 491
 492    --  This is for use in implementing delay statements, so
 493    --  we assume the caller is holding no locks.
 494
 495    procedure Timed_Delay
 496      (Self_ID  : Task_ID;
 497       Time     : Duration;
 498       Mode     : ST.Delay_Modes)
 499    is
 500       Orig     : constant Duration := Monotonic_Clock;
 501       Absolute : Duration;
 502       Ticks    : int;
 503       Timedout : Boolean;
 504       Result   : int;
 505
 506    begin
 507       SSL.Abort_Defer.all;
 508
 509       if Single_Lock then
 510          Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
 511       else
 512          Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
 513       end if;
 514
 515       pragma Assert (Result = 0);
 516
 517       if Mode = Relative then
 518          Absolute := Orig + Time;
 519
 520          Ticks := To_Clock_Ticks (Time);
 521
 522          if Ticks > 0 then
 523             --  The first tick will delay anytime between 0 and
 524             --  1 / sysClkRateGet seconds, so we need to add one to
 525             --  be on the safe side.
 526
 527             Ticks := Ticks + 1;
 528          end if;
 529       else
 530          Absolute := Time;
 531          Ticks    := To_Clock_Ticks (Time - Orig);
 532       end if;
 533
 534       if Ticks > 0 then
 535          Self_ID.Common.State := Delay_Sleep;
 536
 537          loop
 538             if Self_ID.Pending_Priority_Change then
 539                Self_ID.Pending_Priority_Change := False;
 540                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 541                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 542             end if;
 543
 544             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 545
 546             Timedout := False;
 547             Result := taskLock;
 548
 549             if Single_Lock then
 550                Result := semGive (Single_RTS_Lock.Mutex);
 551             else
 552                Result := semGive (Self_ID.Common.LL.L.Mutex);
 553             end if;
 554
 555             pragma Assert (Result = 0);
 556
 557             --  Indicate that there is another thread waiting on the CV.
 558
 559             Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1;
 560
 561             Result := semTake (Self_ID.Common.LL.CV.Sem, Ticks);
 562
 563             if Result /= 0 then
 564                Self_ID.Common.LL.CV.Waiting :=
 565                  Self_ID.Common.LL.CV.Waiting - 1;
 566
 567                if errno = S_objLib_OBJ_TIMEOUT then
 568                   Timedout := True;
 569                else
 570                   Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
 571                end if;
 572             end if;
 573
 574             if Single_Lock then
 575                Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
 576             else
 577                Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
 578             end if;
 579
 580             pragma Assert (Result = 0);
 581
 582             --  Reenable task scheduling.
 583
 584             Result := taskUnlock;
 585
 586             exit when Timedout;
 587          end loop;
 588
 589          Self_ID.Common.State := Runnable;
 590       else
 591          taskDelay (0);
 592       end if;
 593
 594       if Single_Lock then
 595          Result := semGive (Single_RTS_Lock.Mutex);
 596       else
 597          Result := semGive (Self_ID.Common.LL.L.Mutex);
 598       end if;
 599
 600       pragma Assert (Result = 0);
 601       SSL.Abort_Undefer.all;
 602    end Timed_Delay;
 603
 604    ---------------------
 605    -- Monotonic_Clock --
 606    ---------------------
 607
 608    function Monotonic_Clock return Duration is
 609       TS     : aliased timespec;
 610       Result : int;
 611
 612    begin
 613       Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
 614       pragma Assert (Result = 0);
 615       return To_Duration (TS);
 616    end Monotonic_Clock;
 617
 618    -------------------
 619    -- RT_Resolution --
 620    -------------------
 621
 622    function RT_Resolution return Duration is
 623    begin
 624       return 10#1.0#E-6;
 625    end RT_Resolution;
 626
 627    ------------
 628    -- Wakeup --
 629    ------------
 630
 631    procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
 632       Result : int;
 633    begin
 634       --  Disable task scheduling.
 635
 636       Result := taskLock;
 637
 638       --  Iff someone is currently waiting on the condition variable
 639       --  then release the semaphore; we don't want to leave the
 640       --  semaphore in the full state because the next guy to do
 641       --  a condition wait operation would not block.
 642
 643       if T.Common.LL.CV.Waiting > 0 then
 644          Result := semGive (T.Common.LL.CV.Sem);
 645
 646          --  One less thread waiting on the CV.
 647
 648          T.Common.LL.CV.Waiting := T.Common.LL.CV.Waiting - 1;
 649
 650          pragma Assert (Result = 0);
 651       end if;
 652
 653       --  Reenable task scheduling.
 654
 655       Result := taskUnlock;
 656    end Wakeup;
 657
 658    -----------
 659    -- Yield --
 660    -----------
 661
 662    procedure Yield (Do_Yield : Boolean := True) is
 663       Result : int;
 664    begin
 665       Result := taskDelay (0);
 666    end Yield;
 667
 668    ------------------
 669    -- Set_Priority --
 670    ------------------
 671
 672    type Prio_Array_Type is array (System.Any_Priority) of Integer;
 673    pragma Atomic_Components (Prio_Array_Type);
 674
 675    Prio_Array : Prio_Array_Type;
 676    --  Global array containing the id of the currently running task for
 677    --  each priority.
 678    --
 679    --  Note: we assume that we are on a single processor with run-til-blocked
 680    --  scheduling.
 681
 682    procedure Set_Priority
 683      (T : Task_ID;
 684       Prio : System.Any_Priority;
 685       Loss_Of_Inheritance : Boolean := False)
 686    is
 687       Array_Item : Integer;
 688       Result     : int;
 689
 690    begin
 691       Result := taskPrioritySet
 692         (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
 693       pragma Assert (Result = 0);
 694
 695       if FIFO_Within_Priorities then
 696          --  Annex D requirement [RM D.2.2 par. 9]:
 697          --    If the task drops its priority due to the loss of inherited
 698          --    priority, it is added at the head of the ready queue for its
 699          --    new active priority.
 700
 701          if Loss_Of_Inheritance
 702            and then Prio < T.Common.Current_Priority
 703          then
 704             Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
 705             Prio_Array (T.Common.Base_Priority) := Array_Item;
 706
 707             loop
 708                --  Let some processes a chance to arrive
 709
 710                Yield;
 711
 712                --  Then wait for our turn to proceed
 713
 714                exit when Array_Item = Prio_Array (T.Common.Base_Priority)
 715                  or else Prio_Array (T.Common.Base_Priority) = 1;
 716             end loop;
 717
 718             Prio_Array (T.Common.Base_Priority) :=
 719               Prio_Array (T.Common.Base_Priority) - 1;
 720          end if;
 721       end if;
 722
 723       T.Common.Current_Priority := Prio;
 724    end Set_Priority;
 725
 726    ------------------
 727    -- Get_Priority --
 728    ------------------
 729
 730    function Get_Priority (T : Task_ID) return System.Any_Priority is
 731    begin
 732       return T.Common.Current_Priority;
 733    end Get_Priority;
 734
 735    ----------------
 736    -- Enter_Task --
 737    ----------------
 738
 739    procedure Enter_Task (Self_ID : Task_ID) is
 740       Result : int;
 741
 742       procedure Init_Float;
 743       pragma Import (C, Init_Float, "__gnat_init_float");
 744       --  Properly initializes the FPU for PPC/MIPS systems.
 745
 746    begin
 747       Self_ID.Common.LL.Thread := taskIdSelf;
 748       Result := taskVarAdd (0, Current_Task'Address);
 749       Current_Task := Self_ID;
 750       Init_Float;
 751
 752       --  Install the signal handlers.
 753       --  This is called for each task since there is no signal inheritance
 754       --  between VxWorks tasks.
 755
 756       Install_Signal_Handlers;
 757
 758       Lock_RTS;
 759
 760       for J in Known_Tasks'Range loop
 761          if Known_Tasks (J) = null then
 762             Known_Tasks (J) := Self_ID;
 763             Self_ID.Known_Tasks_Index := J;
 764             exit;
 765          end if;
 766       end loop;
 767
 768       Unlock_RTS;
 769    end Enter_Task;
 770
 771    --------------
 772    -- New_ATCB --
 773    --------------
 774
 775    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 776    begin
 777       return new Ada_Task_Control_Block (Entry_Num);
 778    end New_ATCB;
 779
 780    --------------------
 781    -- Initialize_TCB --
 782    --------------------
 783
 784    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 785    begin
 786       Self_ID.Common.LL.CV.Sem := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
 787       Self_ID.Common.LL.CV.Waiting := 0;
 788       Self_ID.Common.LL.Thread := 0;
 789
 790       if Self_ID.Common.LL.CV.Sem = 0 then
 791          Succeeded := False;
 792       else
 793          Succeeded := True;
 794
 795          if not Single_Lock then
 796             Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
 797          end if;
 798       end if;
 799    end Initialize_TCB;
 800
 801    -----------------
 802    -- Create_Task --
 803    -----------------
 804
 805    procedure Create_Task
 806      (T          : Task_ID;
 807       Wrapper    : System.Address;
 808       Stack_Size : System.Parameters.Size_Type;
 809       Priority   : System.Any_Priority;
 810       Succeeded  : out Boolean)
 811    is
 812       use type System.Task_Info.Task_Image_Type;
 813
 814       Adjusted_Stack_Size : size_t;
 815
 816    begin
 817       if Stack_Size = Unspecified_Size then
 818          Adjusted_Stack_Size := size_t (Default_Stack_Size);
 819
 820       elsif Stack_Size < Minimum_Stack_Size then
 821          Adjusted_Stack_Size := size_t (Minimum_Stack_Size);
 822
 823       else
 824          Adjusted_Stack_Size := size_t (Stack_Size);
 825       end if;
 826
 827       --  Ask for 4 extra bytes of stack space so that the ATCB
 828       --  pointer can be stored below the stack limit, plus extra
 829       --  space for the frame of Task_Wrapper.  This is so the user
 830       --  gets the amount of stack requested exclusive of the needs
 831       --  of the runtime.
 832       --
 833       --  We also have to allocate n more bytes for the task name
 834       --  storage and enough space for the Wind Task Control Block
 835       --  which is around 0x778 bytes.  VxWorks also seems to carve out
 836       --  additional space, so use 2048 as a nice round number.
 837       --  We might want to increment to the nearest page size in
 838       --  case we ever support VxVMI.
 839       --
 840       --  XXX - we should come back and visit this so we can
 841       --        set the task name to something appropriate.
 842       Adjusted_Stack_Size := Adjusted_Stack_Size + 2048;
 843
 844       --  Since the initial signal mask of a thread is inherited from the
 845       --  creator, and the Environment task has all its signals masked, we
 846       --  do not need to manipulate caller's signal mask at this point.
 847       --  All tasks in RTS will have All_Tasks_Mask initially.
 848
 849       if T.Common.Task_Image = null then
 850          T.Common.LL.Thread := taskSpawn
 851            (System.Null_Address,
 852             To_VxWorks_Priority (int (Priority)),
 853             VX_FP_TASK,
 854             Adjusted_Stack_Size,
 855             Wrapper,
 856             To_Address (T));
 857       else
 858          declare
 859             Name : aliased String (1 .. T.Common.Task_Image'Length + 1);
 860          begin
 861             Name (1 .. Name'Last - 1) := T.Common.Task_Image.all;
 862             Name (Name'Last) := ASCII.NUL;
 863
 864             T.Common.LL.Thread := taskSpawn
 865               (Name'Address,
 866                To_VxWorks_Priority (int (Priority)),
 867                VX_FP_TASK,
 868                Adjusted_Stack_Size,
 869                Wrapper,
 870                To_Address (T));
 871          end;
 872       end if;
 873
 874       if T.Common.LL.Thread = -1 then
 875          Succeeded := False;
 876       else
 877          Succeeded := True;
 878       end if;
 879
 880       Task_Creation_Hook (T.Common.LL.Thread);
 881       Set_Priority (T, Priority);
 882    end Create_Task;
 883
 884    ------------------
 885    -- Finalize_TCB --
 886    ------------------
 887
 888    procedure Finalize_TCB (T : Task_ID) is
 889       Result : int;
 890       Tmp    : Task_ID := T;
 891
 892       procedure Free is new
 893         Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
 894
 895    begin
 896       if Single_Lock then
 897          Result := semDelete (T.Common.LL.L.Mutex);
 898          pragma Assert (Result = 0);
 899       end if;
 900
 901       T.Common.LL.Thread := 0;
 902
 903       Result := semDelete (T.Common.LL.CV.Sem);
 904       pragma Assert (Result = 0);
 905
 906       if T.Known_Tasks_Index /= -1 then
 907          Known_Tasks (T.Known_Tasks_Index) := null;
 908       end if;
 909
 910       Free (Tmp);
 911    end Finalize_TCB;
 912
 913    ---------------
 914    -- Exit_Task --
 915    ---------------
 916
 917    procedure Exit_Task is
 918    begin
 919       Task_Termination_Hook;
 920       taskDelete (0);
 921    end Exit_Task;
 922
 923    ----------------
 924    -- Abort_Task --
 925    ----------------
 926
 927    procedure Abort_Task (T : Task_ID) is
 928       Result : int;
 929    begin
 930       Result := kill (T.Common.LL.Thread,
 931         Signal (Interrupt_Management.Abort_Task_Interrupt));
 932       pragma Assert (Result = 0);
 933    end Abort_Task;
 934
 935    ----------------
 936    -- Check_Exit --
 937    ----------------
 938
 939    --  Dummy versions. The only currently working version is for solaris
 940    --  (native).
 941
 942    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 943    begin
 944       return True;
 945    end Check_Exit;
 946
 947    --------------------
 948    -- Check_No_Locks --
 949    --------------------
 950
 951    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 952    begin
 953       return True;
 954    end Check_No_Locks;
 955
 956    ----------------------
 957    -- Environment_Task --
 958    ----------------------
 959
 960    function Environment_Task return Task_ID is
 961    begin
 962       return Environment_Task_ID;
 963    end Environment_Task;
 964
 965    --------------
 966    -- Lock_RTS --
 967    --------------
 968
 969    procedure Lock_RTS is
 970    begin
 971       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 972    end Lock_RTS;
 973
 974    ----------------
 975    -- Unlock_RTS --
 976    ----------------
 977
 978    procedure Unlock_RTS is
 979    begin
 980       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 981    end Unlock_RTS;
 982
 983    ------------------
 984    -- Suspend_Task --
 985    ------------------
 986
 987    function Suspend_Task
 988      (T           : ST.Task_ID;
 989       Thread_Self : Thread_Id) return Boolean is
 990    begin
 991       if T.Common.LL.Thread /= 0
 992         and then T.Common.LL.Thread /= Thread_Self
 993       then
 994          return taskSuspend (T.Common.LL.Thread) = 0;
 995       else
 996          return True;
 997       end if;
 998    end Suspend_Task;
 999
1000    -----------------
1001    -- Resume_Task --
1002    -----------------
1003
1004    function Resume_Task
1005      (T           : ST.Task_ID;
1006       Thread_Self : Thread_Id) return Boolean is
1007    begin
1008       if T.Common.LL.Thread /= 0
1009         and then T.Common.LL.Thread /= Thread_Self
1010       then
1011          return taskResume (T.Common.LL.Thread) = 0;
1012       else
1013          return True;
1014       end if;
1015    end Resume_Task;
1016
1017    ----------------
1018    -- Initialize --
1019    ----------------
1020
1021    procedure Initialize (Environment_Task : Task_ID) is
1022    begin
1023       Environment_Task_ID := Environment_Task;
1024
1025       --  Initialize the lock used to synchronize chain of all ATCBs.
1026
1027       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1028
1029       Enter_Task (Environment_Task);
1030    end Initialize;
1031
1032 begin
1033    declare
1034       Result : int;
1035    begin
1036       if Locking_Policy = 'C' then
1037          Mutex_Protocol := Prio_Protect;
1038       elsif Locking_Policy = 'I' then
1039          Mutex_Protocol := Prio_Inherit;
1040       else
1041          Mutex_Protocol := Prio_None;
1042       end if;
1043
1044       if Time_Slice_Val > 0 then
1045          Result := kernelTimeSlice
1046            (To_Clock_Ticks
1047              (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
1048       end if;
1049
1050       Result := sigemptyset (Unblocked_Signal_Mask'Access);
1051       pragma Assert (Result = 0);
1052    end;
1053 end System.Task_Primitives.Operations;