File : s-tarest-raven.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
   4 --                                                                          --
   5 --     S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S      --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --                     Copyright (C) 1999-2014, AdaCore                     --
  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 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  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 a simplified version of the System.Tasking.Stages package, for use
  33 --  with the ravenscar/HI-E profile.
  34 
  35 --  This package represents the high level tasking interface used by the
  36 --  compiler to expand Ada 95 tasking constructs into simpler run time calls.
  37 
  38 pragma Style_Checks (All_Checks);
  39 --  Turn off subprogram alpha order check, since we group soft link bodies and
  40 --  also separate off subprograms for restricted GNARLI.
  41 
  42 pragma Polling (Off);
  43 --  Turn off polling, we do not want ATC polling to take place during
  44 --  tasking operations. It causes infinite loops and other problems.
  45 
  46 with System.Task_Primitives.Operations;
  47 --  used for Enter_Task
  48 --           Wakeup
  49 --           Get_Priority
  50 --           Set_Priority
  51 --           Sleep
  52 
  53 with System.Secondary_Stack;
  54 --  used for SS_Init
  55 --           Default_Secondary_Stack_Size
  56 
  57 with System.Storage_Elements;
  58 --  used for Storage_Array
  59 
  60 package body System.Tasking.Restricted.Stages is
  61 
  62    use System.Secondary_Stack;
  63    use System.Task_Primitives.Operations;
  64    use System.Task_Info;
  65 
  66    Tasks_Activation_Chain : Task_Id;
  67    --  Chain of all the tasks to activate, when the sequential elaboration
  68    --  policy is used
  69 
  70    -----------------------
  71    -- Local Subprograms --
  72    -----------------------
  73 
  74    procedure Activate_Tasks (Chain : Task_Id);
  75    --  Activate the list of tasks started by Chain
  76 
  77    procedure Create_Restricted_Task
  78      (Priority      : Integer;
  79       Stack_Address : System.Address;
  80       Size          : System.Parameters.Size_Type;
  81       Task_Info     : System.Task_Info.Task_Info_Type;
  82       CPU           : Integer;
  83       State         : Task_Procedure_Access;
  84       Discriminants : System.Address;
  85       Created_Task  : Task_Id);
  86    --  Code shared between Create_Restricted_Task (the concurrent version) and
  87    --  Create_Restricted_Task_Sequential. See comment of the former in the
  88    --  specification of this package.
  89 
  90    procedure Task_Wrapper (Self_ID : Task_Id);
  91    --  This is the procedure that is called by the GNULL from the new context
  92    --  when a task is created. It waits for activation and then calls the task
  93    --  body procedure. When the task body procedure completes, it terminates
  94    --  the task.
  95 
  96    ------------------
  97    -- Task_Wrapper --
  98    ------------------
  99 
 100    --  The task wrapper is a procedure that is called first for each task
 101    --  task body, and which in turn calls the compiler-generated task body
 102    --  procedure. The wrapper's main job is to do initialization for the task.
 103 
 104    --  The variable ID in the task wrapper is used to implement the Self
 105    --  function on targets where there is a fast way to find the stack
 106    --  base of the current thread, since it should be at a fixed offset
 107    --  from the stack base.
 108 
 109    procedure Task_Wrapper (Self_ID : Task_Id) is
 110       use type System.Storage_Elements.Storage_Offset;
 111 
 112       Sec_Stack_Size : constant Storage_Elements.Storage_Offset :=
 113                          Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size
 114                            * SSE.Storage_Offset
 115                               (Parameters.Sec_Stack_Percentage)
 116                            / 100;
 117 
 118       Secondary_Stack : aliased Storage_Elements.Storage_Array
 119                           (1 .. Sec_Stack_Size);
 120       for Secondary_Stack'Alignment use Standard'Maximum_Alignment;
 121       --  This is the secondary stack data. Note that it is critical that this
 122       --  have maximum alignment, since any kind of data can be allocated here.
 123 
 124       TH : Termination_Handler := null;
 125 
 126    begin
 127       Self_ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address;
 128       SS_Init (Secondary_Stack'Address, Integer (Sec_Stack_Size));
 129 
 130       --  Initialize low-level TCB components, that cannot be initialized by
 131       --  the creator.
 132 
 133       Enter_Task (Self_ID);
 134 
 135       --  Call the task body procedure
 136 
 137       Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
 138 
 139       --  Look for a fall-back handler. There is a single task termination
 140       --  procedure for all the tasks in the partition.
 141 
 142       --  This package is part of the restricted run time which supports
 143       --  neither task hierarchies (No_Task_Hierarchy) nor specific task
 144       --  termination handlers (No_Specific_Termination_Handlers).
 145 
 146       --  Raise the priority to prevent race conditions when using
 147       --  System.Tasking.Fall_Back_Handler.
 148 
 149       Set_Priority (Self_ID, Any_Priority'Last);
 150 
 151       TH := System.Tasking.Fall_Back_Handler;
 152 
 153       --  Restore original priority after retrieving shared data
 154 
 155       Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 156 
 157       --  Execute the task termination handler if we found it
 158 
 159       if TH /= null then
 160          TH.all (Self_ID);
 161       end if;
 162 
 163       --  We used to raise a Program_Error here to signal the task termination
 164       --  event in order to avoid silent task death. It has been removed
 165       --  because the Ada.Task_Termination functionality serves the same
 166       --  purpose in a more flexible (and standard) way. In addition, this
 167       --  exception triggered a second execution of the termination handler
 168       --  (if any was installed). We simply ensure that the task does not
 169       --  execute any more.
 170 
 171       Sleep (Self_ID, Terminated);
 172    end Task_Wrapper;
 173 
 174    -----------------------
 175    -- Restricted GNARLI --
 176    -----------------------
 177 
 178    -----------------------------------
 179    -- Activate_All_Tasks_Sequential --
 180    -----------------------------------
 181 
 182    procedure Activate_All_Tasks_Sequential is
 183    begin
 184       pragma Assert (Partition_Elaboration_Policy = 'S');
 185       Activate_Tasks (Tasks_Activation_Chain);
 186       Tasks_Activation_Chain := Null_Task;
 187    end Activate_All_Tasks_Sequential;
 188 
 189    -------------------------------
 190    -- Activate_Restricted_Tasks --
 191    -------------------------------
 192 
 193    procedure Activate_Restricted_Tasks
 194      (Chain_Access : Activation_Chain_Access) is
 195    begin
 196       if Partition_Elaboration_Policy = 'S' then
 197 
 198          --  In sequential elaboration policy, the chain must be empty. This
 199          --  procedure can be called if the unit has been compiled without
 200          --  partition elaboration policy, but the partition has a sequential
 201          --  elaboration policy.
 202 
 203          pragma Assert (Chain_Access.T_ID = Null_Task);
 204          null;
 205       else
 206          Activate_Tasks (Chain_Access.T_ID);
 207          Chain_Access.T_ID := Null_Task;
 208       end if;
 209    end Activate_Restricted_Tasks;
 210 
 211    --------------------
 212    -- Activate_Tasks --
 213    --------------------
 214 
 215    procedure Activate_Tasks (Chain : Task_Id) is
 216       Self_ID : constant Task_Id := Task_Primitives.Operations.Self;
 217       C       : Task_Id;
 218       Next_C  : Task_Id;
 219       Success : Boolean;
 220 
 221    begin
 222       --  Raise the priority to prevent activated tasks from racing ahead
 223       --  before we finish activating the chain.
 224 
 225       Set_Priority (Self_ID, System.Any_Priority'Last);
 226 
 227       --  Activate all the tasks in the chain
 228 
 229       --  Creation of the thread of control was deferred until activation.
 230       --  So create it now.
 231 
 232       --  Note that since all created tasks will be blocked trying to get our
 233       --  (environment task) lock, there is no need to lock C here.
 234 
 235       C := Chain;
 236       while C /= Null_Task loop
 237          Next_C := C.Common.Activation_Link;
 238 
 239          C.Common.Activation_Link := null;
 240 
 241          Task_Primitives.Operations.Create_Task
 242            (T          => C,
 243             Wrapper    => Task_Wrapper'Address,
 244             Stack_Size => Parameters.Size_Type
 245                             (C.Common.Compiler_Data.Pri_Stack_Info.Size),
 246             Priority   => C.Common.Base_Priority,
 247             Base_CPU   => C.Common.Base_CPU,
 248             Succeeded  => Success);
 249 
 250          if Success then
 251             C.Common.State := Runnable;
 252          else
 253             raise Program_Error;
 254          end if;
 255 
 256          C := Next_C;
 257       end loop;
 258 
 259       Self_ID.Common.State := Runnable;
 260 
 261       --  Restore the original priority
 262 
 263       Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 264    end Activate_Tasks;
 265 
 266    ------------------------------------
 267    -- Complete_Restricted_Activation --
 268    ------------------------------------
 269 
 270    procedure Complete_Restricted_Activation is
 271    begin
 272       --  Nothing to be done
 273 
 274       null;
 275    end Complete_Restricted_Activation;
 276 
 277    ------------------------------
 278    -- Complete_Restricted_Task --
 279    ------------------------------
 280 
 281    procedure Complete_Restricted_Task is
 282    begin
 283       --  Mark the task as terminated. Do not suspend the task now
 284       --  because we need to allow for the task termination procedure
 285       --  to execute (if needed) in the Task_Wrapper.
 286 
 287       Task_Primitives.Operations.Self.Common.State := Terminated;
 288    end Complete_Restricted_Task;
 289 
 290    ----------------------------
 291    -- Create_Restricted_Task --
 292    ----------------------------
 293 
 294    procedure Create_Restricted_Task
 295      (Priority      : Integer;
 296       Stack_Address : System.Address;
 297       Size          : System.Parameters.Size_Type;
 298       Task_Info     : System.Task_Info.Task_Info_Type;
 299       CPU           : Integer;
 300       State         : Task_Procedure_Access;
 301       Discriminants : System.Address;
 302       Created_Task  : Task_Id)
 303    is
 304       Base_Priority : System.Any_Priority;
 305       Base_CPU      : System.Multiprocessors.CPU_Range;
 306       Success       : Boolean;
 307 
 308    begin
 309       Base_Priority :=
 310         (if Priority = Unspecified_Priority
 311          then System.Default_Priority
 312          else System.Any_Priority (Priority));
 313 
 314       --  Legal values of CPU are the special Unspecified_CPU value which is
 315       --  inserted by the compiler for tasks without CPU aspect, and those in
 316       --  the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
 317       --  the task is defined to have failed, and it becomes a completed task
 318       --  (RM D.16(14/3)).
 319 
 320       if CPU /= Unspecified_CPU
 321         and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)
 322                     or else
 323                   CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
 324       then
 325          raise Tasking_Error with "CPU not in range";
 326 
 327       --  Normal CPU affinity
 328 
 329       else
 330          --  When the application code says nothing about the task affinity
 331          --  (task without CPU aspect) then the compiler inserts the
 332          --  Unspecified_CPU value which indicates to the run-time library that
 333          --  the task will activate and execute on the same processor as its
 334          --  activating task if the activating task is assigned a processor
 335          --  (RM D.16(14/3)).
 336 
 337          Base_CPU :=
 338            (if CPU = Unspecified_CPU
 339             then Self.Common.Base_CPU
 340             else System.Multiprocessors.CPU_Range (CPU));
 341       end if;
 342 
 343       --  No need to lock Self_ID here, since only environment task is running
 344 
 345       Initialize_ATCB
 346         (State, Discriminants, Base_Priority, Base_CPU,
 347          Task_Info, Stack_Address, Size, Created_Task, Success);
 348 
 349       if not Success then
 350          raise Program_Error;
 351       end if;
 352 
 353       Created_Task.Entry_Call.Self := Created_Task;
 354    end Create_Restricted_Task;
 355 
 356    procedure Create_Restricted_Task
 357      (Priority      : Integer;
 358       Stack_Address : System.Address;
 359       Size          : System.Parameters.Size_Type;
 360       Task_Info     : System.Task_Info.Task_Info_Type;
 361       CPU           : Integer;
 362       State         : Task_Procedure_Access;
 363       Discriminants : System.Address;
 364       Elaborated    : Access_Boolean;
 365       Chain         : in out Activation_Chain;
 366       Task_Image    : String;
 367       Created_Task  : Task_Id)
 368    is
 369    begin
 370       if Partition_Elaboration_Policy = 'S' then
 371 
 372          --  A unit may have been compiled without partition elaboration
 373          --  policy, and in this case the compiler will emit calls for the
 374          --  default policy (concurrent). But if the partition policy is
 375          --  sequential, activation must be deferred.
 376 
 377          Create_Restricted_Task_Sequential
 378            (Priority, Stack_Address, Size, Task_Info, CPU, State,
 379             Discriminants, Elaborated, Task_Image, Created_Task);
 380 
 381       else
 382          Create_Restricted_Task
 383            (Priority, Stack_Address, Size, Task_Info, CPU, State,
 384             Discriminants, Created_Task);
 385 
 386          --  Append this task to the activation chain
 387 
 388          Created_Task.Common.Activation_Link := Chain.T_ID;
 389          Chain.T_ID := Created_Task;
 390       end if;
 391    end Create_Restricted_Task;
 392 
 393    ---------------------------------------
 394    -- Create_Restricted_Task_Sequential --
 395    ---------------------------------------
 396 
 397    procedure Create_Restricted_Task_Sequential
 398      (Priority      : Integer;
 399       Stack_Address : System.Address;
 400       Size          : System.Parameters.Size_Type;
 401       Task_Info     : System.Task_Info.Task_Info_Type;
 402       CPU           : Integer;
 403       State         : Task_Procedure_Access;
 404       Discriminants : System.Address;
 405       Elaborated    : Access_Boolean;
 406       Task_Image    : String;
 407       Created_Task  : Task_Id)
 408    is
 409       pragma Unreferenced (Task_Image, Elaborated);
 410 
 411    begin
 412       Create_Restricted_Task (Priority, Stack_Address, Size, Task_Info,
 413                               CPU, State, Discriminants, Created_Task);
 414 
 415       --  Append this task to the activation chain
 416 
 417       Created_Task.Common.Activation_Link := Tasks_Activation_Chain;
 418       Tasks_Activation_Chain := Created_Task;
 419    end Create_Restricted_Task_Sequential;
 420 
 421    ---------------------------
 422    -- Finalize_Global_Tasks --
 423    ---------------------------
 424 
 425    --  Dummy version since this procedure is not used in true ravenscar mode
 426 
 427    procedure Finalize_Global_Tasks is
 428    begin
 429       raise Program_Error;
 430    end Finalize_Global_Tasks;
 431 
 432    ---------------------------
 433    -- Restricted_Terminated --
 434    ---------------------------
 435 
 436    function Restricted_Terminated (T : Task_Id) return Boolean is
 437    begin
 438       return T.Common.State = Terminated;
 439    end Restricted_Terminated;
 440 
 441 begin
 442    Tasking.Initialize;
 443 end System.Tasking.Restricted.Stages;