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-2016, 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.Storage_Elements;
  51
  52 with System.Secondary_Stack;
  53 pragma Elaborate_All (System.Secondary_Stack);
  54 --  Make sure the body of Secondary_Stack is elaborated before calling
  55 --  Init_Tasking_Soft_Links. See comments for this routine for explanation.
  56
  57 with System.Soft_Links;
  58 --  Used for the non-tasking routines (*_NT) that refer to global data. They
  59 --  are needed here before the tasking run time has been elaborated. used for
  60 --  Create_TSD This package also provides initialization routines for task
  61 --  specific data. The GNARL must call these to be sure that all non-tasking
  62 --  Ada constructs will work.
  63
  64 package body System.Tasking.Restricted.Stages is
  65
  66    package STPO renames System.Task_Primitives.Operations;
  67    package SSL  renames System.Soft_Links;
  68    package SSE  renames System.Storage_Elements;
  69    package SST  renames System.Secondary_Stack;
  70
  71    use Ada.Exceptions;
  72
  73    use Parameters;
  74    use Task_Primitives.Operations;
  75    use Task_Info;
  76
  77    Tasks_Activation_Chain : Task_Id;
  78    --  Chain of all the tasks to activate
  79
  80    Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock;
  81    --  This is a global lock; it is used to execute in mutual exclusion
  82    --  from all other tasks. It is only used by Task_Lock and Task_Unlock.
  83
  84    -----------------------------------------------------------------
  85    -- Tasking versions of services needed by non-tasking programs --
  86    -----------------------------------------------------------------
  87
  88    function Get_Current_Excep return SSL.EOA;
  89    --  Task-safe version of SSL.Get_Current_Excep
  90
  91    procedure Task_Lock;
  92    --  Locks out other tasks. Preceding a section of code by Task_Lock and
  93    --  following it by Task_Unlock creates a critical region. This is used
  94    --  for ensuring that a region of non-tasking code (such as code used to
  95    --  allocate memory) is tasking safe. Note that it is valid for calls to
  96    --  Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
  97    --  only the corresponding outer level Task_Unlock will actually unlock.
  98
  99    procedure Task_Unlock;
 100    --  Releases lock previously set by call to Task_Lock. In the nested case,
 101    --  all nested locks must be released before other tasks competing for the
 102    --  tasking lock are released.
 103
 104    -----------------------
 105    -- Local Subprograms --
 106    -----------------------
 107
 108    procedure Task_Wrapper (Self_ID : Task_Id);
 109    --  This is the procedure that is called by the GNULL from the
 110    --  new context when a task is created. It waits for activation
 111    --  and then calls the task body procedure. When the task body
 112    --  procedure completes, it terminates the task.
 113
 114    procedure Terminate_Task (Self_ID : Task_Id);
 115    --  Terminate the calling task.
 116    --  This should only be called by the Task_Wrapper procedure.
 117
 118    procedure Create_Restricted_Task
 119      (Priority             : Integer;
 120       Stack_Address        : System.Address;
 121       Size                 : System.Parameters.Size_Type;
 122       Secondary_Stack_Size : System.Parameters.Size_Type;
 123       Task_Info            : System.Task_Info.Task_Info_Type;
 124       CPU                  : Integer;
 125       State                : Task_Procedure_Access;
 126       Discriminants        : System.Address;
 127       Elaborated           : Access_Boolean;
 128       Task_Image           : String;
 129       Created_Task         : Task_Id);
 130    --  Code shared between Create_Restricted_Task (the concurrent version) and
 131    --  Create_Restricted_Task_Sequential. See comment of the former in the
 132    --  specification of this package.
 133
 134    procedure Activate_Tasks (Chain : Task_Id);
 135    --  Activate the list of tasks started by Chain
 136
 137    procedure Init_RTS;
 138    --  This procedure performs the initialization of the GNARL.
 139    --  It consists of initializing the environment task, global locks, and
 140    --  installing tasking versions of certain operations used by the compiler.
 141    --  Init_RTS is called during elaboration.
 142
 143    -----------------------
 144    -- Get_Current_Excep --
 145    -----------------------
 146
 147    function Get_Current_Excep return SSL.EOA is
 148    begin
 149       return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
 150    end Get_Current_Excep;
 151
 152    ---------------
 153    -- Task_Lock --
 154    ---------------
 155
 156    procedure Task_Lock is
 157       Self_ID : constant Task_Id := STPO.Self;
 158
 159    begin
 160       Self_ID.Common.Global_Task_Lock_Nesting :=
 161         Self_ID.Common.Global_Task_Lock_Nesting + 1;
 162
 163       if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
 164          STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
 165       end if;
 166    end Task_Lock;
 167
 168    -----------------
 169    -- Task_Unlock --
 170    -----------------
 171
 172    procedure Task_Unlock is
 173       Self_ID : constant Task_Id := STPO.Self;
 174
 175    begin
 176       pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0);
 177       Self_ID.Common.Global_Task_Lock_Nesting :=
 178         Self_ID.Common.Global_Task_Lock_Nesting - 1;
 179
 180       if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
 181          STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
 182       end if;
 183    end Task_Unlock;
 184
 185    ------------------
 186    -- Task_Wrapper --
 187    ------------------
 188
 189    --  The task wrapper is a procedure that is called first for each task
 190    --  task body, and which in turn calls the compiler-generated task body
 191    --  procedure. The wrapper's main job is to do initialization for the task.
 192
 193    --  The variable ID in the task wrapper is used to implement the Self
 194    --  function on targets where there is a fast way to find the stack base
 195    --  of the current thread, since it should be at a fixed offset from the
 196    --  stack base.
 197
 198    procedure Task_Wrapper (Self_ID : Task_Id) is
 199       ID : Task_Id := Self_ID;
 200       pragma Volatile (ID);
 201       pragma Warnings (Off, ID);
 202       --  Variable used on some targets to implement a fast self. We turn off
 203       --  warnings because a stand alone volatile constant has to be imported,
 204       --  so we don't want warnings about ID not being referenced, and volatile
 205       --  having no effect.
 206       --
 207       --  DO NOT delete ID. As noted, it is needed on some targets.
 208
 209       function Secondary_Stack_Size return Storage_Elements.Storage_Offset;
 210       --  Returns the size of the secondary stack for the task. For fixed
 211       --  secondary stacks, the function will return the ATCB field
 212       --  Secondary_Stack_Size if it is not set to Unspecified_Size,
 213       --  otherwise a percentage of the stack is reserved using the
 214       --  System.Parameters.Sec_Stack_Percentage property.
 215
 216       --  Dynamic secondary stacks are allocated in System.Soft_Links.
 217       --  Create_TSD and thus the function returns 0 to suppress the
 218       --  creation of the fixed secondary stack in the primary stack.
 219
 220       --------------------------
 221       -- Secondary_Stack_Size --
 222       --------------------------
 223
 224       function Secondary_Stack_Size return Storage_Elements.Storage_Offset is
 225          use System.Storage_Elements;
 226          use System.Secondary_Stack;
 227
 228       begin
 229          if Parameters.Sec_Stack_Dynamic then
 230             return 0;
 231
 232          elsif Self_ID.Common.Secondary_Stack_Size = Unspecified_Size then
 233             return (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size
 234                        * SSE.Storage_Offset (Sec_Stack_Percentage) / 100);
 235          else
 236             --  Use the size specified by aspect Secondary_Stack_Size padded
 237             --  by the amount of space used by the stack data structure.
 238
 239             return Storage_Offset (Self_ID.Common.Secondary_Stack_Size) +
 240                      Storage_Offset (Minimum_Secondary_Stack_Size);
 241          end if;
 242       end Secondary_Stack_Size;
 243
 244       Secondary_Stack : aliased Storage_Elements.Storage_Array
 245                           (1 .. Secondary_Stack_Size);
 246       for Secondary_Stack'Alignment use Standard'Maximum_Alignment;
 247       --  This is the secondary stack data. Note that it is critical that this
 248       --  have maximum alignment, since any kind of data can be allocated here.
 249
 250       pragma Warnings (Off);
 251       Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
 252       pragma Warnings (On);
 253       --  Address of secondary stack. In the fixed secondary stack case, this
 254       --  value is not modified, causing a warning, hence the bracketing with
 255       --  Warnings (Off/On).
 256
 257       Cause : Cause_Of_Termination := Normal;
 258       --  Indicates the reason why this task terminates. Normal corresponds to
 259       --  a task terminating due to completing the last statement of its body.
 260       --  If the task terminates because of an exception raised by the
 261       --  execution of its task body, then Cause is set to Unhandled_Exception.
 262       --  Aborts are not allowed in the restricted profile to which this file
 263       --  belongs.
 264
 265       EO : Exception_Occurrence;
 266       --  If the task terminates because of an exception raised by the
 267       --  execution of its task body, then EO will contain the associated
 268       --  exception occurrence. Otherwise, it will contain Null_Occurrence.
 269
 270    --  Start of processing for Task_Wrapper
 271
 272    begin
 273       if not Parameters.Sec_Stack_Dynamic then
 274          Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
 275            Secondary_Stack'Address;
 276          SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
 277       end if;
 278
 279       --  Initialize low-level TCB components, that cannot be initialized by
 280       --  the creator.
 281
 282       Enter_Task (Self_ID);
 283
 284       --  Call the task body procedure
 285
 286       begin
 287          --  We are separating the following portion of the code in order to
 288          --  place the exception handlers in a different block. In this way we
 289          --  do not call Set_Jmpbuf_Address (which needs Self) before we set
 290          --  Self in Enter_Task.
 291
 292          --  Note that in the case of Ravenscar HI-E where there are no
 293          --  exception handlers, the exception handler is suppressed.
 294
 295          --  Call the task body procedure
 296
 297          Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
 298
 299          --  Normal task termination
 300
 301          Cause := Normal;
 302          Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
 303
 304       exception
 305          when E : others =>
 306
 307             --  Task terminating because of an unhandled exception
 308
 309             Cause := Unhandled_Exception;
 310             Save_Occurrence (EO, E);
 311       end;
 312
 313       --  Look for a fall-back handler
 314
 315       --  This package is part of the restricted run time which supports
 316       --  neither task hierarchies (No_Task_Hierarchy) nor specific task
 317       --  termination handlers (No_Specific_Termination_Handlers).
 318
 319       --  As specified in ARM C.7.3 par. 9/2, "the fall-back handler applies
 320       --  only to the dependent tasks of the task". Hence, if the terminating
 321       --  tasks (Self_ID) had a fall-back handler, it would not apply to
 322       --  itself. This code is always executed by a task whose master is the
 323       --  environment task (the task termination code for the environment task
 324       --  is executed by SSL.Task_Termination_Handler), so the fall-back
 325       --  handler to execute for this task can only be defined by its parent
 326       --  (there is no grandparent).
 327
 328       declare
 329          TH : Termination_Handler := null;
 330
 331       begin
 332          if Single_Lock then
 333             Lock_RTS;
 334          end if;
 335
 336          Write_Lock (Self_ID.Common.Parent);
 337
 338          TH := Self_ID.Common.Parent.Common.Fall_Back_Handler;
 339
 340          Unlock (Self_ID.Common.Parent);
 341
 342          if Single_Lock then
 343             Unlock_RTS;
 344          end if;
 345
 346          --  Execute the task termination handler if we found it
 347
 348          if TH /= null then
 349             TH.all (Cause, Self_ID, EO);
 350          end if;
 351       end;
 352
 353       Terminate_Task (Self_ID);
 354    end Task_Wrapper;
 355
 356    -----------------------
 357    -- Restricted GNARLI --
 358    -----------------------
 359
 360    -----------------------------------
 361    -- Activate_All_Tasks_Sequential --
 362    -----------------------------------
 363
 364    procedure Activate_All_Tasks_Sequential is
 365    begin
 366       pragma Assert (Partition_Elaboration_Policy = 'S');
 367
 368       Activate_Tasks (Tasks_Activation_Chain);
 369       Tasks_Activation_Chain := Null_Task;
 370    end Activate_All_Tasks_Sequential;
 371
 372    -------------------------------
 373    -- Activate_Restricted_Tasks --
 374    -------------------------------
 375
 376    procedure Activate_Restricted_Tasks
 377      (Chain_Access : Activation_Chain_Access) is
 378    begin
 379       if Partition_Elaboration_Policy = 'S' then
 380
 381          --  In sequential elaboration policy, the chain must be empty. This
 382          --  procedure can be called if the unit has been compiled without
 383          --  partition elaboration policy, but the partition has a sequential
 384          --  elaboration policy.
 385
 386          pragma Assert (Chain_Access.T_ID = Null_Task);
 387          null;
 388       else
 389          Activate_Tasks (Chain_Access.T_ID);
 390          Chain_Access.T_ID := Null_Task;
 391       end if;
 392    end Activate_Restricted_Tasks;
 393
 394    --------------------
 395    -- Activate_Tasks --
 396    --------------------
 397
 398    --  Note that locks of activator and activated task are both locked here.
 399    --  This is necessary because C.State and Self.Wait_Count have to be
 400    --  synchronized. This is safe from deadlock because the activator is always
 401    --  created before the activated task. That satisfies our
 402    --  in-order-of-creation ATCB locking policy.
 403
 404    procedure Activate_Tasks (Chain : Task_Id) is
 405       Self_ID       : constant Task_Id := STPO.Self;
 406       C             : Task_Id;
 407       Activate_Prio : System.Any_Priority;
 408       Success       : Boolean;
 409
 410    begin
 411       pragma Assert (Self_ID = Environment_Task);
 412       pragma Assert (Self_ID.Common.Wait_Count = 0);
 413
 414       if Single_Lock then
 415          Lock_RTS;
 416       end if;
 417
 418       --  Lock self, to prevent activated tasks from racing ahead before we
 419       --  finish activating the chain.
 420
 421       Write_Lock (Self_ID);
 422
 423       --  Activate all the tasks in the chain. Creation of the thread of
 424       --  control was deferred until activation. So create it now.
 425
 426       C := Chain;
 427       while C /= null loop
 428          if C.Common.State /= Terminated then
 429             pragma Assert (C.Common.State = Unactivated);
 430
 431             Write_Lock (C);
 432
 433             Activate_Prio :=
 434               (if C.Common.Base_Priority < Get_Priority (Self_ID)
 435                then Get_Priority (Self_ID)
 436                else C.Common.Base_Priority);
 437
 438             STPO.Create_Task
 439               (C, Task_Wrapper'Address,
 440                Parameters.Size_Type
 441                  (C.Common.Compiler_Data.Pri_Stack_Info.Size),
 442                Activate_Prio, Success);
 443
 444             Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
 445
 446             if Success then
 447                C.Common.State := Runnable;
 448             else
 449                raise Program_Error;
 450             end if;
 451
 452             Unlock (C);
 453          end if;
 454
 455          C := C.Common.Activation_Link;
 456       end loop;
 457
 458       Self_ID.Common.State := Activator_Sleep;
 459
 460       --  Wait for the activated tasks to complete activation. It is unsafe to
 461       --  abort any of these tasks until the count goes to zero.
 462
 463       loop
 464          exit when Self_ID.Common.Wait_Count = 0;
 465          Sleep (Self_ID, Activator_Sleep);
 466       end loop;
 467
 468       Self_ID.Common.State := Runnable;
 469       Unlock (Self_ID);
 470
 471       if Single_Lock then
 472          Unlock_RTS;
 473       end if;
 474    end Activate_Tasks;
 475
 476    ------------------------------------
 477    -- Complete_Restricted_Activation --
 478    ------------------------------------
 479
 480    --  As in several other places, the locks of the activator and activated
 481    --  task are both locked here. This follows our deadlock prevention lock
 482    --  ordering policy, since the activated task must be created after the
 483    --  activator.
 484
 485    procedure Complete_Restricted_Activation is
 486       Self_ID   : constant Task_Id := STPO.Self;
 487       Activator : constant Task_Id := Self_ID.Common.Activator;
 488
 489    begin
 490       if Single_Lock then
 491          Lock_RTS;
 492       end if;
 493
 494       Write_Lock (Activator);
 495       Write_Lock (Self_ID);
 496
 497       --  Remove dangling reference to Activator, since a task may outlive its
 498       --  activator.
 499
 500       Self_ID.Common.Activator := null;
 501
 502       --  Wake up the activator, if it is waiting for a chain of tasks to
 503       --  activate, and we are the last in the chain to complete activation
 504
 505       if Activator.Common.State = Activator_Sleep then
 506          Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
 507
 508          if Activator.Common.Wait_Count = 0 then
 509             Wakeup (Activator, Activator_Sleep);
 510          end if;
 511       end if;
 512
 513       Unlock (Self_ID);
 514       Unlock (Activator);
 515
 516       if Single_Lock then
 517          Unlock_RTS;
 518       end if;
 519
 520       --  After the activation, active priority should be the same as base
 521       --  priority. We must unlock the Activator first, though, since it should
 522       --  not wait if we have lower priority.
 523
 524       if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
 525          Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 526       end if;
 527    end Complete_Restricted_Activation;
 528
 529    ------------------------------
 530    -- Complete_Restricted_Task --
 531    ------------------------------
 532
 533    procedure Complete_Restricted_Task is
 534    begin
 535       STPO.Self.Common.State := Terminated;
 536    end Complete_Restricted_Task;
 537
 538    ----------------------------
 539    -- Create_Restricted_Task --
 540    ----------------------------
 541
 542    procedure Create_Restricted_Task
 543      (Priority             : Integer;
 544       Stack_Address        : System.Address;
 545       Size                 : System.Parameters.Size_Type;
 546       Secondary_Stack_Size : System.Parameters.Size_Type;
 547       Task_Info            : System.Task_Info.Task_Info_Type;
 548       CPU                  : Integer;
 549       State                : Task_Procedure_Access;
 550       Discriminants        : System.Address;
 551       Elaborated           : Access_Boolean;
 552       Task_Image           : String;
 553       Created_Task         : Task_Id)
 554    is
 555       Self_ID       : constant Task_Id := STPO.Self;
 556       Base_Priority : System.Any_Priority;
 557       Base_CPU      : System.Multiprocessors.CPU_Range;
 558       Success       : Boolean;
 559       Len           : Integer;
 560
 561    begin
 562       --  Stack is not preallocated on this target, so that Stack_Address must
 563       --  be null.
 564
 565       pragma Assert (Stack_Address = Null_Address);
 566
 567       Base_Priority :=
 568         (if Priority = Unspecified_Priority
 569          then Self_ID.Common.Base_Priority
 570          else System.Any_Priority (Priority));
 571
 572       --  Legal values of CPU are the special Unspecified_CPU value which is
 573       --  inserted by the compiler for tasks without CPU aspect, and those in
 574       --  the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
 575       --  the task is defined to have failed, and it becomes a completed task
 576       --  (RM D.16(14/3)).
 577
 578       if CPU /= Unspecified_CPU
 579         and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)
 580           or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
 581       then
 582          raise Tasking_Error with "CPU not in range";
 583
 584       --  Normal CPU affinity
 585       else
 586          --  When the application code says nothing about the task affinity
 587          --  (task without CPU aspect) then the compiler inserts the
 588          --  Unspecified_CPU value which indicates to the run-time library that
 589          --  the task will activate and execute on the same processor as its
 590          --  activating task if the activating task is assigned a processor
 591          --  (RM D.16(14/3)).
 592
 593          Base_CPU :=
 594            (if CPU = Unspecified_CPU
 595             then Self_ID.Common.Base_CPU
 596             else System.Multiprocessors.CPU_Range (CPU));
 597       end if;
 598
 599       if Single_Lock then
 600          Lock_RTS;
 601       end if;
 602
 603       Write_Lock (Self_ID);
 604
 605       --  With no task hierarchy, the parent of all non-Environment tasks that
 606       --  are created must be the Environment task. Dispatching domains are
 607       --  not allowed in Ravenscar, so the dispatching domain parameter will
 608       --  always be null.
 609
 610       Initialize_ATCB
 611         (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
 612          Base_CPU, null, Task_Info, Size, Secondary_Stack_Size,
 613          Created_Task, Success);
 614
 615       --  If we do our job right then there should never be any failures, which
 616       --  was probably said about the Titanic; so just to be safe, let's retain
 617       --  this code for now
 618
 619       if not Success then
 620          Unlock (Self_ID);
 621
 622          if Single_Lock then
 623             Unlock_RTS;
 624          end if;
 625
 626          raise Program_Error;
 627       end if;
 628
 629       Created_Task.Entry_Calls (1).Self := Created_Task;
 630
 631       Len :=
 632         Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length);
 633       Created_Task.Common.Task_Image_Len := Len;
 634       Created_Task.Common.Task_Image (1 .. Len) :=
 635         Task_Image (Task_Image'First .. Task_Image'First + Len - 1);
 636
 637       Unlock (Self_ID);
 638
 639       if Single_Lock then
 640          Unlock_RTS;
 641       end if;
 642
 643       --  Create TSD as early as possible in the creation of a task, since it
 644       --  may be used by the operation of Ada code within the task.
 645
 646       SSL.Create_TSD (Created_Task.Common.Compiler_Data);
 647    end Create_Restricted_Task;
 648
 649    procedure Create_Restricted_Task
 650      (Priority             : Integer;
 651       Stack_Address        : System.Address;
 652       Size                 : System.Parameters.Size_Type;
 653       Secondary_Stack_Size : System.Parameters.Size_Type;
 654       Task_Info            : System.Task_Info.Task_Info_Type;
 655       CPU                  : Integer;
 656       State                : Task_Procedure_Access;
 657       Discriminants        : System.Address;
 658       Elaborated           : Access_Boolean;
 659       Chain                : in out Activation_Chain;
 660       Task_Image           : String;
 661       Created_Task         : Task_Id)
 662    is
 663    begin
 664       if Partition_Elaboration_Policy = 'S' then
 665
 666          --  A unit may have been compiled without partition elaboration
 667          --  policy, and in this case the compiler will emit calls for the
 668          --  default policy (concurrent). But if the partition policy is
 669          --  sequential, activation must be deferred.
 670
 671          Create_Restricted_Task_Sequential
 672            (Priority, Stack_Address, Size, Secondary_Stack_Size,
 673             Task_Info, CPU, State, Discriminants, Elaborated,
 674             Task_Image, Created_Task);
 675
 676       else
 677          Create_Restricted_Task
 678            (Priority, Stack_Address, Size, Secondary_Stack_Size,
 679             Task_Info, CPU, State, Discriminants, Elaborated,
 680             Task_Image, Created_Task);
 681
 682          --  Append this task to the activation chain
 683
 684          Created_Task.Common.Activation_Link := Chain.T_ID;
 685          Chain.T_ID := Created_Task;
 686       end if;
 687    end Create_Restricted_Task;
 688
 689    ---------------------------------------
 690    -- Create_Restricted_Task_Sequential --
 691    ---------------------------------------
 692
 693    procedure Create_Restricted_Task_Sequential
 694      (Priority             : Integer;
 695       Stack_Address        : System.Address;
 696       Size                 : System.Parameters.Size_Type;
 697       Secondary_Stack_Size : System.Parameters.Size_Type;
 698       Task_Info            : System.Task_Info.Task_Info_Type;
 699       CPU                  : Integer;
 700       State                : Task_Procedure_Access;
 701       Discriminants        : System.Address;
 702       Elaborated           : Access_Boolean;
 703       Task_Image           : String;
 704       Created_Task         : Task_Id) is
 705    begin
 706       Create_Restricted_Task (Priority, Stack_Address, Size,
 707                               Secondary_Stack_Size, Task_Info,
 708                               CPU, State, Discriminants, Elaborated,
 709                               Task_Image, Created_Task);
 710
 711       --  Append this task to the activation chain
 712
 713       Created_Task.Common.Activation_Link := Tasks_Activation_Chain;
 714       Tasks_Activation_Chain := Created_Task;
 715    end Create_Restricted_Task_Sequential;
 716
 717    ---------------------------
 718    -- Finalize_Global_Tasks --
 719    ---------------------------
 720
 721    --  This is needed to support the compiler interface; it will only be called
 722    --  by the Environment task. Instead, it will cause the Environment to block
 723    --  forever, since none of the dependent tasks are expected to terminate
 724
 725    procedure Finalize_Global_Tasks is
 726       Self_ID : constant Task_Id := STPO.Self;
 727
 728    begin
 729       pragma Assert (Self_ID = STPO.Environment_Task);
 730
 731       if Single_Lock then
 732          Lock_RTS;
 733       end if;
 734
 735       --  Handle normal task termination by the environment task, but only for
 736       --  the normal task termination. In the case of Abnormal and
 737       --  Unhandled_Exception they must have been handled before, and the task
 738       --  termination soft link must have been changed so the task termination
 739       --  routine is not executed twice.
 740
 741       --  Note that in the "normal" implementation in s-tassta.adb the task
 742       --  termination procedure for the environment task should be executed
 743       --  after termination of library-level tasks. However, this
 744       --  implementation is to be used when the Ravenscar restrictions are in
 745       --  effect, and AI-394 says that if there is a fall-back handler set for
 746       --  the partition it should be called when the first task (including the
 747       --  environment task) attempts to terminate.
 748
 749       SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
 750
 751       Write_Lock (Self_ID);
 752       Sleep (Self_ID, Master_Completion_Sleep);
 753       Unlock (Self_ID);
 754
 755       if Single_Lock then
 756          Unlock_RTS;
 757       end if;
 758
 759       --  Should never return from Master Completion Sleep
 760
 761       raise Program_Error;
 762    end Finalize_Global_Tasks;
 763
 764    ---------------------------
 765    -- Restricted_Terminated --
 766    ---------------------------
 767
 768    function Restricted_Terminated (T : Task_Id) return Boolean is
 769    begin
 770       return T.Common.State = Terminated;
 771    end Restricted_Terminated;
 772
 773    --------------------
 774    -- Terminate_Task --
 775    --------------------
 776
 777    procedure Terminate_Task (Self_ID : Task_Id) is
 778    begin
 779       Self_ID.Common.State := Terminated;
 780    end Terminate_Task;
 781
 782    --------------
 783    -- Init_RTS --
 784    --------------
 785
 786    procedure Init_RTS is
 787    begin
 788       Tasking.Initialize;
 789
 790       --  Initialize lock used to implement mutual exclusion between all tasks
 791
 792       STPO.Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level);
 793
 794       --  Notify that the tasking run time has been elaborated so that
 795       --  the tasking version of the soft links can be used.
 796
 797       SSL.Lock_Task         := Task_Lock'Access;
 798       SSL.Unlock_Task       := Task_Unlock'Access;
 799       SSL.Adafinal          := Finalize_Global_Tasks'Access;
 800       SSL.Get_Current_Excep := Get_Current_Excep'Access;
 801
 802       --  Initialize the tasking soft links (if not done yet) that are common
 803       --  to the full and the restricted run times.
 804
 805       SSL.Tasking.Init_Tasking_Soft_Links;
 806    end Init_RTS;
 807
 808 begin
 809    Init_RTS;
 810 end System.Tasking.Restricted.Stages;