diff options
| author | pmderodat <pmderodat@138bc75d-0d04-0410-961f-82ee72b054a4> | 2017-10-14 16:25:21 +0000 |
|---|---|---|
| committer | pmderodat <pmderodat@138bc75d-0d04-0410-961f-82ee72b054a4> | 2017-10-14 16:25:21 +0000 |
| commit | 1fd4bc16aba3ffeaeddcf75bd223f091dbb777ee (patch) | |
| tree | 8ca509794ef973e3ed4925e310c611f15ffee4d8 | |
| parent | 74edde2f97da812517d352b907e04d0279fc23f4 (diff) | |
| download | gcc-1fd4bc16aba3ffeaeddcf75bd223f091dbb777ee.tar.gz | |
2017-10-14 Bob Duff <duff@adacore.com>
* exp_ch6.adb (Is_Build_In_Place_Result_Type): Include code for
enabling b-i-p for nonlimited controlled types (but disabled).
2017-10-14 Justin Squirek <squirek@adacore.com>
* sem_elab.adb (Is_Suitable_Variable_Assignment): Replace call to
Has_Warnings_Off with Warnings_Off.
2017-10-14 Piotr Trojanek <trojanek@adacore.com>
* sinfo.ads (Generic_Parent): Remove wrong (possibly obsolete) comment.
2017-10-14 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch3.adb (Analyze_Declarations): Analyze the contract of an
enclosing package at the end of the visible declarations.
* sem_prag.adb (Analyze_Initialization_Item): Suppress the analysis of
an initialization item which is undefined due to some illegality.
2017-10-14 Patrick Bernardi <bernardi@adacore.com>
* ali.adb: Add new ALI line 'T' to read the number of tasks contain
within each unit that require a default-sized primary and secondary
stack to be generated by the binder.
(Scan_ALI): Scan new 'T' lines.
* ali.ads: Add Primary_Stack_Count and Sec_Stack_Count to Unit_Record.
* bindgen.adb (Gen_Output_File): Count the number of default-sized
stacks within the closure that are to be created by the binder.
(Gen_Adainit, Gen_Output_File_Ada): Generate default-sized secondary
stacks and record these in System.Secodnary_Stack.
(Resolve_Binder_Options): Check if System.Secondary_Stack is in the
closure of the program being bound.
* bindusg.adb (Display): Add "-Q" switch. Remove rouge "--RTS" comment.
* exp_ch3.adb (Count_Default_Sized_Task_Stacks): New routine.
(Expand_N_Object_Declaration): Count the number of default-sized stacks
used by task objects contained within the object whose declaration is
being expanded. Only performed when either the restrictions
No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations are in
effect.
* exp_ch9.adb (Create_Secondary_Stack_For_Task): New routine.
(Expand_N_Task_Type_Declaration): Create a secondary stack as part of
the expansion of a task type if the size of the stack is known at
run-time and the restrictions No_Implicit_Heap_Allocations or
No_Implicit_Task_Allocations are in effect.
(Make_Task_Create_Call): If using a restricted profile provide
secondary stack parameter: either the statically created stack or null.
* lib-load.adb (Create_Dummy_Package_Unit, Load_Unit,
Load_Main_Source): Include Primary_Stack_Count and Sec_Stack_Count in
Unit_Record initialization expressions.
* lib-writ.adb (Add_Preprocessing_Dependency,
Ensure_System_Dependency): Include Primary_Stack_Count and
Sec_Stack_Count in Unit_Record initialization expression.
(Write_ALI): Write T lines.
(Write_Unit_Information): Do not output 'T' lines if there are no
stacks for the binder to generate.
* lib-writ.ads: Updated library information documentation to include
new T line entry.
* lib.adb (Increment_Primary_Stack_Count): New routine.
(Increment_Sec_Stack_Count): New routine.
(Primary_Stack_Count): New routine.
(Sec_Stack_Count): New routine.
* lib.ads: Add Primary_Stack_Count and Sec_Stack_Count components to
Unit_Record and updated documentation.
(Increment_Primary_Stack_Count): New routine along with pragma Inline.
(Increment_Sec_Stack_Count): New routine along with pragma Inline.
(Primary_Stack_Count): New routine along with pragma Inline.
(Sec_Stack_Count): New routine along with pragma Inline.
* opt.ads: New constant No_Stack_Size. Flag Default_Stack_Size
redefined. New flag Default_Sec_Stack_Size and
Quantity_Of_Default_Size_Sec_Stacks.
* rtfinal.c Fixed erroneous comment.
* rtsfind.ads: Moved RE_Default_Secondary_Stack_Size from
System.Secondary_Stack to System.Parameters. Add RE_SS_Stack.
* sem_util.adb (Number_Of_Elements_In_Array): New routine.
* sem_util.ads (Number_Of_Elements_In_Array): New routine.
* switch-b.adb (Scan_Binder_Switches): Scan "-Q" switch.
* libgnarl/s-solita.adb (Get_Sec_Stack_Addr): Removed routine.
(Set_Sec_Stack_Addr): Removed routine.
(Get_Sec_Stack): New routine.
(Set_Sec_Stack): New routine.
(Init_Tasking_Soft_Links): Update System.Soft_Links reference to
reflect new procedure and global names.
* libgnarl/s-taprop__linux.adb, libgnarl/s-taprop__mingw.adb,
libgnarl/s-taprop__posix.adb, libgnarl/s-taprop__solaris.adb,
libgnarl/s-taprop__vxworks.adb (Register_Foreign_Thread): Update
parameter profile to allow the secondary stack size to be specified.
* libgnarl/s-tarest.adb (Create_Restricted_Task): Update the parameter
profile to include Sec_Stack_Address. Update Tasking.Initialize_ATCB
call to remove Secondary_Stack_Size reference. Add secondary stack
address and size to SSL.Create_TSD call.
(Task_Wrapper): Remove secondary stack creation.
* libgnarl/s-tarest.ads (Create_Restricted_Task,
Create_Restricted_Task_Sequential): Update parameter profile to include
Sec_Stack_Address and clarify the Size parameter.
* libgnarl/s-taskin.adb (Initialize_ATCB): Remove Secondary_Stack_Size
from profile and body.
(Initialize): Remove Secondary_Stack_Size from Initialize_ATCB call.
* libgnarl/s-taskin.ads: Removed component Secondary_Stack_Size from
Common_ATCB.
(Initialize_ATCB): Update the parameter profile to remove
Secondary_Stack_Size.
* libgnarl/s-tassta.adb (Create_Task): Updated parameter profile and
call to Initialize_ATCB. Add secondary stack address and size to
SSL.Create_TSD call, and catch any storage exception from the call.
(Finalize_Global_Tasks): Update System.Soft_Links references to reflect
new subprogram and component names.
(Task_Wrapper): Remove secondary stack creation.
(Vulnerable_Complete_Master): Update to reflect TSD changes.
* libgnarl/s-tassta.ads: Reformat comments.
(Create_Task): Update parameter profile.
* libgnarl/s-tporft.adb (Register_Foreign_Thread): Update parameter
profile to include secondary stack size. Remove secondary size
parameter from Initialize_ATCB call and add it to Create_TSD call.
* libgnat/s-parame.adb, libgnat/s-parame__rtems.adb,
libgnat/s-parame__vxworks.adb (Default_Sec_Stack_Size): New routine.
* libgnat/s-parame.ads, libgnat/s-parame__ae653.ads,
libgnat/s-parame__hpux.ads, libgnat/s-parame__vxworks.ads: Remove type
Percentage. Remove constants Dynamic, Sec_Stack_Percentage and
Sec_Stack_Dynamic. Add constant Runtime_Default_Sec_Stack_Size and
Sec_Stack_Dynamic.
(Default_Sec_Stack_Size): New routine.
* libgnat/s-secsta.adb, libgnat/s-secsta.ads: New implementation. Is
now Preelaborate.
* libgnat/s-soflin.adb: Removed unused with-clauses. With
System.Soft_Links.Initialize to initialize non-tasking TSD.
(Create_TSD): Update parameter profile. Initialize the TSD and
unconditionally call SS_Init.
(Destroy_TSD): Update SST.SS_Free call.
(Get_Sec_Stack_Addr_NT, Get_Sec_Stack_Addr_Soft, Set_Sec_Stack_Addr_NT,
Set_Sec_Stack_Addr_Soft): Remove routines.
(Get_Sec_Stack_NT, Get_Sec_Stack_Soft, Set_Sec_Stack_NT,
Set_Sec_Stack_Soft): Add routines.
(NT_TSD): Move to private part of package specification.
* libgnat/s-soflin.ads: New types Get_Stack_Call and Set_Stack_Call
with suppressed access checks. Renamed *_Sec_Stack_Addr_* routines and
objects to *_Sec_Stack_*. TSD: removed warning suppression and
component intialization. Changed Sec_Stack_Addr to Sec_Stack_Ptr.
(Create_TSD): Update parameter profile.
(NT_TSD): Move to private section from body.
* libgnat/s-soliin.adb, libgnat/s-soliin.ads: New files.
* libgnat/s-thread.ads (Thread_Body_Enter): Update parameter profile.
* libgnat/s-thread__ae653.adb (Get_Sec_Stack_Addr, Set_Sec_Stack_Addr):
Remove routine.
(Get_Sec_Stack, Set_Sec_Stack): Add routine.
(Thread_Body_Enter): Update parameter profile and body to adapt to new
System.Secondary_Stack.
(Init_RTS): Update body for new System.Soft_Links names.
* gcc-interface/Make-lang.in (GNAT_ADA_OBJS, GNATBIND_OBJS): Add
s-soliin.o.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@253754 138bc75d-0d04-0410-961f-82ee72b054a4
52 files changed, 1836 insertions, 996 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3e1f53762c0..8e8be98fd4f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,155 @@ +2017-10-14 Bob Duff <duff@adacore.com> + + * exp_ch6.adb (Is_Build_In_Place_Result_Type): Include code for + enabling b-i-p for nonlimited controlled types (but disabled). + +2017-10-14 Justin Squirek <squirek@adacore.com> + + * sem_elab.adb (Is_Suitable_Variable_Assignment): Replace call to + Has_Warnings_Off with Warnings_Off. + +2017-10-14 Piotr Trojanek <trojanek@adacore.com> + + * sinfo.ads (Generic_Parent): Remove wrong (possibly obsolete) comment. + +2017-10-14 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch3.adb (Analyze_Declarations): Analyze the contract of an + enclosing package at the end of the visible declarations. + * sem_prag.adb (Analyze_Initialization_Item): Suppress the analysis of + an initialization item which is undefined due to some illegality. + +2017-10-14 Patrick Bernardi <bernardi@adacore.com> + + * ali.adb: Add new ALI line 'T' to read the number of tasks contain + within each unit that require a default-sized primary and secondary + stack to be generated by the binder. + (Scan_ALI): Scan new 'T' lines. + * ali.ads: Add Primary_Stack_Count and Sec_Stack_Count to Unit_Record. + * bindgen.adb (Gen_Output_File): Count the number of default-sized + stacks within the closure that are to be created by the binder. + (Gen_Adainit, Gen_Output_File_Ada): Generate default-sized secondary + stacks and record these in System.Secodnary_Stack. + (Resolve_Binder_Options): Check if System.Secondary_Stack is in the + closure of the program being bound. + * bindusg.adb (Display): Add "-Q" switch. Remove rouge "--RTS" comment. + * exp_ch3.adb (Count_Default_Sized_Task_Stacks): New routine. + (Expand_N_Object_Declaration): Count the number of default-sized stacks + used by task objects contained within the object whose declaration is + being expanded. Only performed when either the restrictions + No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations are in + effect. + * exp_ch9.adb (Create_Secondary_Stack_For_Task): New routine. + (Expand_N_Task_Type_Declaration): Create a secondary stack as part of + the expansion of a task type if the size of the stack is known at + run-time and the restrictions No_Implicit_Heap_Allocations or + No_Implicit_Task_Allocations are in effect. + (Make_Task_Create_Call): If using a restricted profile provide + secondary stack parameter: either the statically created stack or null. + * lib-load.adb (Create_Dummy_Package_Unit, Load_Unit, + Load_Main_Source): Include Primary_Stack_Count and Sec_Stack_Count in + Unit_Record initialization expressions. + * lib-writ.adb (Add_Preprocessing_Dependency, + Ensure_System_Dependency): Include Primary_Stack_Count and + Sec_Stack_Count in Unit_Record initialization expression. + (Write_ALI): Write T lines. + (Write_Unit_Information): Do not output 'T' lines if there are no + stacks for the binder to generate. + * lib-writ.ads: Updated library information documentation to include + new T line entry. + * lib.adb (Increment_Primary_Stack_Count): New routine. + (Increment_Sec_Stack_Count): New routine. + (Primary_Stack_Count): New routine. + (Sec_Stack_Count): New routine. + * lib.ads: Add Primary_Stack_Count and Sec_Stack_Count components to + Unit_Record and updated documentation. + (Increment_Primary_Stack_Count): New routine along with pragma Inline. + (Increment_Sec_Stack_Count): New routine along with pragma Inline. + (Primary_Stack_Count): New routine along with pragma Inline. + (Sec_Stack_Count): New routine along with pragma Inline. + * opt.ads: New constant No_Stack_Size. Flag Default_Stack_Size + redefined. New flag Default_Sec_Stack_Size and + Quantity_Of_Default_Size_Sec_Stacks. + * rtfinal.c Fixed erroneous comment. + * rtsfind.ads: Moved RE_Default_Secondary_Stack_Size from + System.Secondary_Stack to System.Parameters. Add RE_SS_Stack. + * sem_util.adb (Number_Of_Elements_In_Array): New routine. + * sem_util.ads (Number_Of_Elements_In_Array): New routine. + * switch-b.adb (Scan_Binder_Switches): Scan "-Q" switch. + * libgnarl/s-solita.adb (Get_Sec_Stack_Addr): Removed routine. + (Set_Sec_Stack_Addr): Removed routine. + (Get_Sec_Stack): New routine. + (Set_Sec_Stack): New routine. + (Init_Tasking_Soft_Links): Update System.Soft_Links reference to + reflect new procedure and global names. + * libgnarl/s-taprop__linux.adb, libgnarl/s-taprop__mingw.adb, + libgnarl/s-taprop__posix.adb, libgnarl/s-taprop__solaris.adb, + libgnarl/s-taprop__vxworks.adb (Register_Foreign_Thread): Update + parameter profile to allow the secondary stack size to be specified. + * libgnarl/s-tarest.adb (Create_Restricted_Task): Update the parameter + profile to include Sec_Stack_Address. Update Tasking.Initialize_ATCB + call to remove Secondary_Stack_Size reference. Add secondary stack + address and size to SSL.Create_TSD call. + (Task_Wrapper): Remove secondary stack creation. + * libgnarl/s-tarest.ads (Create_Restricted_Task, + Create_Restricted_Task_Sequential): Update parameter profile to include + Sec_Stack_Address and clarify the Size parameter. + * libgnarl/s-taskin.adb (Initialize_ATCB): Remove Secondary_Stack_Size + from profile and body. + (Initialize): Remove Secondary_Stack_Size from Initialize_ATCB call. + * libgnarl/s-taskin.ads: Removed component Secondary_Stack_Size from + Common_ATCB. + (Initialize_ATCB): Update the parameter profile to remove + Secondary_Stack_Size. + * libgnarl/s-tassta.adb (Create_Task): Updated parameter profile and + call to Initialize_ATCB. Add secondary stack address and size to + SSL.Create_TSD call, and catch any storage exception from the call. + (Finalize_Global_Tasks): Update System.Soft_Links references to reflect + new subprogram and component names. + (Task_Wrapper): Remove secondary stack creation. + (Vulnerable_Complete_Master): Update to reflect TSD changes. + * libgnarl/s-tassta.ads: Reformat comments. + (Create_Task): Update parameter profile. + * libgnarl/s-tporft.adb (Register_Foreign_Thread): Update parameter + profile to include secondary stack size. Remove secondary size + parameter from Initialize_ATCB call and add it to Create_TSD call. + * libgnat/s-parame.adb, libgnat/s-parame__rtems.adb, + libgnat/s-parame__vxworks.adb (Default_Sec_Stack_Size): New routine. + * libgnat/s-parame.ads, libgnat/s-parame__ae653.ads, + libgnat/s-parame__hpux.ads, libgnat/s-parame__vxworks.ads: Remove type + Percentage. Remove constants Dynamic, Sec_Stack_Percentage and + Sec_Stack_Dynamic. Add constant Runtime_Default_Sec_Stack_Size and + Sec_Stack_Dynamic. + (Default_Sec_Stack_Size): New routine. + * libgnat/s-secsta.adb, libgnat/s-secsta.ads: New implementation. Is + now Preelaborate. + * libgnat/s-soflin.adb: Removed unused with-clauses. With + System.Soft_Links.Initialize to initialize non-tasking TSD. + (Create_TSD): Update parameter profile. Initialize the TSD and + unconditionally call SS_Init. + (Destroy_TSD): Update SST.SS_Free call. + (Get_Sec_Stack_Addr_NT, Get_Sec_Stack_Addr_Soft, Set_Sec_Stack_Addr_NT, + Set_Sec_Stack_Addr_Soft): Remove routines. + (Get_Sec_Stack_NT, Get_Sec_Stack_Soft, Set_Sec_Stack_NT, + Set_Sec_Stack_Soft): Add routines. + (NT_TSD): Move to private part of package specification. + * libgnat/s-soflin.ads: New types Get_Stack_Call and Set_Stack_Call + with suppressed access checks. Renamed *_Sec_Stack_Addr_* routines and + objects to *_Sec_Stack_*. TSD: removed warning suppression and + component intialization. Changed Sec_Stack_Addr to Sec_Stack_Ptr. + (Create_TSD): Update parameter profile. + (NT_TSD): Move to private section from body. + * libgnat/s-soliin.adb, libgnat/s-soliin.ads: New files. + * libgnat/s-thread.ads (Thread_Body_Enter): Update parameter profile. + * libgnat/s-thread__ae653.adb (Get_Sec_Stack_Addr, Set_Sec_Stack_Addr): + Remove routine. + (Get_Sec_Stack, Set_Sec_Stack): Add routine. + (Thread_Body_Enter): Update parameter profile and body to adapt to new + System.Secondary_Stack. + (Init_RTS): Update body for new System.Soft_Links names. + * gcc-interface/Make-lang.in (GNAT_ADA_OBJS, GNATBIND_OBJS): Add + s-soliin.o. + 2017-10-10 Richard Sandiford <richard.sandiford@linaro.org> * gcc-interface/decl.c (annotate_value): Use wi::to_wide when diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 2b1d472baba..959b3058728 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -58,6 +58,7 @@ package body ALI is 'Z' => True, -- implicit with from instantiation 'C' => True, -- SCO information 'F' => True, -- SPARK cross-reference information + 'T' => True, -- task stack information others => False); -------------------- @@ -842,7 +843,7 @@ package body ALI is if Read_Xref then Ignore := - ('U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True); + ('T' | 'U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True); -- Read_Lines parameter given @@ -1744,6 +1745,8 @@ package body ALI is UL.Elaborate_Body_Desirable := False; UL.Optimize_Alignment := 'O'; UL.Has_Finalizer := False; + UL.Primary_Stack_Count := 0; + UL.Sec_Stack_Count := 0; if Debug_Flag_U then Write_Str (" ----> reading unit "); @@ -2096,6 +2099,28 @@ package body ALI is Units.Table (Units.Last).Last_With := Withs.Last; Units.Table (Units.Last).Last_Arg := Args.Last; + -- Scan out task stack information for the unit if present + + Check_Unknown_Line; + + if C = 'T' then + if Ignore ('T') then + Skip_Line; + + else + Checkc (' '); + Skip_Space; + + Units.Table (Units.Last).Primary_Stack_Count := Get_Nat; + Skip_Space; + Units.Table (Units.Last).Sec_Stack_Count := Get_Nat; + Skip_Space; + Skip_Eol; + end if; + + C := Getc; + end if; + -- If there are linker options lines present, scan them Name_Len := 0; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index e15a1c455bd..3fa4d99fb09 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -388,11 +388,19 @@ package ALI is -- together as possible. Optimize_Alignment : Character; - -- Optimize_Alignment setting. Set to L/S/T/O for OL/OS/OT/OO present + -- Optimize_Alignment setting. Set to L/S/T/O for OL/OS/OT/OO present. Has_Finalizer : Boolean; -- Indicates whether a package body or a spec has a library-level -- finalization routine. + + Primary_Stack_Count : Int; + -- Indicates the number of task objects declared in this unit that have + -- default sized primary stacks. + + Sec_Stack_Count : Int; + -- Indicates the number of task objects declared in this unit that have + -- default sized secondary stacks. end record; package Units is new Table.Table ( diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index a9ea20ebd9b..b8d61a86095 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -59,6 +59,14 @@ package body Bindgen is Num_Elab_Calls : Nat := 0; -- Number of generated calls to elaboration routines + Num_Primary_Stacks : Int := 0; + -- Number of default-sized primary stacks the binder needs to allocate for + -- task objects declared in the program. + + Num_Sec_Stacks : Int := 0; + -- Number of default-sized primary stacks the binder needs to allocate for + -- task objects declared in the program. + System_Restrictions_Used : Boolean := False; -- Flag indicating whether the unit System.Restrictions is in the closure -- of the partition. This is set by Resolve_Binder_Options, and is used @@ -74,6 +82,12 @@ package body Bindgen is -- domains just before calling the main procedure from the environment -- task. + System_Secondary_Stack_Used : Boolean := False; + -- Flag indicating whether the unit System.Secondary_Stack is in the + -- closure of the partition. This is set by Resolve_Binder_Options, and + -- is used to initialize the package in cases where the run-time brings + -- in package but the secondary stack is not used. + System_Tasking_Restricted_Stages_Used : Boolean := False; -- Flag indicating whether the unit System.Tasking.Restricted.Stages is in -- the closure of the partition. This is set by Resolve_Binder_Options, @@ -179,8 +193,11 @@ package body Bindgen is -- Exception_Tracebacks_Symbolic : Integer; -- Detect_Blocking : Integer; -- Default_Stack_Size : Integer; + -- Default_Secondary_Stack_Size : System.Parameters.Size_Type; -- Leap_Seconds_Support : Integer; -- Main_CPU : Integer; + -- Default_Sized_SS_Pool : System.Address; + -- Binder_Sec_Stacks_Count : Natural; -- Main_Priority is the priority value set by pragma Priority in the main -- program. If no such pragma is present, the value is -1. @@ -261,6 +278,9 @@ package body Bindgen is -- Default_Stack_Size is the default stack size used when creating an Ada -- task with no explicit Storage_Size clause. + -- Default_Secondary_Stack_Size is the default secondary stack size used + -- when creating an Ada task with no explicit Secondary_Stack_Size clause. + -- Leap_Seconds_Support denotes whether leap seconds have been enabled or -- disabled. A value of zero indicates that leap seconds are turned "off", -- while a value of one signifies "on" status. @@ -268,6 +288,14 @@ package body Bindgen is -- Main_CPU is the processor set by pragma CPU in the main program. If no -- such pragma is present, the value is -1. + -- Default_Sized_SS_Pool is set to the address of the default-sized + -- secondary stacks array generated by the binder. This pool of stacks is + -- generated when either the restriction No_Implicit_Heap_Allocations + -- or No_Implicit_Task_Allocations is active. + + -- Binder_Sec_Stacks_Count is the number of generated secondary stacks in + -- the Default_Sized_SS_Pool. + procedure WBI (Info : String) renames Osint.B.Write_Binder_Info; -- Convenient shorthand used throughout @@ -554,6 +582,32 @@ package body Bindgen is WBI (" procedure Start_Slave_CPUs;"); WBI (" pragma Import (C, Start_Slave_CPUs," & " ""__gnat_start_slave_cpus"");"); + WBI (""); + end if; + + -- A restricted run-time may attempt to initialize the main task's + -- secondary stack even if the stack is not used. Consequently, + -- the binder needs to initialize Binder_Sec_Stacks_Count anytime + -- System.Secondary_Stack is in the enclosure of the partition. + + if System_Secondary_Stack_Used then + WBI (" Binder_Sec_Stacks_Count : Natural;"); + WBI (" pragma Import (Ada, Binder_Sec_Stacks_Count, " & + """__gnat_binder_ss_count"");"); + WBI (""); + end if; + + if Sec_Stack_Used then + WBI (" Default_Secondary_Stack_Size : " & + "System.Parameters.Size_Type;"); + WBI (" pragma Import (C, Default_Secondary_Stack_Size, " & + """__gnat_default_ss_size"");"); + + WBI (" Default_Sized_SS_Pool : System.Address;"); + WBI (" pragma Import (Ada, Default_Sized_SS_Pool, " & + """__gnat_default_ss_pool"");"); + + WBI (""); end if; WBI (" begin"); @@ -588,6 +642,48 @@ package body Bindgen is WBI (" null;"); end if; + -- Generate default-sized secondary stack pool and set secondary + -- stack globals. + + if Sec_Stack_Used then + -- Elaborate the body of the binder to initialize the + -- default-sized secondary stack pool. + + WBI (""); + WBI (" " & Get_Ada_Main_Name & "'Elab_Body;"); + + -- Generate the default-sized secondary stack pool and set the + -- related secondary stack globals. + + Set_String (" Default_Secondary_Stack_Size := "); + if Opt.Default_Sec_Stack_Size /= Opt.No_Stack_Size then + Set_Int (Opt.Default_Sec_Stack_Size); + else + Set_String + ("System.Parameters.Runtime_Default_Sec_Stack_Size"); + end if; + Set_Char (';'); + Write_Statement_Buffer; + + Set_String (" Binder_Sec_Stacks_Count := "); + Set_Int (Num_Sec_Stacks); + Set_Char (';'); + Write_Statement_Buffer; + + WBI (" Default_Sized_SS_Pool := " & + "Sec_Default_Sized_Stacks'Address;"); + WBI (""); + + -- When a restricted run-time initializes the main task's secondary + -- stack but the program does not use it, no secondary stack is + -- generated. Binder_Sec_Stacks_Count is set to zero so the run-time + -- is aware that the lack of pre-allocated secondary stack is + -- expected. + + elsif System_Secondary_Stack_Used then + WBI (" Binder_Sec_Stacks_Count := 0;"); + end if; + -- Normal case (standard library not suppressed). Set all global values -- used by the run time. @@ -647,6 +743,10 @@ package body Bindgen is WBI (" Default_Stack_Size : Integer;"); WBI (" pragma Import (C, Default_Stack_Size, " & """__gl_default_stack_size"");"); + WBI (" Default_Secondary_Stack_Size : " & + "System.Parameters.Size_Type;"); + WBI (" pragma Import (C, Default_Secondary_Stack_Size, " & + """__gnat_default_ss_size"");"); WBI (" Leap_Seconds_Support : Integer;"); WBI (" pragma Import (C, Leap_Seconds_Support, " & """__gl_leap_seconds_support"");"); @@ -730,6 +830,18 @@ package body Bindgen is & """__gnat_freeze_dispatching_domains"");"); end if; + -- Secondary stack global variables + + WBI (" Binder_Sec_Stacks_Count : Natural;"); + WBI (" pragma Import (Ada, Binder_Sec_Stacks_Count, " & + """__gnat_binder_ss_count"");"); + + WBI (" Default_Sized_SS_Pool : System.Address;"); + WBI (" pragma Import (Ada, Default_Sized_SS_Pool, " & + """__gnat_default_ss_pool"");"); + + WBI (""); + -- Start of processing for Adainit WBI (" begin"); @@ -870,9 +982,46 @@ package body Bindgen is WBI (" Bind_Env_Addr := Bind_Env'Address;"); end if; - -- Generate call to Install_Handler - WBI (""); + + -- Generate default-sized secondary stack pool and set secondary + -- stack globals. + + if Sec_Stack_Used then + -- Elaborate the body of the binder to initialize the + -- default-sized secondary stack pool. + + WBI (" " & Get_Ada_Main_Name & "'Elab_Body;"); + + -- Generate the default-sized secondary stack pool and set the + -- related secondary stack globals. + + Set_String (" Default_Secondary_Stack_Size := "); + if Opt.Default_Sec_Stack_Size /= Opt.No_Stack_Size then + Set_Int (Opt.Default_Sec_Stack_Size); + else + Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size"); + end if; + Set_Char (';'); + Write_Statement_Buffer; + + Set_String (" Binder_Sec_Stacks_Count := "); + Set_Int (Num_Sec_Stacks); + Set_Char (';'); + Write_Statement_Buffer; + + Set_String (" Default_Sized_SS_Pool := "); + if Num_Sec_Stacks > 0 then + Set_String ("Sec_Default_Sized_Stacks'Address;"); + else + Set_String ("System.Null_Address;"); + end if; + Write_Statement_Buffer; + + WBI (""); + end if; + + -- Generate call to Runtime_Initialize WBI (" Runtime_Initialize (1);"); end if; @@ -888,17 +1037,6 @@ package body Bindgen is Write_Statement_Buffer; end if; - -- Generate assignment of default secondary stack size if set - - if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then - WBI (""); - Set_String (" System.Secondary_Stack."); - Set_String ("Default_Secondary_Stack_Size := "); - Set_Int (Opt.Default_Sec_Stack_Size); - Set_Char (';'); - Write_Statement_Buffer; - end if; - -- Initialize stack limit variable of the environment task if the stack -- check method is stack limit and stack check is enabled. @@ -2044,6 +2182,24 @@ package body Bindgen is end if; end loop; + -- Count the number of statically allocated stacks to be generated by + -- the binder. If the user has specified the number of default-sized + -- secondary stacks, use that number. Otherwise start the count at one + -- as the binder is responsible for creating a secondary stack for the + -- main task. + + if Opt.Quantity_Of_Default_Size_Sec_Stacks /= -1 then + Num_Sec_Stacks := Quantity_Of_Default_Size_Sec_Stacks; + elsif Sec_Stack_Used then + Num_Sec_Stacks := 1; + end if; + + for J in Units.First .. Units.Last loop + Num_Primary_Stacks := Num_Primary_Stacks + + Units.Table (J).Primary_Stack_Count; + Num_Sec_Stacks := Num_Sec_Stacks + Units.Table (J).Sec_Stack_Count; + end loop; + -- Generate output file in appropriate language Gen_Output_File_Ada (Filename, Elab_Order); @@ -2114,9 +2270,11 @@ package body Bindgen is WBI ("with System.Scalar_Values;"); end if; - -- Generate with of System.Secondary_Stack if active + -- Generate withs of System.Secondary_Stack and System.Parameters to + -- allow the generation of the default-sized secondary stack pool. - if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + if Sec_Stack_Used then + WBI ("with System.Parameters;"); WBI ("with System.Secondary_Stack;"); end if; @@ -2156,10 +2314,10 @@ package body Bindgen is end if; end if; - -- Define exit status. Again in normal mode, this is in the - -- run-time library, and is initialized there, but in the - -- configurable runtime case, the variable is declared and - -- initialized in this file. + -- Define exit status. Again in normal mode, this is in the run-time + -- library, and is initialized there, but in the configurable + -- run-time case, the variable is declared and initialized in this + -- file. WBI (""); @@ -2358,6 +2516,27 @@ package body Bindgen is Gen_Elab_Externals (Elab_Order); + -- Generate default-sized secondary stacks pool. At least one stack is + -- created and assigned to the environment task if secondary stacks are + -- used by the program. + + if Sec_Stack_Used then + Set_String (" Sec_Default_Sized_Stacks"); + Set_String (" : array (1 .. "); + Set_Int (Num_Sec_Stacks); + Set_String (") of aliased System.Secondary_Stack.SS_Stack ("); + if Opt.Default_Sec_Stack_Size /= No_Stack_Size then + Set_Int (Opt.Default_Sec_Stack_Size); + else + Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size"); + end if; + Set_String (");"); + Write_Statement_Buffer; + WBI (""); + end if; + + -- Generate reference + if not CodePeer_Mode then if not Suppress_Standard_Library_On_Target then @@ -2873,6 +3052,11 @@ package body Bindgen is Check_Package (System_Restrictions_Used, "system.restrictions%s"); + -- Ditto for the use of System.Secondary_Stack + + Check_Package + (System_Secondary_Stack_Used, "system.secondary_stack%s"); + -- Ditto for use of an SMP bareboard runtime Check_Package (System_BB_CPU_Primitives_Multiprocessors_Used, diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index 6cf7710219e..7c17f939514 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -210,6 +210,11 @@ package body Bindusg is Write_Line (" -P Generate binder file suitable for CodePeer"); + -- Line for Q switch + + Write_Line + (" -Qnnn Generate nnn default-sized secondary stacks"); + -- Line for -r switch Write_Line @@ -309,8 +314,6 @@ package body Bindusg is Write_Line (" -z No main subprogram (zero main)"); - -- Line for --RTS - -- Line for -Z switch Write_Line diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 29e79dcead9..837c8a98d86 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -43,6 +43,7 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Ghost; use Ghost; +with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -5580,6 +5581,15 @@ package body Exp_Ch3 is -- arithmetic might yield a meaningless value for the length of the -- array, or its corresponding attribute. + procedure Count_Default_Sized_Task_Stacks + (Typ : Entity_Id; + Pri_Stacks : out Int; + Sec_Stacks : out Int); + -- Count the number of default-sized primary and secondary task stacks + -- required for task objects contained within type Typ. If the number of + -- task objects contained within the type is not known at compile time + -- the procedure will return the stack counts of zero. + procedure Default_Initialize_Object (After : Node_Id); -- Generate all default initialization actions for object Def_Id. Any -- new code is inserted after node After. @@ -5772,6 +5782,116 @@ package body Exp_Ch3 is end if; end Check_Large_Modular_Array; + ------------------------------------- + -- Count_Default_Sized_Task_Stacks -- + ------------------------------------- + + procedure Count_Default_Sized_Task_Stacks + (Typ : Entity_Id; + Pri_Stacks : out Int; + Sec_Stacks : out Int) + is + Component : Entity_Id; + begin + -- To calculate the number of default-sized task stacks required for + -- an object of Typ, a depth-first recursive traversal of the AST + -- from the Typ entity node is undertaken. Only type nodes containing + -- task objects are visited. + + Pri_Stacks := 0; + Sec_Stacks := 0; + + if not Has_Task (Typ) then + return; + end if; + + case Ekind (Typ) is + when E_Task_Type + | E_Task_Subtype + => + -- A task type is found marking the bottom of the descent. If + -- the type has no representation aspect for the corresponding + -- stack then that stack is using the default size. + + if Present (Get_Rep_Item (Typ, Name_Storage_Size)) then + Pri_Stacks := 0; + else + Pri_Stacks := 1; + end if; + + if Present (Get_Rep_Item (Typ, Name_Secondary_Stack_Size)) then + Sec_Stacks := 0; + else + Sec_Stacks := 1; + end if; + + when E_Array_Type + | E_Array_Subtype + => + -- First find the number of default stacks contained within an + -- array component. + + Count_Default_Sized_Task_Stacks + (Component_Type (Typ), + Pri_Stacks, + Sec_Stacks); + + -- Then multiply the result by the size of the array + + declare + Quantity : constant Int := Number_Of_Elements_In_Array (Typ); + -- Number_Of_Elements_In_Array is non-trival, consequently + -- its result is captured as an optimization. + + begin + Pri_Stacks := Pri_Stacks * Quantity; + Sec_Stacks := Sec_Stacks * Quantity; + end; + + when E_Record_Type + | E_Record_Subtype + | E_Protected_Type + | E_Protected_Subtype + => + Component := First_Component_Or_Discriminant (Typ); + + -- Recursively descend each component of the composite type + -- looking for tasks, but only if the component is marked as + -- having a task. + + while Present (Component) loop + if Has_Task (Etype (Component)) then + declare + P, S : Int; + begin + Count_Default_Sized_Task_Stacks + (Etype (Component), P, S); + Pri_Stacks := Pri_Stacks + P; + Sec_Stacks := Sec_Stacks + S; + end; + end if; + + Next_Component_Or_Discriminant (Component); + end loop; + + when E_Limited_Private_Type + | E_Limited_Private_Subtype + | E_Record_Type_With_Private + | E_Record_Subtype_With_Private + => + -- Switch to the full view of the private type to continue + -- search. + + Count_Default_Sized_Task_Stacks + (Full_View (Typ), Pri_Stacks, Sec_Stacks); + + -- Other types should not contain tasks + + when others => + raise Program_Error; + end case; + end Count_Default_Sized_Task_Stacks; + ------------------------------- -- Default_Initialize_Object -- ------------------------------- @@ -6198,6 +6318,37 @@ package body Exp_Ch3 is Check_Large_Modular_Array; + -- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations + -- restrictions are active then default-sized secondary stacks are + -- generated by the binder and allocated by SS_Init. To provide the + -- binder the number of stacks to generate, the number of default-sized + -- stacks required for task objects contained within the object + -- declaration N is calculated here as it is at this point where + -- unconstrained types become constrained. The result is stored in the + -- enclosing unit's Unit_Record. + + -- Note if N is an array object declaration that has an initialization + -- expression, a second object declaration for the initialization + -- expression is created by the compiler. To prevent double counting + -- of the stacks in this scenario, the stacks of the first array are + -- not counted. + + if Has_Task (Typ) + and then not Restriction_Active (No_Secondary_Stack) + and then (Restriction_Active (No_Implicit_Heap_Allocations) + or else Restriction_Active (No_Implicit_Task_Allocations)) + and then not (Ekind_In (Ekind (Typ), E_Array_Type, E_Array_Subtype) + and then (Has_Init_Expression (N))) + then + declare + PS_Count, SS_Count : Int := 0; + begin + Count_Default_Sized_Task_Stacks (Typ, PS_Count, SS_Count); + Increment_Primary_Stack_Count (PS_Count); + Increment_Sec_Stack_Count (SS_Count); + end; + end if; + -- Default initialization required, and no expression present if No (Expr) then diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 6c27741d37c..4e229c452a4 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7240,7 +7240,37 @@ package body Exp_Ch6 is if Is_Limited_View (Typ) then return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; else - return Debug_Flag_Dot_9; +-- if Debug_Flag_Dot_9 then + if True then + return False; -- ???disable bip for nonlimited types + end if; + + if Has_Interfaces (Typ) then + return False; + end if; + + -- For T'Class, return True if it's True for the corresponding + -- specific type. This is necessary because a class-wide function + -- might say "return F (...)", where F returns the corresponding + -- specific type. + + if Is_Class_Wide_Type (Typ) then + return Is_Build_In_Place_Result_Type (Etype (Typ)); + end if; + + declare + T : Entity_Id := Typ; + begin + if Present (Underlying_Type (Typ)) then + T := Underlying_Type (Typ); + end if; + + declare + Result : constant Boolean := Is_Controlled (T); + begin + return Result; + end; + end; end if; end Is_Build_In_Place_Result_Type; @@ -7326,7 +7356,12 @@ package body Exp_Ch6 is raise Program_Error; end if; - return Is_Build_In_Place_Function (Function_Id); + declare + Result : constant Boolean := Is_Build_In_Place_Function (Function_Id); + -- So we can stop here in the debugger + begin + return Result; + end; end Is_Build_In_Place_Function_Call; ----------------------- diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index aca0c18e3b6..be205e47a7e 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -339,6 +339,14 @@ package body Exp_Ch9 is -- same parameter names and the same resolved types, but with new entities -- for the formals. + function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean; + -- Return whether a secondary stack for the task T should be created by the + -- expander. The secondary stack for a task will be created by the expander + -- if the size of the stack has been specified by the Secondary_Stack_Size + -- representation aspect and either the No_Implicit_Heap_Allocations or + -- No_Implicit_Task_Allocations restrictions are in effect and the + -- No_Secondary_Stack restriction is not. + procedure Debug_Private_Data_Declarations (Decls : List_Id); -- Decls is a list which may contain the declarations created by Install_ -- Private_Data_Declarations. All generated entities are marked as needing @@ -5415,6 +5423,20 @@ package body Exp_Ch9 is end Convert_Concurrent; ------------------------------------- + -- Create_Secondary_Stack_For_Task -- + ------------------------------------- + + function Create_Secondary_Stack_For_Task (T : Node_Id) return Boolean is + begin + return + (Restriction_Active (No_Implicit_Heap_Allocations) + or else Restriction_Active (No_Implicit_Task_Allocations)) + and then not Restriction_Active (No_Secondary_Stack) + and then Has_Rep_Item (T, Name_Secondary_Stack_Size, + Check_Parents => False); + end Create_Secondary_Stack_For_Task; + + ------------------------------------- -- Debug_Private_Data_Declarations -- ------------------------------------- @@ -11712,6 +11734,7 @@ package body Exp_Ch9 is Body_Decl : Node_Id; Cdecls : List_Id; Decl_Stack : Node_Id; + Decl_SS : Node_Id; Elab_Decl : Node_Id; Ent_Stack : Entity_Id; Proc_Spec : Node_Id; @@ -11939,6 +11962,57 @@ package body Exp_Ch9 is end if; + -- Declare a static secondary stack if the conditions for a statically + -- generated stack are met. + + if Create_Secondary_Stack_For_Task (TaskId) then + declare + Ritem : Node_Id; + Size_Expr : Node_Id; + + begin + -- First extract the secondary stack size from the task type's + -- representation aspect. + + Ritem := + Get_Rep_Item + (TaskId, Name_Secondary_Stack_Size, Check_Parents => False); + + -- Get Secondary_Stack_Size expression. Can be a pragma or + -- aspect. + + if Nkind (Ritem) = N_Pragma then + Size_Expr := + Expression + (First (Pragma_Argument_Associations (Ritem))); + else + Size_Expr := Expression (Ritem); + end if; + + pragma Assert (Compile_Time_Known_Value (Size_Expr)); + + -- Create the secondary stack for the task + + Decl_SS := Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uSecondary_Stack), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => True, + Subtype_Indication => Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_SS_Stack), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, + Expr_Value (Size_Expr))))))); + + Append_To (Cdecls, Decl_SS); + end; + end if; + -- Add components for entry families Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); @@ -14136,11 +14210,33 @@ package body Exp_Ch9 is New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc)); end if; - -- Secondary_Stack_Size parameter. Set Default_Secondary_Stack_Size - -- unless there is a Secondary_Stack_Size rep item, in which case we - -- take the value from the rep item. If the restriction - -- No_Secondary_Stack is active then a size of 0 is passed regardless - -- to prevent the allocation of the unused stack. + -- Secondary_Stack parameter used for restricted profiles + + if Restricted_Profile then + + -- If the secondary stack has been allocated by the expander then + -- pass its access pointer. Otherwise, pass null. + + if Create_Secondary_Stack_For_Task (Ttyp) then + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Name_uSecondary_Stack)), + Attribute_Name => Name_Unrestricted_Access)); + + else + Append_To (Args, Make_Null (Loc)); + end if; + end if; + + -- Secondary_Stack_Size parameter. Set RE_Unspecified_Size unless there + -- is a Secondary_Stack_Size rep item, in which case take the value from + -- the rep item. If the restriction No_Secondary_Stack is active then a + -- size of 0 is passed regardless to prevent the allocation of the + -- unused stack. if Restriction_Active (No_Secondary_Stack) then Append_To (Args, Make_Integer_Literal (Loc, 0)); diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 113c84f390b..9c7b6e1496f 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -390,6 +390,7 @@ GNAT_ADA_OBJS = \ ada/libgnat/s-restri.o \ ada/libgnat/s-secsta.o \ ada/libgnat/s-soflin.o \ + ada/libgnat/s-soliin.o \ ada/libgnat/s-sopco3.o \ ada/libgnat/s-sopco4.o \ ada/libgnat/s-sopco5.o \ @@ -579,6 +580,7 @@ GNATBIND_OBJS = \ ada/libgnat/s-restri.o \ ada/libgnat/s-secsta.o \ ada/libgnat/s-soflin.o \ + ada/libgnat/s-soliin.o \ ada/libgnat/s-sopco3.o \ ada/libgnat/s-sopco4.o \ ada/libgnat/s-sopco5.o \ diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 977567d4983..0b0ea7f5057 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -214,34 +214,36 @@ package body Lib.Load is Unum := Units.Last; Units.Table (Unum) := - (Cunit => Cunit, - Cunit_Entity => Cunit_Entity, - Dependency_Num => 0, - Dynamic_Elab => False, - Error_Location => Sloc (With_Node), - Expected_Unit => Spec_Name, - Fatal_Error => Error_Detected, - Generate_Code => False, - Has_RACW => False, - Filler => False, - Ident_String => Empty, + (Cunit => Cunit, + Cunit_Entity => Cunit_Entity, + Dependency_Num => 0, + Dynamic_Elab => False, + Error_Location => Sloc (With_Node), + Expected_Unit => Spec_Name, + Fatal_Error => Error_Detected, + Generate_Code => False, + Has_RACW => False, + Filler => False, + Ident_String => Empty, Is_Predefined_Renaming => Ren_Name, Is_Predefined_Unit => Pre_Name or Ren_Name, Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name, Filler2 => False, - Loading => False, - Main_Priority => Default_Main_Priority, - Main_CPU => Default_Main_CPU, - Munit_Index => 0, - No_Elab_Code_All => False, - Serial_Number => 0, - Source_Index => No_Source_File, - Unit_File_Name => Fname, - Unit_Name => Spec_Name, - Version => 0, - OA_Setting => 'O'); + Loading => False, + Main_Priority => Default_Main_Priority, + Main_CPU => Default_Main_CPU, + Primary_Stack_Count => 0, + Sec_Stack_Count => 0, + Munit_Index => 0, + No_Elab_Code_All => False, + Serial_Number => 0, + Source_Index => No_Source_File, + Unit_File_Name => Fname, + Unit_Name => Spec_Name, + Version => 0, + OA_Setting => 'O'); Set_Comes_From_Source_Default (Save_CS); Set_Error_Posted (Cunit_Entity); @@ -350,34 +352,37 @@ package body Lib.Load is end if; Units.Table (Main_Unit) := - (Cunit => Empty, - Cunit_Entity => Empty, - Dependency_Num => 0, - Dynamic_Elab => False, - Error_Location => No_Location, - Expected_Unit => No_Unit_Name, - Fatal_Error => None, - Generate_Code => False, - Has_RACW => False, - Filler => False, - Ident_String => Empty, + (Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dynamic_Elab => False, + Error_Location => No_Location, + Expected_Unit => No_Unit_Name, + Fatal_Error => None, + Generate_Code => False, + Has_RACW => False, + Filler => False, + Ident_String => Empty, Is_Predefined_Renaming => Ren_Name, Is_Predefined_Unit => Pre_Name or Ren_Name, Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name, Filler2 => False, - Loading => True, - Main_Priority => Default_Main_Priority, - Main_CPU => Default_Main_CPU, - Munit_Index => 0, - No_Elab_Code_All => False, - Serial_Number => 0, - Source_Index => Main_Source_File, - Unit_File_Name => Fname, - Unit_Name => No_Unit_Name, - Version => Version, - OA_Setting => 'O'); + Loading => True, + Main_Priority => Default_Main_Priority, + Main_CPU => Default_Main_CPU, + Primary_Stack_Count => 0, + Sec_Stack_Count => 0, + + Munit_Index => 0, + No_Elab_Code_All => False, + Serial_Number => 0, + Source_Index => Main_Source_File, + Unit_File_Name => Fname, + Unit_Name => No_Unit_Name, + Version => Version, + OA_Setting => 'O'); end if; end Load_Main_Source; @@ -728,34 +733,36 @@ package body Lib.Load is if Src_Ind > No_Source_File then Units.Table (Unum) := - (Cunit => Empty, - Cunit_Entity => Empty, - Dependency_Num => 0, - Dynamic_Elab => False, - Error_Location => Sloc (Error_Node), - Expected_Unit => Uname_Actual, - Fatal_Error => None, - Generate_Code => False, - Has_RACW => False, - Filler => False, - Ident_String => Empty, + (Cunit => Empty, + Cunit_Entity => Empty, + Dependency_Num => 0, + Dynamic_Elab => False, + Error_Location => Sloc (Error_Node), + Expected_Unit => Uname_Actual, + Fatal_Error => None, + Generate_Code => False, + Has_RACW => False, + Filler => False, + Ident_String => Empty, Is_Predefined_Renaming => Ren_Name, Is_Predefined_Unit => Pre_Name or Ren_Name, Is_Internal_Unit => Pre_Name or Ren_Name or GNAT_Name, Filler2 => False, - Loading => True, - Main_Priority => Default_Main_Priority, - Main_CPU => Default_Main_CPU, - Munit_Index => 0, - No_Elab_Code_All => False, - Serial_Number => 0, - Source_Index => Src_Ind, - Unit_File_Name => Fname, - Unit_Name => Uname_Actual, - Version => Source_Checksum (Src_Ind), - OA_Setting => 'O'); + Loading => True, + Main_Priority => Default_Main_Priority, + Main_CPU => Default_Main_CPU, + Primary_Stack_Count => 0, + Sec_Stack_Count => 0, + Munit_Index => 0, + No_Elab_Code_All => False, + Serial_Number => 0, + Source_Index => Src_Ind, + Unit_File_Name => Fname, + Unit_Name => Uname_Actual, + Version => Source_Checksum (Src_Ind), + OA_Setting => 'O'); -- Parse the new unit diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index d263b05dc1c..47109b4e3f9 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -96,6 +96,8 @@ package body Lib.Writ is Main_CPU => -1, Munit_Index => 0, No_Elab_Code_All => False, + Primary_Stack_Count => 0, + Sec_Stack_Count => 0, Serial_Number => 0, Version => 0, Error_Location => No_Location, @@ -157,6 +159,8 @@ package body Lib.Writ is Main_CPU => -1, Munit_Index => 0, No_Elab_Code_All => False, + Primary_Stack_Count => 0, + Sec_Stack_Count => 0, Serial_Number => 0, Version => 0, Error_Location => No_Location, @@ -616,6 +620,19 @@ package body Lib.Writ is Write_With_Lines; + -- Generate task stack lines + + if Primary_Stack_Count (Unit_Num) > 0 + or else Sec_Stack_Count (Unit_Num) > 0 + then + Write_Info_Initiate ('T'); + Write_Info_Char (' '); + Write_Info_Int (Primary_Stack_Count (Unit_Num)); + Write_Info_Char (' '); + Write_Info_Int (Sec_Stack_Count (Unit_Num)); + Write_Info_EOL; + end if; + -- Generate the linker option lines for J in 1 .. Linker_Option_Lines.Last loop diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index f113b0a5993..a959e94e2fc 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -670,14 +670,33 @@ package Lib.Writ is -- binder do the consistency check, but not include the unit in the -- partition closure (unless it is properly With'ed somewhere). + -- -------------------- + -- -- T Task Stacks -- + -- -------------------- + + -- Following the W lines (if any, or the U line if not), is an optional + -- line that identifies the number of default-sized primary and secondary + -- stacks that the binder needs to create for the tasks declared within the + -- unit. For each compilation unit, a line is present in the form: + + -- T primary-stack-quantity secondary-stack-quantity + + -- The first parameter of T defines the number of task objects declared + -- in the unit that have no Storage_Size specified. The second parameter + -- defines the number of task objects declared in the unit that have no + -- Secondary_Stack_Size specified. These values are non-zero only if + -- the restrictions No_Implicit_Heap_Allocations or + -- No_Implicit_Task_Allocations are active. + -- ----------------------- -- -- L Linker_Options -- -- ----------------------- - -- Following the W lines (if any, or the U line if not), are an optional - -- series of lines that indicates the usage of the pragma Linker_Options in - -- the associated unit. For each appearance of a pragma Linker_Options (or - -- Link_With) in the unit, a line is present with the form: + -- Following the T and W lines (if any, or the U line if not), are + -- an optional series of lines that indicates the usage of the pragma + -- Linker_Options in the associated unit. For each appearance of a pragma + -- Linker_Options (or Link_With) in the unit, a line is present with the + -- form: -- L "string" diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 8de6f355d0c..02eb1987d8e 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -178,6 +178,16 @@ package body Lib is return Units.Table (U).OA_Setting; end OA_Setting; + function Primary_Stack_Count (U : Unit_Number_Type) return Int is + begin + return Units.Table (U).Primary_Stack_Count; + end Primary_Stack_Count; + + function Sec_Stack_Count (U : Unit_Number_Type) return Int is + begin + return Units.Table (U).Sec_Stack_Count; + end Sec_Stack_Count; + function Source_Index (U : Unit_Number_Type) return Source_File_Index is begin return Units.Table (U).Source_Index; @@ -1027,6 +1037,26 @@ package body Lib is return Get_Source_Unit (N1) = Get_Source_Unit (N2); end In_Same_Source_Unit; + ----------------------------------- + -- Increment_Primary_Stack_Count -- + ----------------------------------- + + procedure Increment_Primary_Stack_Count (Increment : Int) is + PSC : Int renames Units.Table (Current_Sem_Unit).Primary_Stack_Count; + begin + PSC := PSC + Increment; + end Increment_Primary_Stack_Count; + + ------------------------------- + -- Increment_Sec_Stack_Count -- + ------------------------------- + + procedure Increment_Sec_Stack_Count (Increment : Int) is + SSC : Int renames Units.Table (Current_Sem_Unit).Sec_Stack_Count; + begin + SSC := SSC + Increment; + end Increment_Sec_Stack_Count; + ----------------------------- -- Increment_Serial_Number -- ----------------------------- diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index be6864a3e83..f2b195c75c2 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -370,6 +370,20 @@ package Lib is -- This is a character field containing L if Optimize_Alignment mode -- was set locally, and O/T/S for Off/Time/Space default if not. + -- Primary_Stack_Count + -- The number of primary stacks belonging to tasks defined within the + -- unit that have no Storage_Size specified when the either restriction + -- No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations is + -- active. Only used by the binder to generate stacks for these tasks + -- at bind time. + + -- Sec_Stack_Count + -- The number of secondary stacks belonging to tasks defined within the + -- unit that have no Secondary_Stack_Size specified when the either + -- the No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations + -- restrictions are active. Only used by the binder to generate stacks + -- for these tasks at bind time. + -- Serial_Number -- This field holds a serial number used by New_Internal_Name to -- generate unique temporary numbers on a unit by unit basis. The @@ -450,6 +464,8 @@ package Lib is function Munit_Index (U : Unit_Number_Type) return Nat; function No_Elab_Code_All (U : Unit_Number_Type) return Boolean; function OA_Setting (U : Unit_Number_Type) return Character; + function Primary_Stack_Count (U : Unit_Number_Type) return Int; + function Sec_Stack_Count (U : Unit_Number_Type) return Int; function Source_Index (U : Unit_Number_Type) return Source_File_Index; function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type; function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type; @@ -662,6 +678,13 @@ package Lib is -- source unit, the criterion being that Get_Source_Unit yields the -- same value for each argument. + procedure Increment_Primary_Stack_Count (Increment : Int); + -- Increment the Primary_Stack_Count field for the current unit by + -- Increment. + + procedure Increment_Sec_Stack_Count (Increment : Int); + -- Increment the Sec_Stack_Count field for the current unit by Increment + function Increment_Serial_Number return Nat; -- Increment Serial_Number field for current unit, and return the -- incremented value. @@ -794,6 +817,8 @@ private pragma Inline (Fatal_Error); pragma Inline (Generate_Code); pragma Inline (Has_RACW); + pragma Inline (Increment_Primary_Stack_Count); + pragma Inline (Increment_Sec_Stack_Count); pragma Inline (Increment_Serial_Number); pragma Inline (Loading); pragma Inline (Main_CPU); @@ -809,6 +834,8 @@ private pragma Inline (Is_Predefined_Renaming); pragma Inline (Is_Internal_Unit); pragma Inline (Is_Predefined_Unit); + pragma Inline (Primary_Stack_Count); + pragma Inline (Sec_Stack_Count); pragma Inline (Set_Loading); pragma Inline (Set_Main_CPU); pragma Inline (Set_Main_Priority); @@ -822,28 +849,30 @@ private -- The Units Table type Unit_Record is record - Unit_File_Name : File_Name_Type; - Unit_Name : Unit_Name_Type; - Munit_Index : Nat; - Expected_Unit : Unit_Name_Type; - Source_Index : Source_File_Index; - Cunit : Node_Id; - Cunit_Entity : Entity_Id; - Dependency_Num : Int; - Ident_String : Node_Id; - Main_Priority : Int; - Main_CPU : Int; - Serial_Number : Nat; - Version : Word; - Error_Location : Source_Ptr; - Fatal_Error : Fatal_Type; - Generate_Code : Boolean; - Has_RACW : Boolean; - Dynamic_Elab : Boolean; - No_Elab_Code_All : Boolean; - Filler : Boolean; - Loading : Boolean; - OA_Setting : Character; + Unit_File_Name : File_Name_Type; + Unit_Name : Unit_Name_Type; + Munit_Index : Nat; + Expected_Unit : Unit_Name_Type; + Source_Index : Source_File_Index; + Cunit : Node_Id; + Cunit_Entity : Entity_Id; + Dependency_Num : Int; + Ident_String : Node_Id; + Main_Priority : Int; + Main_CPU : Int; + Primary_Stack_Count : Int; + Sec_Stack_Count : Int; + Serial_Number : Nat; + Version : Word; + Error_Location : Source_Ptr; + Fatal_Error : Fatal_Type; + Generate_Code : Boolean; + Has_RACW : Boolean; + Dynamic_Elab : Boolean; + No_Elab_Code_All : Boolean; + Filler : Boolean; + Loading : Boolean; + OA_Setting : Character; Is_Predefined_Renaming : Boolean; Is_Internal_Unit : Boolean; @@ -856,36 +885,38 @@ private -- written by Tree_Gen, we do not write uninitialized values to the file. for Unit_Record use record - Unit_File_Name at 0 range 0 .. 31; - Unit_Name at 4 range 0 .. 31; - Munit_Index at 8 range 0 .. 31; - Expected_Unit at 12 range 0 .. 31; - Source_Index at 16 range 0 .. 31; - Cunit at 20 range 0 .. 31; - Cunit_Entity at 24 range 0 .. 31; - Dependency_Num at 28 range 0 .. 31; - Ident_String at 32 range 0 .. 31; - Main_Priority at 36 range 0 .. 31; - Main_CPU at 40 range 0 .. 31; - Serial_Number at 44 range 0 .. 31; - Version at 48 range 0 .. 31; - Error_Location at 52 range 0 .. 31; - Fatal_Error at 56 range 0 .. 7; - Generate_Code at 57 range 0 .. 7; - Has_RACW at 58 range 0 .. 7; - Dynamic_Elab at 59 range 0 .. 7; - No_Elab_Code_All at 60 range 0 .. 7; - Filler at 61 range 0 .. 7; - OA_Setting at 62 range 0 .. 7; - Loading at 63 range 0 .. 7; - - Is_Predefined_Renaming at 64 range 0 .. 7; - Is_Internal_Unit at 65 range 0 .. 7; - Is_Predefined_Unit at 66 range 0 .. 7; - Filler2 at 67 range 0 .. 7; + Unit_File_Name at 0 range 0 .. 31; + Unit_Name at 4 range 0 .. 31; + Munit_Index at 8 range 0 .. 31; + Expected_Unit at 12 range 0 .. 31; + Source_Index at 16 range 0 .. 31; + Cunit at 20 range 0 .. 31; + Cunit_Entity at 24 range 0 .. 31; + Dependency_Num at 28 range 0 .. 31; + Ident_String at 32 range 0 .. 31; + Main_Priority at 36 range 0 .. 31; + Main_CPU at 40 range 0 .. 31; + Primary_Stack_Count at 44 range 0 .. 31; + Sec_Stack_Count at 48 range 0 .. 31; + Serial_Number at 52 range 0 .. 31; + Version at 56 range 0 .. 31; + Error_Location at 60 range 0 .. 31; + Fatal_Error at 64 range 0 .. 7; + Generate_Code at 65 range 0 .. 7; + Has_RACW at 66 range 0 .. 7; + Dynamic_Elab at 67 range 0 .. 7; + No_Elab_Code_All at 68 range 0 .. 7; + Filler at 69 range 0 .. 7; + OA_Setting at 70 range 0 .. 7; + Loading at 71 range 0 .. 7; + + Is_Predefined_Renaming at 72 range 0 .. 7; + Is_Internal_Unit at 73 range 0 .. 7; + Is_Predefined_Unit at 74 range 0 .. 7; + Filler2 at 75 range 0 .. 7; end record; - for Unit_Record'Size use 68 * 8; + for Unit_Record'Size use 76 * 8; -- This ensures that we did not leave out any fields package Units is new Table.Table ( diff --git a/gcc/ada/libgnarl/s-solita.adb b/gcc/ada/libgnarl/s-solita.adb index bb38578b06f..a5485aa268d 100644 --- a/gcc/ada/libgnarl/s-solita.adb +++ b/gcc/ada/libgnarl/s-solita.adb @@ -44,6 +44,7 @@ with Ada.Exceptions.Is_Null_Occurrence; with System.Task_Primitives.Operations; with System.Tasking; with System.Stack_Checking; +with System.Secondary_Stack; package body System.Soft_Links.Tasking is @@ -52,6 +53,8 @@ package body System.Soft_Links.Tasking is use Ada.Exceptions; + use type System.Secondary_Stack.SS_Stack_Ptr; + use type System.Tasking.Task_Id; use type System.Tasking.Termination_Handler; @@ -71,8 +74,8 @@ package body System.Soft_Links.Tasking is procedure Set_Jmpbuf_Address (Addr : Address); -- Get/Set Jmpbuf_Address for current task - function Get_Sec_Stack_Addr return Address; - procedure Set_Sec_Stack_Addr (Addr : Address); + function Get_Sec_Stack return SST.SS_Stack_Ptr; + procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr); -- Get/Set location of current task's secondary stack procedure Timed_Delay_T (Time : Duration; Mode : Integer); @@ -93,14 +96,14 @@ package body System.Soft_Links.Tasking is return STPO.Self.Common.Compiler_Data.Jmpbuf_Address; end Get_Jmpbuf_Address; - function Get_Sec_Stack_Addr return Address is + function Get_Sec_Stack return SST.SS_Stack_Ptr is begin - return Result : constant Address := - STPO.Self.Common.Compiler_Data.Sec_Stack_Addr + return Result : constant SST.SS_Stack_Ptr := + STPO.Self.Common.Compiler_Data.Sec_Stack_Ptr do - pragma Assert (Result /= Null_Address); + pragma Assert (Result /= null); end return; - end Get_Sec_Stack_Addr; + end Get_Sec_Stack; function Get_Stack_Info return Stack_Checking.Stack_Access is begin @@ -116,10 +119,10 @@ package body System.Soft_Links.Tasking is STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr; end Set_Jmpbuf_Address; - procedure Set_Sec_Stack_Addr (Addr : Address) is + procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr) is begin - STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr; - end Set_Sec_Stack_Addr; + STPO.Self.Common.Compiler_Data.Sec_Stack_Ptr := Stack; + end Set_Sec_Stack; ------------------- -- Timed_Delay_T -- @@ -213,20 +216,20 @@ package body System.Soft_Links.Tasking is SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; - SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; + SSL.Get_Sec_Stack := Get_Sec_Stack'Access; SSL.Get_Stack_Info := Get_Stack_Info'Access; - SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; + SSL.Set_Sec_Stack := Set_Sec_Stack'Access; SSL.Timed_Delay := Timed_Delay_T'Access; SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access; -- No need to create a new secondary stack, since we will use the -- default one created in s-secsta.adb. - SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT); + SSL.Set_Sec_Stack (SSL.Get_Sec_Stack_NT); SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); end if; - pragma Assert (Get_Sec_Stack_Addr /= Null_Address); + pragma Assert (Get_Sec_Stack /= null); end Init_Tasking_Soft_Links; end System.Soft_Links.Tasking; diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb index 1dfcf39dd81..ba5a09907c1 100644 --- a/gcc/ada/libgnarl/s-taprop__linux.adb +++ b/gcc/ada/libgnarl/s-taprop__linux.adb @@ -152,11 +152,16 @@ package body System.Task_Primitives.Operations is -- Support for foreign threads -- --------------------------------- - function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread + function Register_Foreign_Thread + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id; + -- Allocate and initialize a new ATCB for the current Thread. The size of + -- the secondary stack can be optionally specified. function Register_Foreign_Thread - (Thread : Thread_Id) return Task_Id is separate; + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) + return Task_Id is separate; ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/libgnarl/s-taprop__mingw.adb b/gcc/ada/libgnarl/s-taprop__mingw.adb index fa966514568..b14444ad185 100644 --- a/gcc/ada/libgnarl/s-taprop__mingw.adb +++ b/gcc/ada/libgnarl/s-taprop__mingw.adb @@ -190,11 +190,16 @@ package body System.Task_Primitives.Operations is -- Support for foreign threads -- --------------------------------- - function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread + function Register_Foreign_Thread + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id; + -- Allocate and initialize a new ATCB for the current Thread. The size of + -- the secondary stack can be optionally specified. function Register_Foreign_Thread - (Thread : Thread_Id) return Task_Id is separate; + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) + return Task_Id is separate; ---------------------------------- -- Condition Variable Functions -- diff --git a/gcc/ada/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb index 3efc1e0de1a..a614507bd04 100644 --- a/gcc/ada/libgnarl/s-taprop__posix.adb +++ b/gcc/ada/libgnarl/s-taprop__posix.adb @@ -156,11 +156,16 @@ package body System.Task_Primitives.Operations is -- Support for foreign threads -- --------------------------------- - function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread + function Register_Foreign_Thread + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id; + -- Allocate and initialize a new ATCB for the current Thread. The size of + -- the secondary stack can be optionally specified. function Register_Foreign_Thread - (Thread : Thread_Id) return Task_Id is separate; + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) + return Task_Id is separate; ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/libgnarl/s-taprop__solaris.adb b/gcc/ada/libgnarl/s-taprop__solaris.adb index e97662c12b1..26d83e584d6 100644 --- a/gcc/ada/libgnarl/s-taprop__solaris.adb +++ b/gcc/ada/libgnarl/s-taprop__solaris.adb @@ -237,11 +237,16 @@ package body System.Task_Primitives.Operations is -- Support for foreign threads -- --------------------------------- - function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread + function Register_Foreign_Thread + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id; + -- Allocate and initialize a new ATCB for the current Thread. The size of + -- the secondary stack can be optionally specified. function Register_Foreign_Thread - (Thread : Thread_Id) return Task_Id is separate; + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) + return Task_Id is separate; ------------ -- Checks -- diff --git a/gcc/ada/libgnarl/s-taprop__vxworks.adb b/gcc/ada/libgnarl/s-taprop__vxworks.adb index b77fb106b37..83ebc22312e 100644 --- a/gcc/ada/libgnarl/s-taprop__vxworks.adb +++ b/gcc/ada/libgnarl/s-taprop__vxworks.adb @@ -149,11 +149,16 @@ package body System.Task_Primitives.Operations is -- Support for foreign threads -- --------------------------------- - function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread + function Register_Foreign_Thread + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) return Task_Id; + -- Allocate and initialize a new ATCB for the current Thread. The size of + -- the secondary stack can be optionally specified. function Register_Foreign_Thread - (Thread : Thread_Id) return Task_Id is separate; + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) + return Task_Id is separate; ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/libgnarl/s-tarest.adb b/gcc/ada/libgnarl/s-tarest.adb index daff5c1c3ae..7b9f260927e 100644 --- a/gcc/ada/libgnarl/s-tarest.adb +++ b/gcc/ada/libgnarl/s-tarest.adb @@ -47,12 +47,6 @@ with Ada.Exceptions; with System.Task_Primitives.Operations; with System.Soft_Links.Tasking; -with System.Storage_Elements; - -with System.Secondary_Stack; -pragma Elaborate_All (System.Secondary_Stack); --- Make sure the body of Secondary_Stack is elaborated before calling --- Init_Tasking_Soft_Links. See comments for this routine for explanation. with System.Soft_Links; -- Used for the non-tasking routines (*_NT) that refer to global data. They @@ -65,8 +59,6 @@ package body System.Tasking.Restricted.Stages is package STPO renames System.Task_Primitives.Operations; package SSL renames System.Soft_Links; - package SSE renames System.Storage_Elements; - package SST renames System.Secondary_Stack; use Ada.Exceptions; @@ -115,17 +107,18 @@ package body System.Tasking.Restricted.Stages is -- This should only be called by the Task_Wrapper procedure. procedure Create_Restricted_Task - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Task_Image : String; - Created_Task : Task_Id); + (Priority : Integer; + Stack_Address : System.Address; + Stack_Size : System.Parameters.Size_Type; + Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr; + Sec_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Task_Image : String; + Created_Task : Task_Id); -- Code shared between Create_Restricted_Task (the concurrent version) and -- Create_Restricted_Task_Sequential. See comment of the former in the -- specification of this package. @@ -205,54 +198,6 @@ package body System.Tasking.Restricted.Stages is -- -- DO NOT delete ID. As noted, it is needed on some targets. - function Secondary_Stack_Size return Storage_Elements.Storage_Offset; - -- Returns the size of the secondary stack for the task. For fixed - -- secondary stacks, the function will return the ATCB field - -- Secondary_Stack_Size if it is not set to Unspecified_Size, - -- otherwise a percentage of the stack is reserved using the - -- System.Parameters.Sec_Stack_Percentage property. - - -- Dynamic secondary stacks are allocated in System.Soft_Links. - -- Create_TSD and thus the function returns 0 to suppress the - -- creation of the fixed secondary stack in the primary stack. - - -------------------------- - -- Secondary_Stack_Size -- - -------------------------- - - function Secondary_Stack_Size return Storage_Elements.Storage_Offset is - use System.Storage_Elements; - use System.Secondary_Stack; - - begin - if Parameters.Sec_Stack_Dynamic then - return 0; - - elsif Self_ID.Common.Secondary_Stack_Size = Unspecified_Size then - return (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size - * SSE.Storage_Offset (Sec_Stack_Percentage) / 100); - else - -- Use the size specified by aspect Secondary_Stack_Size padded - -- by the amount of space used by the stack data structure. - - return Storage_Offset (Self_ID.Common.Secondary_Stack_Size) + - Storage_Offset (Minimum_Secondary_Stack_Size); - end if; - end Secondary_Stack_Size; - - Secondary_Stack : aliased Storage_Elements.Storage_Array - (1 .. Secondary_Stack_Size); - for Secondary_Stack'Alignment use Standard'Maximum_Alignment; - -- This is the secondary stack data. Note that it is critical that this - -- have maximum alignment, since any kind of data can be allocated here. - - pragma Warnings (Off); - Secondary_Stack_Address : System.Address := Secondary_Stack'Address; - pragma Warnings (On); - -- Address of secondary stack. In the fixed secondary stack case, this - -- value is not modified, causing a warning, hence the bracketing with - -- Warnings (Off/On). - Cause : Cause_Of_Termination := Normal; -- Indicates the reason why this task terminates. Normal corresponds to -- a task terminating due to completing the last statement of its body. @@ -266,15 +211,7 @@ package body System.Tasking.Restricted.Stages is -- execution of its task body, then EO will contain the associated -- exception occurrence. Otherwise, it will contain Null_Occurrence. - -- Start of processing for Task_Wrapper - begin - if not Parameters.Sec_Stack_Dynamic then - Self_ID.Common.Compiler_Data.Sec_Stack_Addr := - Secondary_Stack'Address; - SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); - end if; - -- Initialize low-level TCB components, that cannot be initialized by -- the creator. @@ -539,17 +476,18 @@ package body System.Tasking.Restricted.Stages is ---------------------------- procedure Create_Restricted_Task - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Task_Image : String; - Created_Task : Task_Id) + (Priority : Integer; + Stack_Address : System.Address; + Stack_Size : System.Parameters.Size_Type; + Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr; + Sec_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Task_Image : String; + Created_Task : Task_Id) is Self_ID : constant Task_Id := STPO.Self; Base_Priority : System.Any_Priority; @@ -608,8 +546,7 @@ package body System.Tasking.Restricted.Stages is Initialize_ATCB (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, - Base_CPU, null, Task_Info, Size, Secondary_Stack_Size, - Created_Task, Success); + Base_CPU, null, Task_Info, Stack_Size, Created_Task, Success); -- If we do our job right then there should never be any failures, which -- was probably said about the Titanic; so just to be safe, let's retain @@ -639,25 +576,31 @@ package body System.Tasking.Restricted.Stages is Unlock_RTS; end if; - -- Create TSD as early as possible in the creation of a task, since it - -- may be used by the operation of Ada code within the task. + -- Create TSD as early as possible in the creation of a task, since + -- it may be used by the operation of Ada code within the task. If the + -- compiler has not allocated a secondary stack, a stack will be + -- allocated fromt the binder generated pool. - SSL.Create_TSD (Created_Task.Common.Compiler_Data); + SSL.Create_TSD + (Created_Task.Common.Compiler_Data, + Sec_Stack_Address, + Sec_Stack_Size); end Create_Restricted_Task; procedure Create_Restricted_Task - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Chain : in out Activation_Chain; - Task_Image : String; - Created_Task : Task_Id) + (Priority : Integer; + Stack_Address : System.Address; + Stack_Size : System.Parameters.Size_Type; + Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr; + Sec_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : Task_Id) is begin if Partition_Elaboration_Policy = 'S' then @@ -668,14 +611,14 @@ package body System.Tasking.Restricted.Stages is -- sequential, activation must be deferred. Create_Restricted_Task_Sequential - (Priority, Stack_Address, Size, Secondary_Stack_Size, - Task_Info, CPU, State, Discriminants, Elaborated, + (Priority, Stack_Address, Stack_Size, Sec_Stack_Address, + Sec_Stack_Size, Task_Info, CPU, State, Discriminants, Elaborated, Task_Image, Created_Task); else Create_Restricted_Task - (Priority, Stack_Address, Size, Secondary_Stack_Size, - Task_Info, CPU, State, Discriminants, Elaborated, + (Priority, Stack_Address, Stack_Size, Sec_Stack_Address, + Sec_Stack_Size, Task_Info, CPU, State, Discriminants, Elaborated, Task_Image, Created_Task); -- Append this task to the activation chain @@ -690,22 +633,24 @@ package body System.Tasking.Restricted.Stages is --------------------------------------- procedure Create_Restricted_Task_Sequential - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Task_Image : String; - Created_Task : Task_Id) is + (Priority : Integer; + Stack_Address : System.Address; + Stack_Size : System.Parameters.Size_Type; + Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr; + Sec_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Task_Image : String; + Created_Task : Task_Id) + is begin - Create_Restricted_Task (Priority, Stack_Address, Size, - Secondary_Stack_Size, Task_Info, - CPU, State, Discriminants, Elaborated, - Task_Image, Created_Task); + Create_Restricted_Task + (Priority, Stack_Address, Stack_Size, Sec_Stack_Address, + Sec_Stack_Size, Task_Info, CPU, State, Discriminants, Elaborated, + Task_Image, Created_Task); -- Append this task to the activation chain diff --git a/gcc/ada/libgnarl/s-tarest.ads b/gcc/ada/libgnarl/s-tarest.ads index ccc5683bd31..e51fa58ca61 100644 --- a/gcc/ada/libgnarl/s-tarest.ads +++ b/gcc/ada/libgnarl/s-tarest.ads @@ -43,8 +43,9 @@ -- The restricted GNARLI is also composed of System.Protected_Objects and -- System.Protected_Objects.Single_Entry -with System.Task_Info; with System.Parameters; +with System.Secondary_Stack; +with System.Task_Info; package System.Tasking.Restricted.Stages is pragma Elaborate_Body; @@ -128,33 +129,38 @@ package System.Tasking.Restricted.Stages is -- by the binder generated code, before calling elaboration code. procedure Create_Restricted_Task - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Chain : in out Activation_Chain; - Task_Image : String; - Created_Task : Task_Id); + (Priority : Integer; + Stack_Address : System.Address; + Stack_Size : System.Parameters.Size_Type; + Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr; + Sec_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : Task_Id); -- Compiler interface only. Do not call from within the RTS. -- This must be called to create a new task, when the partition -- elaboration policy is not specified (or is concurrent). -- -- Priority is the task's priority (assumed to be in the - -- System.Any_Priority'Range) + -- System.Any_Priority'Range). -- -- Stack_Address is the start address of the stack associated to the task, -- in case it has been preallocated by the compiler; it is equal to -- Null_Address when the stack needs to be allocated by the underlying -- operating system. -- - -- Size is the stack size of the task to create + -- Stack_Size is the stack size of the task to create. + -- + -- Sec_Stack_Address is the pointer to the secondary stack created by the + -- compiler. If null, the secondary stack is either allocated by the binder + -- or the run-time. -- - -- Secondary_Stack_Size is the secondary stack size of the task to create + -- Secondary_Stack_Size is the secondary stack size of the task to create. -- -- Task_Info is the task info associated with the created task, or -- Unspecified_Task_Info if none. @@ -164,7 +170,7 @@ package System.Tasking.Restricted.Stages is -- checks are performed when analyzing the pragma, and dynamic ones are -- performed before setting the affinity at run time. -- - -- State is the compiler generated task's procedure body + -- State is the compiler generated task's procedure body. -- -- Discriminants is a pointer to a limited record whose discriminants are -- those of the task to create. This parameter should be passed as the @@ -182,20 +188,21 @@ package System.Tasking.Restricted.Stages is -- -- Created_Task is the resulting task. -- - -- This procedure can raise Storage_Error if the task creation fails + -- This procedure can raise Storage_Error if the task creation fails. procedure Create_Restricted_Task_Sequential - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Task_Image : String; - Created_Task : Task_Id); + (Priority : Integer; + Stack_Address : System.Address; + Stack_Size : System.Parameters.Size_Type; + Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr; + Sec_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Task_Image : String; + Created_Task : Task_Id); -- Compiler interface only. Do not call from within the RTS. -- This must be called to create a new task, when the sequential partition -- elaboration policy is used. diff --git a/gcc/ada/libgnarl/s-taskin.adb b/gcc/ada/libgnarl/s-taskin.adb index 462e229645c..d9fc6e3213b 100644 --- a/gcc/ada/libgnarl/s-taskin.adb +++ b/gcc/ada/libgnarl/s-taskin.adb @@ -96,7 +96,6 @@ package body System.Tasking is Domain : Dispatching_Domain_Access; Task_Info : System.Task_Info.Task_Info_Type; Stack_Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; T : Task_Id; Success : out Boolean) is @@ -147,7 +146,6 @@ package body System.Tasking is T.Common.Specific_Handler := null; T.Common.Debug_Events := (others => False); T.Common.Task_Image_Len := 0; - T.Common.Secondary_Stack_Size := Secondary_Stack_Size; if T.Common.Parent = null then @@ -244,7 +242,6 @@ package body System.Tasking is Domain => System_Domain, Task_Info => Task_Info.Unspecified_Task_Info, Stack_Size => 0, - Secondary_Stack_Size => Parameters.Unspecified_Size, T => T, Success => Success); pragma Assert (Success); diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads index cd53cf93471..7c8b44b952c 100644 --- a/gcc/ada/libgnarl/s-taskin.ads +++ b/gcc/ada/libgnarl/s-taskin.ads @@ -37,12 +37,12 @@ with Ada.Exceptions; with Ada.Unchecked_Conversion; +with System.Multiprocessors; with System.Parameters; -with System.Task_Info; with System.Soft_Links; -with System.Task_Primitives; with System.Stack_Usage; -with System.Multiprocessors; +with System.Task_Info; +with System.Task_Primitives; package System.Tasking is pragma Preelaborate; @@ -702,13 +702,6 @@ package System.Tasking is -- need to do different things depending on the situation. -- -- Protection: Self.L - - Secondary_Stack_Size : System.Parameters.Size_Type; - -- Secondary_Stack_Size is the size of the secondary stack for the - -- task. Defined here since it is the responsibility of the task to - -- creates its own secondary stack. - -- - -- Protected: Only accessed by Self end record; --------------------------------------- @@ -1173,7 +1166,6 @@ package System.Tasking is Domain : Dispatching_Domain_Access; Task_Info : System.Task_Info.Task_Info_Type; Stack_Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; T : Task_Id; Success : out Boolean); -- Initialize fields of the TCB for task T, and link into global TCB diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb index 44c054fec3e..518a02c8b48 100644 --- a/gcc/ada/libgnarl/s-tassta.adb +++ b/gcc/ada/libgnarl/s-tassta.adb @@ -71,11 +71,11 @@ package body System.Tasking.Stages is package STPO renames System.Task_Primitives.Operations; package SSL renames System.Soft_Links; package SSE renames System.Storage_Elements; - package SST renames System.Secondary_Stack; use Ada.Exceptions; use Parameters; + use Secondary_Stack; use Task_Primitives; use Task_Primitives.Operations; @@ -465,7 +465,7 @@ package body System.Tasking.Stages is procedure Create_Task (Priority : Integer; - Size : System.Parameters.Size_Type; + Stack_Size : System.Parameters.Size_Type; Secondary_Stack_Size : System.Parameters.Size_Type; Task_Info : System.Task_Info.Task_Info_Type; CPU : Integer; @@ -604,8 +604,7 @@ package body System.Tasking.Stages is end if; Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, - Base_Priority, Base_CPU, Domain, Task_Info, Size, - Secondary_Stack_Size, T, Success); + Base_Priority, Base_CPU, Domain, Task_Info, Stack_Size, T, Success); if not Success then Free (T); @@ -692,10 +691,18 @@ package body System.Tasking.Stages is Dispatching_Domain_Tasks (Base_CPU) + 1; end if; - -- Create TSD as early as possible in the creation of a task, since it - -- may be used by the operation of Ada code within the task. + -- Create the secondary stack for the task as early as possible during + -- in the creation of a task, since it may be used by the operation of + -- Ada code within the task. + + begin + SSL.Create_TSD (T.Common.Compiler_Data, null, Secondary_Stack_Size); + exception + when others => + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Storage_Error with "Secondary stack could not be allocated"; + end; - SSL.Create_TSD (T.Common.Compiler_Data); T.Common.Activation_Link := Chain.T_ID; Chain.T_ID := T; Created_Task := T; @@ -914,8 +921,8 @@ package body System.Tasking.Stages is SSL.Unlock_Task := SSL.Task_Unlock_NT'Access; SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access; SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access; - SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access; - SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access; + SSL.Get_Sec_Stack := SSL.Get_Sec_Stack_NT'Access; + SSL.Set_Sec_Stack := SSL.Set_Sec_Stack_NT'Access; SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access; SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access; @@ -1014,7 +1021,6 @@ package body System.Tasking.Stages is -- at-end handler that the compiler generates. procedure Task_Wrapper (Self_ID : Task_Id) is - use type SSE.Storage_Offset; use System.Standard_Library; use System.Stack_Usage; @@ -1027,52 +1033,6 @@ package body System.Tasking.Stages is Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; -- Whether to use above alternate signal stack for stack overflows - function Secondary_Stack_Size return Storage_Elements.Storage_Offset; - -- Returns the size of the secondary stack for the task. For fixed - -- secondary stacks, the function will return the ATCB field - -- Secondary_Stack_Size if it is not set to Unspecified_Size, - -- otherwise a percentage of the stack is reserved using the - -- System.Parameters.Sec_Stack_Percentage property. - - -- Dynamic secondary stacks are allocated in System.Soft_Links. - -- Create_TSD and thus the function returns 0 to suppress the - -- creation of the fixed secondary stack in the primary stack. - - -------------------------- - -- Secondary_Stack_Size -- - -------------------------- - - function Secondary_Stack_Size return Storage_Elements.Storage_Offset is - use System.Storage_Elements; - - begin - if Parameters.Sec_Stack_Dynamic then - return 0; - - elsif Self_ID.Common.Secondary_Stack_Size = Unspecified_Size then - return (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size - * SSE.Storage_Offset (Sec_Stack_Percentage) / 100); - else - -- Use the size specified by aspect Secondary_Stack_Size padded - -- by the amount of space used by the stack data structure. - - return Storage_Offset (Self_ID.Common.Secondary_Stack_Size) + - Storage_Offset (SST.Minimum_Secondary_Stack_Size); - end if; - end Secondary_Stack_Size; - - Secondary_Stack : aliased Storage_Elements.Storage_Array - (1 .. Secondary_Stack_Size); - for Secondary_Stack'Alignment use Standard'Maximum_Alignment; - -- Actual area allocated for secondary stack. Note that it is critical - -- that this have maximum alignment, since any kind of data can be - -- allocated here. - - Secondary_Stack_Address : System.Address := Secondary_Stack'Address; - -- Address of secondary stack. In the fixed secondary stack case, this - -- value is not modified, causing a warning, hence the bracketing with - -- Warnings (Off/On). But why is so much *more* bracketed??? - SEH_Table : aliased SSE.Storage_Array (1 .. 8); -- Structured Exception Registration table (2 words) @@ -1136,14 +1096,6 @@ package body System.Tasking.Stages is Debug.Master_Hook (Self_ID, Self_ID.Common.Parent, Self_ID.Master_of_Task); - -- Assume a size of the stack taken at this stage - - if not Parameters.Sec_Stack_Dynamic then - Self_ID.Common.Compiler_Data.Sec_Stack_Addr := - Secondary_Stack'Address; - SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); - end if; - if Use_Alternate_Stack then Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; end if; @@ -1197,15 +1149,6 @@ package body System.Tasking.Stages is Stack_Base := Bottom_Of_Stack'Address; - -- Also reduce the size of the stack to take into account the - -- secondary stack array declared in this frame. This is for - -- sure very conservative. - - if not Parameters.Sec_Stack_Dynamic then - Pattern_Size := - Pattern_Size - Natural (Secondary_Stack_Size); - end if; - -- Adjustments for inner frames Pattern_Size := Pattern_Size - @@ -1973,10 +1916,10 @@ package body System.Tasking.Stages is then Initialization.Task_Lock (Self_ID); - -- If Sec_Stack_Addr is not null, it means that Destroy_TSD + -- If Sec_Stack_Ptr is not null, it means that Destroy_TSD -- has not been called yet (case of an unactivated task). - if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then + if T.Common.Compiler_Data.Sec_Stack_Ptr /= null then SSL.Destroy_TSD (T.Common.Compiler_Data); end if; diff --git a/gcc/ada/libgnarl/s-tassta.ads b/gcc/ada/libgnarl/s-tassta.ads index bc837fc9af8..a1129a1085a 100644 --- a/gcc/ada/libgnarl/s-tassta.ads +++ b/gcc/ada/libgnarl/s-tassta.ads @@ -70,7 +70,7 @@ package System.Tasking.Stages is -- tE : aliased boolean := false; -- tZ : size_type := unspecified_size; -- type tV (discr : integer) is limited record - -- _task_id : task_id; + -- _task_id : task_id; -- end record; -- procedure tB (_task : access tV); -- freeze tV [ @@ -168,7 +168,7 @@ package System.Tasking.Stages is procedure Create_Task (Priority : Integer; - Size : System.Parameters.Size_Type; + Stack_Size : System.Parameters.Size_Type; Secondary_Stack_Size : System.Parameters.Size_Type; Task_Info : System.Task_Info.Task_Info_Type; CPU : Integer; @@ -187,31 +187,44 @@ package System.Tasking.Stages is -- -- Priority is the task's priority (assumed to be in range of type -- System.Any_Priority) - -- Size is the stack size of the task to create - -- Secondary_Stack_Size is the secondary stack size of the task to create + -- + -- Stack_Size is the stack size of the task to create + -- + -- Secondary_Stack_Size is the size of the secondary stack to be used by + -- the task. + -- -- Task_Info is the task info associated with the created task, or -- Unspecified_Task_Info if none. + -- -- CPU is the task affinity. Passed as an Integer because the undefined -- value is not in the range of CPU_Range. Static range checks are -- performed when analyzing the pragma, and dynamic ones are performed -- before setting the affinity at run time. + -- -- Relative_Deadline is the relative deadline associated with the created -- task by means of a pragma Relative_Deadline, or 0.0 if none. + -- -- Domain is the dispatching domain associated with the created task by -- means of a Dispatching_Domain pragma or aspect, or null if none. + -- -- State is the compiler generated task's procedure body + -- -- Discriminants is a pointer to a limited record whose discriminants -- are those of the task to create. This parameter should be passed as -- the single argument to State. + -- -- Elaborated is a pointer to a Boolean that must be set to true on exit -- if the task could be successfully elaborated. + -- -- Chain is a linked list of task that needs to be created. On exit, -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID -- will be Created_Task (e.g the created task will be linked at the front -- of Chain). + -- -- Task_Image is a string created by the compiler that the -- run time can store to ease the debugging and the -- Ada.Task_Identification facility. + -- -- Created_Task is the resulting task. -- -- This procedure can raise Storage_Error if the task creation failed. diff --git a/gcc/ada/libgnarl/s-tporft.adb b/gcc/ada/libgnarl/s-tporft.adb index 7b8a59276f8..56eda26e6a1 100644 --- a/gcc/ada/libgnarl/s-tporft.adb +++ b/gcc/ada/libgnarl/s-tporft.adb @@ -29,16 +29,16 @@ -- -- ------------------------------------------------------------------------------ -with System.Task_Info; --- Use for Unspecified_Task_Info - -with System.Soft_Links; --- used to initialize TSD for a C thread, in function Self - with System.Multiprocessors; +with System.Soft_Links; +with System.Task_Info; separate (System.Task_Primitives.Operations) -function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id is +function Register_Foreign_Thread + (Thread : Thread_Id; + Sec_Stack_Size : Size_Type := Unspecified_Size) + return Task_Id +is Local_ATCB : aliased Ada_Task_Control_Block (0); Self_Id : Task_Id; Succeeded : Boolean; @@ -66,7 +66,7 @@ begin (Self_Id, null, Null_Address, Null_Task, Foreign_Task_Elaborated'Access, System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, null, - Task_Info.Unspecified_Task_Info, 0, 0, Self_Id, Succeeded); + Task_Info.Unspecified_Task_Info, 0, Self_Id, Succeeded); Unlock_RTS; pragma Assert (Succeeded); @@ -92,7 +92,10 @@ begin Self_Id.Common.Task_Alternate_Stack := Null_Address; - System.Soft_Links.Create_TSD (Self_Id.Common.Compiler_Data); + -- Create the TSD for the task + + System.Soft_Links.Create_TSD + (Self_Id.Common.Compiler_Data, null, Sec_Stack_Size); Enter_Task (Self_Id); 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 diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 687d1eb75b9..96e2f3e2f92 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -462,18 +462,21 @@ package Opt is -- otherwise: "pragma Default_Storage_Pool (X);" applies, and -- this points to the name X. -- Push_Scope and Pop_Scope in Sem_Ch8 save and restore this value. - Default_Stack_Size : Int := -1; + + No_Stack_Size : constant := -1; + + Default_Stack_Size : Int := No_Stack_Size; -- GNATBIND - -- Set to default primary stack size in units of bytes. Set by - -- the -dnnn switch for the binder. A value of -1 indicates that no - -- default was set by the binder. + -- Set to default primary stack size in units of bytes. Set by the -dnnn + -- switch for the binder. A value of No_Stack_Size indicates that + -- no default was set by the binder. - Default_Sec_Stack_Size : Int := -1; + Default_Sec_Stack_Size : Int := No_Stack_Size; -- GNATBIND - -- Set to default secondary stack size in units of bytes. Set by - -- the -Dnnn switch for the binder. A value of -1 indicates that no - -- default was set by the binder, and that the default should be the - -- initial value of System.Secondary_Stack.Default_Secondary_Stack_Size. + -- Set to default secondary stack size in units of bytes. Set by the -Dnnn + -- switch for the binder. A value of No_Stack_Size indicates that no + -- default was set by the binder and the run-time value should be used + -- instead. Default_SSO : Character := ' '; -- GNAT @@ -1313,6 +1316,13 @@ package Opt is -- Indicates if a project file is used or not. Set to In_Use by the first -- SFNP pragma. + Quantity_Of_Default_Size_Sec_Stacks : Int := -1; + -- GNATBIND + -- The number of default sized secondary stacks that the binder should + -- generate. Allows ZFP users to have the binder generate extra stacks if + -- needed to support multithreaded applications. A value of -1 indicates + -- that no size was set by the binder. + Queuing_Policy : Character := ' '; -- GNAT, GNATBIND -- Set to ' ' for the default case (no queuing policy specified). Reset to diff --git a/gcc/ada/rtfinal.c b/gcc/ada/rtfinal.c index 8f7e163cded..9398af393ba 100644 --- a/gcc/ada/rtfinal.c +++ b/gcc/ada/rtfinal.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2014, Free Software Foundation, Inc. * + * Copyright (C) 2014-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- * @@ -40,7 +40,7 @@ extern void __gnat_runtime_finalize (void); at all, the intention is that this be replaced by system specific code where finalization is required. - Note that __gnat_runtime_initialize() is called in adafinal() */ + Note that __gnat_runtime_finalize() is called in adafinal() */ extern int __gnat_rt_init_count; /* see initialize.c */ diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index bdad2520fd4..c4d7d3c80c6 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1249,6 +1249,7 @@ package Rtsfind is RE_Set_63, -- System.Pack_63 RE_Adjust_Storage_Size, -- System.Parameters + RE_Default_Secondary_Stack_Size, -- System.Parameters RE_Default_Stack_Size, -- System.Parameters RE_Garbage_Collected, -- System.Parameters RE_Size_Type, -- System.Parameters @@ -1424,12 +1425,12 @@ package Rtsfind is RE_IS_Ilf, -- System.Scalar_Values RE_IS_Ill, -- System.Scalar_Values - RE_Default_Secondary_Stack_Size, -- System.Secondary_Stack RE_Mark_Id, -- System.Secondary_Stack RE_SS_Allocate, -- System.Secondary_Stack RE_SS_Pool, -- System.Secondary_Stack RE_SS_Mark, -- System.Secondary_Stack RE_SS_Release, -- System.Secondary_Stack + RE_SS_Stack, -- System.Secondary_Stack RE_Shared_Var_Lock, -- System.Shared_Storage RE_Shared_Var_Unlock, -- System.Shared_Storage @@ -2487,6 +2488,7 @@ package Rtsfind is RE_Set_63 => System_Pack_63, RE_Adjust_Storage_Size => System_Parameters, + RE_Default_Secondary_Stack_Size => System_Parameters, RE_Default_Stack_Size => System_Parameters, RE_Garbage_Collected => System_Parameters, RE_Size_Type => System_Parameters, @@ -2662,12 +2664,12 @@ package Rtsfind is RE_IS_Ilf => System_Scalar_Values, RE_IS_Ill => System_Scalar_Values, - RE_Default_Secondary_Stack_Size => System_Secondary_Stack, RE_Mark_Id => System_Secondary_Stack, RE_SS_Allocate => System_Secondary_Stack, RE_SS_Mark => System_Secondary_Stack, RE_SS_Pool => System_Secondary_Stack, RE_SS_Release => System_Secondary_Stack, + RE_SS_Stack => System_Secondary_Stack, RE_Shared_Var_Lock => System_Shared_Storage, RE_Shared_Var_Unlock => System_Shared_Storage, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index c163aab8e78..1e3b78ccf2f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2820,24 +2820,10 @@ package body Sem_Ch3 is -- Analyze the contracts of packages and their bodies - if Nkind (Context) = N_Package_Specification then - - -- When a package has private declarations, its contract must be - -- analyzed at the end of the said declarations. This way both the - -- analysis and freeze actions are properly synchronized in case - -- of private type use within the contract. - - if L = Private_Declarations (Context) then - Analyze_Package_Contract (Defining_Entity (Context)); - - -- Otherwise the contract is analyzed at the end of the visible - -- declarations. - - elsif L = Visible_Declarations (Context) - and then No (Private_Declarations (Context)) - then - Analyze_Package_Contract (Defining_Entity (Context)); - end if; + if Nkind (Context) = N_Package_Specification + and then L = Visible_Declarations (Context) + then + Analyze_Package_Contract (Defining_Entity (Context)); elsif Nkind (Context) = N_Package_Body then Analyze_Package_Body_Contract (Defining_Entity (Context)); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 5ba6938cf97..dafc563d56b 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -5186,7 +5186,7 @@ package body Sem_Elab is -- The variable must be a source entity and susceptible to warnings Comes_From_Source (Var_Id) - and then not Has_Warnings_Off (Var_Id) + and then not Warnings_Off (Var_Id) -- The variable must be declared in the spec of compilation unit U diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0456101092a..e2bf4b5d7d5 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2818,10 +2818,16 @@ package body Sem_Prag is E_Constant, E_Variable) then + -- When the initialization item is undefined, it appears as + -- Any_Id. Do not continue with the analysis of the item. + + if Item_Id = Any_Id then + null; + -- The state or variable must be declared in the visible -- declarations of the package (SPARK RM 7.1.5(7)). - if not Contains (States_And_Objs, Item_Id) then + elsif not Contains (States_And_Objs, Item_Id) then Error_Msg_Name_1 := Chars (Pack_Id); SPARK_Msg_NE ("initialization item & must appear in the visible " diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f003ef5a8ac..e07d6fd74df 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -20584,6 +20584,51 @@ package body Sem_Util is return False; end Null_To_Null_Address_Convert_OK; + --------------------------------- + -- Number_Of_Elements_In_Array -- + --------------------------------- + + function Number_Of_Elements_In_Array (T : Entity_Id) return Int is + Indx : Node_Id; + Typ : Entity_Id; + Low : Node_Id; + High : Node_Id; + Num : Int := 1; + + begin + pragma Assert (Is_Array_Type (T)); + + Indx := First_Index (T); + while Present (Indx) loop + Typ := Underlying_Type (Etype (Indx)); + + -- Never look at junk bounds of a generic type + + if Is_Generic_Type (Typ) then + return 0; + end if; + + -- Check the array bounds are known at compile time and return zero + -- if they are not. + + Low := Type_Low_Bound (Typ); + High := Type_High_Bound (Typ); + + if not Compile_Time_Known_Value (Low) then + return 0; + elsif not Compile_Time_Known_Value (High) then + return 0; + else + Num := + Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1)); + end if; + + Next_Index (Indx); + end loop; + + return Num; + end Number_Of_Elements_In_Array; + ------------------------- -- Object_Access_Level -- ------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2ebd54f3989..f7c4c564c87 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2275,6 +2275,11 @@ package Sem_Util is -- 2) N is a comparison operator, one of the operands is null, and the -- type of the other operand is a descendant of System.Address. + function Number_Of_Elements_In_Array (T : Entity_Id) return Int; + -- Returns the number elements in the array T if the index bounds of T is + -- known at compile time. If the bounds are not known at compile time, the + -- function returns the value zero. + function Object_Access_Level (Obj : Node_Id) return Uint; -- Return the accessibility level of the view of the object Obj. For -- convenience, qualified expressions applied to object names are also diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 247d127982d..9030c7c1176 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1472,10 +1472,7 @@ package Sinfo is -- Generic_Parent (Node5-Sem) -- Generic_Parent is defined on declaration nodes that are instances. The -- value of Generic_Parent is the generic entity from which the instance - -- is obtained. Generic_Parent is also defined for the renaming - -- declarations and object declarations created for the actuals in an - -- instantiation. The generic parent of such a declaration is the - -- corresponding generic association in the Instantiation node. + -- is obtained. -- Generic_Parent_Type (Node4-Sem) -- Generic_Parent_Type is defined on Subtype_Declaration nodes for the diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index 52a72e4de40..61fe4404b7d 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -391,6 +391,18 @@ package body Switch.B is Ptr := Ptr + 1; Quiet_Output := True; + -- Processing for Q switch + + when 'Q' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + Scan_Pos + (Switch_Chars, Max, Ptr, + Quantity_Of_Default_Size_Sec_Stacks, C); + -- Processing for r switch when 'r' => |