gcc/ada/s-secsta.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --               S Y S T E M . S E C O N D A R Y _ S T A C K                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT 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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Compiler_Unit_Warning;
  33
  34 with System.Soft_Links;
  35 with System.Parameters;
  36
  37 with Ada.Unchecked_Conversion;
  38 with Ada.Unchecked_Deallocation;
  39
  40 package body System.Secondary_Stack is
  41
  42    package SSL renames System.Soft_Links;
  43
  44    use type SSE.Storage_Offset;
  45    use type System.Parameters.Size_Type;
  46
  47    SS_Ratio_Dynamic : constant Boolean :=
  48                         Parameters.Sec_Stack_Percentage = Parameters.Dynamic;
  49    --  There are two entirely different implementations of the secondary
  50    --  stack mechanism in this unit, and this Boolean is used to select
  51    --  between them (at compile time, so the generated code will contain
  52    --  only the code for the desired variant). If SS_Ratio_Dynamic is
  53    --  True, then the secondary stack is dynamically allocated from the
  54    --  heap in a linked list of chunks. If SS_Ration_Dynamic is False,
  55    --  then the secondary stack is allocated statically by grabbing a
  56    --  section of the primary stack and using it for this purpose.
  57
  58    type Memory is array (SS_Ptr range <>) of SSE.Storage_Element;
  59    for Memory'Alignment use Standard'Maximum_Alignment;
  60    --  This is the type used for actual allocation of secondary stack
  61    --  areas. We require maximum alignment for all such allocations.
  62
  63    ---------------------------------------------------------------
  64    -- Data Structures for Dynamically Allocated Secondary Stack --
  65    ---------------------------------------------------------------
  66
  67    --  The following is a diagram of the data structures used for the
  68    --  case of a dynamically allocated secondary stack, where the stack
  69    --  is allocated as a linked list of chunks allocated from the heap.
  70
  71    --                                      +------------------+
  72    --                                      |       Next       |
  73    --                                      +------------------+
  74    --                                      |                  | Last (200)
  75    --                                      |                  |
  76    --                                      |                  |
  77    --                                      |                  |
  78    --                                      |                  |
  79    --                                      |                  |
  80    --                                      |                  | First (101)
  81    --                                      +------------------+
  82    --                         +----------> |          |       |
  83    --                         |            +--------- | ------+
  84    --                         |                    ^  |
  85    --                         |                    |  |
  86    --                         |                    |  V
  87    --                         |            +------ | ---------+
  88    --                         |            |       |          |
  89    --                         |            +------------------+
  90    --                         |            |                  | Last (100)
  91    --                         |            |         C        |
  92    --                         |            |         H        |
  93    --    +-----------------+  |   +------->|         U        |
  94    --    |  Current_Chunk ----+   |        |         N        |
  95    --    +-----------------+      |        |         K        |
  96    --    |       Top      --------+        |                  | First (1)
  97    --    +-----------------+               +------------------+
  98    --    | Default_Size    |               |       Prev       |
  99    --    +-----------------+               +------------------+
 100    --
 101
 102    type Chunk_Id (First, Last : SS_Ptr);
 103    type Chunk_Ptr is access all Chunk_Id;
 104
 105    type Chunk_Id (First, Last : SS_Ptr) is record
 106       Prev, Next : Chunk_Ptr;
 107       Mem        : Memory (First .. Last);
 108    end record;
 109
 110    type Stack_Id is record
 111       Top           : SS_Ptr;
 112       Default_Size  : SSE.Storage_Count;
 113       Current_Chunk : Chunk_Ptr;
 114    end record;
 115
 116    type Stack_Ptr is access Stack_Id;
 117    --  Pointer to record used to represent a dynamically allocated secondary
 118    --  stack descriptor for a secondary stack chunk.
 119
 120    procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
 121    --  Free a dynamically allocated chunk
 122
 123    function To_Stack_Ptr is new
 124      Ada.Unchecked_Conversion (Address, Stack_Ptr);
 125    function To_Addr is new
 126      Ada.Unchecked_Conversion (Stack_Ptr, Address);
 127    --  Convert to and from address stored in task data structures
 128
 129    --------------------------------------------------------------
 130    -- Data Structures for Statically Allocated Secondary Stack --
 131    --------------------------------------------------------------
 132
 133    --  For the static case, the secondary stack is a single contiguous
 134    --  chunk of storage, carved out of the primary stack, and represented
 135    --  by the following data structure
 136
 137    type Fixed_Stack_Id is record
 138       Top : SS_Ptr;
 139       --  Index of next available location in Mem. This is initialized to
 140       --  0, and then incremented on Allocate, and Decremented on Release.
 141
 142       Last : SS_Ptr;
 143       --  Length of usable Mem array, which is thus the index past the
 144       --  last available location in Mem. Mem (Last-1) can be used. This
 145       --  is used to check that the stack does not overflow.
 146
 147       Max : SS_Ptr;
 148       --  Maximum value of Top. Initialized to 0, and then may be incremented
 149       --  on Allocate, but is never Decremented. The last used location will
 150       --  be Mem (Max - 1), so Max is the maximum count of used stack space.
 151
 152       Mem : Memory (0 .. 0);
 153       --  This is the area that is actually used for the secondary stack.
 154       --  Note that the upper bound is a dummy value properly defined by
 155       --  the value of Last. We never actually allocate objects of type
 156       --  Fixed_Stack_Id, so the bounds declared here do not matter.
 157    end record;
 158
 159    Dummy_Fixed_Stack : Fixed_Stack_Id;
 160    pragma Warnings (Off, Dummy_Fixed_Stack);
 161    --  Well it is not quite true that we never allocate an object of the
 162    --  type. This dummy object is allocated for the purpose of getting the
 163    --  offset of the Mem field via the 'Position attribute (such a nuisance
 164    --  that we cannot apply this to a field of a type).
 165
 166    type Fixed_Stack_Ptr is access Fixed_Stack_Id;
 167    --  Pointer to record used to describe statically allocated sec stack
 168
 169    function To_Fixed_Stack_Ptr is new
 170      Ada.Unchecked_Conversion (Address, Fixed_Stack_Ptr);
 171    --  Convert from address stored in task data structures
 172
 173    --------------
 174    -- Allocate --
 175    --------------
 176
 177    procedure SS_Allocate
 178      (Addr         : out Address;
 179       Storage_Size : SSE.Storage_Count)
 180    is
 181       Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
 182       Max_Size  : constant SS_Ptr :=
 183                     ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) *
 184                       Max_Align;
 185
 186    begin
 187       --  Case of fixed allocation secondary stack
 188
 189       if not SS_Ratio_Dynamic then
 190          declare
 191             Fixed_Stack : constant Fixed_Stack_Ptr :=
 192                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 193
 194          begin
 195             --  Check if max stack usage is increasing
 196
 197             if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then
 198
 199                --  If so, check if max size is exceeded
 200
 201                if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
 202                   raise Storage_Error;
 203                end if;
 204
 205                --  Record new max usage
 206
 207                Fixed_Stack.Max := Fixed_Stack.Top + Max_Size;
 208             end if;
 209
 210             --  Set resulting address and update top of stack pointer
 211
 212             Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
 213             Fixed_Stack.Top := Fixed_Stack.Top + Max_Size;
 214          end;
 215
 216       --  Case of dynamically allocated secondary stack
 217
 218       else
 219          declare
 220             Stack : constant Stack_Ptr :=
 221                       To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 222             Chunk : Chunk_Ptr;
 223
 224             To_Be_Released_Chunk : Chunk_Ptr;
 225
 226          begin
 227             Chunk := Stack.Current_Chunk;
 228
 229             --  The Current_Chunk may not be the good one if a lot of release
 230             --  operations have taken place. Go down the stack if necessary.
 231
 232             while Chunk.First > Stack.Top loop
 233                Chunk := Chunk.Prev;
 234             end loop;
 235
 236             --  Find out if the available memory in the current chunk is
 237             --  sufficient, if not, go to the next one and eventually create
 238             --  the necessary room.
 239
 240             while Chunk.Last - Stack.Top + 1 < Max_Size loop
 241                if Chunk.Next /= null then
 242
 243                   --  Release unused non-first empty chunk
 244
 245                   if Chunk.Prev /= null and then Chunk.First = Stack.Top then
 246                      To_Be_Released_Chunk := Chunk;
 247                      Chunk := Chunk.Prev;
 248                      Chunk.Next := To_Be_Released_Chunk.Next;
 249                      To_Be_Released_Chunk.Next.Prev := Chunk;
 250                      Free (To_Be_Released_Chunk);
 251                   end if;
 252
 253                --  Create new chunk of default size unless it is not sufficient
 254                --  to satisfy the current request.
 255
 256                elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
 257                   Chunk.Next :=
 258                     new Chunk_Id
 259                       (First => Chunk.Last + 1,
 260                        Last  => Chunk.Last + SS_Ptr (Stack.Default_Size));
 261
 262                   Chunk.Next.Prev := Chunk;
 263
 264                --  Otherwise create new chunk of requested size
 265
 266                else
 267                   Chunk.Next :=
 268                     new Chunk_Id
 269                       (First => Chunk.Last + 1,
 270                        Last  => Chunk.Last + Max_Size);
 271
 272                   Chunk.Next.Prev := Chunk;
 273                end if;
 274
 275                Chunk     := Chunk.Next;
 276                Stack.Top := Chunk.First;
 277             end loop;
 278
 279             --  Resulting address is the address pointed by Stack.Top
 280
 281             Addr                := Chunk.Mem (Stack.Top)'Address;
 282             Stack.Top           := Stack.Top + Max_Size;
 283             Stack.Current_Chunk := Chunk;
 284          end;
 285       end if;
 286    end SS_Allocate;
 287
 288    -------------
 289    -- SS_Free --
 290    -------------
 291
 292    procedure SS_Free (Stk : in out Address) is
 293    begin
 294       --  Case of statically allocated secondary stack, nothing to free
 295
 296       if not SS_Ratio_Dynamic then
 297          return;
 298
 299       --  Case of dynamically allocated secondary stack
 300
 301       else
 302          declare
 303             Stack : Stack_Ptr := To_Stack_Ptr (Stk);
 304             Chunk : Chunk_Ptr;
 305
 306             procedure Free is
 307               new Ada.Unchecked_Deallocation (Stack_Id, Stack_Ptr);
 308
 309          begin
 310             Chunk := Stack.Current_Chunk;
 311
 312             while Chunk.Prev /= null loop
 313                Chunk := Chunk.Prev;
 314             end loop;
 315
 316             while Chunk.Next /= null loop
 317                Chunk := Chunk.Next;
 318                Free (Chunk.Prev);
 319             end loop;
 320
 321             Free (Chunk);
 322             Free (Stack);
 323             Stk := Null_Address;
 324          end;
 325       end if;
 326    end SS_Free;
 327
 328    ----------------
 329    -- SS_Get_Max --
 330    ----------------
 331
 332    function SS_Get_Max return Long_Long_Integer is
 333    begin
 334       if SS_Ratio_Dynamic then
 335          return -1;
 336       else
 337          declare
 338             Fixed_Stack : constant Fixed_Stack_Ptr :=
 339                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 340          begin
 341             return Long_Long_Integer (Fixed_Stack.Max);
 342          end;
 343       end if;
 344    end SS_Get_Max;
 345
 346    -------------
 347    -- SS_Info --
 348    -------------
 349
 350    procedure SS_Info is
 351    begin
 352       Put_Line ("Secondary Stack information:");
 353
 354       --  Case of fixed secondary stack
 355
 356       if not SS_Ratio_Dynamic then
 357          declare
 358             Fixed_Stack : constant Fixed_Stack_Ptr :=
 359                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 360
 361          begin
 362             Put_Line (
 363                       "  Total size              : "
 364                       & SS_Ptr'Image (Fixed_Stack.Last)
 365                       & " bytes");
 366
 367             Put_Line (
 368                       "  Current allocated space : "
 369                       & SS_Ptr'Image (Fixed_Stack.Top - 1)
 370                       & " bytes");
 371          end;
 372
 373       --  Case of dynamically allocated secondary stack
 374
 375       else
 376          declare
 377             Stack     : constant Stack_Ptr :=
 378                           To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 379             Nb_Chunks : Integer   := 1;
 380             Chunk     : Chunk_Ptr := Stack.Current_Chunk;
 381
 382          begin
 383             while Chunk.Prev /= null loop
 384                Chunk := Chunk.Prev;
 385             end loop;
 386
 387             while Chunk.Next /= null loop
 388                Nb_Chunks := Nb_Chunks + 1;
 389                Chunk := Chunk.Next;
 390             end loop;
 391
 392             --  Current Chunk information
 393
 394             Put_Line (
 395                       "  Total size              : "
 396                       & SS_Ptr'Image (Chunk.Last)
 397                       & " bytes");
 398
 399             Put_Line (
 400                       "  Current allocated space : "
 401                       & SS_Ptr'Image (Stack.Top - 1)
 402                       & " bytes");
 403
 404             Put_Line (
 405                       "  Number of Chunks       : "
 406                       & Integer'Image (Nb_Chunks));
 407
 408             Put_Line (
 409                       "  Default size of Chunks : "
 410                       & SSE.Storage_Count'Image (Stack.Default_Size));
 411          end;
 412       end if;
 413    end SS_Info;
 414
 415    -------------
 416    -- SS_Init --
 417    -------------
 418
 419    procedure SS_Init
 420      (Stk  : in out Address;
 421       Size : Natural := Default_Secondary_Stack_Size)
 422    is
 423    begin
 424       --  Case of fixed size secondary stack
 425
 426       if not SS_Ratio_Dynamic then
 427          declare
 428             Fixed_Stack : constant Fixed_Stack_Ptr :=
 429                             To_Fixed_Stack_Ptr (Stk);
 430
 431          begin
 432             Fixed_Stack.Top  := 0;
 433             Fixed_Stack.Max  := 0;
 434
 435             if Size < Dummy_Fixed_Stack.Mem'Position then
 436                Fixed_Stack.Last := 0;
 437             else
 438                Fixed_Stack.Last :=
 439                  SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position;
 440             end if;
 441          end;
 442
 443       --  Case of dynamically allocated secondary stack
 444
 445       else
 446          declare
 447             Stack : Stack_Ptr;
 448          begin
 449             Stack               := new Stack_Id;
 450             Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size));
 451             Stack.Top           := 1;
 452             Stack.Default_Size  := SSE.Storage_Count (Size);
 453             Stk := To_Addr (Stack);
 454          end;
 455       end if;
 456    end SS_Init;
 457
 458    -------------
 459    -- SS_Mark --
 460    -------------
 461
 462    function SS_Mark return Mark_Id is
 463       Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all;
 464    begin
 465       if SS_Ratio_Dynamic then
 466          return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top);
 467       else
 468          return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top);
 469       end if;
 470    end SS_Mark;
 471
 472    ----------------
 473    -- SS_Release --
 474    ----------------
 475
 476    procedure SS_Release (M : Mark_Id) is
 477    begin
 478       if SS_Ratio_Dynamic then
 479          To_Stack_Ptr (M.Sstk).Top := M.Sptr;
 480       else
 481          To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr;
 482       end if;
 483    end SS_Release;
 484
 485    -------------------------
 486    -- Package Elaboration --
 487    -------------------------
 488
 489    --  Allocate a secondary stack for the main program to use
 490
 491    --  We make sure that the stack has maximum alignment. Some systems require
 492    --  this (e.g. Sparc), and in any case it is a good idea for efficiency.
 493
 494    Stack : aliased Stack_Id;
 495    for Stack'Alignment use Standard'Maximum_Alignment;
 496
 497    Static_Secondary_Stack_Size : constant := 10 * 1024;
 498    --  Static_Secondary_Stack_Size must be static so that Chunk is allocated
 499    --  statically, and not via dynamic memory allocation.
 500
 501    Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size);
 502    for Chunk'Alignment use Standard'Maximum_Alignment;
 503    --  Default chunk used, unless gnatbind -D is specified with a value greater
 504    --  than Static_Secondary_Stack_Size.
 505
 506 begin
 507    declare
 508       Chunk_Address : Address;
 509       Chunk_Access  : Chunk_Ptr;
 510
 511    begin
 512       if Default_Secondary_Stack_Size <= Static_Secondary_Stack_Size then
 513
 514          --  Normally we allocate the secondary stack for the main program
 515          --  statically, using the default secondary stack size.
 516
 517          Chunk_Access := Chunk'Access;
 518
 519       else
 520          --  Default_Secondary_Stack_Size was increased via gnatbind -D, so we
 521          --  need to allocate a chunk dynamically.
 522
 523          Chunk_Access :=
 524            new Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size));
 525       end if;
 526
 527       if SS_Ratio_Dynamic then
 528          Stack.Top           := 1;
 529          Stack.Current_Chunk := Chunk_Access;
 530          Stack.Default_Size  :=
 531            SSE.Storage_Offset (Default_Secondary_Stack_Size);
 532          System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
 533
 534       else
 535          Chunk_Address := Chunk_Access.all'Address;
 536          SS_Init (Chunk_Address, Default_Secondary_Stack_Size);
 537          System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address);
 538       end if;
 539    end;
 540 end System.Secondary_Stack;