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