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    -- Minimum_Secondary_Stack_Size --
 175    ----------------------------------
 176
 177    function Minimum_Secondary_Stack_Size return Natural is
 178    begin
 179       return Dummy_Fixed_Stack.Mem'Position;
 180    end Minimum_Secondary_Stack_Size;
 181
 182    --------------
 183    -- Allocate --
 184    --------------
 185
 186    procedure SS_Allocate
 187      (Addr         : out Address;
 188       Storage_Size : SSE.Storage_Count)
 189    is
 190       Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
 191       Max_Size  : constant SS_Ptr :=
 192                     ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) *
 193                       Max_Align;
 194
 195    begin
 196       --  Case of fixed allocation secondary stack
 197
 198       if not SS_Ratio_Dynamic then
 199          declare
 200             Fixed_Stack : constant Fixed_Stack_Ptr :=
 201                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 202
 203          begin
 204             --  Check if max stack usage is increasing
 205
 206             if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then
 207
 208                --  If so, check if max size is exceeded
 209
 210                if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
 211                   raise Storage_Error;
 212                end if;
 213
 214                --  Record new max usage
 215
 216                Fixed_Stack.Max := Fixed_Stack.Top + Max_Size;
 217             end if;
 218
 219             --  Set resulting address and update top of stack pointer
 220
 221             Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
 222             Fixed_Stack.Top := Fixed_Stack.Top + Max_Size;
 223          end;
 224
 225       --  Case of dynamically allocated secondary stack
 226
 227       else
 228          declare
 229             Stack : constant Stack_Ptr :=
 230                       To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 231             Chunk : Chunk_Ptr;
 232
 233             To_Be_Released_Chunk : Chunk_Ptr;
 234
 235          begin
 236             Chunk := Stack.Current_Chunk;
 237
 238             --  The Current_Chunk may not be the good one if a lot of release
 239             --  operations have taken place. Go down the stack if necessary.
 240
 241             while Chunk.First > Stack.Top loop
 242                Chunk := Chunk.Prev;
 243             end loop;
 244
 245             --  Find out if the available memory in the current chunk is
 246             --  sufficient, if not, go to the next one and eventually create
 247             --  the necessary room.
 248
 249             while Chunk.Last - Stack.Top + 1 < Max_Size loop
 250                if Chunk.Next /= null then
 251
 252                   --  Release unused non-first empty chunk
 253
 254                   if Chunk.Prev /= null and then Chunk.First = Stack.Top then
 255                      To_Be_Released_Chunk := Chunk;
 256                      Chunk := Chunk.Prev;
 257                      Chunk.Next := To_Be_Released_Chunk.Next;
 258                      To_Be_Released_Chunk.Next.Prev := Chunk;
 259                      Free (To_Be_Released_Chunk);
 260                   end if;
 261
 262                --  Create new chunk of default size unless it is not sufficient
 263                --  to satisfy the current request.
 264
 265                elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
 266                   Chunk.Next :=
 267                     new Chunk_Id
 268                       (First => Chunk.Last + 1,
 269                        Last  => Chunk.Last + SS_Ptr (Stack.Default_Size));
 270
 271                   Chunk.Next.Prev := Chunk;
 272
 273                --  Otherwise create new chunk of requested size
 274
 275                else
 276                   Chunk.Next :=
 277                     new Chunk_Id
 278                       (First => Chunk.Last + 1,
 279                        Last  => Chunk.Last + Max_Size);
 280
 281                   Chunk.Next.Prev := Chunk;
 282                end if;
 283
 284                Chunk     := Chunk.Next;
 285                Stack.Top := Chunk.First;
 286             end loop;
 287
 288             --  Resulting address is the address pointed by Stack.Top
 289
 290             Addr                := Chunk.Mem (Stack.Top)'Address;
 291             Stack.Top           := Stack.Top + Max_Size;
 292             Stack.Current_Chunk := Chunk;
 293          end;
 294       end if;
 295    end SS_Allocate;
 296
 297    -------------
 298    -- SS_Free --
 299    -------------
 300
 301    procedure SS_Free (Stk : in out Address) is
 302    begin
 303       --  Case of statically allocated secondary stack, nothing to free
 304
 305       if not SS_Ratio_Dynamic then
 306          return;
 307
 308       --  Case of dynamically allocated secondary stack
 309
 310       else
 311          declare
 312             Stack : Stack_Ptr := To_Stack_Ptr (Stk);
 313             Chunk : Chunk_Ptr;
 314
 315             procedure Free is
 316               new Ada.Unchecked_Deallocation (Stack_Id, Stack_Ptr);
 317
 318          begin
 319             Chunk := Stack.Current_Chunk;
 320
 321             while Chunk.Prev /= null loop
 322                Chunk := Chunk.Prev;
 323             end loop;
 324
 325             while Chunk.Next /= null loop
 326                Chunk := Chunk.Next;
 327                Free (Chunk.Prev);
 328             end loop;
 329
 330             Free (Chunk);
 331             Free (Stack);
 332             Stk := Null_Address;
 333          end;
 334       end if;
 335    end SS_Free;
 336
 337    ----------------
 338    -- SS_Get_Max --
 339    ----------------
 340
 341    function SS_Get_Max return Long_Long_Integer is
 342    begin
 343       if SS_Ratio_Dynamic then
 344          return -1;
 345       else
 346          declare
 347             Fixed_Stack : constant Fixed_Stack_Ptr :=
 348                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 349          begin
 350             return Long_Long_Integer (Fixed_Stack.Max);
 351          end;
 352       end if;
 353    end SS_Get_Max;
 354
 355    -------------
 356    -- SS_Info --
 357    -------------
 358
 359    procedure SS_Info is
 360    begin
 361       Put_Line ("Secondary Stack information:");
 362
 363       --  Case of fixed secondary stack
 364
 365       if not SS_Ratio_Dynamic then
 366          declare
 367             Fixed_Stack : constant Fixed_Stack_Ptr :=
 368                             To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 369
 370          begin
 371             Put_Line ("  Total size              : "
 372                       & SS_Ptr'Image (Fixed_Stack.Last)
 373                       & " bytes");
 374
 375             Put_Line ("  Current allocated space : "
 376                       & SS_Ptr'Image (Fixed_Stack.Top)
 377                       & " bytes");
 378          end;
 379
 380       --  Case of dynamically allocated secondary stack
 381
 382       else
 383          declare
 384             Stack     : constant Stack_Ptr :=
 385                           To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
 386             Nb_Chunks : Integer   := 1;
 387             Chunk     : Chunk_Ptr := Stack.Current_Chunk;
 388
 389          begin
 390             while Chunk.Prev /= null loop
 391                Chunk := Chunk.Prev;
 392             end loop;
 393
 394             while Chunk.Next /= null loop
 395                Nb_Chunks := Nb_Chunks + 1;
 396                Chunk := Chunk.Next;
 397             end loop;
 398
 399             --  Current Chunk information
 400
 401             --  Note that First of each chunk is one more than Last of the
 402             --  previous one, so Chunk.Last is the total size of all chunks; we
 403             --  don't need to walk all the chunks to compute the total size.
 404
 405             Put_Line ("  Total size              : "
 406                       & SS_Ptr'Image (Chunk.Last)
 407                       & " bytes");
 408
 409             Put_Line ("  Current allocated space : "
 410                       & SS_Ptr'Image (Stack.Top - 1)
 411                       & " bytes");
 412
 413             Put_Line ("  Number of Chunks       : "
 414                       & Integer'Image (Nb_Chunks));
 415
 416             Put_Line ("  Default size of Chunks : "
 417                       & SSE.Storage_Count'Image (Stack.Default_Size));
 418          end;
 419       end if;
 420    end SS_Info;
 421
 422    -------------
 423    -- SS_Init --
 424    -------------
 425
 426    procedure SS_Init
 427      (Stk  : in out Address;
 428       Size : Natural := Default_Secondary_Stack_Size)
 429    is
 430    begin
 431       --  Case of fixed size secondary stack
 432
 433       if not SS_Ratio_Dynamic then
 434          declare
 435             Fixed_Stack : constant Fixed_Stack_Ptr :=
 436                             To_Fixed_Stack_Ptr (Stk);
 437
 438          begin
 439             Fixed_Stack.Top  := 0;
 440             Fixed_Stack.Max  := 0;
 441
 442             if Size <= Dummy_Fixed_Stack.Mem'Position then
 443                Fixed_Stack.Last := 0;
 444             else
 445                Fixed_Stack.Last :=
 446                  SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position;
 447             end if;
 448          end;
 449
 450       --  Case of dynamically allocated secondary stack
 451
 452       else
 453          declare
 454             Stack : Stack_Ptr;
 455          begin
 456             Stack               := new Stack_Id;
 457             Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size));
 458             Stack.Top           := 1;
 459             Stack.Default_Size  := SSE.Storage_Count (Size);
 460             Stk := To_Addr (Stack);
 461          end;
 462       end if;
 463    end SS_Init;
 464
 465    -------------
 466    -- SS_Mark --
 467    -------------
 468
 469    function SS_Mark return Mark_Id is
 470       Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all;
 471    begin
 472       if SS_Ratio_Dynamic then
 473          return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top);
 474       else
 475          return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top);
 476       end if;
 477    end SS_Mark;
 478
 479    ----------------
 480    -- SS_Release --
 481    ----------------
 482
 483    procedure SS_Release (M : Mark_Id) is
 484    begin
 485       if SS_Ratio_Dynamic then
 486          To_Stack_Ptr (M.Sstk).Top := M.Sptr;
 487       else
 488          To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr;
 489       end if;
 490    end SS_Release;
 491
 492    -------------------------
 493    -- Package Elaboration --
 494    -------------------------
 495
 496    --  Allocate a secondary stack for the main program to use
 497
 498    --  We make sure that the stack has maximum alignment. Some systems require
 499    --  this (e.g. Sparc), and in any case it is a good idea for efficiency.
 500
 501    Stack : aliased Stack_Id;
 502    for Stack'Alignment use Standard'Maximum_Alignment;
 503
 504    Static_Secondary_Stack_Size : constant := 10 * 1024;
 505    --  Static_Secondary_Stack_Size must be static so that Chunk is allocated
 506    --  statically, and not via dynamic memory allocation.
 507
 508    Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size);
 509    for Chunk'Alignment use Standard'Maximum_Alignment;
 510    --  Default chunk used, unless gnatbind -D is specified with a value greater
 511    --  than Static_Secondary_Stack_Size.
 512
 513 begin
 514    declare
 515       Chunk_Address : Address;
 516       Chunk_Access  : Chunk_Ptr;
 517
 518    begin
 519       if Default_Secondary_Stack_Size <= Static_Secondary_Stack_Size then
 520
 521          --  Normally we allocate the secondary stack for the main program
 522          --  statically, using the default secondary stack size.
 523
 524          Chunk_Access := Chunk'Access;
 525
 526       else
 527          --  Default_Secondary_Stack_Size was increased via gnatbind -D, so we
 528          --  need to allocate a chunk dynamically.
 529
 530          Chunk_Access :=
 531            new Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size));
 532       end if;
 533
 534       if SS_Ratio_Dynamic then
 535          Stack.Top           := 1;
 536          Stack.Current_Chunk := Chunk_Access;
 537          Stack.Default_Size  :=
 538            SSE.Storage_Offset (Default_Secondary_Stack_Size);
 539          System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
 540
 541       else
 542          Chunk_Address := Chunk_Access.all'Address;
 543          SS_Init (Chunk_Address, Default_Secondary_Stack_Size);
 544          System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address);
 545       end if;
 546    end;
 547 end System.Secondary_Stack;