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-2005, 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 System.Parameters;
  49 --  used for Size_Type
  50 --           Single_Lock
  51
  52 with System.Task_Info;
  53 --  used for Task_Info_Type
  54
  55 with System.Task_Primitives.Operations;
  56 --  used for Enter_Task
  57 --           Write_Lock
  58 --           Unlock
  59 --           Wakeup
  60 --           Get_Priority
  61
  62 with System.Soft_Links;
  63 --  used for the non-tasking routines (*_NT) that refer to global data.
  64 --  They are needed here before the tasking run time has been elaborated.
  65 --  used for Create_TSD
  66 --  This package also provides initialization routines for task specific data.
  67 --  The GNARL must call these to be sure that all non-tasking
  68 --  Ada constructs will work.
  69
  70 with System.Soft_Links.Tasking;
  71 --  Used for Init_Tasking_Soft_Links
  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 Parameters;
  87    use Task_Primitives.Operations;
  88    use 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    -----------------------
 112    -- Local Subprograms --
 113    -----------------------
 114
 115    procedure Task_Wrapper (Self_ID : Task_Id);
 116    --  This is the procedure that is called by the GNULL from the
 117    --  new context when a task is created. It waits for activation
 118    --  and then calls the task body procedure. When the task body
 119    --  procedure completes, it terminates the task.
 120
 121    procedure Terminate_Task (Self_ID : Task_Id);
 122    --  Terminate the calling task.
 123    --  This should only be called by the Task_Wrapper procedure.
 124
 125    procedure Init_RTS;
 126    --  This procedure performs the initialization of the GNARL.
 127    --  It consists of initializing the environment task, global locks, and
 128    --  installing tasking versions of certain operations used by the compiler.
 129    --  Init_RTS is called during elaboration.
 130
 131    ---------------
 132    -- Task_Lock --
 133    ---------------
 134
 135    procedure Task_Lock is
 136    begin
 137       STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
 138    end Task_Lock;
 139
 140    -----------------
 141    -- Task_Unlock --
 142    -----------------
 143
 144    procedure Task_Unlock is
 145    begin
 146       STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
 147    end Task_Unlock;
 148
 149    ------------------
 150    -- Task_Wrapper --
 151    ------------------
 152
 153    --  The task wrapper is a procedure that is called first for each task
 154    --  task body, and which in turn calls the compiler-generated task body
 155    --  procedure. The wrapper's main job is to do initialization for the task.
 156
 157    --  The variable ID in the task wrapper is used to implement the Self
 158    --  function on targets where there is a fast way to find the stack base
 159    --  of the current thread, since it should be at a fixed offset from the
 160    --  stack base.
 161
 162    procedure Task_Wrapper (Self_ID : Task_Id) is
 163       ID : Task_Id := Self_ID;
 164       pragma Volatile (ID);
 165
 166       pragma Warnings (Off, ID);
 167       --  Turn off warnings (stand alone volatile constant has to be
 168       --  imported, so we cannot just make ID constant).
 169
 170       --  Do not delete this variable.
 171       --  In some targets, we need this variable to implement a fast Self.
 172
 173       use type System.Parameters.Size_Type;
 174       use type SSE.Storage_Offset;
 175
 176       Secondary_Stack : aliased SSE.Storage_Array
 177         (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
 178            SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
 179       Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
 180
 181    begin
 182       if not Parameters.Sec_Stack_Dynamic then
 183          Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
 184            Secondary_Stack'Address;
 185          SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
 186       end if;
 187
 188       --  Initialize low-level TCB components, that
 189       --  cannot be initialized by the creator.
 190
 191       Enter_Task (Self_ID);
 192
 193       --  Call the task body procedure.
 194
 195       begin
 196          --  We are separating the following portion of the code in order to
 197          --  place the exception handlers in a different block.
 198          --  In this way we do not call Set_Jmpbuf_Address (which needs
 199          --  Self) before we set Self in Enter_Task.
 200          --  Note that in the case of Ravenscar HI-E where there are no
 201          --  exception handlers, the exception handler is suppressed.
 202
 203          --  Call the task body procedure.
 204
 205          Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
 206          Terminate_Task (Self_ID);
 207
 208       exception
 209          when others =>
 210             Terminate_Task (Self_ID);
 211       end;
 212    end Task_Wrapper;
 213
 214    -----------------------
 215    -- Restricted GNARLI --
 216    -----------------------
 217
 218    -------------------------------
 219    -- Activate_Restricted_Tasks --
 220    -------------------------------
 221
 222    --  Note that locks of activator and activated task are both locked
 223    --  here. This is necessary because C.State and Self.Wait_Count
 224    --  have to be synchronized. This is safe from deadlock because
 225    --  the activator is always created before the activated task.
 226    --  That satisfies our in-order-of-creation ATCB locking policy.
 227
 228    procedure Activate_Restricted_Tasks
 229      (Chain_Access : Activation_Chain_Access)
 230    is
 231       Self_ID       : constant Task_Id := STPO.Self;
 232       C             : Task_Id;
 233       Activate_Prio : System.Any_Priority;
 234       Success       : Boolean;
 235
 236    begin
 237       pragma Assert (Self_ID = Environment_Task);
 238       pragma Assert (Self_ID.Common.Wait_Count = 0);
 239
 240       if Single_Lock then
 241          Lock_RTS;
 242       end if;
 243
 244       --  Lock self, to prevent activated tasks
 245       --  from racing ahead before we finish activating the chain.
 246
 247       Write_Lock (Self_ID);
 248
 249       --  Activate all the tasks in the chain.
 250       --  Creation of the thread of control was deferred until
 251       --  activation. So create it now.
 252
 253       C := Chain_Access.T_ID;
 254
 255       while C /= null loop
 256          if C.Common.State /= Terminated then
 257             pragma Assert (C.Common.State = Unactivated);
 258
 259             Write_Lock (C);
 260
 261             if C.Common.Base_Priority < Get_Priority (Self_ID) then
 262                Activate_Prio := Get_Priority (Self_ID);
 263             else
 264                Activate_Prio := C.Common.Base_Priority;
 265             end if;
 266
 267             STPO.Create_Task
 268               (C, Task_Wrapper'Address,
 269                Parameters.Size_Type
 270                  (C.Common.Compiler_Data.Pri_Stack_Info.Size),
 271                Activate_Prio, Success);
 272
 273             Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
 274
 275             if Success then
 276                C.Common.State := Runnable;
 277             else
 278                raise Program_Error;
 279             end if;
 280
 281             Unlock (C);
 282          end if;
 283
 284          C := C.Common.Activation_Link;
 285       end loop;
 286
 287       Self_ID.Common.State := Activator_Sleep;
 288
 289       --  Wait for the activated tasks to complete activation.
 290       --  It is unsafe to abort any of these tasks until the count goes to
 291       --  zero.
 292
 293       loop
 294          exit when Self_ID.Common.Wait_Count = 0;
 295          Sleep (Self_ID, Activator_Sleep);
 296       end loop;
 297
 298       Self_ID.Common.State := Runnable;
 299       Unlock (Self_ID);
 300
 301       if Single_Lock then
 302          Unlock_RTS;
 303       end if;
 304
 305       --  Remove the tasks from the chain.
 306
 307       Chain_Access.T_ID := null;
 308    end Activate_Restricted_Tasks;
 309
 310    ------------------------------------
 311    -- Complete_Restricted_Activation --
 312    ------------------------------------
 313
 314    --  As in several other places, the locks of the activator and activated
 315    --  task are both locked here. This follows our deadlock prevention lock
 316    --  ordering policy, since the activated task must be created after the
 317    --  activator.
 318
 319    procedure Complete_Restricted_Activation is
 320       Self_ID   : constant Task_Id := STPO.Self;
 321       Activator : constant Task_Id := Self_ID.Common.Activator;
 322
 323    begin
 324       if Single_Lock then
 325          Lock_RTS;
 326       end if;
 327
 328       Write_Lock (Activator);
 329       Write_Lock (Self_ID);
 330
 331       --  Remove dangling reference to Activator,
 332       --  since a task may outlive its activator.
 333
 334       Self_ID.Common.Activator := null;
 335
 336       --  Wake up the activator, if it is waiting for a chain
 337       --  of tasks to activate, and we are the last in the chain
 338       --  to complete activation
 339
 340       if Activator.Common.State = Activator_Sleep then
 341          Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
 342
 343          if Activator.Common.Wait_Count = 0 then
 344             Wakeup (Activator, Activator_Sleep);
 345          end if;
 346       end if;
 347
 348       Unlock (Self_ID);
 349       Unlock (Activator);
 350
 351       if Single_Lock then
 352          Unlock_RTS;
 353       end if;
 354
 355       --  After the activation, active priority should be the same
 356       --  as base priority. We must unlock the Activator first,
 357       --  though, since it should not wait if we have lower priority.
 358
 359       if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
 360          Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 361       end if;
 362    end Complete_Restricted_Activation;
 363
 364    ------------------------------
 365    -- Complete_Restricted_Task --
 366    ------------------------------
 367
 368    procedure Complete_Restricted_Task is
 369    begin
 370       STPO.Self.Common.State := Terminated;
 371    end Complete_Restricted_Task;
 372
 373    ----------------------------
 374    -- Create_Restricted_Task --
 375    ----------------------------
 376
 377    procedure Create_Restricted_Task
 378      (Priority      : Integer;
 379       Stack_Address : System.Address;
 380       Size          : System.Parameters.Size_Type;
 381       Task_Info     : System.Task_Info.Task_Info_Type;
 382       State         : Task_Procedure_Access;
 383       Discriminants : System.Address;
 384       Elaborated    : Access_Boolean;
 385       Chain         : in out Activation_Chain;
 386       Task_Image    : String;
 387       Created_Task  : Task_Id)
 388    is
 389       Self_ID       : constant Task_Id := STPO.Self;
 390       Base_Priority : System.Any_Priority;
 391       Success       : Boolean;
 392
 393    begin
 394       --  Stack is not preallocated on this target, so that
 395       --  Stack_Address must be null.
 396
 397       pragma Assert (Stack_Address = Null_Address);
 398
 399       if Priority = Unspecified_Priority then
 400          Base_Priority := Self_ID.Common.Base_Priority;
 401       else
 402          Base_Priority := System.Any_Priority (Priority);
 403       end if;
 404
 405       if Single_Lock then
 406          Lock_RTS;
 407       end if;
 408
 409       Write_Lock (Self_ID);
 410
 411       --  With no task hierarchy, the parent of all non-Environment tasks that
 412       --  are created must be the Environment task
 413
 414       Initialize_ATCB
 415         (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
 416          Task_Info, Size, Created_Task, Success);
 417
 418       --  If we do our job right then there should never be any failures,
 419       --  which was probably said about the Titanic; so just to be safe,
 420       --  let's retain this code for now
 421
 422       if not Success then
 423          Unlock (Self_ID);
 424
 425          if Single_Lock then
 426             Unlock_RTS;
 427          end if;
 428
 429          raise Program_Error;
 430       end if;
 431
 432       Created_Task.Entry_Calls (1).Self := Created_Task;
 433
 434       Created_Task.Common.Task_Image_Len :=
 435         Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length);
 436       Created_Task.Common.Task_Image
 437         (1 .. Created_Task.Common.Task_Image_Len) := Task_Image;
 438
 439       Unlock (Self_ID);
 440
 441       if Single_Lock then
 442          Unlock_RTS;
 443       end if;
 444
 445       --  Create TSD as early as possible in the creation of a task, since it
 446       --  may be used by the operation of Ada code within the task.
 447
 448       SSL.Create_TSD (Created_Task.Common.Compiler_Data);
 449       Created_Task.Common.Activation_Link := Chain.T_ID;
 450       Chain.T_ID := Created_Task;
 451    end Create_Restricted_Task;
 452
 453    ---------------------------
 454    -- Finalize_Global_Tasks --
 455    ---------------------------
 456
 457    --  This is needed to support the compiler interface; it will only be called
 458    --  by the Environment task. Instead, it will cause the Environment to block
 459    --  forever, since none of the dependent tasks are expected to terminate
 460
 461    procedure Finalize_Global_Tasks is
 462       Self_ID : constant Task_Id := STPO.Self;
 463
 464    begin
 465       pragma Assert (Self_ID = STPO.Environment_Task);
 466
 467       if Single_Lock then
 468          Lock_RTS;
 469       end if;
 470
 471       Write_Lock (Self_ID);
 472       Sleep (Self_ID, Master_Completion_Sleep);
 473       Unlock (Self_ID);
 474
 475       if Single_Lock then
 476          Unlock_RTS;
 477       end if;
 478
 479       --  Should never return from Master Completion Sleep
 480
 481       raise Program_Error;
 482    end Finalize_Global_Tasks;
 483
 484    ---------------------------
 485    -- Restricted_Terminated --
 486    ---------------------------
 487
 488    function Restricted_Terminated (T : Task_Id) return Boolean is
 489    begin
 490       return T.Common.State = Terminated;
 491    end Restricted_Terminated;
 492
 493    --------------------
 494    -- Terminate_Task --
 495    --------------------
 496
 497    procedure Terminate_Task (Self_ID : Task_Id) is
 498    begin
 499       Self_ID.Common.State := Terminated;
 500    end Terminate_Task;
 501
 502    --------------
 503    -- Init_RTS --
 504    --------------
 505
 506    procedure Init_RTS is
 507    begin
 508       --  Initialize lock used to implement mutual exclusion between all tasks
 509
 510       STPO.Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level);
 511
 512       --  Notify that the tasking run time has been elaborated so that
 513       --  the tasking version of the soft links can be used.
 514
 515       SSL.Lock_Task   := Task_Lock'Access;
 516       SSL.Unlock_Task := Task_Unlock'Access;
 517       SSL.Adafinal    := Finalize_Global_Tasks'Access;
 518
 519       --  Initialize the tasking soft links (if not done yet) that are common
 520       --  to the full and the restricted run times.
 521
 522       SSL.Tasking.Init_Tasking_Soft_Links;
 523    end Init_RTS;
 524
 525 begin
 526    Init_RTS;
 527 end System.Tasking.Restricted.Stages;