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