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