gcc/ada/s-tarest.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA 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 --                                                                          --
  10 --         Copyright (C) 1999-2001, Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNARL was developed by the GNARL team at Florida State University. It is --
  31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com).     --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 pragma Style_Checks (All_Checks);
  36 --  Turn off subprogram alpha order check, since we group soft link
  37 --  bodies and also separate off subprograms for restricted GNARLI.
  38
  39 --  This is a simplified version of the System.Tasking.Stages package,
  40 --  intended to be used in a restricted run time.
  41
  42 --  This package represents the high level tasking interface used by the
  43 --  compiler to expand Ada 95 tasking constructs into simpler run time calls.
  44
  45 pragma Polling (Off);
  46 --  Turn off polling, we do not want ATC polling to take place during
  47 --  tasking operations. It causes infinite loops and other problems.
  48
  49 with System.Parameters;
  50 --  used for Size_Type
  51 --           Single_Lock
  52
  53 with System.Task_Info;
  54 --  used for Task_Info_Type
  55 --           Task_Image_Type
  56
  57 with System.Task_Primitives.Operations;
  58 --  used for Enter_Task
  59 --           Write_Lock
  60 --           Unlock
  61 --           Wakeup
  62 --           Get_Priority
  63
  64 with System.Soft_Links;
  65 --  used for the non-tasking routines (*_NT) that refer to global data.
  66 --  They are needed here before the tasking run time has been elaborated.
  67 --  used for Create_TSD
  68 --  This package also provides initialization routines for task specific data.
  69 --  The GNARL must call these to be sure that all non-tasking
  70 --  Ada constructs will work.
  71
  72 with System.Secondary_Stack;
  73 --  used for SS_Init;
  74
  75 with System.Storage_Elements;
  76 --  used for Storage_Array;
  77
  78 package body System.Tasking.Restricted.Stages is
  79
  80    package STPO renames System.Task_Primitives.Operations;
  81    package SSL  renames System.Soft_Links;
  82    package SSE  renames System.Storage_Elements;
  83    package SST  renames System.Secondary_Stack;
  84
  85    use Parameters;
  86    use Task_Primitives.Operations;
  87    use Task_Info;
  88
  89    Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock;
  90    --  This is a global lock; it is used to execute in mutual exclusion
  91    --  from all other tasks. It is only used by Task_Lock and Task_Unlock.
  92
  93    -----------------------------------------------------------------
  94    -- Tasking versions of services needed by non-tasking programs --
  95    -----------------------------------------------------------------
  96
  97    procedure Task_Lock;
  98    --  Locks out other tasks. Preceding a section of code by Task_Lock and
  99    --  following it by Task_Unlock creates a critical region. This is used
 100    --  for ensuring that a region of non-tasking code (such as code used to
 101    --  allocate memory) is tasking safe. Note that it is valid for calls to
 102    --  Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
 103    --  only the corresponding outer level Task_Unlock will actually unlock.
 104
 105    procedure Task_Unlock;
 106    --  Releases lock previously set by call to Task_Lock. In the nested case,
 107    --  all nested locks must be released before other tasks competing for the
 108    --  tasking lock are released.
 109
 110    function Get_Jmpbuf_Address return Address;
 111    procedure Set_Jmpbuf_Address (Addr : Address);
 112
 113    function Get_Sec_Stack_Addr return Address;
 114    procedure Set_Sec_Stack_Addr (Addr : Address);
 115
 116    function  Get_Machine_State_Addr return Address;
 117    procedure Set_Machine_State_Addr (Addr : Address);
 118
 119    function Get_Current_Excep return SSL.EOA;
 120
 121    procedure Timed_Delay_T (Time : Duration; Mode : Integer);
 122
 123    ------------------------
 124    --  Local Subprograms --
 125    ------------------------
 126
 127    procedure Task_Wrapper (Self_ID : Task_ID);
 128    --  This is the procedure that is called by the GNULL from the
 129    --  new context when a task is created. It waits for activation
 130    --  and then calls the task body procedure. When the task body
 131    --  procedure completes, it terminates the task.
 132
 133    procedure Terminate_Task (Self_ID : Task_ID);
 134    --  Terminate the calling task.
 135    --  This should only be called by the Task_Wrapper procedure.
 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    -- Task_Lock --
 145    ---------------
 146
 147    procedure Task_Lock is
 148    begin
 149       STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
 150    end Task_Lock;
 151
 152    -----------------
 153    -- Task_Unlock --
 154    -----------------
 155
 156    procedure Task_Unlock is
 157    begin
 158       STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
 159    end Task_Unlock;
 160
 161    ----------------------
 162    -- Soft-Link Bodies --
 163    ----------------------
 164
 165    function Get_Current_Excep return SSL.EOA is
 166    begin
 167       return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
 168    end Get_Current_Excep;
 169
 170    function Get_Jmpbuf_Address return  Address is
 171    begin
 172       return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
 173    end Get_Jmpbuf_Address;
 174
 175    function Get_Machine_State_Addr return Address is
 176    begin
 177       return STPO.Self.Common.Compiler_Data.Machine_State_Addr;
 178    end Get_Machine_State_Addr;
 179
 180    function Get_Sec_Stack_Addr return  Address is
 181    begin
 182       return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
 183    end Get_Sec_Stack_Addr;
 184
 185    procedure Set_Jmpbuf_Address (Addr : Address) is
 186    begin
 187       STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
 188    end Set_Jmpbuf_Address;
 189
 190    procedure Set_Machine_State_Addr (Addr : Address) is
 191    begin
 192       STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr;
 193    end Set_Machine_State_Addr;
 194
 195    procedure Set_Sec_Stack_Addr (Addr : Address) is
 196    begin
 197       STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
 198    end Set_Sec_Stack_Addr;
 199
 200    ------------------
 201    -- Task_Wrapper --
 202    ------------------
 203
 204    --  The task wrapper is a procedure that is called first for each task
 205    --  task body, and which in turn calls the compiler-generated task body
 206    --  procedure. The wrapper's main job is to do initialization for the task.
 207
 208    --  The variable ID in the task wrapper is used to implement the Self
 209    --  function on targets where there is a fast way to find the stack base
 210    --  of the current thread, since it should be at a fixed offset from the
 211    --  stack base.
 212
 213    procedure Task_Wrapper (Self_ID : Task_ID) is
 214       ID : Task_ID := Self_ID;
 215       pragma Volatile (ID);
 216
 217       --  Do not delete this variable.
 218       --  In some targets, we need this variable to implement a fast Self.
 219
 220       use type System.Parameters.Size_Type;
 221       use type SSE.Storage_Offset;
 222
 223       Secondary_Stack : aliased SSE.Storage_Array
 224         (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
 225            SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
 226       Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
 227
 228    begin
 229       if not Parameters.Sec_Stack_Dynamic then
 230          Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
 231            Secondary_Stack'Address;
 232          SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
 233       end if;
 234
 235       --  Initialize low-level TCB components, that
 236       --  cannot be initialized by the creator.
 237
 238       Enter_Task (Self_ID);
 239
 240       --  Call the task body procedure.
 241
 242       begin
 243          --  We are separating the following portion of the code in order to
 244          --  place the exception handlers in a different block.
 245          --  In this way we do not call Set_Jmpbuf_Address (which needs
 246          --  Self) before we set Self in Enter_Task.
 247          --  Note that in the case of Ravenscar HI-E where there are no
 248          --  exception handlers, the exception handler is suppressed.
 249
 250          --  Call the task body procedure.
 251
 252          Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
 253          Terminate_Task (Self_ID);
 254
 255       exception
 256          when others =>
 257             Terminate_Task (Self_ID);
 258       end;
 259    end Task_Wrapper;
 260
 261    -------------------
 262    -- Timed_Delay_T --
 263    -------------------
 264
 265    procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
 266    begin
 267       STPO.Timed_Delay (STPO.Self, Time, Mode);
 268    end Timed_Delay_T;
 269
 270    -----------------------
 271    -- Restricted GNARLI --
 272    -----------------------
 273
 274    -------------------------------
 275    -- Activate_Restricted_Tasks --
 276    -------------------------------
 277
 278    --  Note that locks of activator and activated task are both locked
 279    --  here. This is necessary because C.State and Self.Wait_Count
 280    --  have to be synchronized. This is safe from deadlock because
 281    --  the activator is always created before the activated task.
 282    --  That satisfies our in-order-of-creation ATCB locking policy.
 283
 284    procedure Activate_Restricted_Tasks
 285      (Chain_Access : Activation_Chain_Access)
 286    is
 287       Self_ID       : constant Task_ID := STPO.Self;
 288       C             : Task_ID;
 289       Activate_Prio : System.Any_Priority;
 290       Success       : Boolean;
 291
 292    begin
 293       pragma Assert (Self_ID = Environment_Task);
 294       pragma Assert (Self_ID.Common.Wait_Count = 0);
 295
 296       if Single_Lock then
 297          Lock_RTS;
 298       end if;
 299
 300       --  Lock self, to prevent activated tasks
 301       --  from racing ahead before we finish activating the chain.
 302
 303       Write_Lock (Self_ID);
 304
 305       --  Activate all the tasks in the chain.
 306       --  Creation of the thread of control was deferred until
 307       --  activation. So create it now.
 308
 309       C := Chain_Access.T_ID;
 310
 311       while C /= null loop
 312          if C.Common.State /= Terminated then
 313             pragma Assert (C.Common.State = Unactivated);
 314
 315             Write_Lock (C);
 316
 317             if C.Common.Base_Priority < Get_Priority (Self_ID) then
 318                Activate_Prio := Get_Priority (Self_ID);
 319             else
 320                Activate_Prio := C.Common.Base_Priority;
 321             end if;
 322
 323             STPO.Create_Task
 324               (C, Task_Wrapper'Address,
 325                Parameters.Size_Type
 326                  (C.Common.Compiler_Data.Pri_Stack_Info.Size),
 327                Activate_Prio, Success);
 328
 329             Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
 330
 331             if Success then
 332                C.Common.State := Runnable;
 333             else
 334                raise Program_Error;
 335             end if;
 336
 337             Unlock (C);
 338          end if;
 339
 340          C := C.Common.Activation_Link;
 341       end loop;
 342
 343       Self_ID.Common.State := Activator_Sleep;
 344
 345       --  Wait for the activated tasks to complete activation.
 346       --  It is unsafe to abort any of these tasks until the count goes to
 347       --  zero.
 348
 349       loop
 350          exit when Self_ID.Common.Wait_Count = 0;
 351          Sleep (Self_ID, Activator_Sleep);
 352       end loop;
 353
 354       Self_ID.Common.State := Runnable;
 355       Unlock (Self_ID);
 356
 357       if Single_Lock then
 358          Unlock_RTS;
 359       end if;
 360
 361       --  Remove the tasks from the chain.
 362
 363       Chain_Access.T_ID := null;
 364    end Activate_Restricted_Tasks;
 365
 366    ------------------------------------
 367    -- Complete_Restricted_Activation --
 368    ------------------------------------
 369
 370    --  As in several other places, the locks of the activator and activated
 371    --  task are both locked here. This follows our deadlock prevention lock
 372    --  ordering policy, since the activated task must be created after the
 373    --  activator.
 374
 375    procedure Complete_Restricted_Activation is
 376       Self_ID   : constant Task_ID := STPO.Self;
 377       Activator : constant Task_ID := Self_ID.Common.Activator;
 378
 379    begin
 380       if Single_Lock then
 381          Lock_RTS;
 382       end if;
 383
 384       Write_Lock (Activator);
 385       Write_Lock (Self_ID);
 386
 387       --  Remove dangling reference to Activator,
 388       --  since a task may outlive its activator.
 389
 390       Self_ID.Common.Activator := null;
 391
 392       --  Wake up the activator, if it is waiting for a chain
 393       --  of tasks to activate, and we are the last in the chain
 394       --  to complete activation
 395
 396       if Activator.Common.State = Activator_Sleep then
 397          Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
 398
 399          if Activator.Common.Wait_Count = 0 then
 400             Wakeup (Activator, Activator_Sleep);
 401          end if;
 402       end if;
 403
 404       Unlock (Self_ID);
 405       Unlock (Activator);
 406
 407       if Single_Lock then
 408          Unlock_RTS;
 409       end if;
 410
 411       --  After the activation, active priority should be the same
 412       --  as base priority. We must unlock the Activator first,
 413       --  though, since it should not wait if we have lower priority.
 414
 415       if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
 416          Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 417       end if;
 418    end Complete_Restricted_Activation;
 419
 420    ------------------------------
 421    -- Complete_Restricted_Task --
 422    ------------------------------
 423
 424    procedure Complete_Restricted_Task is
 425    begin
 426       STPO.Self.Common.State := Terminated;
 427    end Complete_Restricted_Task;
 428
 429    ----------------------------
 430    -- Create_Restricted_Task --
 431    ----------------------------
 432
 433    procedure Create_Restricted_Task
 434      (Priority      : Integer;
 435       Size          : System.Parameters.Size_Type;
 436       Task_Info     : System.Task_Info.Task_Info_Type;
 437       State         : Task_Procedure_Access;
 438       Discriminants : System.Address;
 439       Elaborated    : Access_Boolean;
 440       Chain         : in out Activation_Chain;
 441       Task_Image    : System.Task_Info.Task_Image_Type;
 442       Created_Task  : out Task_ID)
 443    is
 444       T             : Task_ID;
 445       Self_ID       : constant Task_ID := STPO.Self;
 446       Base_Priority : System.Any_Priority;
 447       Success       : Boolean;
 448
 449    begin
 450       if Priority = Unspecified_Priority then
 451          Base_Priority := Self_ID.Common.Base_Priority;
 452       else
 453          Base_Priority := System.Any_Priority (Priority);
 454       end if;
 455
 456       T := New_ATCB (0);
 457
 458       if Single_Lock then
 459          Lock_RTS;
 460       end if;
 461
 462       Write_Lock (Self_ID);
 463
 464       --  With no task hierarchy, the parent of all non-Environment tasks that
 465       --  are created must be the Environment task
 466
 467       Initialize_ATCB
 468         (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
 469          Task_Info, Size, T, Success);
 470
 471       --  If we do our job right then there should never be any failures,
 472       --  which was probably said about the Titanic; so just to be safe,
 473       --  let's retain this code for now
 474
 475       if not Success then
 476          Unlock (Self_ID);
 477
 478          if Single_Lock then
 479             Unlock_RTS;
 480          end if;
 481
 482          raise Program_Error;
 483       end if;
 484
 485       T.Entry_Calls (1).Self := T;
 486       T.Common.Task_Image    := Task_Image;
 487       Unlock (Self_ID);
 488
 489       if Single_Lock then
 490          Unlock_RTS;
 491       end if;
 492
 493       --  Create TSD as early as possible in the creation of a task, since it
 494       --  may be used by the operation of Ada code within the task.
 495
 496       SSL.Create_TSD (T.Common.Compiler_Data);
 497       T.Common.Activation_Link := Chain.T_ID;
 498       Chain.T_ID   := T;
 499       Created_Task := T;
 500    end Create_Restricted_Task;
 501
 502    ---------------------------
 503    -- Finalize_Global_Tasks --
 504    ---------------------------
 505
 506    --  This is needed to support the compiler interface; it will only be called
 507    --  by the Environment task. Instead, it will cause the Environment to block
 508    --  forever, since none of the dependent tasks are expected to terminate
 509
 510    procedure Finalize_Global_Tasks is
 511       Self_ID : constant Task_ID := STPO.Self;
 512    begin
 513       pragma Assert (Self_ID = STPO.Environment_Task);
 514
 515       if Single_Lock then
 516          Lock_RTS;
 517       end if;
 518
 519       Write_Lock (Self_ID);
 520       Sleep (Self_ID, Master_Completion_Sleep);
 521       Unlock (Self_ID);
 522
 523       if Single_Lock then
 524          Unlock_RTS;
 525       end if;
 526
 527       --  Should never return from Master Completion Sleep
 528
 529       raise Program_Error;
 530    end Finalize_Global_Tasks;
 531
 532    ---------------------------
 533    -- Restricted_Terminated --
 534    ---------------------------
 535
 536    function Restricted_Terminated (T : Task_ID) return Boolean is
 537    begin
 538       return T.Common.State = Terminated;
 539    end Restricted_Terminated;
 540
 541    --------------------
 542    -- Terminate_Task --
 543    --------------------
 544
 545    procedure Terminate_Task (Self_ID : Task_ID) is
 546    begin
 547       Self_ID.Common.State := Terminated;
 548    end Terminate_Task;
 549
 550    --------------
 551    -- Init_RTS --
 552    --------------
 553
 554    procedure Init_RTS is
 555    begin
 556       --  Initialize lock used to implement mutual exclusion between all tasks
 557
 558       STPO.Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level);
 559
 560       --  Notify that the tasking run time has been elaborated so that
 561       --  the tasking version of the soft links can be used.
 562
 563       SSL.Lock_Task              := Task_Lock'Access;
 564       SSL.Unlock_Task            := Task_Unlock'Access;
 565
 566       SSL.Get_Jmpbuf_Address     := Get_Jmpbuf_Address'Access;
 567       SSL.Set_Jmpbuf_Address     := Set_Jmpbuf_Address'Access;
 568       SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
 569       SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
 570       SSL.Get_Current_Excep      := Get_Current_Excep'Access;
 571       SSL.Set_Jmpbuf_Address     (SSL.Get_Jmpbuf_Address_NT);
 572       SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
 573
 574       SSL.Get_Sec_Stack_Addr     := Get_Sec_Stack_Addr'Access;
 575       SSL.Set_Sec_Stack_Addr     := Set_Sec_Stack_Addr'Access;
 576
 577       --  No need to create a new Secondary Stack, since we will use the
 578       --  default one created in s-secsta.adb
 579
 580       Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
 581
 582       SSL.Timed_Delay            := Timed_Delay_T'Access;
 583       SSL.Adafinal               := Finalize_Global_Tasks'Access;
 584    end Init_RTS;
 585
 586 begin
 587    Init_RTS;
 588 end System.Tasking.Restricted.Stages;