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