diff options
Diffstat (limited to 'gcc/ada/libgnat')
| -rw-r--r-- | gcc/ada/libgnat/a-tags.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-tags.ads | 13 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-parame.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-parame.ads | 32 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-parame__ae653.ads | 26 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-parame__hpux.ads | 26 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-parame__rtems.adb | 48 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-parame__vxworks.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-parame__vxworks.ads | 26 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-secsta.adb | 470 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-secsta.ads | 198 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-soflin.adb | 81 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-soflin.ads | 50 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-soliin.adb | 47 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-soliin.ads | 48 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-thread.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-thread__ae653.adb | 45 |
17 files changed, 638 insertions, 528 deletions
diff --git a/gcc/ada/libgnat/a-tags.adb b/gcc/ada/libgnat/a-tags.adb index 322f9915f6e..f3c2c0e969c 100644 --- a/gcc/ada/libgnat/a-tags.adb +++ b/gcc/ada/libgnat/a-tags.adb @@ -842,9 +842,21 @@ package body Ada.Tags is begin Curr_DT := DT (To_Tag_Ptr (This).all); + -- See the documentation of Dispatch_Table_Wrapper.Offset_To_Top + if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then + + -- The parent record type has variable-size components, so the + -- instance-specific offset is stored in the tagged record, right + -- after the reference to Curr_DT (which is a secondary dispatch + -- table). + return To_Storage_Offset_Ptr (This + Tag_Size).all; + else + -- The offset is compile-time known, so it is simply stored in the + -- Offset_To_Top field. + return Curr_DT.Offset_To_Top; end if; end Offset_To_Top; diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads index 564ce205f49..a11cdd4a44d 100644 --- a/gcc/ada/libgnat/a-tags.ads +++ b/gcc/ada/libgnat/a-tags.ads @@ -380,12 +380,21 @@ private -- Prims_Ptr table. Offset_To_Top : SSE.Storage_Offset; - TSD : System.Address; + -- Offset between the _Tag field and the field that contains the + -- reference to this dispatch table. For primary dispatch tables it is + -- zero. For secondary dispatch tables: if the parent record type (if + -- any) has a compile-time-known size, then Offset_To_Top contains the + -- expected value, otherwise it contains SSE.Storage_Offset'Last and the + -- actual offset is to be found in the tagged record, right after the + -- field that contains the reference to this dispatch table. See the + -- implementation of Ada.Tags.Offset_To_Top for the corresponding logic. + + TSD : System.Address; Prims_Ptr : aliased Address_Array (1 .. Num_Prims); -- The size of the Prims_Ptr array actually depends on the tagged type -- to which it applies. For each tagged type, the expander computes the - -- actual array size, allocates the Dispatch_Table record accordingly. + -- actual array size, allocating the Dispatch_Table record accordingly. end record; type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper; diff --git a/gcc/ada/libgnat/s-parame.adb b/gcc/ada/libgnat/s-parame.adb index 0f4d45f2da8..27e352f2b46 100644 --- a/gcc/ada/libgnat/s-parame.adb +++ b/gcc/ada/libgnat/s-parame.adb @@ -50,6 +50,32 @@ package body System.Parameters is end if; end Adjust_Storage_Size; + ---------------------------- + -- Default_Sec_Stack_Size -- + ---------------------------- + + function Default_Sec_Stack_Size return Size_Type is + Default_SS_Size : Integer; + pragma Import (C, Default_SS_Size, + "__gnat_default_ss_size"); + begin + -- There are two situations where the default secondary stack size is + -- set to zero: + -- * The user sets it to zero erroneously thinking it will disable + -- the secondary stack. + -- * Or more likely, we are building with an old compiler and + -- Default_SS_Size is never set. + -- + -- In both case set the default secondary stack size to the run-time + -- default. + + if Default_SS_Size > 0 then + return Size_Type (Default_SS_Size); + else + return Runtime_Default_Sec_Stack_Size; + end if; + end Default_Sec_Stack_Size; + ------------------------ -- Default_Stack_Size -- ------------------------ diff --git a/gcc/ada/libgnat/s-parame.ads b/gcc/ada/libgnat/s-parame.ads index f48c7e0973f..60a5e997021 100644 --- a/gcc/ada/libgnat/s-parame.ads +++ b/gcc/ada/libgnat/s-parame.ads @@ -64,20 +64,6 @@ package System.Parameters is Unspecified_Size : constant Size_Type := Size_Type'First; -- Value used to indicate that no size type is set - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - function Default_Stack_Size return Size_Type; -- Default task stack size used if none is specified @@ -94,15 +80,27 @@ package System.Parameters is -- otherwise return given Size Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. + -- Assumed size of the environment task, if no other information is + -- available. This value is used when stack checking is enabled and + -- no GNAT_STACK_LIMIT environment variable is set. Stack_Grows_Down : constant Boolean := True; -- This constant indicates whether the stack grows up (False) or -- down (True) in memory as functions are called. It is used for -- proper implementation of the stack overflow check. + Runtime_Default_Sec_Stack_Size : constant Size_Type := 10 * 1024; + -- The run-time chosen default size for secondary stacks that may be + -- overriden by the user with the use of binder -D switch. + + function Default_Sec_Stack_Size return Size_Type; + -- The default initial size for secondary stacks that reflects any user + -- specified default via the binder -D switch. + + Sec_Stack_Dynamic : constant Boolean := True; + -- Indicates if secondary stacks can grow and shrink at run-time. If False, + -- the size of a secondary stack is fixed at the point of its creation. + ---------------------------------------------- -- Characteristics of types in Interfaces.C -- ---------------------------------------------- diff --git a/gcc/ada/libgnat/s-parame__ae653.ads b/gcc/ada/libgnat/s-parame__ae653.ads index 8a787f007bc..42d438e72ea 100644 --- a/gcc/ada/libgnat/s-parame__ae653.ads +++ b/gcc/ada/libgnat/s-parame__ae653.ads @@ -62,20 +62,6 @@ package System.Parameters is Unspecified_Size : constant Size_Type := Size_Type'First; -- Value used to indicate that no size type is set - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := 25; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - function Default_Stack_Size return Size_Type; -- Default task stack size used if none is specified @@ -103,6 +89,18 @@ package System.Parameters is -- down (True) in memory as functions are called. It is used for -- proper implementation of the stack overflow check. + Runtime_Default_Sec_Stack_Size : constant Size_Type := 10 * 1024; + -- The run-time chosen default size for secondary stacks that may be + -- overriden by the user with the use of binder -D switch. + + function Default_Sec_Stack_Size return Size_Type; + -- The default size for secondary stacks that reflects any user specified + -- default via the binder -D switch. + + Sec_Stack_Dynamic : constant Boolean := False; + -- Indicates if secondary stacks can grow and shrink at run-time. If False, + -- the size of a secondary stack is fixed at the point of its creation. + ---------------------------------------------- -- Characteristics of types in Interfaces.C -- ---------------------------------------------- diff --git a/gcc/ada/libgnat/s-parame__hpux.ads b/gcc/ada/libgnat/s-parame__hpux.ads index f20cfbebe7e..846b165561e 100644 --- a/gcc/ada/libgnat/s-parame__hpux.ads +++ b/gcc/ada/libgnat/s-parame__hpux.ads @@ -62,20 +62,6 @@ package System.Parameters is Unspecified_Size : constant Size_Type := Size_Type'First; -- Value used to indicate that no size type is set - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - function Default_Stack_Size return Size_Type; -- Default task stack size used if none is specified @@ -101,6 +87,18 @@ package System.Parameters is -- down (True) in memory as functions are called. It is used for -- proper implementation of the stack overflow check. + Runtime_Default_Sec_Stack_Size : constant Size_Type := 10 * 1024; + -- The run-time chosen default size for secondary stacks that may be + -- overriden by the user with the use of binder -D switch. + + function Default_Sec_Stack_Size return Size_Type; + -- The default initial size for secondary stacks that reflects any user + -- specified default via the binder -D switch. + + Sec_Stack_Dynamic : constant Boolean := True; + -- Indicates if secondary stacks can grow and shrink at run-time. If False, + -- the size of a secondary stack is fixed at the point of its creation. + ---------------------------------------------- -- Characteristics of Types in Interfaces.C -- ---------------------------------------------- diff --git a/gcc/ada/libgnat/s-parame__rtems.adb b/gcc/ada/libgnat/s-parame__rtems.adb index aa131147eb6..5a19c4396da 100644 --- a/gcc/ada/libgnat/s-parame__rtems.adb +++ b/gcc/ada/libgnat/s-parame__rtems.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,6 +39,35 @@ package body System.Parameters is pragma Import (C, ada_pthread_minimum_stack_size, "_ada_pthread_minimum_stack_size"); + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + + else + return Size; + end if; + end Adjust_Storage_Size; + + ---------------------------- + -- Default_Sec_Stack_Size -- + ---------------------------- + + function Default_Sec_Stack_Size return Size_Type is + Default_SS_Size : Integer; + pragma Import (C, Default_SS_Size, + "__gnat_default_ss_size"); + begin + return Size_Type (Default_SS_Size); + end Default_Sec_Stack_Size; + ------------------------ -- Default_Stack_Size -- ------------------------ @@ -58,21 +87,4 @@ package body System.Parameters is return Size_Type (ada_pthread_minimum_stack_size); end Minimum_Stack_Size; - ------------------------- - -- Adjust_Storage_Size -- - ------------------------- - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type is - begin - if Size = Unspecified_Size then - return Default_Stack_Size; - - elsif Size < Minimum_Stack_Size then - return Minimum_Stack_Size; - - else - return Size; - end if; - end Adjust_Storage_Size; - end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame__vxworks.adb b/gcc/ada/libgnat/s-parame__vxworks.adb index 325aa2e4f08..97d74b6932e 100644 --- a/gcc/ada/libgnat/s-parame__vxworks.adb +++ b/gcc/ada/libgnat/s-parame__vxworks.adb @@ -48,6 +48,18 @@ package body System.Parameters is end if; end Adjust_Storage_Size; + ---------------------------- + -- Default_Sec_Stack_Size -- + ---------------------------- + + function Default_Sec_Stack_Size return Size_Type is + Default_SS_Size : Integer; + pragma Import (C, Default_SS_Size, + "__gnat_default_ss_size"); + begin + return Size_Type (Default_SS_Size); + end Default_Sec_Stack_Size; + ------------------------ -- Default_Stack_Size -- ------------------------ diff --git a/gcc/ada/libgnat/s-parame__vxworks.ads b/gcc/ada/libgnat/s-parame__vxworks.ads index 919361ad10d..e395e017b05 100644 --- a/gcc/ada/libgnat/s-parame__vxworks.ads +++ b/gcc/ada/libgnat/s-parame__vxworks.ads @@ -62,20 +62,6 @@ package System.Parameters is Unspecified_Size : constant Size_Type := Size_Type'First; -- Value used to indicate that no size type is set - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - function Default_Stack_Size return Size_Type; -- Default task stack size used if none is specified @@ -103,6 +89,18 @@ package System.Parameters is -- down (True) in memory as functions are called. It is used for -- proper implementation of the stack overflow check. + Runtime_Default_Sec_Stack_Size : constant Size_Type := 10 * 1024; + -- The run-time chosen default size for secondary stacks that may be + -- overriden by the user with the use of binder -D switch. + + function Default_Sec_Stack_Size return Size_Type; + -- The default initial size for secondary stacks that reflects any user + -- specified default via the binder -D switch. + + Sec_Stack_Dynamic : constant Boolean := True; + -- Indicates if secondary stacks can grow and shrink at run-time. If False, + -- the size of a secondary stack is fixed at the point of its creation. + ---------------------------------------------- -- Characteristics of types in Interfaces.C -- ---------------------------------------------- diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb index 0449ee4dbcd..b39cf0dc33d 100644 --- a/gcc/ada/libgnat/s-secsta.adb +++ b/gcc/ada/libgnat/s-secsta.adb @@ -31,203 +31,65 @@ pragma Compiler_Unit_Warning; -with System.Soft_Links; -with System.Parameters; - with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; +with System.Soft_Links; package body System.Secondary_Stack is package SSL renames System.Soft_Links; - use type SSE.Storage_Offset; use type System.Parameters.Size_Type; - SS_Ratio_Dynamic : constant Boolean := - Parameters.Sec_Stack_Percentage = Parameters.Dynamic; - -- There are two entirely different implementations of the secondary - -- stack mechanism in this unit, and this Boolean is used to select - -- between them (at compile time, so the generated code will contain - -- only the code for the desired variant). If SS_Ratio_Dynamic is - -- True, then the secondary stack is dynamically allocated from the - -- heap in a linked list of chunks. If SS_Ration_Dynamic is False, - -- then the secondary stack is allocated statically by grabbing a - -- section of the primary stack and using it for this purpose. - - type Memory is array (SS_Ptr range <>) of SSE.Storage_Element; - for Memory'Alignment use Standard'Maximum_Alignment; - -- This is the type used for actual allocation of secondary stack - -- areas. We require maximum alignment for all such allocations. - - --------------------------------------------------------------- - -- Data Structures for Dynamically Allocated Secondary Stack -- - --------------------------------------------------------------- - - -- The following is a diagram of the data structures used for the - -- case of a dynamically allocated secondary stack, where the stack - -- is allocated as a linked list of chunks allocated from the heap. - - -- +------------------+ - -- | Next | - -- +------------------+ - -- | | Last (200) - -- | | - -- | | - -- | | - -- | | - -- | | - -- | | First (101) - -- +------------------+ - -- +----------> | | | - -- | +--------- | ------+ - -- | ^ | - -- | | | - -- | | V - -- | +------ | ---------+ - -- | | | | - -- | +------------------+ - -- | | | Last (100) - -- | | C | - -- | | H | - -- +-----------------+ | +------->| U | - -- | Current_Chunk ----+ | | N | - -- +-----------------+ | | K | - -- | Top --------+ | | First (1) - -- +-----------------+ +------------------+ - -- | Default_Size | | Prev | - -- +-----------------+ +------------------+ - -- - - type Chunk_Id (First, Last : SS_Ptr); - type Chunk_Ptr is access all Chunk_Id; - - type Chunk_Id (First, Last : SS_Ptr) is record - Prev, Next : Chunk_Ptr; - Mem : Memory (First .. Last); - end record; - - type Stack_Id is record - Top : SS_Ptr; - Default_Size : SSE.Storage_Count; - Current_Chunk : Chunk_Ptr; - end record; - - type Stack_Ptr is access Stack_Id; - -- Pointer to record used to represent a dynamically allocated secondary - -- stack descriptor for a secondary stack chunk. - procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); -- Free a dynamically allocated chunk - function To_Stack_Ptr is new - Ada.Unchecked_Conversion (Address, Stack_Ptr); - function To_Addr is new - Ada.Unchecked_Conversion (Stack_Ptr, Address); - -- Convert to and from address stored in task data structures - - -------------------------------------------------------------- - -- Data Structures for Statically Allocated Secondary Stack -- - -------------------------------------------------------------- - - -- For the static case, the secondary stack is a single contiguous - -- chunk of storage, carved out of the primary stack, and represented - -- by the following data structure - - type Fixed_Stack_Id is record - Top : SS_Ptr; - -- Index of next available location in Mem. This is initialized to - -- 0, and then incremented on Allocate, and Decremented on Release. - - Last : SS_Ptr; - -- Length of usable Mem array, which is thus the index past the - -- last available location in Mem. Mem (Last-1) can be used. This - -- is used to check that the stack does not overflow. - - Max : SS_Ptr; - -- Maximum value of Top. Initialized to 0, and then may be incremented - -- on Allocate, but is never Decremented. The last used location will - -- be Mem (Max - 1), so Max is the maximum count of used stack space. - - Mem : Memory (0 .. 0); - -- This is the area that is actually used for the secondary stack. - -- Note that the upper bound is a dummy value properly defined by - -- the value of Last. We never actually allocate objects of type - -- Fixed_Stack_Id, so the bounds declared here do not matter. - end record; - - Dummy_Fixed_Stack : Fixed_Stack_Id; - pragma Warnings (Off, Dummy_Fixed_Stack); - -- Well it is not quite true that we never allocate an object of the - -- type. This dummy object is allocated for the purpose of getting the - -- offset of the Mem field via the 'Position attribute (such a nuisance - -- that we cannot apply this to a field of a type). - - type Fixed_Stack_Ptr is access Fixed_Stack_Id; - -- Pointer to record used to describe statically allocated sec stack - - function To_Fixed_Stack_Ptr is new - Ada.Unchecked_Conversion (Address, Fixed_Stack_Ptr); - -- Convert from address stored in task data structures - - ---------------------------------- - -- Minimum_Secondary_Stack_Size -- - ---------------------------------- - - function Minimum_Secondary_Stack_Size return Natural is - begin - return Dummy_Fixed_Stack.Mem'Position; - end Minimum_Secondary_Stack_Size; - - -------------- - -- Allocate -- - -------------- + ----------------- + -- SS_Allocate -- + ----------------- procedure SS_Allocate (Addr : out Address; Storage_Size : SSE.Storage_Count) is - Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment); - Max_Size : constant SS_Ptr := - ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) * - Max_Align; - + Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment); + Mem_Request : constant SS_Ptr := + ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) * + Max_Align; + -- Round up Storage_Size to the nearest multiple of the max alignment + -- value for the target. This ensures efficient stack access. + + Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; begin - -- Case of fixed allocation secondary stack - - if not SS_Ratio_Dynamic then - declare - Fixed_Stack : constant Fixed_Stack_Ptr := - To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); + -- Case of fixed secondary stack - begin - -- Check if max stack usage is increasing + if not SP.Sec_Stack_Dynamic then + -- Check if max stack usage is increasing - if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then + if Stack.Top + Mem_Request > Stack.Max then - -- If so, check if max size is exceeded + -- If so, check if the stack is exceeded, noting Stack.Top points + -- to the first free byte (so the value of Stack.Top on a fully + -- allocated stack will be Stack.Size + 1). - if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then - raise Storage_Error; - end if; + if Stack.Top + Mem_Request > Stack.Size + 1 then + raise Storage_Error; + end if; - -- Record new max usage + -- Record new max usage - Fixed_Stack.Max := Fixed_Stack.Top + Max_Size; - end if; + Stack.Max := Stack.Top + Mem_Request; + end if; - -- Set resulting address and update top of stack pointer + -- Set resulting address and update top of stack pointer - Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address; - Fixed_Stack.Top := Fixed_Stack.Top + Max_Size; - end; + Addr := Stack.Internal_Chunk.Mem (Stack.Top)'Address; + Stack.Top := Stack.Top + Mem_Request; - -- Case of dynamically allocated secondary stack + -- Case of dynamic secondary stack else declare - Stack : constant Stack_Ptr := - To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); Chunk : Chunk_Ptr; To_Be_Released_Chunk : Chunk_Ptr; @@ -235,7 +97,7 @@ package body System.Secondary_Stack is begin Chunk := Stack.Current_Chunk; - -- The Current_Chunk may not be the good one if a lot of release + -- The Current_Chunk may not be the best one if a lot of release -- operations have taken place. Go down the stack if necessary. while Chunk.First > Stack.Top loop @@ -246,7 +108,7 @@ package body System.Secondary_Stack is -- sufficient, if not, go to the next one and eventually create -- the necessary room. - while Chunk.Last - Stack.Top + 1 < Max_Size loop + while Chunk.Last - Stack.Top + 1 < Mem_Request loop if Chunk.Next /= null then -- Release unused non-first empty chunk @@ -262,11 +124,11 @@ package body System.Secondary_Stack is -- Create new chunk of default size unless it is not sufficient -- to satisfy the current request. - elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then + elsif Mem_Request <= Stack.Size then Chunk.Next := new Chunk_Id (First => Chunk.Last + 1, - Last => Chunk.Last + SS_Ptr (Stack.Default_Size)); + Last => Chunk.Last + SS_Ptr (Stack.Size)); Chunk.Next.Prev := Chunk; @@ -276,7 +138,7 @@ package body System.Secondary_Stack is Chunk.Next := new Chunk_Id (First => Chunk.Last + 1, - Last => Chunk.Last + Max_Size); + Last => Chunk.Last + Mem_Request); Chunk.Next.Prev := Chunk; end if; @@ -288,8 +150,15 @@ package body System.Secondary_Stack is -- Resulting address is the address pointed by Stack.Top Addr := Chunk.Mem (Stack.Top)'Address; - Stack.Top := Stack.Top + Max_Size; + Stack.Top := Stack.Top + Mem_Request; Stack.Current_Chunk := Chunk; + + -- Record new max usage + + if Stack.Top > Stack.Max then + Stack.Max := Stack.Top; + end if; + end; end if; end SS_Allocate; @@ -298,40 +167,39 @@ package body System.Secondary_Stack is -- SS_Free -- ------------- - procedure SS_Free (Stk : in out Address) is + procedure SS_Free (Stack : in out SS_Stack_Ptr) is + procedure Free is + new Ada.Unchecked_Deallocation (SS_Stack, SS_Stack_Ptr); begin - -- Case of statically allocated secondary stack, nothing to free - - if not SS_Ratio_Dynamic then - return; + -- If using dynamic secondary stack, free any external chunks - -- Case of dynamically allocated secondary stack - - else + if SP.Sec_Stack_Dynamic then declare - Stack : Stack_Ptr := To_Stack_Ptr (Stk); Chunk : Chunk_Ptr; procedure Free is - new Ada.Unchecked_Deallocation (Stack_Id, Stack_Ptr); + new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); begin Chunk := Stack.Current_Chunk; - while Chunk.Prev /= null loop - Chunk := Chunk.Prev; - end loop; + -- Go to top of linked list and free backwards. Do not free the + -- internal chunk as it is part of SS_Stack. while Chunk.Next /= null loop Chunk := Chunk.Next; - Free (Chunk.Prev); end loop; - Free (Chunk); - Free (Stack); - Stk := Null_Address; + while Chunk.Prev /= null loop + Chunk := Chunk.Prev; + Free (Chunk.Next); + end loop; end; end if; + + if Stack.Freeable then + Free (Stack); + end if; end SS_Free; ---------------- @@ -339,17 +207,13 @@ package body System.Secondary_Stack is ---------------- function SS_Get_Max return Long_Long_Integer is + Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; begin - if SS_Ratio_Dynamic then - return -1; - else - declare - Fixed_Stack : constant Fixed_Stack_Ptr := - To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); - begin - return Long_Long_Integer (Fixed_Stack.Max); - end; - end if; + -- Stack.Max points to the first untouched byte in the stack, thus the + -- maximum number of bytes that have been allocated on the stack is one + -- less the value of Stack.Max. + + return Long_Long_Integer (Stack.Max - 1); end SS_Get_Max; ------------- @@ -357,32 +221,25 @@ package body System.Secondary_Stack is ------------- procedure SS_Info is + Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; begin Put_Line ("Secondary Stack information:"); -- Case of fixed secondary stack - if not SS_Ratio_Dynamic then - declare - Fixed_Stack : constant Fixed_Stack_Ptr := - To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); - - begin - Put_Line (" Total size : " - & SS_Ptr'Image (Fixed_Stack.Last) - & " bytes"); + if not SP.Sec_Stack_Dynamic then + Put_Line (" Total size : " + & SS_Ptr'Image (Stack.Size) + & " bytes"); - Put_Line (" Current allocated space : " - & SS_Ptr'Image (Fixed_Stack.Top) - & " bytes"); - end; + Put_Line (" Current allocated space : " + & SS_Ptr'Image (Stack.Top - 1) + & " bytes"); - -- Case of dynamically allocated secondary stack + -- Case of dynamic secondary stack else declare - Stack : constant Stack_Ptr := - To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); Nb_Chunks : Integer := 1; Chunk : Chunk_Ptr := Stack.Current_Chunk; @@ -414,7 +271,7 @@ package body System.Secondary_Stack is & Integer'Image (Nb_Chunks)); Put_Line (" Default size of Chunks : " - & SSE.Storage_Count'Image (Stack.Default_Size)); + & SP.Size_Type'Image (Stack.Size)); end; end if; end SS_Info; @@ -424,42 +281,86 @@ package body System.Secondary_Stack is ------------- procedure SS_Init - (Stk : in out Address; - Size : Natural := Default_Secondary_Stack_Size) + (Stack : in out SS_Stack_Ptr; + Size : SP.Size_Type := SP.Unspecified_Size) is - begin - -- Case of fixed size secondary stack - - if not SS_Ratio_Dynamic then - declare - Fixed_Stack : constant Fixed_Stack_Ptr := - To_Fixed_Stack_Ptr (Stk); - - begin - Fixed_Stack.Top := 0; - Fixed_Stack.Max := 0; - - if Size <= Dummy_Fixed_Stack.Mem'Position then - Fixed_Stack.Last := 0; - else - Fixed_Stack.Last := - SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position; - end if; - end; - - -- Case of dynamically allocated secondary stack + use Parameters; - else - declare - Stack : Stack_Ptr; - begin - Stack := new Stack_Id; - Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size)); - Stack.Top := 1; - Stack.Default_Size := SSE.Storage_Count (Size); - Stk := To_Addr (Stack); - end; + Stack_Size : Size_Type; + begin + -- If Stack is not null then the stack has been allocated outside the + -- package (by the compiler or the user) and all that is left to do is + -- initialize the stack. Otherwise, SS_Init will allocate a secondary + -- stack from either the heap or the default-sized secondary stack pool + -- generated by the binder. In the later case, this pool is generated + -- only when the either No_Implicit_Heap_Allocations + -- or No_Implicit_Task_Allocations are active, and SS_Init will allocate + -- all requests for a secondary stack of Unspecified_Size from this + -- pool. + + if Stack = null then + if Size = Unspecified_Size then + Stack_Size := Default_Sec_Stack_Size; + else + Stack_Size := Size; + end if; + + if Size = Unspecified_Size + and then Binder_SS_Count > 0 + and then Num_Of_Assigned_Stacks < Binder_SS_Count + then + -- The default-sized secondary stack pool is passed from the + -- binder to this package as an Address since it is not possible + -- to have a pointer to an array of unconstrained objects. A + -- pointer to the pool is obtainable via an unchecked conversion + -- to a constrained array of SS_Stacks that mirrors the one used + -- by the binder. + + -- However, Ada understandably does not allow a local pointer to + -- a stack in the pool to be stored in a pointer outside of this + -- scope. While the conversion is safe in this case, since a view + -- of a global object is being used, using Unchecked_Access + -- would prevent users from specifying the restriction + -- No_Unchecked_Access whenever the secondary stack is used. As + -- a workaround, the local stack pointer is converted to a global + -- pointer via System.Address. + + declare + type Stk_Pool_Array is array (1 .. Binder_SS_Count) of + aliased SS_Stack (Default_SS_Size); + type Stk_Pool_Access is access Stk_Pool_Array; + + function To_Stack_Pool is new + Ada.Unchecked_Conversion (Address, Stk_Pool_Access); + + pragma Warnings (Off); + function To_Global_Ptr is new + Ada.Unchecked_Conversion (Address, SS_Stack_Ptr); + pragma Warnings (On); + -- Suppress aliasing warning since the pointer we return will + -- be the only access to the stack. + + Local_Stk_Address : System.Address; + + begin + Num_Of_Assigned_Stacks := Num_Of_Assigned_Stacks + 1; + + Local_Stk_Address := + To_Stack_Pool + (Default_Sized_SS_Pool) (Num_Of_Assigned_Stacks)'Address; + Stack := To_Global_Ptr (Local_Stk_Address); + end; + + Stack.Freeable := False; + else + Stack := new SS_Stack (Stack_Size); + Stack.Freeable := True; + end if; end if; + + Stack.Top := 1; + Stack.Max := 1; + Stack.Current_Chunk := Stack.Internal_Chunk'Access; end SS_Init; ------------- @@ -467,13 +368,9 @@ package body System.Secondary_Stack is ------------- function SS_Mark return Mark_Id is - Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all; + Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; begin - if SS_Ratio_Dynamic then - return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top); - else - return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top); - end if; + return (Sec_Stack => Stack, Sptr => Stack.Top); end SS_Mark; ---------------- @@ -482,66 +379,7 @@ package body System.Secondary_Stack is procedure SS_Release (M : Mark_Id) is begin - if SS_Ratio_Dynamic then - To_Stack_Ptr (M.Sstk).Top := M.Sptr; - else - To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr; - end if; + M.Sec_Stack.Top := M.Sptr; end SS_Release; - ------------------------- - -- Package Elaboration -- - ------------------------- - - -- Allocate a secondary stack for the main program to use - - -- We make sure that the stack has maximum alignment. Some systems require - -- this (e.g. Sparc), and in any case it is a good idea for efficiency. - - Stack : aliased Stack_Id; - for Stack'Alignment use Standard'Maximum_Alignment; - - Static_Secondary_Stack_Size : constant := 10 * 1024; - -- Static_Secondary_Stack_Size must be static so that Chunk is allocated - -- statically, and not via dynamic memory allocation. - - Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size); - for Chunk'Alignment use Standard'Maximum_Alignment; - -- Default chunk used, unless gnatbind -D is specified with a value greater - -- than Static_Secondary_Stack_Size. - -begin - declare - Chunk_Address : Address; - Chunk_Access : Chunk_Ptr; - - begin - if Default_Secondary_Stack_Size <= Static_Secondary_Stack_Size then - - -- Normally we allocate the secondary stack for the main program - -- statically, using the default secondary stack size. - - Chunk_Access := Chunk'Access; - - else - -- Default_Secondary_Stack_Size was increased via gnatbind -D, so we - -- need to allocate a chunk dynamically. - - Chunk_Access := - new Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size)); - end if; - - if SS_Ratio_Dynamic then - Stack.Top := 1; - Stack.Current_Chunk := Chunk_Access; - Stack.Default_Size := - SSE.Storage_Offset (Default_Secondary_Stack_Size); - System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address); - - else - Chunk_Address := Chunk_Access.all'Address; - SS_Init (Chunk_Address, Default_Secondary_Stack_Size); - System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address); - end if; - end; end System.Secondary_Stack; diff --git a/gcc/ada/libgnat/s-secsta.ads b/gcc/ada/libgnat/s-secsta.ads index 534708d1a6f..ae5ec888453 100644 --- a/gcc/ada/libgnat/s-secsta.ads +++ b/gcc/ada/libgnat/s-secsta.ads @@ -31,41 +31,27 @@ pragma Compiler_Unit_Warning; +with System.Parameters; with System.Storage_Elements; package System.Secondary_Stack is + pragma Preelaborate; + package SP renames System.Parameters; package SSE renames System.Storage_Elements; - Default_Secondary_Stack_Size : Natural := 10 * 1024; - -- Default size of a secondary stack. May be modified by binder -D switch - -- which causes the binder to generate an appropriate assignment in the - -- binder generated file. + type SS_Stack (Size : SP.Size_Type) is private; + -- Data structure for secondary stacks - function Minimum_Secondary_Stack_Size return Natural; - -- The minimum size of the secondary stack so that the internal - -- requirements of the stack are met. + type SS_Stack_Ptr is access all SS_Stack; + -- Pointer to secondary stack objects procedure SS_Init - (Stk : in out Address; - Size : Natural := Default_Secondary_Stack_Size); - -- Initialize the secondary stack with a main stack of the given Size. - -- - -- If System.Parameters.Sec_Stack_Percentage equals Dynamic, Stk is really - -- an OUT parameter that will be allocated on the heap. Then all further - -- allocations which do not overflow the main stack will not generate - -- dynamic (de)allocation calls. If the main Stack overflows, a new - -- chuck of at least the same size will be allocated and linked to the - -- previous chunk. - -- - -- Otherwise (Sec_Stack_Percentage between 0 and 100), Stk is an IN - -- parameter that is already pointing to a Stack_Id. The secondary stack - -- in this case is fixed, and any attempt to allocate more than the initial - -- size will result in a Storage_Error being raised. - -- - -- Note: the reason that Stk is passed is that SS_Init is called before - -- the proper interface is established to obtain the address of the - -- stack using System.Soft_Links.Get_Sec_Stack_Addr. + (Stack : in out SS_Stack_Ptr; + Size : SP.Size_Type := SP.Unspecified_Size); + -- Initialize the secondary stack Stack. If Stack is null allocate a stack + -- from the heap or from the default-sized secondary stack pool if the + -- pool exists and the requested size is Unspecified_Size. procedure SS_Allocate (Addr : out Address; @@ -73,10 +59,9 @@ package System.Secondary_Stack is -- Allocate enough space for a 'Storage_Size' bytes object with Maximum -- alignment. The address of the allocated space is returned in Addr. - procedure SS_Free (Stk : in out Address); - -- Release the memory allocated for the Secondary Stack. That is - -- to say, all the allocated chunks. Upon return, Stk will be set - -- to System.Null_Address. + procedure SS_Free (Stack : in out SS_Stack_Ptr); + -- Release the memory allocated for the Stack. If the stack was statically + -- allocated the SS_Stack record is not freed. type Mark_Id is private; -- Type used to mark the stack for mark/release processing @@ -85,17 +70,11 @@ package System.Secondary_Stack is -- Return the Mark corresponding to the current state of the stack procedure SS_Release (M : Mark_Id); - -- Restore the state of the stack corresponding to the mark M. If an - -- additional chunk have been allocated, it will never be freed during a - -- ??? missing comment here + -- Restore the state of the stack corresponding to the mark M function SS_Get_Max return Long_Long_Integer; - -- Return maximum used space in storage units for the current secondary - -- stack. For a dynamically allocated secondary stack, the returned - -- result is always -1. For a statically allocated secondary stack, - -- the returned value shows the largest amount of space allocated so - -- far during execution of the program to the current secondary stack, - -- i.e. the secondary stack for the current task. + -- Return the high water mark of the secondary stack for the current + -- secondary stack in bytes. generic with procedure Put_Line (S : String); @@ -109,15 +88,142 @@ private -- Unused entity that is just present to ease the sharing of the pool -- mechanism for specific allocation/deallocation in the compiler - type SS_Ptr is new SSE.Integer_Address; - -- Stack pointer value for secondary stack + ------------------------------------- + -- Secondary Stack Data Structures -- + ------------------------------------- + + -- This package provides fixed and dynamically sized secondary stack + -- implementations centered around a common data structure SS_Stack. This + -- record contains an initial secondary stack allocation of the requested + -- size, and markers for the current top of the stack and the high-water + -- mark of the stack. A SS_Stack can be either pre-allocated outside the + -- package or SS_Init can allocate a stack from the heap or the + -- default-sized secondary stack from a pool generated by the binder. + + -- For dynamically allocated secondary stacks, the stack can grow via a + -- linked list of stack chunks allocated from the heap. New chunks are + -- allocated once the initial static allocation and any existing chunks are + -- exhausted. The following diagram illustrated the data structures used + -- for a dynamically allocated secondary stack: + -- + -- +------------------+ + -- | Next | + -- +------------------+ + -- | | Last (300) + -- | | + -- | | + -- | | + -- | | + -- | | + -- | | First (201) + -- +------------------+ + -- +-----------------+ +------> | | | + -- | | (100) | +--------- | ------+ + -- | | | ^ | + -- | | | | | + -- | | | | V + -- | | | +------ | ---------+ + -- | | | | | | + -- | | | +------------------+ + -- | | | | | Last (200) + -- | | | | C | + -- | | (1) | | H | + -- +-----------------+ | +---->| U | + -- | Current_Chunk ---------+ | | N | + -- +-----------------+ | | K | + -- | Top ------------+ | | First (101) + -- +-----------------+ +------------------+ + -- | Size | | Prev | + -- +-----------------+ +------------------+ + -- + -- The implementation used by the runtime is controlled via the constant + -- System.Parameter.Sec_Stack_Dynamic. If True, the implementation is + -- permitted to grow the secondary stack at runtime. The implementation is + -- designed for the compiler to include only code to support the desired + -- secondary stack behavior. + + subtype SS_Ptr is SP.Size_Type; + -- Stack pointer value for the current position within the secondary stack. + -- Size_Type is used as the base type since the Size discriminate of + -- SS_Stack forms the bounds of the internal memory array. + + type Memory is array (SS_Ptr range <>) of SSE.Storage_Element; + for Memory'Alignment use Standard'Maximum_Alignment; + -- The region of memory that holds the stack itself. Requires maximum + -- alignment for efficient stack operations. + + -- Chunk_Id + + -- Chunk_Id is a contiguous block of dynamically allocated stack. First + -- and Last indicate the range of secondary stack addresses present in the + -- chunk. Chunk_Ptr points to a Chunk_Id block. + + type Chunk_Id (First, Last : SS_Ptr); + type Chunk_Ptr is access all Chunk_Id; + + type Chunk_Id (First, Last : SS_Ptr) is record + Prev, Next : Chunk_Ptr; + Mem : Memory (First .. Last); + end record; + + -- Secondary stack data structure + + type SS_Stack (Size : SP.Size_Type) is record + Top : SS_Ptr; + -- Index of next available location in the stack. Initialized to 1 and + -- then incremented on Allocate and decremented on Release. + + Max : SS_Ptr; + -- Contains the high-water mark of Top. Initialized to 1 and then + -- may be incremented on Allocate but never decremented. Since + -- Top = Size + 1 represents a fully used stack, Max - 1 indicates + -- the size of the stack used in bytes. + + Current_Chunk : Chunk_Ptr; + -- A link to the chunk containing the highest range of the stack + + Freeable : Boolean; + -- Indicates if an object of this type can be freed + + Internal_Chunk : aliased Chunk_Id (1, Size); + -- Initial memory allocation of the secondary stack + end record; type Mark_Id is record - Sstk : System.Address; - Sptr : SS_Ptr; + Sec_Stack : SS_Stack_Ptr; + Sptr : SS_Ptr; end record; - -- A mark value contains the address of the secondary stack structure, - -- as returned by System.Soft_Links.Get_Sec_Stack_Addr, and a stack - -- pointer value corresponding to the point of the mark call. + -- Contains the pointer to the secondary stack object and the stack pointer + -- value corresponding to the top of the stack at the time of the mark + -- call. + + ------------------------------------ + -- Binder Allocated Stack Support -- + ------------------------------------ + + -- When the No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations + -- restrictions are in effect the binder statically generates secondary + -- stacks for tasks who are using default-sized secondary stack. Assignment + -- of these stacks to tasks is handled by SS_Init. The following variables + -- assist SS_Init and are defined here so the runtime does not depend on + -- the binder. + + Binder_SS_Count : Natural; + pragma Export (Ada, Binder_SS_Count, "__gnat_binder_ss_count"); + -- The number of default sized secondary stacks allocated by the binder + + Default_SS_Size : SP.Size_Type; + pragma Export (Ada, Default_SS_Size, "__gnat_default_ss_size"); + -- The default size for secondary stacks. Defined here and not in init.c/ + -- System.Init because these locations are not present on ZFP or + -- Ravenscar-SFP run-times. + + Default_Sized_SS_Pool : System.Address; + pragma Export (Ada, Default_Sized_SS_Pool, "__gnat_default_ss_pool"); + -- Address to the secondary stack pool generated by the binder that + -- contains default sized stacks. + + Num_Of_Assigned_Stacks : Natural := 0; + -- The number of currently allocated secondary stacks end System.Secondary_Stack; diff --git a/gcc/ada/libgnat/s-soflin.adb b/gcc/ada/libgnat/s-soflin.adb index f604f4df3be..94ead0306fa 100644 --- a/gcc/ada/libgnat/s-soflin.adb +++ b/gcc/ada/libgnat/s-soflin.adb @@ -35,25 +35,19 @@ pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get an -- infinite loop from the code within the Poll routine itself. -with System.Parameters; - pragma Warnings (Off); --- Disable warnings since System.Secondary_Stack is currently not Preelaborate -with System.Secondary_Stack; +-- Disable warnings as System.Soft_Links.Initialize is not Preelaborate. It is +-- safe to with this unit as its elaboration routine will only be initializing +-- NT_TSD, which is part of this package spec. +with System.Soft_Links.Initialize; pragma Warnings (On); package body System.Soft_Links is - package SST renames System.Secondary_Stack; - - NT_TSD : TSD; - -- Note: we rely on the default initialization of NT_TSD - - -- Needed for Vx6Cert (Vx653mc) GOS cert and ravenscar-cert runtimes, - -- VxMILS cert, ravenscar-cert and full runtimes, Vx 5 default runtime Stack_Limit : aliased System.Address := System.Null_Address; - pragma Export (C, Stack_Limit, "__gnat_stack_limit"); + -- Needed for Vx6Cert (Vx653mc) GOS cert and ravenscar-cert runtimes, + -- VxMILS cert, ravenscar-cert and full runtimes, Vx 5 default runtime -------------------- -- Abort_Defer_NT -- @@ -125,14 +119,16 @@ package body System.Soft_Links is -- Create_TSD -- ---------------- - procedure Create_TSD (New_TSD : in out TSD) is - use Parameters; - SS_Ratio_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; + procedure Create_TSD + (New_TSD : in out TSD; + Sec_Stack : SST.SS_Stack_Ptr; + Sec_Stack_Size : System.Parameters.Size_Type) + is begin - if SS_Ratio_Dynamic then - SST.SS_Init - (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size); - end if; + New_TSD.Jmpbuf_Address := Null_Address; + + New_TSD.Sec_Stack_Ptr := Sec_Stack; + SST.SS_Init (New_TSD.Sec_Stack_Ptr, Sec_Stack_Size); end Create_TSD; ----------------------- @@ -150,7 +146,7 @@ package body System.Soft_Links is procedure Destroy_TSD (Old_TSD : in out TSD) is begin - SST.SS_Free (Old_TSD.Sec_Stack_Addr); + SST.SS_Free (Old_TSD.Sec_Stack_Ptr); end Destroy_TSD; --------------------- @@ -198,23 +194,23 @@ package body System.Soft_Links is return Get_Jmpbuf_Address.all; end Get_Jmpbuf_Address_Soft; - --------------------------- - -- Get_Sec_Stack_Addr_NT -- - --------------------------- + ---------------------- + -- Get_Sec_Stack_NT -- + ---------------------- - function Get_Sec_Stack_Addr_NT return Address is + function Get_Sec_Stack_NT return SST.SS_Stack_Ptr is begin - return NT_TSD.Sec_Stack_Addr; - end Get_Sec_Stack_Addr_NT; + return NT_TSD.Sec_Stack_Ptr; + end Get_Sec_Stack_NT; ----------------------------- - -- Get_Sec_Stack_Addr_Soft -- + -- Get_Sec_Stack_Soft -- ----------------------------- - function Get_Sec_Stack_Addr_Soft return Address is + function Get_Sec_Stack_Soft return SST.SS_Stack_Ptr is begin - return Get_Sec_Stack_Addr.all; - end Get_Sec_Stack_Addr_Soft; + return Get_Sec_Stack.all; + end Get_Sec_Stack_Soft; ----------------------- -- Get_Stack_Info_NT -- @@ -254,23 +250,23 @@ package body System.Soft_Links is Set_Jmpbuf_Address (Addr); end Set_Jmpbuf_Address_Soft; - --------------------------- - -- Set_Sec_Stack_Addr_NT -- - --------------------------- + ---------------------- + -- Set_Sec_Stack_NT -- + ---------------------- - procedure Set_Sec_Stack_Addr_NT (Addr : Address) is + procedure Set_Sec_Stack_NT (Stack : SST.SS_Stack_Ptr) is begin - NT_TSD.Sec_Stack_Addr := Addr; - end Set_Sec_Stack_Addr_NT; + NT_TSD.Sec_Stack_Ptr := Stack; + end Set_Sec_Stack_NT; - ----------------------------- - -- Set_Sec_Stack_Addr_Soft -- - ----------------------------- + ------------------------ + -- Set_Sec_Stack_Soft -- + ------------------------ - procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is + procedure Set_Sec_Stack_Soft (Stack : SST.SS_Stack_Ptr) is begin - Set_Sec_Stack_Addr (Addr); - end Set_Sec_Stack_Addr_Soft; + Set_Sec_Stack (Stack); + end Set_Sec_Stack_Soft; ------------------ -- Task_Lock_NT -- @@ -308,5 +304,4 @@ package body System.Soft_Links is begin null; end Task_Unlock_NT; - end System.Soft_Links; diff --git a/gcc/ada/libgnat/s-soflin.ads b/gcc/ada/libgnat/s-soflin.ads index 402ea84818b..4242fcee7ee 100644 --- a/gcc/ada/libgnat/s-soflin.ads +++ b/gcc/ada/libgnat/s-soflin.ads @@ -40,11 +40,15 @@ pragma Compiler_Unit_Warning; with Ada.Exceptions; +with System.Parameters; +with System.Secondary_Stack; with System.Stack_Checking; package System.Soft_Links is pragma Preelaborate; + package SST renames System.Secondary_Stack; + subtype EOA is Ada.Exceptions.Exception_Occurrence_Access; subtype EO is Ada.Exceptions.Exception_Occurrence; @@ -89,6 +93,11 @@ package System.Soft_Links is type Set_EO_Call is access procedure (Excep : EO); pragma Favor_Top_Level (Set_EO_Call); + type Get_Stack_Call is access function return SST.SS_Stack_Ptr; + pragma Favor_Top_Level (Get_Stack_Call); + type Set_Stack_Call is access procedure (Stack : SST.SS_Stack_Ptr); + pragma Favor_Top_Level (Set_Stack_Call); + type Special_EO_Call is access procedure (Excep : EO := Current_Target_Exception); pragma Favor_Top_Level (Special_EO_Call); @@ -118,6 +127,8 @@ package System.Soft_Links is pragma Suppress (Access_Check, Set_Integer_Call); pragma Suppress (Access_Check, Get_EOA_Call); pragma Suppress (Access_Check, Set_EOA_Call); + pragma Suppress (Access_Check, Get_Stack_Call); + pragma Suppress (Access_Check, Set_Stack_Call); pragma Suppress (Access_Check, Timed_Delay_Call); pragma Suppress (Access_Check, Get_Stack_Access_Call); pragma Suppress (Access_Check, Task_Name_Call); @@ -228,11 +239,11 @@ package System.Soft_Links is Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access; Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access; - function Get_Sec_Stack_Addr_NT return Address; - procedure Set_Sec_Stack_Addr_NT (Addr : Address); + function Get_Sec_Stack_NT return SST.SS_Stack_Ptr; + procedure Set_Sec_Stack_NT (Stack : SST.SS_Stack_Ptr); - Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access; - Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access; + Get_Sec_Stack : Get_Stack_Call := Get_Sec_Stack_NT'Access; + Set_Sec_Stack : Set_Stack_Call := Set_Sec_Stack_NT'Access; function Get_Current_Excep_NT return EOA; @@ -320,19 +331,14 @@ package System.Soft_Links is -- must be initialized to the tasks requested stack size before the task -- can do its first stack check. - pragma Warnings (Off); - -- Needed because we are giving a non-static default to an object in - -- a preelaborated unit, which is formally not permitted, but OK here. - - Jmpbuf_Address : System.Address := System.Null_Address; + Jmpbuf_Address : System.Address; -- Address of jump buffer used to store the address of the current -- longjmp/setjmp buffer for exception management. These buffers are -- threaded into a stack, and the address here is the top of the stack. -- A null address means that no exception handler is currently active. - Sec_Stack_Addr : System.Address := System.Null_Address; - pragma Warnings (On); - -- Address of currently allocated secondary stack + Sec_Stack_Ptr : SST.SS_Stack_Ptr; + -- Pointer of the allocated secondary stack Current_Excep : aliased EO; -- Exception occurrence that contains the information for the current @@ -344,7 +350,10 @@ package System.Soft_Links is -- exception mechanism, organized as a stack with the most recent first. end record; - procedure Create_TSD (New_TSD : in out TSD); + procedure Create_TSD + (New_TSD : in out TSD; + Sec_Stack : SST.SS_Stack_Ptr; + Sec_Stack_Size : System.Parameters.Size_Type); pragma Inline (Create_TSD); -- Called from s-tassta when a new thread is created to perform -- any required initialization of the TSD. @@ -370,10 +379,10 @@ package System.Soft_Links is pragma Inline (Get_Jmpbuf_Address_Soft); pragma Inline (Set_Jmpbuf_Address_Soft); - function Get_Sec_Stack_Addr_Soft return Address; - procedure Set_Sec_Stack_Addr_Soft (Addr : Address); - pragma Inline (Get_Sec_Stack_Addr_Soft); - pragma Inline (Set_Sec_Stack_Addr_Soft); + function Get_Sec_Stack_Soft return SST.SS_Stack_Ptr; + procedure Set_Sec_Stack_Soft (Stack : SST.SS_Stack_Ptr); + pragma Inline (Get_Sec_Stack_Soft); + pragma Inline (Set_Sec_Stack_Soft); -- The following is a dummy record designed to mimic Communication_Block as -- defined in s-tpobop.ads: @@ -396,4 +405,11 @@ package System.Soft_Links is Comp_3 : Boolean; end record; +private + NT_TSD : TSD; + -- The task specific data for the main task when the Ada tasking run-time + -- is not used. It relies on the default initialization of NT_TSD. It is + -- placed here and not the body to ensure the default initialization does + -- not clobber the secondary stack initialization that occurs as part of + -- System.Soft_Links.Initialization. end System.Soft_Links; diff --git a/gcc/ada/libgnat/s-soliin.adb b/gcc/ada/libgnat/s-soliin.adb new file mode 100644 index 00000000000..5364e46f6f4 --- /dev/null +++ b/gcc/ada/libgnat/s-soliin.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S . I N I T I A L I Z E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Secondary_Stack; + +package body System.Soft_Links.Initialize is + + package SSS renames System.Secondary_Stack; + +begin + -- Initialize the TSD of the main task + + NT_TSD.Jmpbuf_Address := System.Null_Address; + + -- Allocate and initialize the secondary stack for the main task + + NT_TSD.Sec_Stack_Ptr := null; + SSS.SS_Init (NT_TSD.Sec_Stack_Ptr); +end System.Soft_Links.Initialize; diff --git a/gcc/ada/libgnat/s-soliin.ads b/gcc/ada/libgnat/s-soliin.ads new file mode 100644 index 00000000000..ba9cf745f48 --- /dev/null +++ b/gcc/ada/libgnat/s-soliin.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S . I N I T I A L I Z E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package exists to initialize the TSD record of the main task and in +-- the process, allocate and initialize the secondary stack for the main task. +-- The initialization routine is contained within its own package because +-- System.Soft_Links and System.Secondary_Stack are both Preelaborate packages +-- that are the parents to other Preelaborate System packages. + +-- Ideally, the secondary stack would be set up via __gnat_runtime_initialize +-- to have the secondary stack active as early as possible and to remove the +-- awkwardness of System.Soft_Links depending on a non-Preelaborate package. +-- However, as this procedure only exists from 2014, for bootstrapping +-- purposes the elaboration mechanism is used instead to perform these +-- functions. + +package System.Soft_Links.Initialize is + pragma Elaborate_Body; + -- Allow this package to have a body +end System.Soft_Links.Initialize; diff --git a/gcc/ada/libgnat/s-thread.ads b/gcc/ada/libgnat/s-thread.ads index cd4faaec1ed..185141b1f1b 100644 --- a/gcc/ada/libgnat/s-thread.ads +++ b/gcc/ada/libgnat/s-thread.ads @@ -42,10 +42,13 @@ with Ada.Unchecked_Conversion; with Interfaces.C; +with System.Secondary_Stack; with System.Soft_Links; package System.Threads is + package SST renames System.Secondary_Stack; + type ATSD is limited private; -- Type of the Ada thread specific data. It contains datas needed -- by the GNAT runtime. @@ -71,8 +74,7 @@ package System.Threads is -- wrapper in the APEX process registration package. procedure Thread_Body_Enter - (Sec_Stack_Address : System.Address; - Sec_Stack_Size : Natural; + (Sec_Stack_Ptr : SST.SS_Stack_Ptr; Process_ATSD_Address : System.Address); -- Enter thread body, see above for details diff --git a/gcc/ada/libgnat/s-thread__ae653.adb b/gcc/ada/libgnat/s-thread__ae653.adb index ca871286fce..9e8b2abb946 100644 --- a/gcc/ada/libgnat/s-thread__ae653.adb +++ b/gcc/ada/libgnat/s-thread__ae653.adb @@ -37,15 +37,11 @@ pragma Restrictions (No_Tasking); -- will be checked by the binder. with System.OS_Versions; use System.OS_Versions; -with System.Secondary_Stack; -pragma Elaborate_All (System.Secondary_Stack); package body System.Threads is use Interfaces.C; - package SSS renames System.Secondary_Stack; - package SSL renames System.Soft_Links; Current_ATSD : aliased System.Address := System.Null_Address; @@ -94,17 +90,16 @@ package body System.Threads is procedure Install_Handler; pragma Import (C, Install_Handler, "__gnat_install_handler"); - function Get_Sec_Stack_Addr return Address; + function Get_Sec_Stack return SST.SS_Stack_Ptr; - procedure Set_Sec_Stack_Addr (Addr : Address); + procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr); ----------------------- -- Thread_Body_Enter -- ----------------------- procedure Thread_Body_Enter - (Sec_Stack_Address : System.Address; - Sec_Stack_Size : Natural; + (Sec_Stack_Ptr : SST.SS_Stack_Ptr; Process_ATSD_Address : System.Address) is -- Current_ATSD must already be a taskVar of taskIdSelf. @@ -115,8 +110,8 @@ package body System.Threads is begin - TSD.Sec_Stack_Addr := Sec_Stack_Address; - SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size); + TSD.Sec_Stack_Ptr := Sec_Stack_Ptr; + SST.SS_Init (TSD.Sec_Stack_Ptr); Current_ATSD := Process_ATSD_Address; Install_Handler; @@ -166,23 +161,23 @@ package body System.Threads is pragma Assert (Result /= ERROR); begin - Main_ATSD.Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT; + Main_ATSD.Sec_Stack_Ptr := SSL.Get_Sec_Stack_NT; Current_ATSD := Main_ATSD'Address; Install_Handler; - SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; - SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; + SSL.Get_Sec_Stack := Get_Sec_Stack'Access; + SSL.Set_Sec_Stack := Set_Sec_Stack'Access; end Init_RTS; - ------------------------ - -- Get_Sec_Stack_Addr -- - ------------------------ + ------------------- + -- Get_Sec_Stack -- + ------------------- - function Get_Sec_Stack_Addr return Address is + function Get_Sec_Stack return SST.SS_Stack_Ptr is CTSD : constant ATSD_Access := From_Address (Current_ATSD); begin pragma Assert (CTSD /= null); - return CTSD.Sec_Stack_Addr; - end Get_Sec_Stack_Addr; + return CTSD.Sec_Stack_Ptr; + end Get_Sec_Stack; -------------- -- Register -- @@ -229,16 +224,16 @@ package body System.Threads is return Result; end Register; - ------------------------ - -- Set_Sec_Stack_Addr -- - ------------------------ + ------------------- + -- Set_Sec_Stack -- + ------------------- - procedure Set_Sec_Stack_Addr (Addr : Address) is + procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr) is CTSD : constant ATSD_Access := From_Address (Current_ATSD); begin pragma Assert (CTSD /= null); - CTSD.Sec_Stack_Addr := Addr; - end Set_Sec_Stack_Addr; + CTSD.Sec_Stack_Ptr := Stack; + end Set_Sec_Stack; begin -- Initialize run-time library |