gcc/ada/s-taprop-vxworks.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
   4 --                                                                          --
   5 --     S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S    --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2009, 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 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT 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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNARL was developed by the GNARL team at Florida State University.       --
  28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  This is the VxWorks version of this package
  33
  34 --  This package contains all the GNULL primitives that interface directly with
  35 --  the underlying OS.
  36
  37 pragma Polling (Off);
  38 --  Turn off polling, we do not want ATC polling to take place during tasking
  39 --  operations. It causes infinite loops and other problems.
  40
  41 with Ada.Unchecked_Conversion;
  42 with Ada.Unchecked_Deallocation;
  43
  44 with Interfaces.C;
  45
  46 with System.Tasking.Debug;
  47 with System.Interrupt_Management;
  48
  49 with System.Soft_Links;
  50 --  We use System.Soft_Links instead of System.Tasking.Initialization
  51 --  because the later is a higher level package that we shouldn't depend
  52 --  on. For example when using the restricted run time, it is replaced by
  53 --  System.Tasking.Restricted.Stages.
  54
  55 with System.Task_Info;
  56 with System.VxWorks.Ext;
  57
  58 package body System.Task_Primitives.Operations is
  59
  60    package SSL renames System.Soft_Links;
  61
  62    use System.Tasking.Debug;
  63    use System.Tasking;
  64    use System.OS_Interface;
  65    use System.Parameters;
  66    use type System.VxWorks.Ext.t_id;
  67    use type Interfaces.C.int;
  68
  69    subtype int is System.OS_Interface.int;
  70
  71    Relative : constant := 0;
  72
  73    ----------------
  74    -- Local Data --
  75    ----------------
  76
  77    --  The followings are logically constants, but need to be initialized at
  78    --  run time.
  79
  80    Single_RTS_Lock : aliased RTS_Lock;
  81    --  This is a lock to allow only one thread of control in the RTS at a
  82    --  time; it is used to execute in mutual exclusion from all other tasks.
  83    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
  84
  85    Environment_Task_Id : Task_Id;
  86    --  A variable to hold Task_Id for the environment task
  87
  88    Unblocked_Signal_Mask : aliased sigset_t;
  89    --  The set of signals that should unblocked in all tasks
  90
  91    --  The followings are internal configuration constants needed
  92
  93    Time_Slice_Val : Integer;
  94    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
  95
  96    Locking_Policy : Character;
  97    pragma Import (C, Locking_Policy, "__gl_locking_policy");
  98
  99    Dispatching_Policy : Character;
 100    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 101
 102    function Get_Policy (Prio : System.Any_Priority) return Character;
 103    pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
 104    --  Get priority specific dispatching policy
 105
 106    Mutex_Protocol : Priority_Type;
 107
 108    Foreign_Task_Elaborated : aliased Boolean := True;
 109    --  Used to identified fake tasks (i.e., non-Ada Threads)
 110
 111    type Set_Stack_Limit_Proc_Acc is access procedure;
 112    pragma Convention (C, Set_Stack_Limit_Proc_Acc);
 113
 114    Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
 115    pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
 116    --  Procedure to be called when a task is created to set stack
 117    --  limit.
 118
 119    --------------------
 120    -- Local Packages --
 121    --------------------
 122
 123    package Specific is
 124
 125       procedure Initialize;
 126       pragma Inline (Initialize);
 127       --  Initialize task specific data
 128
 129       function Is_Valid_Task return Boolean;
 130       pragma Inline (Is_Valid_Task);
 131       --  Does executing thread have a TCB?
 132
 133       procedure Set (Self_Id : Task_Id);
 134       pragma Inline (Set);
 135       --  Set the self id for the current task
 136
 137       procedure Delete;
 138       pragma Inline (Delete);
 139       --  Delete the task specific data associated with the current task
 140
 141       function Self return Task_Id;
 142       pragma Inline (Self);
 143       --  Return a pointer to the Ada Task Control Block of the calling task
 144
 145    end Specific;
 146
 147    package body Specific is separate;
 148    --  The body of this package is target specific
 149
 150    ---------------------------------
 151    -- Support for foreign threads --
 152    ---------------------------------
 153
 154    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
 155    --  Allocate and Initialize a new ATCB for the current Thread
 156
 157    function Register_Foreign_Thread
 158      (Thread : Thread_Id) return Task_Id is separate;
 159
 160    -----------------------
 161    -- Local Subprograms --
 162    -----------------------
 163
 164    procedure Abort_Handler (signo : Signal);
 165    --  Handler for the abort (SIGABRT) signal to handle asynchronous abort
 166
 167    procedure Install_Signal_Handlers;
 168    --  Install the default signal handlers for the current task
 169
 170    function To_Address is
 171      new Ada.Unchecked_Conversion (Task_Id, System.Address);
 172
 173    -------------------
 174    -- Abort_Handler --
 175    -------------------
 176
 177    procedure Abort_Handler (signo : Signal) is
 178       pragma Unreferenced (signo);
 179
 180       Self_ID : constant Task_Id := Self;
 181       Old_Set : aliased sigset_t;
 182
 183       Result : int;
 184       pragma Warnings (Off, Result);
 185
 186    begin
 187       --  It is not safe to raise an exception when using ZCX and the GCC
 188       --  exception handling mechanism.
 189
 190       if ZCX_By_Default and then GCC_ZCX_Support then
 191          return;
 192       end if;
 193
 194       if Self_ID.Deferral_Level = 0
 195         and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 196         and then not Self_ID.Aborting
 197       then
 198          Self_ID.Aborting := True;
 199
 200          --  Make sure signals used for RTS internal purpose are unmasked
 201
 202          Result :=
 203            pthread_sigmask
 204              (SIG_UNBLOCK,
 205               Unblocked_Signal_Mask'Access,
 206               Old_Set'Access);
 207          pragma Assert (Result = 0);
 208
 209          raise Standard'Abort_Signal;
 210       end if;
 211    end Abort_Handler;
 212
 213    -----------------
 214    -- Stack_Guard --
 215    -----------------
 216
 217    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 218       pragma Unreferenced (T);
 219       pragma Unreferenced (On);
 220
 221    begin
 222       --  Nothing needed (why not???)
 223
 224       null;
 225    end Stack_Guard;
 226
 227    -------------------
 228    -- Get_Thread_Id --
 229    -------------------
 230
 231    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 232    begin
 233       return T.Common.LL.Thread;
 234    end Get_Thread_Id;
 235
 236    ----------
 237    -- Self --
 238    ----------
 239
 240    function Self return Task_Id renames Specific.Self;
 241
 242    -----------------------------
 243    -- Install_Signal_Handlers --
 244    -----------------------------
 245
 246    procedure Install_Signal_Handlers is
 247       act     : aliased struct_sigaction;
 248       old_act : aliased struct_sigaction;
 249       Tmp_Set : aliased sigset_t;
 250       Result  : int;
 251
 252    begin
 253       act.sa_flags := 0;
 254       act.sa_handler := Abort_Handler'Address;
 255
 256       Result := sigemptyset (Tmp_Set'Access);
 257       pragma Assert (Result = 0);
 258       act.sa_mask := Tmp_Set;
 259
 260       Result :=
 261         sigaction
 262           (Signal (Interrupt_Management.Abort_Task_Interrupt),
 263            act'Unchecked_Access,
 264            old_act'Unchecked_Access);
 265       pragma Assert (Result = 0);
 266
 267       Interrupt_Management.Initialize_Interrupts;
 268    end Install_Signal_Handlers;
 269
 270    ---------------------
 271    -- Initialize_Lock --
 272    ---------------------
 273
 274    procedure Initialize_Lock
 275      (Prio : System.Any_Priority;
 276       L    : not null access Lock)
 277    is
 278    begin
 279       L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
 280       L.Prio_Ceiling := int (Prio);
 281       L.Protocol := Mutex_Protocol;
 282       pragma Assert (L.Mutex /= 0);
 283    end Initialize_Lock;
 284
 285    procedure Initialize_Lock
 286      (L     : not null access RTS_Lock;
 287       Level : Lock_Level)
 288    is
 289       pragma Unreferenced (Level);
 290    begin
 291       L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
 292       L.Prio_Ceiling := int (System.Any_Priority'Last);
 293       L.Protocol := Mutex_Protocol;
 294       pragma Assert (L.Mutex /= 0);
 295    end Initialize_Lock;
 296
 297    -------------------
 298    -- Finalize_Lock --
 299    -------------------
 300
 301    procedure Finalize_Lock (L : not null access Lock) is
 302       Result : int;
 303    begin
 304       Result := semDelete (L.Mutex);
 305       pragma Assert (Result = 0);
 306    end Finalize_Lock;
 307
 308    procedure Finalize_Lock (L : not null access RTS_Lock) is
 309       Result : int;
 310    begin
 311       Result := semDelete (L.Mutex);
 312       pragma Assert (Result = 0);
 313    end Finalize_Lock;
 314
 315    ----------------
 316    -- Write_Lock --
 317    ----------------
 318
 319    procedure Write_Lock
 320      (L                 : not null access Lock;
 321       Ceiling_Violation : out Boolean)
 322    is
 323       Result : int;
 324
 325    begin
 326       if L.Protocol = Prio_Protect
 327         and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
 328       then
 329          Ceiling_Violation := True;
 330          return;
 331       else
 332          Ceiling_Violation := False;
 333       end if;
 334
 335       Result := semTake (L.Mutex, WAIT_FOREVER);
 336       pragma Assert (Result = 0);
 337    end Write_Lock;
 338
 339    procedure Write_Lock
 340      (L           : not null access RTS_Lock;
 341       Global_Lock : Boolean := False)
 342    is
 343       Result : int;
 344    begin
 345       if not Single_Lock or else Global_Lock then
 346          Result := semTake (L.Mutex, WAIT_FOREVER);
 347          pragma Assert (Result = 0);
 348       end if;
 349    end Write_Lock;
 350
 351    procedure Write_Lock (T : Task_Id) is
 352       Result : int;
 353    begin
 354       if not Single_Lock then
 355          Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
 356          pragma Assert (Result = 0);
 357       end if;
 358    end Write_Lock;
 359
 360    ---------------
 361    -- Read_Lock --
 362    ---------------
 363
 364    procedure Read_Lock
 365      (L                 : not null access Lock;
 366       Ceiling_Violation : out Boolean)
 367    is
 368    begin
 369       Write_Lock (L, Ceiling_Violation);
 370    end Read_Lock;
 371
 372    ------------
 373    -- Unlock --
 374    ------------
 375
 376    procedure Unlock (L : not null access Lock) is
 377       Result : int;
 378    begin
 379       Result := semGive (L.Mutex);
 380       pragma Assert (Result = 0);
 381    end Unlock;
 382
 383    procedure Unlock
 384      (L           : not null access RTS_Lock;
 385       Global_Lock : Boolean := False)
 386    is
 387       Result : int;
 388    begin
 389       if not Single_Lock or else Global_Lock then
 390          Result := semGive (L.Mutex);
 391          pragma Assert (Result = 0);
 392       end if;
 393    end Unlock;
 394
 395    procedure Unlock (T : Task_Id) is
 396       Result : int;
 397    begin
 398       if not Single_Lock then
 399          Result := semGive (T.Common.LL.L.Mutex);
 400          pragma Assert (Result = 0);
 401       end if;
 402    end Unlock;
 403
 404    -----------------
 405    -- Set_Ceiling --
 406    -----------------
 407
 408    --  Dynamic priority ceilings are not supported by the underlying system
 409
 410    procedure Set_Ceiling
 411      (L    : not null access Lock;
 412       Prio : System.Any_Priority)
 413    is
 414       pragma Unreferenced (L, Prio);
 415    begin
 416       null;
 417    end Set_Ceiling;
 418
 419    -----------
 420    -- Sleep --
 421    -----------
 422
 423    procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
 424       pragma Unreferenced (Reason);
 425
 426       Result : int;
 427
 428    begin
 429       pragma Assert (Self_ID = Self);
 430
 431       --  Release the mutex before sleeping
 432
 433       if Single_Lock then
 434          Result := semGive (Single_RTS_Lock.Mutex);
 435       else
 436          Result := semGive (Self_ID.Common.LL.L.Mutex);
 437       end if;
 438
 439       pragma Assert (Result = 0);
 440
 441       --  Perform a blocking operation to take the CV semaphore. Note that a
 442       --  blocking operation in VxWorks will reenable task scheduling. When we
 443       --  are no longer blocked and control is returned, task scheduling will
 444       --  again be disabled.
 445
 446       Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
 447       pragma Assert (Result = 0);
 448
 449       --  Take the mutex back
 450
 451       if Single_Lock then
 452          Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
 453       else
 454          Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
 455       end if;
 456
 457       pragma Assert (Result = 0);
 458    end Sleep;
 459
 460    -----------------
 461    -- Timed_Sleep --
 462    -----------------
 463
 464    --  This is for use within the run-time system, so abort is assumed to be
 465    --  already deferred, and the caller should be holding its own ATCB lock.
 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       pragma Unreferenced (Reason);
 476
 477       Orig     : constant Duration := Monotonic_Clock;
 478       Absolute : Duration;
 479       Ticks    : int;
 480       Result   : int;
 481       Wakeup   : Boolean := False;
 482
 483    begin
 484       Timedout := False;
 485       Yielded  := True;
 486
 487       if Mode = Relative then
 488          Absolute := Orig + Time;
 489
 490          --  Systematically add one since the first tick will delay *at most*
 491          --  1 / Rate_Duration seconds, so we need to add one to be on the
 492          --  safe side.
 493
 494          Ticks := To_Clock_Ticks (Time);
 495
 496          if Ticks > 0 and then Ticks < int'Last then
 497             Ticks := Ticks + 1;
 498          end if;
 499
 500       else
 501          Absolute := Time;
 502          Ticks    := To_Clock_Ticks (Time - Monotonic_Clock);
 503       end if;
 504
 505       if Ticks > 0 then
 506          loop
 507             --  Release the mutex before sleeping
 508
 509             if Single_Lock then
 510                Result := semGive (Single_RTS_Lock.Mutex);
 511             else
 512                Result := semGive (Self_ID.Common.LL.L.Mutex);
 513             end if;
 514
 515             pragma Assert (Result = 0);
 516
 517             --  Perform a blocking operation to take the CV semaphore. Note
 518             --  that a blocking operation in VxWorks will reenable task
 519             --  scheduling. When we are no longer blocked and control is
 520             --  returned, task scheduling will again be disabled.
 521
 522             Result := semTake (Self_ID.Common.LL.CV, Ticks);
 523
 524             if Result = 0 then
 525
 526                --  Somebody may have called Wakeup for us
 527
 528                Wakeup := True;
 529
 530             else
 531                if errno /= S_objLib_OBJ_TIMEOUT then
 532                   Wakeup := True;
 533
 534                else
 535                   --  If Ticks = int'last, it was most probably truncated so
 536                   --  let's make another round after recomputing Ticks from
 537                   --  the absolute time.
 538
 539                   if Ticks /= int'Last then
 540                      Timedout := True;
 541
 542                   else
 543                      Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
 544
 545                      if Ticks < 0 then
 546                         Timedout := True;
 547                      end if;
 548                   end if;
 549                end if;
 550             end if;
 551
 552             --  Take the mutex back
 553
 554             if Single_Lock then
 555                Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
 556             else
 557                Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
 558             end if;
 559
 560             pragma Assert (Result = 0);
 561
 562             exit when Timedout or Wakeup;
 563          end loop;
 564
 565       else
 566          Timedout := True;
 567
 568          --  Should never hold a lock while yielding
 569
 570          if Single_Lock then
 571             Result := semGive (Single_RTS_Lock.Mutex);
 572             taskDelay (0);
 573             Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
 574
 575          else
 576             Result := semGive (Self_ID.Common.LL.L.Mutex);
 577             taskDelay (0);
 578             Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
 579          end if;
 580       end if;
 581    end Timed_Sleep;
 582
 583    -----------------
 584    -- Timed_Delay --
 585    -----------------
 586
 587    --  This is for use in implementing delay statements, so we assume the
 588    --  caller is holding no locks.
 589
 590    procedure Timed_Delay
 591      (Self_ID : Task_Id;
 592       Time    : Duration;
 593       Mode    : ST.Delay_Modes)
 594    is
 595       Orig     : constant Duration := Monotonic_Clock;
 596       Absolute : Duration;
 597       Ticks    : int;
 598       Timedout : Boolean;
 599       Aborted  : Boolean := False;
 600
 601       Result : int;
 602       pragma Warnings (Off, Result);
 603
 604    begin
 605       if Mode = Relative then
 606          Absolute := Orig + Time;
 607          Ticks    := To_Clock_Ticks (Time);
 608
 609          if Ticks > 0 and then Ticks < int'Last then
 610
 611             --  First tick will delay anytime between 0 and 1 / sysClkRateGet
 612             --  seconds, so we need to add one to be on the safe side.
 613
 614             Ticks := Ticks + 1;
 615          end if;
 616
 617       else
 618          Absolute := Time;
 619          Ticks    := To_Clock_Ticks (Time - Orig);
 620       end if;
 621
 622       if Ticks > 0 then
 623
 624          --  Modifying State, locking the TCB
 625
 626          if Single_Lock then
 627             Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
 628          else
 629             Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
 630          end if;
 631
 632          pragma Assert (Result = 0);
 633
 634          Self_ID.Common.State := Delay_Sleep;
 635          Timedout := False;
 636
 637          loop
 638             Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 639
 640             --  Release the TCB before sleeping
 641
 642             if Single_Lock then
 643                Result := semGive (Single_RTS_Lock.Mutex);
 644             else
 645                Result := semGive (Self_ID.Common.LL.L.Mutex);
 646             end if;
 647             pragma Assert (Result = 0);
 648
 649             exit when Aborted;
 650
 651             Result := semTake (Self_ID.Common.LL.CV, Ticks);
 652
 653             if Result /= 0 then
 654
 655                --  If Ticks = int'last, it was most probably truncated
 656                --  so let's make another round after recomputing Ticks
 657                --  from the absolute time.
 658
 659                if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then
 660                   Timedout := True;
 661                else
 662                   Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
 663
 664                   if Ticks < 0 then
 665                      Timedout := True;
 666                   end if;
 667                end if;
 668             end if;
 669
 670             --  Take back the lock after having slept, to protect further
 671             --  access to Self_ID.
 672
 673             if Single_Lock then
 674                Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
 675             else
 676                Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
 677             end if;
 678
 679             pragma Assert (Result = 0);
 680
 681             exit when Timedout;
 682          end loop;
 683
 684          Self_ID.Common.State := Runnable;
 685
 686          if Single_Lock then
 687             Result := semGive (Single_RTS_Lock.Mutex);
 688          else
 689             Result := semGive (Self_ID.Common.LL.L.Mutex);
 690          end if;
 691
 692       else
 693          taskDelay (0);
 694       end if;
 695    end Timed_Delay;
 696
 697    ---------------------
 698    -- Monotonic_Clock --
 699    ---------------------
 700
 701    function Monotonic_Clock return Duration is
 702       TS     : aliased timespec;
 703       Result : int;
 704    begin
 705       Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
 706       pragma Assert (Result = 0);
 707       return To_Duration (TS);
 708    end Monotonic_Clock;
 709
 710    -------------------
 711    -- RT_Resolution --
 712    -------------------
 713
 714    function RT_Resolution return Duration is
 715    begin
 716       return 1.0 / Duration (sysClkRateGet);
 717    end RT_Resolution;
 718
 719    ------------
 720    -- Wakeup --
 721    ------------
 722
 723    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 724       pragma Unreferenced (Reason);
 725       Result : int;
 726    begin
 727       Result := semGive (T.Common.LL.CV);
 728       pragma Assert (Result = 0);
 729    end Wakeup;
 730
 731    -----------
 732    -- Yield --
 733    -----------
 734
 735    procedure Yield (Do_Yield : Boolean := True) is
 736       pragma Unreferenced (Do_Yield);
 737       Result : int;
 738       pragma Unreferenced (Result);
 739    begin
 740       Result := taskDelay (0);
 741    end Yield;
 742
 743    ------------------
 744    -- Set_Priority --
 745    ------------------
 746
 747    type Prio_Array_Type is array (System.Any_Priority) of Integer;
 748    pragma Atomic_Components (Prio_Array_Type);
 749
 750    Prio_Array : Prio_Array_Type;
 751    --  Global array containing the id of the currently running task for each
 752    --  priority. Note that we assume that we are on a single processor with
 753    --  run-till-blocked scheduling.
 754
 755    procedure Set_Priority
 756      (T                   : Task_Id;
 757       Prio                : System.Any_Priority;
 758       Loss_Of_Inheritance : Boolean := False)
 759    is
 760       Array_Item : Integer;
 761       Result     : int;
 762
 763    begin
 764       Result :=
 765         taskPrioritySet
 766           (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
 767       pragma Assert (Result = 0);
 768
 769       if (Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F')
 770         and then Loss_Of_Inheritance
 771         and then Prio < T.Common.Current_Priority
 772       then
 773          --  Annex D requirement (RM D.2.2(9)):
 774
 775          --    If the task drops its priority due to the loss of inherited
 776          --    priority, it is added at the head of the ready queue for its
 777          --    new active priority.
 778
 779          Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
 780          Prio_Array (T.Common.Base_Priority) := Array_Item;
 781
 782          loop
 783             --  Give some processes a chance to arrive
 784
 785             taskDelay (0);
 786
 787             --  Then wait for our turn to proceed
 788
 789             exit when Array_Item = Prio_Array (T.Common.Base_Priority)
 790               or else Prio_Array (T.Common.Base_Priority) = 1;
 791          end loop;
 792
 793          Prio_Array (T.Common.Base_Priority) :=
 794            Prio_Array (T.Common.Base_Priority) - 1;
 795       end if;
 796
 797       T.Common.Current_Priority := Prio;
 798    end Set_Priority;
 799
 800    ------------------
 801    -- Get_Priority --
 802    ------------------
 803
 804    function Get_Priority (T : Task_Id) return System.Any_Priority is
 805    begin
 806       return T.Common.Current_Priority;
 807    end Get_Priority;
 808
 809    ----------------
 810    -- Enter_Task --
 811    ----------------
 812
 813    procedure Enter_Task (Self_ID : Task_Id) is
 814       procedure Init_Float;
 815       pragma Import (C, Init_Float, "__gnat_init_float");
 816       --  Properly initializes the FPU for PPC/MIPS systems
 817
 818    begin
 819       --  Store the user-level task id in the Thread field (to be used
 820       --  internally by the run-time system) and the kernel-level task id in
 821       --  the LWP field (to be used by the debugger).
 822
 823       Self_ID.Common.LL.Thread := taskIdSelf;
 824       Self_ID.Common.LL.LWP := getpid;
 825
 826       Specific.Set (Self_ID);
 827
 828       Init_Float;
 829
 830       --  Install the signal handlers
 831
 832       --  This is called for each task since there is no signal inheritance
 833       --  between VxWorks tasks.
 834
 835       Install_Signal_Handlers;
 836
 837       --  If stack checking is enabled, set the stack limit for this task
 838
 839       if Set_Stack_Limit_Hook /= null then
 840          Set_Stack_Limit_Hook.all;
 841       end if;
 842    end Enter_Task;
 843
 844    --------------
 845    -- New_ATCB --
 846    --------------
 847
 848    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 849    begin
 850       return new Ada_Task_Control_Block (Entry_Num);
 851    end New_ATCB;
 852
 853    -------------------
 854    -- Is_Valid_Task --
 855    -------------------
 856
 857    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 858
 859    -----------------------------
 860    -- Register_Foreign_Thread --
 861    -----------------------------
 862
 863    function Register_Foreign_Thread return Task_Id is
 864    begin
 865       if Is_Valid_Task then
 866          return Self;
 867       else
 868          return Register_Foreign_Thread (taskIdSelf);
 869       end if;
 870    end Register_Foreign_Thread;
 871
 872    --------------------
 873    -- Initialize_TCB --
 874    --------------------
 875
 876    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 877    begin
 878       Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
 879       Self_ID.Common.LL.Thread := 0;
 880
 881       if Self_ID.Common.LL.CV = 0 then
 882          Succeeded := False;
 883
 884       else
 885          Succeeded := True;
 886
 887          if not Single_Lock then
 888             Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
 889          end if;
 890       end if;
 891    end Initialize_TCB;
 892
 893    -----------------
 894    -- Create_Task --
 895    -----------------
 896
 897    procedure Create_Task
 898      (T          : Task_Id;
 899       Wrapper    : System.Address;
 900       Stack_Size : System.Parameters.Size_Type;
 901       Priority   : System.Any_Priority;
 902       Succeeded  : out Boolean)
 903    is
 904       Adjusted_Stack_Size : size_t;
 905       Result : int;
 906
 907       use System.Task_Info;
 908
 909    begin
 910       --  Ask for four extra bytes of stack space so that the ATCB pointer can
 911       --  be stored below the stack limit, plus extra space for the frame of
 912       --  Task_Wrapper. This is so the user gets the amount of stack requested
 913       --  exclusive of the needs.
 914
 915       --  We also have to allocate n more bytes for the task name storage and
 916       --  enough space for the Wind Task Control Block which is around 0x778
 917       --  bytes. VxWorks also seems to carve out additional space, so use 2048
 918       --  as a nice round number. We might want to increment to the nearest
 919       --  page size in case we ever support VxVMI.
 920
 921       --  ??? - we should come back and visit this so we can set the task name
 922       --        to something appropriate.
 923
 924       Adjusted_Stack_Size := size_t (Stack_Size) + 2048;
 925
 926       --  Since the initial signal mask of a thread is inherited from the
 927       --  creator, and the Environment task has all its signals masked, we do
 928       --  not need to manipulate caller's signal mask at this point. All tasks
 929       --  in RTS will have All_Tasks_Mask initially.
 930
 931       --  We now compute the VxWorks task name and options, then spawn ...
 932
 933       declare
 934          Name         : aliased String (1 .. T.Common.Task_Image_Len + 1);
 935          Name_Address : System.Address;
 936          --  Task name we are going to hand down to VxWorks
 937
 938          function Get_Task_Options return int;
 939          pragma Import (C, Get_Task_Options, "__gnat_get_task_options");
 940          --  Function that returns the options to be set for the task that we
 941          --  are creating. We fetch the options assigned to the current task,
 942          --  so offering some user level control over the options for a task
 943          --  hierarchy, and force VX_FP_TASK because it is almost always
 944          --  required.
 945
 946       begin
 947          --  If there is no Ada task name handy, let VxWorks choose one.
 948          --  Otherwise, tell VxWorks what the Ada task name is.
 949
 950          if T.Common.Task_Image_Len = 0 then
 951             Name_Address := System.Null_Address;
 952          else
 953             Name (1 .. Name'Last - 1) :=
 954               T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
 955             Name (Name'Last) := ASCII.NUL;
 956             Name_Address := Name'Address;
 957          end if;
 958
 959          --  Now spawn the VxWorks task for real
 960
 961          T.Common.LL.Thread :=
 962            taskSpawn
 963              (Name_Address,
 964               To_VxWorks_Priority (int (Priority)),
 965               Get_Task_Options,
 966               Adjusted_Stack_Size,
 967               Wrapper,
 968               To_Address (T));
 969       end;
 970
 971       --  Set processor affinity
 972
 973       if T.Common.Task_Info /= Unspecified_Task_Info then
 974          Result :=
 975            taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info);
 976
 977          if Result = -1 then
 978             taskDelete (T.Common.LL.Thread);
 979             T.Common.LL.Thread := -1;
 980          end if;
 981       end if;
 982
 983       if T.Common.LL.Thread = -1 then
 984          Succeeded := False;
 985       else
 986          Succeeded := True;
 987          Task_Creation_Hook (T.Common.LL.Thread);
 988          Set_Priority (T, Priority);
 989       end if;
 990    end Create_Task;
 991
 992    ------------------
 993    -- Finalize_TCB --
 994    ------------------
 995
 996    procedure Finalize_TCB (T : Task_Id) is
 997       Result  : int;
 998       Tmp     : Task_Id          := T;
 999       Is_Self : constant Boolean := (T = Self);
1000
1001       procedure Free is new
1002         Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
1003
1004    begin
1005       if not Single_Lock then
1006          Result := semDelete (T.Common.LL.L.Mutex);
1007          pragma Assert (Result = 0);
1008       end if;
1009
1010       T.Common.LL.Thread := 0;
1011
1012       Result := semDelete (T.Common.LL.CV);
1013       pragma Assert (Result = 0);
1014
1015       if T.Known_Tasks_Index /= -1 then
1016          Known_Tasks (T.Known_Tasks_Index) := null;
1017       end if;
1018
1019       Free (Tmp);
1020
1021       if Is_Self then
1022          Specific.Delete;
1023       end if;
1024    end Finalize_TCB;
1025
1026    ---------------
1027    -- Exit_Task --
1028    ---------------
1029
1030    procedure Exit_Task is
1031    begin
1032       Specific.Set (null);
1033    end Exit_Task;
1034
1035    ----------------
1036    -- Abort_Task --
1037    ----------------
1038
1039    procedure Abort_Task (T : Task_Id) is
1040       Result : int;
1041    begin
1042       Result :=
1043         kill
1044           (T.Common.LL.Thread,
1045            Signal (Interrupt_Management.Abort_Task_Interrupt));
1046       pragma Assert (Result = 0);
1047    end Abort_Task;
1048
1049    ----------------
1050    -- Initialize --
1051    ----------------
1052
1053    procedure Initialize (S : in out Suspension_Object) is
1054    begin
1055       --  Initialize internal state (always to False (RM D.10(6)))
1056
1057       S.State := False;
1058       S.Waiting := False;
1059
1060       --  Initialize internal mutex
1061
1062       --  Use simpler binary semaphore instead of VxWorks
1063       --  mutual exclusion semaphore, because we don't need
1064       --  the fancier semantics and their overhead.
1065
1066       S.L := semBCreate (SEM_Q_FIFO, SEM_FULL);
1067
1068       --  Initialize internal condition variable
1069
1070       S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY);
1071    end Initialize;
1072
1073    --------------
1074    -- Finalize --
1075    --------------
1076
1077    procedure Finalize (S : in out Suspension_Object) is
1078       pragma Unmodified (S);
1079       --  S may be modified on other targets, but not on VxWorks
1080
1081       Result : STATUS;
1082
1083    begin
1084       --  Destroy internal mutex
1085
1086       Result := semDelete (S.L);
1087       pragma Assert (Result = OK);
1088
1089       --  Destroy internal condition variable
1090
1091       Result := semDelete (S.CV);
1092       pragma Assert (Result = OK);
1093    end Finalize;
1094
1095    -------------------
1096    -- Current_State --
1097    -------------------
1098
1099    function Current_State (S : Suspension_Object) return Boolean is
1100    begin
1101       --  We do not want to use lock on this read operation. State is marked
1102       --  as Atomic so that we ensure that the value retrieved is correct.
1103
1104       return S.State;
1105    end Current_State;
1106
1107    ---------------
1108    -- Set_False --
1109    ---------------
1110
1111    procedure Set_False (S : in out Suspension_Object) is
1112       Result : STATUS;
1113
1114    begin
1115       SSL.Abort_Defer.all;
1116
1117       Result := semTake (S.L, WAIT_FOREVER);
1118       pragma Assert (Result = OK);
1119
1120       S.State := False;
1121
1122       Result := semGive (S.L);
1123       pragma Assert (Result = OK);
1124
1125       SSL.Abort_Undefer.all;
1126    end Set_False;
1127
1128    --------------
1129    -- Set_True --
1130    --------------
1131
1132    procedure Set_True (S : in out Suspension_Object) is
1133       Result : STATUS;
1134
1135    begin
1136       SSL.Abort_Defer.all;
1137
1138       Result := semTake (S.L, WAIT_FOREVER);
1139       pragma Assert (Result = OK);
1140
1141       --  If there is already a task waiting on this suspension object then
1142       --  we resume it, leaving the state of the suspension object to False,
1143       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1144       --  the state to True.
1145
1146       if S.Waiting then
1147          S.Waiting := False;
1148          S.State := False;
1149
1150          Result := semGive (S.CV);
1151          pragma Assert (Result = OK);
1152       else
1153          S.State := True;
1154       end if;
1155
1156       Result := semGive (S.L);
1157       pragma Assert (Result = OK);
1158
1159       SSL.Abort_Undefer.all;
1160    end Set_True;
1161
1162    ------------------------
1163    -- Suspend_Until_True --
1164    ------------------------
1165
1166    procedure Suspend_Until_True (S : in out Suspension_Object) is
1167       Result : STATUS;
1168
1169    begin
1170       SSL.Abort_Defer.all;
1171
1172       Result := semTake (S.L, WAIT_FOREVER);
1173
1174       if S.Waiting then
1175
1176          --  Program_Error must be raised upon calling Suspend_Until_True
1177          --  if another task is already waiting on that suspension object
1178          --  (ARM D.10 par. 10).
1179
1180          Result := semGive (S.L);
1181          pragma Assert (Result = OK);
1182
1183          SSL.Abort_Undefer.all;
1184
1185          raise Program_Error;
1186
1187       else
1188          --  Suspend the task if the state is False. Otherwise, the task
1189          --  continues its execution, and the state of the suspension object
1190          --  is set to False (ARM D.10 par. 9).
1191
1192          if S.State then
1193             S.State := False;
1194
1195             Result := semGive (S.L);
1196             pragma Assert (Result = 0);
1197
1198             SSL.Abort_Undefer.all;
1199
1200          else
1201             S.Waiting := True;
1202
1203             --  Release the mutex before sleeping
1204
1205             Result := semGive (S.L);
1206             pragma Assert (Result = OK);
1207
1208             SSL.Abort_Undefer.all;
1209
1210             Result := semTake (S.CV, WAIT_FOREVER);
1211             pragma Assert (Result = 0);
1212          end if;
1213       end if;
1214    end Suspend_Until_True;
1215
1216    ----------------
1217    -- Check_Exit --
1218    ----------------
1219
1220    --  Dummy version
1221
1222    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1223       pragma Unreferenced (Self_ID);
1224    begin
1225       return True;
1226    end Check_Exit;
1227
1228    --------------------
1229    -- Check_No_Locks --
1230    --------------------
1231
1232    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1233       pragma Unreferenced (Self_ID);
1234    begin
1235       return True;
1236    end Check_No_Locks;
1237
1238    ----------------------
1239    -- Environment_Task --
1240    ----------------------
1241
1242    function Environment_Task return Task_Id is
1243    begin
1244       return Environment_Task_Id;
1245    end Environment_Task;
1246
1247    --------------
1248    -- Lock_RTS --
1249    --------------
1250
1251    procedure Lock_RTS is
1252    begin
1253       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1254    end Lock_RTS;
1255
1256    ----------------
1257    -- Unlock_RTS --
1258    ----------------
1259
1260    procedure Unlock_RTS is
1261    begin
1262       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1263    end Unlock_RTS;
1264
1265    ------------------
1266    -- Suspend_Task --
1267    ------------------
1268
1269    function Suspend_Task
1270      (T           : ST.Task_Id;
1271       Thread_Self : Thread_Id) return Boolean
1272    is
1273    begin
1274       if T.Common.LL.Thread /= 0
1275         and then T.Common.LL.Thread /= Thread_Self
1276       then
1277          return taskSuspend (T.Common.LL.Thread) = 0;
1278       else
1279          return True;
1280       end if;
1281    end Suspend_Task;
1282
1283    -----------------
1284    -- Resume_Task --
1285    -----------------
1286
1287    function Resume_Task
1288      (T           : ST.Task_Id;
1289       Thread_Self : Thread_Id) return Boolean
1290    is
1291    begin
1292       if T.Common.LL.Thread /= 0
1293         and then T.Common.LL.Thread /= Thread_Self
1294       then
1295          return taskResume (T.Common.LL.Thread) = 0;
1296       else
1297          return True;
1298       end if;
1299    end Resume_Task;
1300
1301    --------------------
1302    -- Stop_All_Tasks --
1303    --------------------
1304
1305    procedure Stop_All_Tasks
1306    is
1307       Thread_Self : constant Thread_Id := taskIdSelf;
1308       C           : Task_Id;
1309
1310       Dummy : int;
1311       pragma Unreferenced (Dummy);
1312
1313    begin
1314       Dummy := Int_Lock;
1315
1316       C := All_Tasks_List;
1317       while C /= null loop
1318          if C.Common.LL.Thread /= 0
1319            and then C.Common.LL.Thread /= Thread_Self
1320          then
1321             Dummy := Task_Stop (C.Common.LL.Thread);
1322          end if;
1323
1324          C := C.Common.All_Tasks_Link;
1325       end loop;
1326
1327       Dummy := Int_Unlock;
1328    end Stop_All_Tasks;
1329
1330    ---------------
1331    -- Stop_Task --
1332    ---------------
1333
1334    function Stop_Task (T : ST.Task_Id) return Boolean is
1335    begin
1336       if T.Common.LL.Thread /= 0 then
1337          return Task_Stop (T.Common.LL.Thread) = 0;
1338       else
1339          return True;
1340       end if;
1341    end Stop_Task;
1342
1343    -------------------
1344    -- Continue_Task --
1345    -------------------
1346
1347    function Continue_Task (T : ST.Task_Id) return Boolean
1348    is
1349    begin
1350       if T.Common.LL.Thread /= 0 then
1351          return Task_Cont (T.Common.LL.Thread) = 0;
1352       else
1353          return True;
1354       end if;
1355    end Continue_Task;
1356
1357    ----------------
1358    -- Initialize --
1359    ----------------
1360
1361    procedure Initialize (Environment_Task : Task_Id) is
1362       Result : int;
1363
1364    begin
1365       Environment_Task_Id := Environment_Task;
1366
1367       Interrupt_Management.Initialize;
1368       Specific.Initialize;
1369
1370       if Locking_Policy = 'C' then
1371          Mutex_Protocol := Prio_Protect;
1372       elsif Locking_Policy = 'I' then
1373          Mutex_Protocol := Prio_Inherit;
1374       else
1375          Mutex_Protocol := Prio_None;
1376       end if;
1377
1378       if Time_Slice_Val > 0 then
1379          Result :=
1380            Set_Time_Slice
1381              (To_Clock_Ticks
1382                 (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
1383
1384       elsif Dispatching_Policy = 'R' then
1385          Result := Set_Time_Slice (To_Clock_Ticks (0.01));
1386
1387       end if;
1388
1389       Result := sigemptyset (Unblocked_Signal_Mask'Access);
1390       pragma Assert (Result = 0);
1391
1392       for J in Interrupt_Management.Signal_ID loop
1393          if System.Interrupt_Management.Keep_Unmasked (J) then
1394             Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1395             pragma Assert (Result = 0);
1396          end if;
1397       end loop;
1398
1399       --  Initialize the lock used to synchronize chain of all ATCBs
1400
1401       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1402
1403       --  Make environment task known here because it doesn't go through
1404       --  Activate_Tasks, which does it for all other tasks.
1405
1406       Known_Tasks (Known_Tasks'First) := Environment_Task;
1407       Environment_Task.Known_Tasks_Index := Known_Tasks'First;
1408
1409       Enter_Task (Environment_Task);
1410    end Initialize;
1411
1412 end System.Task_Primitives.Operations;