+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
'Z' => True, -- implicit with from instantiation
'C' => True, -- SCO information
'F' => True, -- SPARK cross-reference information
+ 'T' => True, -- task stack information
others => False);
--------------------
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
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 ");
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;
-- 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 (
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
-- 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,
-- 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.
-- 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.
-- 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
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");
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.
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"");");
& """__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");
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;
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.
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);
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;
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 ("");
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
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,
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
Write_Line
(" -z No main subprogram (zero main)");
- -- Line for --RTS
-
-- Line for -Z switch
Write_Line
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;
-- 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.
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 --
-------------------------------
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
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;
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;
-----------------------
-- 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
end if;
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 --
-------------------------------------
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;
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);
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));
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 \
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 \
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);
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;
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
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,
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,
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
-- --
-- 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- --
-- 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"
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;
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 --
-----------------------------
-- 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
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;
-- 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.
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);
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);
-- 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;
-- 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 (
with System.Task_Primitives.Operations;
with System.Tasking;
with System.Stack_Checking;
+with System.Secondary_Stack;
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;
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);
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
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 --
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;
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
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
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;
-- 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.
--
-- 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.
-- 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.
----------------------------
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;
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
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
-- 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
---------------------------------------
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
-- 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;
-- 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.
-- 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
--
-- 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.
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
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
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);
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;
-- 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;
---------------------------------------
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
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;
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;
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);
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;
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;
-- 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;
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)
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;
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 -
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;
-- 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 [
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;
--
-- 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.
-- --
------------------------------------------------------------------------------
-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;
(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);
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);
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 --
------------------------
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
-- 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 --
----------------------------------------------
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
-- 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 --
----------------------------------------------
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
-- 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 --
----------------------------------------------
-- --
-- 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- --
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 --
------------------------
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;
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 --
------------------------
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
-- 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 --
----------------------------------------------
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;
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
-- 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
-- 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;
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;
-- 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;
-- 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;
----------------
----------------
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;
-------------
-------------
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;
& 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;
-------------
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;
-------------
-------------
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;
----------------
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;
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;
-- 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
-- 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);
-- 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;
-- 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 --
-- 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;
-----------------------
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;
---------------------
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 --
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 --
begin
null;
end Task_Unlock_NT;
-
end System.Soft_Links;
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;
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);
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);
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;
-- 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
-- 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.
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:
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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
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.
-- 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
-- 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;
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.
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;
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 --
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
-- 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
-- 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
* *
* 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- *
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 */
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
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
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,
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,
-- 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));
-- 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
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 "
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 --
-------------------------
-- 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
-- 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
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' =>
projects / gcc.git / commitdiff