gcc/ada/s-tarest.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-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 pragma Style_Checks (All_Checks);
  33 --  Turn off subprogram alpha order check, since we group soft link
  34 --  bodies and also separate off subprograms for restricted GNARLI.
  35
  36 --  This is a simplified version of the System.Tasking.Stages package,
  37 --  intended to be used in a restricted run time.
  38
  39 --  This package represents the high level tasking interface used by the
  40 --  compiler to expand Ada 95 tasking constructs into simpler run time calls.
  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 Ada.Exceptions;
  47
  48 with System.Task_Primitives.Operations;
  49 with System.Soft_Links.Tasking;
  50 with System.Secondary_Stack;
  51 with System.Storage_Elements;
  52
  53 with System.Soft_Links;
  54 --  Used for the non-tasking routines (*_NT) that refer to global data. They
  55 --  are needed here before the tasking run time has been elaborated. used for
  56 --  Create_TSD This package also provides initialization routines for task
  57 --  specific data. The GNARL must call these to be sure that all non-tasking
  58 --  Ada constructs will work.
  59
  60 package body System.Tasking.Restricted.Stages is
  61
  62    package STPO renames System.Task_Primitives.Operations;
  63    package SSL  renames System.Soft_Links;
  64    package SSE  renames System.Storage_Elements;
  65    package SST  renames System.Secondary_Stack;
  66
  67    use Ada.Exceptions;
  68
  69    use Parameters;
  70    use Task_Primitives.Operations;
  71    use Task_Info;
  72
  73    Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock;
  74    --  This is a global lock; it is used to execute in mutual exclusion
  75    --  from all other tasks. It is only used by Task_Lock and Task_Unlock.
  76
  77    -----------------------------------------------------------------
  78    -- Tasking versions of services needed by non-tasking programs --
  79    -----------------------------------------------------------------
  80
  81    function Get_Current_Excep return SSL.EOA;
  82    --  Task-safe version of SSL.Get_Current_Excep
  83
  84    procedure Task_Lock;
  85    --  Locks out other tasks. Preceding a section of code by Task_Lock and
  86    --  following it by Task_Unlock creates a critical region. This is used
  87    --  for ensuring that a region of non-tasking code (such as code used to
  88    --  allocate memory) is tasking safe. Note that it is valid for calls to
  89    --  Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
  90    --  only the corresponding outer level Task_Unlock will actually unlock.
  91
  92    procedure Task_Unlock;
  93    --  Releases lock previously set by call to Task_Lock. In the nested case,
  94    --  all nested locks must be released before other tasks competing for the
  95    --  tasking lock are released.
  96
  97    -----------------------
  98    -- Local Subprograms --
  99    -----------------------
 100
 101    procedure Task_Wrapper (Self_ID : Task_Id);
 102    --  This is the procedure that is called by the GNULL from the
 103    --  new context when a task is created. It waits for activation
 104    --  and then calls the task body procedure. When the task body
 105    --  procedure completes, it terminates the task.
 106
 107    procedure Terminate_Task (Self_ID : Task_Id);
 108    --  Terminate the calling task.
 109    --  This should only be called by the Task_Wrapper procedure.
 110
 111    procedure Init_RTS;
 112    --  This procedure performs the initialization of the GNARL.
 113    --  It consists of initializing the environment task, global locks, and
 114    --  installing tasking versions of certain operations used by the compiler.
 115    --  Init_RTS is called during elaboration.
 116
 117    -----------------------
 118    -- Get_Current_Excep --
 119    -----------------------
 120
 121    function Get_Current_Excep return SSL.EOA is
 122    begin
 123       return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
 124    end Get_Current_Excep;
 125
 126    ---------------
 127    -- Task_Lock --
 128    ---------------
 129
 130    procedure Task_Lock is
 131       Self_ID : constant Task_Id := STPO.Self;
 132
 133    begin
 134       Self_ID.Common.Global_Task_Lock_Nesting :=
 135         Self_ID.Common.Global_Task_Lock_Nesting + 1;
 136
 137       if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
 138          STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
 139       end if;
 140    end Task_Lock;
 141
 142    -----------------
 143    -- Task_Unlock --
 144    -----------------
 145
 146    procedure Task_Unlock is
 147       Self_ID : constant Task_Id := STPO.Self;
 148
 149    begin
 150       pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0);
 151       Self_ID.Common.Global_Task_Lock_Nesting :=
 152         Self_ID.Common.Global_Task_Lock_Nesting - 1;
 153
 154       if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
 155          STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
 156       end if;
 157    end Task_Unlock;
 158
 159    ------------------
 160    -- Task_Wrapper --
 161    ------------------
 162
 163    --  The task wrapper is a procedure that is called first for each task
 164    --  task body, and which in turn calls the compiler-generated task body
 165    --  procedure. The wrapper's main job is to do initialization for the task.
 166
 167    --  The variable ID in the task wrapper is used to implement the Self
 168    --  function on targets where there is a fast way to find the stack base
 169    --  of the current thread, since it should be at a fixed offset from the
 170    --  stack base.
 171
 172    procedure Task_Wrapper (Self_ID : Task_Id) is
 173       ID : Task_Id := Self_ID;
 174       pragma Volatile (ID);
 175       pragma Warnings (Off, ID);
 176       --  Variable used on some targets to implement a fast self. We turn off
 177       --  warnings because a stand alone volatile constant has to be imported,
 178       --  so we don't want warnings about ID not being referenced, and volatile
 179       --  having no effect.
 180       --
 181       --  DO NOT delete ID. As noted, it is needed on some targets.
 182
 183       use type SSE.Storage_Offset;
 184
 185       Secondary_Stack : aliased SSE.Storage_Array
 186         (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
 187                 SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
 188
 189       pragma Warnings (Off);
 190       Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
 191       pragma Warnings (On);
 192       --  Address of secondary stack. In the fixed secondary stack case, this
 193       --  value is not modified, causing a warning, hence the bracketing with
 194       --  Warnings (Off/On).
 195
 196       Cause : Cause_Of_Termination := Normal;
 197       --  Indicates the reason why this task terminates. Normal corresponds to
 198       --  a task terminating due to completing the last statement of its body.
 199       --  If the task terminates because of an exception raised by the
 200       --  execution of its task body, then Cause is set to Unhandled_Exception.
 201       --  Aborts are not allowed in the restricted profile to which this file
 202       --  belongs.
 203
 204       EO : Exception_Occurrence;
 205       --  If the task terminates because of an exception raised by the
 206       --  execution of its task body, then EO will contain the associated
 207       --  exception occurrence. Otherwise, it will contain Null_Occurrence.
 208
 209    begin
 210       if not Parameters.Sec_Stack_Dynamic then
 211          Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
 212            Secondary_Stack'Address;
 213          SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
 214       end if;
 215
 216       --  Initialize low-level TCB components, that
 217       --  cannot be initialized by the creator.
 218
 219       Enter_Task (Self_ID);
 220
 221       --  Call the task body procedure
 222
 223       begin
 224          --  We are separating the following portion of the code in order to
 225          --  place the exception handlers in a different block. In this way we
 226          --  do not call Set_Jmpbuf_Address (which needs Self) before we set
 227          --  Self in Enter_Task.
 228
 229          --  Note that in the case of Ravenscar HI-E where there are no
 230          --  exception handlers, the exception handler is suppressed.
 231
 232          --  Call the task body procedure
 233
 234          Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
 235
 236          --  Normal task termination
 237
 238          Cause := Normal;
 239          Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
 240
 241       exception
 242          when E : others =>
 243
 244             --  Task terminating because of an unhandled exception
 245
 246             Cause := Unhandled_Exception;
 247             Save_Occurrence (EO, E);
 248       end;
 249
 250       --  Look for a fall-back handler. It can be either in the task itself
 251       --  or in the environment task. Note that this code is always executed
 252       --  by a task whose master is the environment task. The task termination
 253       --  code for the environment task is executed by
 254       --  SSL.Task_Termination_Handler.
 255
 256       --  This package is part of the restricted run time which supports
 257       --  neither task hierarchies (No_Task_Hierarchy) nor specific task
 258       --  termination handlers (No_Specific_Termination_Handlers).
 259
 260       --  There is no need for explicit protection against race conditions
 261       --  for Self_ID.Common.Fall_Back_Handler because this procedure can
 262       --  only be executed by Self, and the Fall_Back_Handler can only be
 263       --  modified by Self.
 264
 265       if Self_ID.Common.Fall_Back_Handler /= null then
 266          Self_ID.Common.Fall_Back_Handler (Cause, Self_ID, EO);
 267       else
 268          declare
 269             TH : Termination_Handler := null;
 270
 271          begin
 272             if Single_Lock then
 273                Lock_RTS;
 274             end if;
 275
 276             Write_Lock (Self_ID.Common.Parent);
 277
 278             TH := Self_ID.Common.Parent.Common.Fall_Back_Handler;
 279
 280             Unlock (Self_ID.Common.Parent);
 281
 282             if Single_Lock then
 283                Unlock_RTS;
 284             end if;
 285
 286             --  Execute the task termination handler if we found it
 287
 288             if TH /= null then
 289                TH.all (Cause, Self_ID, EO);
 290             end if;
 291          end;
 292       end if;
 293
 294       Terminate_Task (Self_ID);
 295    end Task_Wrapper;
 296
 297    -----------------------
 298    -- Restricted GNARLI --
 299    -----------------------
 300
 301    -------------------------------
 302    -- Activate_Restricted_Tasks --
 303    -------------------------------
 304
 305    --  Note that locks of activator and activated task are both locked here.
 306    --  This is necessary because C.State and Self.Wait_Count have to be
 307    --  synchronized. This is safe from deadlock because the activator is always
 308    --  created before the activated task. That satisfies our
 309    --  in-order-of-creation ATCB locking policy.
 310
 311    procedure Activate_Restricted_Tasks
 312      (Chain_Access : Activation_Chain_Access)
 313    is
 314       Self_ID       : constant Task_Id := STPO.Self;
 315       C             : Task_Id;
 316       Activate_Prio : System.Any_Priority;
 317       Success       : Boolean;
 318
 319    begin
 320       pragma Assert (Self_ID = Environment_Task);
 321       pragma Assert (Self_ID.Common.Wait_Count = 0);
 322
 323       if Single_Lock then
 324          Lock_RTS;
 325       end if;
 326
 327       --  Lock self, to prevent activated tasks from racing ahead before we
 328       --  finish activating the chain.
 329
 330       Write_Lock (Self_ID);
 331
 332       --  Activate all the tasks in the chain. Creation of the thread of
 333       --  control was deferred until activation. So create it now.
 334
 335       C := Chain_Access.T_ID;
 336
 337       while C /= null loop
 338          if C.Common.State /= Terminated then
 339             pragma Assert (C.Common.State = Unactivated);
 340
 341             Write_Lock (C);
 342
 343             Activate_Prio :=
 344               (if C.Common.Base_Priority < Get_Priority (Self_ID)
 345                then Get_Priority (Self_ID)
 346                else C.Common.Base_Priority);
 347
 348             STPO.Create_Task
 349               (C, Task_Wrapper'Address,
 350                Parameters.Size_Type
 351                  (C.Common.Compiler_Data.Pri_Stack_Info.Size),
 352                Activate_Prio, Success);
 353
 354             Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
 355
 356             if Success then
 357                C.Common.State := Runnable;
 358             else
 359                raise Program_Error;
 360             end if;
 361
 362             Unlock (C);
 363          end if;
 364
 365          C := C.Common.Activation_Link;
 366       end loop;
 367
 368       Self_ID.Common.State := Activator_Sleep;
 369
 370       --  Wait for the activated tasks to complete activation. It is unsafe to
 371       --  abort any of these tasks until the count goes to zero.
 372
 373       loop
 374          exit when Self_ID.Common.Wait_Count = 0;
 375          Sleep (Self_ID, Activator_Sleep);
 376       end loop;
 377
 378       Self_ID.Common.State := Runnable;
 379       Unlock (Self_ID);
 380
 381       if Single_Lock then
 382          Unlock_RTS;
 383       end if;
 384
 385       --  Remove the tasks from the chain
 386
 387       Chain_Access.T_ID := null;
 388    end Activate_Restricted_Tasks;
 389
 390    ------------------------------------
 391    -- Complete_Restricted_Activation --
 392    ------------------------------------
 393
 394    --  As in several other places, the locks of the activator and activated
 395    --  task are both locked here. This follows our deadlock prevention lock
 396    --  ordering policy, since the activated task must be created after the
 397    --  activator.
 398
 399    procedure Complete_Restricted_Activation is
 400       Self_ID   : constant Task_Id := STPO.Self;
 401       Activator : constant Task_Id := Self_ID.Common.Activator;
 402
 403    begin
 404       if Single_Lock then
 405          Lock_RTS;
 406       end if;
 407
 408       Write_Lock (Activator);
 409       Write_Lock (Self_ID);
 410
 411       --  Remove dangling reference to Activator, since a task may outlive its
 412       --  activator.
 413
 414       Self_ID.Common.Activator := null;
 415
 416       --  Wake up the activator, if it is waiting for a chain of tasks to
 417       --  activate, and we are the last in the chain to complete activation
 418
 419       if Activator.Common.State = Activator_Sleep then
 420          Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
 421
 422          if Activator.Common.Wait_Count = 0 then
 423             Wakeup (Activator, Activator_Sleep);
 424          end if;
 425       end if;
 426
 427       Unlock (Self_ID);
 428       Unlock (Activator);
 429
 430       if Single_Lock then
 431          Unlock_RTS;
 432       end if;
 433
 434       --  After the activation, active priority should be the same as base
 435       --  priority. We must unlock the Activator first, though, since it should
 436       --  not wait if we have lower priority.
 437
 438       if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
 439          Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 440       end if;
 441    end Complete_Restricted_Activation;
 442
 443    ------------------------------
 444    -- Complete_Restricted_Task --
 445    ------------------------------
 446
 447    procedure Complete_Restricted_Task is
 448    begin
 449       STPO.Self.Common.State := Terminated;
 450    end Complete_Restricted_Task;
 451
 452    ----------------------------
 453    -- Create_Restricted_Task --
 454    ----------------------------
 455
 456    procedure Create_Restricted_Task
 457      (Priority      : Integer;
 458       Stack_Address : System.Address;
 459       Size          : System.Parameters.Size_Type;
 460       Task_Info     : System.Task_Info.Task_Info_Type;
 461       State         : Task_Procedure_Access;
 462       Discriminants : System.Address;
 463       Elaborated    : Access_Boolean;
 464       Chain         : in out Activation_Chain;
 465       Task_Image    : String;
 466       Created_Task  : Task_Id)
 467    is
 468       Self_ID       : constant Task_Id := STPO.Self;
 469       Base_Priority : System.Any_Priority;
 470       Success       : Boolean;
 471       Len           : Integer;
 472
 473    begin
 474       --  Stack is not preallocated on this target, so that Stack_Address must
 475       --  be null.
 476
 477       pragma Assert (Stack_Address = Null_Address);
 478
 479       Base_Priority :=
 480         (if Priority = Unspecified_Priority
 481          then Self_ID.Common.Base_Priority
 482          else System.Any_Priority (Priority));
 483
 484       if Single_Lock then
 485          Lock_RTS;
 486       end if;
 487
 488       Write_Lock (Self_ID);
 489
 490       --  With no task hierarchy, the parent of all non-Environment tasks that
 491       --  are created must be the Environment task
 492
 493       Initialize_ATCB
 494         (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
 495          Task_Info, Size, Created_Task, Success);
 496
 497       --  If we do our job right then there should never be any failures, which
 498       --  was probably said about the Titanic; so just to be safe, let's retain
 499       --  this code for now
 500
 501       if not Success then
 502          Unlock (Self_ID);
 503
 504          if Single_Lock then
 505             Unlock_RTS;
 506          end if;
 507
 508          raise Program_Error;
 509       end if;
 510
 511       Created_Task.Entry_Calls (1).Self := Created_Task;
 512
 513       Len :=
 514         Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length);
 515       Created_Task.Common.Task_Image_Len := Len;
 516       Created_Task.Common.Task_Image (1 .. Len) :=
 517         Task_Image (Task_Image'First .. Task_Image'First + Len - 1);
 518
 519       Unlock (Self_ID);
 520
 521       if Single_Lock then
 522          Unlock_RTS;
 523       end if;
 524
 525       --  Create TSD as early as possible in the creation of a task, since it
 526       --  may be used by the operation of Ada code within the task.
 527
 528       SSL.Create_TSD (Created_Task.Common.Compiler_Data);
 529       Created_Task.Common.Activation_Link := Chain.T_ID;
 530       Chain.T_ID := Created_Task;
 531    end Create_Restricted_Task;
 532
 533    ---------------------------
 534    -- Finalize_Global_Tasks --
 535    ---------------------------
 536
 537    --  This is needed to support the compiler interface; it will only be called
 538    --  by the Environment task. Instead, it will cause the Environment to block
 539    --  forever, since none of the dependent tasks are expected to terminate
 540
 541    procedure Finalize_Global_Tasks is
 542       Self_ID : constant Task_Id := STPO.Self;
 543
 544    begin
 545       pragma Assert (Self_ID = STPO.Environment_Task);
 546
 547       if Single_Lock then
 548          Lock_RTS;
 549       end if;
 550
 551       --  Handle normal task termination by the environment task, but only for
 552       --  the normal task termination. In the case of Abnormal and
 553       --  Unhandled_Exception they must have been handled before, and the task
 554       --  termination soft link must have been changed so the task termination
 555       --  routine is not executed twice.
 556
 557       --  Note that in the "normal" implementation in s-tassta.adb the task
 558       --  termination procedure for the environment task should be executed
 559       --  after termination of library-level tasks. However, this
 560       --  implementation is to be used when the Ravenscar restrictions are in
 561       --  effect, and AI-394 says that if there is a fall-back handler set for
 562       --  the partition it should be called when the first task (including the
 563       --  environment task) attempts to terminate.
 564
 565       SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
 566
 567       Write_Lock (Self_ID);
 568       Sleep (Self_ID, Master_Completion_Sleep);
 569       Unlock (Self_ID);
 570
 571       if Single_Lock then
 572          Unlock_RTS;
 573       end if;
 574
 575       --  Should never return from Master Completion Sleep
 576
 577       raise Program_Error;
 578    end Finalize_Global_Tasks;
 579
 580    ---------------------------
 581    -- Restricted_Terminated --
 582    ---------------------------
 583
 584    function Restricted_Terminated (T : Task_Id) return Boolean is
 585    begin
 586       return T.Common.State = Terminated;
 587    end Restricted_Terminated;
 588
 589    --------------------
 590    -- Terminate_Task --
 591    --------------------
 592
 593    procedure Terminate_Task (Self_ID : Task_Id) is
 594    begin
 595       Self_ID.Common.State := Terminated;
 596    end Terminate_Task;
 597
 598    --------------
 599    -- Init_RTS --
 600    --------------
 601
 602    procedure Init_RTS is
 603    begin
 604       Tasking.Initialize;
 605
 606       --  Initialize lock used to implement mutual exclusion between all tasks
 607
 608       STPO.Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level);
 609
 610       --  Notify that the tasking run time has been elaborated so that
 611       --  the tasking version of the soft links can be used.
 612
 613       SSL.Lock_Task         := Task_Lock'Access;
 614       SSL.Unlock_Task       := Task_Unlock'Access;
 615       SSL.Adafinal          := Finalize_Global_Tasks'Access;
 616       SSL.Get_Current_Excep := Get_Current_Excep'Access;
 617
 618       --  Initialize the tasking soft links (if not done yet) that are common
 619       --  to the full and the restricted run times.
 620
 621       SSL.Tasking.Init_Tasking_Soft_Links;
 622    end Init_RTS;
 623
 624 begin
 625    Init_RTS;
 626 end System.Tasking.Restricted.Stages;