1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Casing
; use Casing
;
27 with Fname
; use Fname
;
28 with Gnatvsn
; use Gnatvsn
;
30 with Namet
; use Namet
;
32 with Osint
; use Osint
;
33 with Osint
.B
; use Osint
.B
;
34 with Output
; use Output
;
35 with Rident
; use Rident
;
37 with Targparm
; use Targparm
;
38 with Types
; use Types
;
41 with System
.WCh_Con
; use System
.WCh_Con
;
43 with GNAT
.Heap_Sort_A
; use GNAT
.Heap_Sort_A
;
46 package body Bindgen
is
47 Statement_Buffer
: String (1 .. 1000);
48 -- Buffer used for constructing output statements
50 Stm_Last
: Natural := 0;
51 -- Stm_Last location in Statement_Buffer currently set
53 With_GNARL
: Boolean := False;
54 -- Flag which indicates whether the program uses the GNARL library
55 -- (presence of the unit System.OS_Interface)
57 Num_Elab_Calls
: Nat
:= 0;
58 -- Number of generated calls to elaboration routines
60 Num_Primary_Stacks
: Int
:= 0;
61 -- Number of default-sized primary stacks the binder needs to allocate for
62 -- task objects declared in the program.
64 Num_Sec_Stacks
: Int
:= 0;
65 -- Number of default-sized primary stacks the binder needs to allocate for
66 -- task objects declared in the program.
68 Command_Line_Used
: Boolean := False;
69 -- Flag indicating whether the unit Ada.Command_Line is in the closure of
70 -- the partition. This is set by Resolve_Binder_Options, and is used to
71 -- determine whether or not to import and use symbols defined in
72 -- Ada.Command_Line's support packages (gnat_argc, gnat_argv, gnat_envp
73 -- and gnat_exit_status). Conservatively, it is always set to True for
74 -- non-configurable run-times as parts of the compiler and run-time assume
75 -- these symbols are available and can be imported directly.
77 System_Restrictions_Used
: Boolean := False;
78 -- Flag indicating whether the unit System.Restrictions is in the closure
79 -- of the partition. This is set by Resolve_Binder_Options, and is used
80 -- to determine whether or not to initialize the restrictions information
81 -- in the body of the binder generated file (we do not want to do this
82 -- unconditionally, since it drags in the System.Restrictions unit
83 -- unconditionally, which is unpleasand, especially for ZFP etc.)
85 Dispatching_Domains_Used
: Boolean := False;
86 -- Flag indicating whether multiprocessor dispatching domains are used in
87 -- the closure of the partition. This is set by Resolve_Binder_Options, and
88 -- is used to call the routine to disallow the creation of new dispatching
89 -- domains just before calling the main procedure from the environment
92 System_Tasking_Restricted_Stages_Used
: Boolean := False;
93 -- Flag indicating whether the unit System.Tasking.Restricted.Stages is in
94 -- the closure of the partition. This is set by Resolve_Binder_Options,
95 -- and it used to call a routine to active all the tasks at the end of
96 -- the elaboration when partition elaboration policy is sequential.
98 System_Interrupts_Used
: Boolean := False;
99 -- Flag indicating whether the unit System.Interrups is in the closure of
100 -- the partition. This is set by Resolve_Binder_Options, and it used to
101 -- attach interrupt handlers at the end of the elaboration when partition
102 -- elaboration policy is sequential.
104 System_BB_CPU_Primitives_Multiprocessors_Used
: Boolean := False;
105 -- Flag indicating whether unit System.BB.CPU_Primitives.Multiprocessors
106 -- is in the closure of the partition. This is set by procedure
107 -- Resolve_Binder_Options, and it is used to call a procedure that starts
110 System_Version_Control_Used
: Boolean := False;
111 -- Flag indicating whether unit System.Version_Control is in the closure.
112 -- This unit is implicitly withed by the compiler when Version or
113 -- Body_Version attributes are used. If the package is not in the closure,
114 -- the version definitions can be removed.
116 Lib_Final_Built
: Boolean := False;
117 -- Flag indicating whether the finalize_library rountine has been built
119 Bind_Env_String_Built
: Boolean := False;
120 -- Flag indicating whether a bind environment string has been built
122 CodePeer_Wrapper_Name
: constant String := "call_main_subprogram";
123 -- For CodePeer, introduce a wrapper subprogram which calls the
124 -- user-defined main subprogram.
126 -- Name for local C-String variable
128 Adainit_String_Obj_Name
: constant String := "Adainit_Name_C_String";
130 -- Name and link_name for CUDA device initialization procedure
132 Device_Ada_Init_Subp_Name
: constant String := "Device_Initialization";
133 Device_Link_Name_Prefix
: constant String := "__device_";
135 function Device_Link_Name
(Suffix
: String) return String is
136 (Device_Link_Name_Prefix
&
137 (if CUDA_Device_Library_Name
= null
138 then "ada" -- is this an error path?
139 else CUDA_Device_Library_Name
.all) & Suffix
);
141 function Device_Ada_Init_Link_Name
return String
142 is (Device_Link_Name
(Suffix
=> "init"));
144 ----------------------------------
145 -- Interface_State Pragma Table --
146 ----------------------------------
148 -- This table assembles the interface state pragma information from
149 -- all the units in the partition. Note that Bcheck has already checked
150 -- that the information is consistent across units. The entries
151 -- in this table are n/u/r/s for not set/user/runtime/system.
153 package IS_Pragma_Settings
is new Table
.Table
154 (Table_Component_Type
=> Character,
155 Table_Index_Type
=> Int
,
156 Table_Low_Bound
=> 0,
157 Table_Initial
=> 100,
158 Table_Increment
=> 200,
159 Table_Name
=> "IS_Pragma_Settings");
161 -- This table assembles the Priority_Specific_Dispatching pragma
162 -- information from all the units in the partition. Note that Bcheck has
163 -- already checked that the information is consistent across units.
164 -- The entries in this table are the upper case first character of the
165 -- policy name, e.g. 'F' for FIFO_Within_Priorities.
167 package PSD_Pragma_Settings
is new Table
.Table
168 (Table_Component_Type
=> Character,
169 Table_Index_Type
=> Int
,
170 Table_Low_Bound
=> 0,
171 Table_Initial
=> 100,
172 Table_Increment
=> 200,
173 Table_Name
=> "PSD_Pragma_Settings");
175 ----------------------------
176 -- Bind_Environment Table --
177 ----------------------------
179 subtype Header_Num
is Int
range 0 .. 36;
181 function Hash
(Nam
: Name_Id
) return Header_Num
;
183 package Bind_Environment
is new GNAT
.HTable
.Simple_HTable
184 (Header_Num
=> Header_Num
,
186 No_Element
=> No_Name
,
191 ----------------------
192 -- Run-Time Globals --
193 ----------------------
195 -- This section documents the global variables that are set from the
196 -- generated binder file.
198 -- Main_Priority : Integer;
199 -- Time_Slice_Value : Integer;
200 -- Heap_Size : Natural;
201 -- WC_Encoding : Character;
202 -- Locking_Policy : Character;
203 -- Queuing_Policy : Character;
204 -- Task_Dispatching_Policy : Character;
205 -- Priority_Specific_Dispatching : System.Address;
206 -- Num_Specific_Dispatching : Integer;
207 -- Restrictions : System.Address;
208 -- Interrupt_States : System.Address;
209 -- Num_Interrupt_States : Integer;
210 -- Unreserve_All_Interrupts : Integer;
211 -- Exception_Tracebacks : Integer;
212 -- Exception_Tracebacks_Symbolic : Integer;
213 -- Detect_Blocking : Integer;
214 -- Default_Stack_Size : Integer;
215 -- Default_Secondary_Stack_Size : System.Parameters.Size_Type;
216 -- Leap_Seconds_Support : Integer;
217 -- Main_CPU : Integer;
218 -- Default_Sized_SS_Pool : System.Address;
219 -- Binder_Sec_Stacks_Count : Natural;
220 -- XDR_Stream : Integer;
222 -- Main_Priority is the priority value set by pragma Priority in the main
223 -- program. If no such pragma is present, the value is -1.
225 -- Time_Slice_Value is the time slice value set by pragma Time_Slice in the
226 -- main program, or by the use of a -Tnnn parameter for the binder (if both
227 -- are present, the binder value overrides). The value is in milliseconds.
228 -- A value of zero indicates that time slicing should be suppressed. If no
229 -- pragma is present, and no -T switch was used, the value is -1.
231 -- WC_Encoding shows the wide character encoding method used for the main
232 -- program. This is one of the encoding letters defined in
233 -- System.WCh_Con.WC_Encoding_Letters.
235 -- Locking_Policy is a space if no locking policy was specified for the
236 -- partition. If a locking policy was specified, the value is the upper
237 -- case first character of the locking policy name, for example, 'C' for
240 -- Queuing_Policy is a space if no queuing policy was specified for the
241 -- partition. If a queuing policy was specified, the value is the upper
242 -- case first character of the queuing policy name for example, 'F' for
245 -- Task_Dispatching_Policy is a space if no task dispatching policy was
246 -- specified for the partition. If a task dispatching policy was specified,
247 -- the value is the upper case first character of the policy name, e.g. 'F'
248 -- for FIFO_Within_Priorities.
250 -- Priority_Specific_Dispatching is the address of a string used to store
251 -- the task dispatching policy specified for the different priorities in
252 -- the partition. The length of this string is determined by the last
253 -- priority for which such a pragma applies (the string will be a null
254 -- string if no specific dispatching policies were used). If pragma were
255 -- present, the entries apply to the priorities in sequence from the first
256 -- priority. The value stored is the upper case first character of the
257 -- policy name, or 'F' (for FIFO_Within_Priorities) as the default value
258 -- for those priority ranges not specified.
260 -- Num_Specific_Dispatching is length of the Priority_Specific_Dispatching
261 -- string. It will be set to zero if no Priority_Specific_Dispatching
262 -- pragmas are present.
264 -- Restrictions is the address of a null-terminated string specifying the
265 -- restrictions information for the partition. The format is identical to
266 -- that of the parameter string found on R lines in ali files (see Lib.Writ
267 -- spec in lib-writ.ads for full details). The difference is that in this
268 -- context the values are the cumulative ones for the entire partition.
270 -- Interrupt_States is the address of a string used to specify the
271 -- cumulative results of Interrupt_State pragmas used in the partition.
272 -- The length of this string is determined by the last interrupt for which
273 -- such a pragma is given (the string will be a null string if no pragmas
274 -- were used). If pragma were present the entries apply to the interrupts
275 -- in sequence from the first interrupt, and are set to one of four
276 -- possible settings: 'n' for not specified, 'u' for user, 'r' for run
277 -- time, 's' for system, see description of Interrupt_State pragma for
280 -- Num_Interrupt_States is the length of the Interrupt_States string. It
281 -- will be set to zero if no Interrupt_State pragmas are present.
283 -- Unreserve_All_Interrupts is set to one if at least one unit in the
284 -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise.
286 -- Exception_Tracebacks is set to one if the -Ea or -E parameter was
287 -- present in the bind and to zero otherwise. Note that on some targets
288 -- exception tracebacks are provided by default, so a value of zero for
289 -- this parameter does not necessarily mean no trace backs are available.
291 -- Exception_Tracebacks_Symbolic is set to one if the -Es parameter was
292 -- present in the bind and to zero otherwise.
294 -- Detect_Blocking indicates whether pragma Detect_Blocking is active or
295 -- not. A value of zero indicates that the pragma is not present, while a
296 -- value of 1 signals its presence in the partition.
298 -- Default_Stack_Size is the default stack size used when creating an Ada
299 -- task with no explicit Storage_Size clause.
301 -- Default_Secondary_Stack_Size is the default secondary stack size used
302 -- when creating an Ada task with no explicit Secondary_Stack_Size clause.
304 -- Leap_Seconds_Support denotes whether leap seconds have been enabled or
305 -- disabled. A value of zero indicates that leap seconds are turned "off",
306 -- while a value of one signifies "on" status.
308 -- Main_CPU is the processor set by pragma CPU in the main program. If no
309 -- such pragma is present, the value is -1.
311 -- Default_Sized_SS_Pool is set to the address of the default-sized
312 -- secondary stacks array generated by the binder. This pool of stacks is
313 -- generated when either the restriction No_Implicit_Heap_Allocations
314 -- or No_Implicit_Task_Allocations is active.
316 -- Binder_Sec_Stacks_Count is the number of generated secondary stacks in
317 -- the Default_Sized_SS_Pool.
319 -- XDR_Stream indicates whether streaming should be performed using the
320 -- XDR protocol. A value of one indicates that XDR streaming is enabled.
322 procedure WBI
(Info
: String) renames Osint
.B
.Write_Binder_Info
;
323 -- Convenient shorthand used throughout
325 -----------------------
326 -- Local Subprograms --
327 -----------------------
329 procedure Gen_Adainit
(Elab_Order
: Unit_Id_Array
);
330 -- Generates the Adainit procedure
332 procedure Gen_Adafinal
;
333 -- Generate the Adafinal procedure
335 procedure Gen_Bind_Env_String
;
336 -- Generate the bind environment buffer
338 procedure Gen_CodePeer_Wrapper
;
339 -- For CodePeer, generate wrapper which calls user-defined main subprogram
341 procedure Gen_CUDA_Defs
;
342 -- Generate definitions needed in order to register kernels
344 procedure Gen_CUDA_Init
;
345 -- Generate calls needed in order to register kernels
347 procedure Gen_Elab_Calls
(Elab_Order
: Unit_Id_Array
);
348 -- Generate sequence of elaboration calls
350 procedure Gen_Elab_Externals
(Elab_Order
: Unit_Id_Array
);
351 -- Generate sequence of external declarations for elaboration
353 procedure Gen_Elab_Order
(Elab_Order
: Unit_Id_Array
);
354 -- Generate comments showing elaboration order chosen
356 procedure Gen_Finalize_Library
(Elab_Order
: Unit_Id_Array
);
357 -- Generate a sequence of finalization calls to elaborated packages
360 -- Generate procedure main
362 procedure Gen_Object_Files_Options
(Elab_Order
: Unit_Id_Array
);
363 -- Output comments containing a list of the full names of the object
364 -- files to be linked and the list of linker options supplied by
365 -- Linker_Options pragmas in the source.
367 procedure Gen_Output_File_Ada
369 Elab_Order
: Unit_Id_Array
);
370 -- Generate Ada output file
372 procedure Gen_Restrictions
;
373 -- Generate initialization of restrictions variable
375 procedure Gen_Versions
;
376 -- Output series of definitions for unit versions
378 function Get_Ada_Main_Name
return String;
379 -- This function is used for the Ada main output to compute a usable name
380 -- for the generated main program. The normal main program name is
381 -- Ada_Main, but this won't work if the user has a unit with this name.
382 -- This function tries Ada_Main first, and if there is such a clash, then
383 -- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence.
385 function Get_Main_Unit_Name
(S
: String) return String;
386 -- Return the main unit name corresponding to S by replacing '.' with '_'
388 function Get_Main_Name
return String;
389 -- This function is used in the main output case to compute the correct
390 -- external main program. It is "main" by default, unless the flag
391 -- Use_Ada_Main_Program_Name_On_Target is set, in which case it is the name
392 -- of the Ada main name without the "_ada". This default can be overridden
393 -- explicitly using the -Mname binder switch.
395 function Get_WC_Encoding
return Character;
396 -- Return wide character encoding method to set as WC_Encoding in output.
397 -- If -W has been used, returns the specified encoding, otherwise returns
398 -- the encoding method used for the main program source. If there is no
399 -- main program source (-z switch used), returns brackets ('b').
401 function Has_Finalizer
(Elab_Order
: Unit_Id_Array
) return Boolean;
402 -- Determine whether the current unit has at least one library-level
405 function Lt_Linker_Option
(Op1
: Natural; Op2
: Natural) return Boolean;
406 -- Compare linker options, when sorting, first according to
407 -- Is_Internal_File (internal files come later) and then by
408 -- elaboration order position (latest to earliest).
410 procedure Move_Linker_Option
(From
: Natural; To
: Natural);
411 -- Move routine for sorting linker options
413 procedure Resolve_Binder_Options
(Elab_Order
: Unit_Id_Array
);
414 -- Set the value of With_GNARL
416 procedure Set_Char
(C
: Character);
417 -- Set given character in Statement_Buffer at the Stm_Last + 1 position
418 -- and increment Stm_Last by one to reflect the stored character.
420 procedure Set_Int
(N
: Int
);
421 -- Set given value in decimal in Statement_Buffer with no spaces starting
422 -- at the Stm_Last + 1 position, and updating Stm_Last past the value. A
423 -- minus sign is output for a negative value.
425 procedure Set_Boolean
(B
: Boolean);
426 -- Set given boolean value in Statement_Buffer at the Stm_Last + 1 position
427 -- and update Stm_Last past the value.
429 procedure Set_IS_Pragma_Table
;
430 -- Initializes contents of IS_Pragma_Settings table from ALI table
432 procedure Set_Main_Program_Name
;
433 -- Given the main program name in Name_Buffer (length in Name_Len) generate
434 -- the name of the routine to be used in the call. The name is generated
435 -- starting at Stm_Last + 1, and Stm_Last is updated past it.
437 procedure Set_Name_Buffer
;
438 -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
440 procedure Set_PSD_Pragma_Table
;
441 -- Initializes contents of PSD_Pragma_Settings table from ALI table
443 procedure Set_String
(S
: String);
444 -- Sets characters of given string in Statement_Buffer, starting at the
445 -- Stm_Last + 1 position, and updating last past the string value.
447 procedure Set_String_Replace
(S
: String);
448 -- Replaces the last S'Length characters in the Statement_Buffer with the
449 -- characters of S. The caller must ensure that these characters do in fact
450 -- exist in the Statement_Buffer.
452 procedure Set_Unit_Name
;
453 -- Given a unit name in the Name_Buffer, copy it into Statement_Buffer,
454 -- starting at the Stm_Last + 1 position and update Stm_Last past the
455 -- value. Each dot (.) will be qualified into double underscores (__).
457 procedure Set_Unit_Number
(U
: Unit_Id
);
458 -- Sets unit number (first unit is 1, leading zeroes output to line up all
459 -- output unit numbers nicely as required by the value, and by the total
462 procedure Write_Statement_Buffer
;
463 -- Write out contents of statement buffer up to Stm_Last, and reset
466 procedure Write_Statement_Buffer
(S
: String);
467 -- First writes its argument (using Set_String (S)), then writes out the
468 -- contents of statement buffer up to Stm_Last, and resets Stm_Last to 0.
470 procedure Write_Bind_Line
(S
: String);
471 -- Write S (an LF-terminated string) to the binder file (for use with
472 -- Set_Special_Output).
478 procedure Gen_Adafinal
is
480 WBI
(" procedure " & Ada_Final_Name
.all & " is");
482 -- Call s_stalib_adafinal to await termination of tasks and so on. We
483 -- want to do this if there is a main program, either in Ada or in some
484 -- other language. (Note that Bind_Main_Program is True for Ada mains,
485 -- but False for mains in other languages.) We do not want to do this if
486 -- we're binding a library.
488 if not Bind_For_Library
and not CodePeer_Mode
then
489 WBI
(" procedure s_stalib_adafinal;");
490 Set_String
(" pragma Import (Ada, s_stalib_adafinal, ");
491 Set_String
("""system__standard_library__adafinal"");");
492 Write_Statement_Buffer
;
496 WBI
(" procedure Runtime_Finalize;");
497 WBI
(" pragma Import (C, Runtime_Finalize, " &
498 """__gnat_runtime_finalize"");");
502 if not CodePeer_Mode
then
503 WBI
(" if not Is_Elaborated then");
506 WBI
(" Is_Elaborated := False;");
509 WBI
(" Runtime_Finalize;");
511 -- By default (real targets), finalization is done differently depending
512 -- on whether this is the main program or a library.
514 if not CodePeer_Mode
then
515 if not Bind_For_Library
then
516 WBI
(" s_stalib_adafinal;");
517 elsif Lib_Final_Built
then
518 WBI
(" finalize_library;");
523 -- Pragma Import C cannot be used on virtual targets, therefore call the
524 -- runtime finalization routine directly in CodePeer mode, where
525 -- imported functions are ignored.
528 WBI
(" System.Standard_Library.Adafinal;");
531 WBI
(" end " & Ada_Final_Name
.all & ";");
539 procedure Gen_Adainit
(Elab_Order
: Unit_Id_Array
) is
540 Main_Priority
: Int
renames ALIs
.Table
(ALIs
.First
).Main_Priority
;
541 Main_CPU
: Int
renames ALIs
.Table
(ALIs
.First
).Main_CPU
;
543 -- Declare the access-to-subprogram type used for initialization of
544 -- of __gnat_finalize_library_objects. This is declared at library
545 -- level for compatibility with the type used in System.Soft_Links.
546 -- The import of the soft link which performs library-level object
547 -- finalization does not work for CodePeer, so regular Ada is used in
548 -- that case. For restricted run-time libraries (ZFP and Ravenscar)
549 -- tasks are non-terminating, so we do not want finalization.
551 if not Suppress_Standard_Library_On_Target
552 and then not CodePeer_Mode
553 and then not Configurable_Run_Time_On_Target
555 WBI
(" type No_Param_Proc is access procedure;");
556 WBI
(" pragma Favor_Top_Level (No_Param_Proc);");
560 WBI
(" procedure " & Ada_Init_Name
.all & " is");
562 -- In CodePeer mode, simplify adainit procedure by only calling
563 -- elaboration procedures.
565 if CodePeer_Mode
then
568 -- If the standard library is suppressed, then the only global variables
569 -- that might be needed (by the Ravenscar profile) are the priority and
570 -- the processor for the environment task.
572 elsif Suppress_Standard_Library_On_Target
then
573 if Main_Priority
/= No_Main_Priority
then
574 WBI
(" Main_Priority : Integer;");
575 WBI
(" pragma Import (C, Main_Priority," &
576 " ""__gl_main_priority"");");
580 if Main_CPU
/= No_Main_CPU
then
581 WBI
(" Main_CPU : Integer;");
582 WBI
(" pragma Import (C, Main_CPU," &
583 " ""__gl_main_cpu"");");
587 if System_Interrupts_Used
588 and then Partition_Elaboration_Policy_Specified
= 'S'
590 WBI
(" procedure Install_Restricted_Handlers_Sequential;");
591 WBI
(" pragma Import (C," &
592 "Install_Restricted_Handlers_Sequential," &
593 " ""__gnat_attach_all_handlers"");");
597 if System_Tasking_Restricted_Stages_Used
598 and then Partition_Elaboration_Policy_Specified
= 'S'
600 WBI
(" Partition_Elaboration_Policy : Character;");
601 WBI
(" pragma Import (C, Partition_Elaboration_Policy," &
602 " ""__gnat_partition_elaboration_policy"");");
604 WBI
(" procedure Activate_All_Tasks_Sequential;");
605 WBI
(" pragma Import (C, Activate_All_Tasks_Sequential," &
606 " ""__gnat_activate_all_tasks"");");
610 if System_BB_CPU_Primitives_Multiprocessors_Used
then
611 WBI
(" procedure Start_Slave_CPUs;");
612 WBI
(" pragma Import (C, Start_Slave_CPUs," &
613 " ""__gnat_start_slave_cpus"");");
617 -- Import the default stack object if a size has been provided to the
620 if Opt
.Default_Stack_Size
/= Opt
.No_Stack_Size
then
621 WBI
(" Default_Stack_Size : Integer;");
622 WBI
(" pragma Import (C, Default_Stack_Size, " &
623 """__gl_default_stack_size"");");
626 -- Initialize stack limit variable of the environment task if the
627 -- stack check method is stack limit and stack check is enabled.
629 if Stack_Check_Limits_On_Target
630 and then (Stack_Check_Default_On_Target
or Stack_Check_Switch_Set
)
633 WBI
(" procedure Initialize_Stack_Limit;");
634 WBI
(" pragma Import (C, Initialize_Stack_Limit, " &
635 """__gnat_initialize_stack_limit"");");
638 if Num_Sec_Stacks
> 0 then
639 WBI
(" Binder_Sec_Stacks_Count : Natural;");
640 WBI
(" pragma Import (Ada, Binder_Sec_Stacks_Count, " &
641 """__gnat_binder_ss_count"");");
645 -- Import secondary stack pool variables if the secondary stack is
646 -- used. They are not referenced otherwise.
648 if Sec_Stack_Used
then
649 WBI
(" Default_Secondary_Stack_Size : " &
650 "System.Parameters.Size_Type;");
651 WBI
(" pragma Import (C, Default_Secondary_Stack_Size, " &
652 """__gnat_default_ss_size"");");
654 WBI
(" Default_Sized_SS_Pool : System.Address;");
655 WBI
(" pragma Import (Ada, Default_Sized_SS_Pool, " &
656 """__gnat_default_ss_pool"");");
663 -- Set the default stack size if provided to the binder
665 if Opt
.Default_Stack_Size
/= Opt
.No_Stack_Size
then
666 Set_String
(" Default_Stack_Size := ");
667 Set_Int
(Default_Stack_Size
);
669 Write_Statement_Buffer
;
672 if Main_Priority
/= No_Main_Priority
then
673 Set_String
(" Main_Priority := ");
674 Set_Int
(Main_Priority
);
676 Write_Statement_Buffer
;
679 if Main_CPU
/= No_Main_CPU
then
680 Set_String
(" Main_CPU := ");
683 Write_Statement_Buffer
;
686 if System_Tasking_Restricted_Stages_Used
687 and then Partition_Elaboration_Policy_Specified
= 'S'
689 Set_String
(" Partition_Elaboration_Policy := '");
690 Set_Char
(Partition_Elaboration_Policy_Specified
);
692 Write_Statement_Buffer
;
695 if Main_Priority
= No_Main_Priority
696 and then Opt
.Default_Stack_Size
= Opt
.No_Stack_Size
697 and then Main_CPU
= No_Main_CPU
698 and then not System_Tasking_Restricted_Stages_Used
705 -- Generate the default-sized secondary stack pool if the secondary
706 -- stack is used by the program.
708 if Sec_Stack_Used
then
709 -- Elaborate the body of the binder to initialize the default-
710 -- sized secondary stack pool.
713 WBI
(" " & Get_Ada_Main_Name
& "'Elab_Body;");
715 -- Generate the default-sized secondary stack pool and set the
716 -- related secondary stack globals.
718 Set_String
(" Default_Secondary_Stack_Size := ");
720 if Opt
.Default_Sec_Stack_Size
/= Opt
.No_Stack_Size
then
721 Set_Int
(Opt
.Default_Sec_Stack_Size
);
724 ("System.Parameters.Runtime_Default_Sec_Stack_Size");
728 Write_Statement_Buffer
;
730 Set_String
(" Binder_Sec_Stacks_Count := ");
731 Set_Int
(Num_Sec_Stacks
);
733 Write_Statement_Buffer
;
735 WBI
(" Default_Sized_SS_Pool := " &
736 "Sec_Default_Sized_Stacks'Address;");
740 -- Normal case (standard library not suppressed). Set all global values
741 -- used by the run time.
744 WBI
(" Main_Priority : Integer;");
745 WBI
(" pragma Import (C, Main_Priority, " &
746 """__gl_main_priority"");");
747 WBI
(" Time_Slice_Value : Integer;");
748 WBI
(" pragma Import (C, Time_Slice_Value, " &
749 """__gl_time_slice_val"");");
750 WBI
(" WC_Encoding : Character;");
751 WBI
(" pragma Import (C, WC_Encoding, ""__gl_wc_encoding"");");
752 WBI
(" Locking_Policy : Character;");
753 WBI
(" pragma Import (C, Locking_Policy, " &
754 """__gl_locking_policy"");");
755 WBI
(" Queuing_Policy : Character;");
756 WBI
(" pragma Import (C, Queuing_Policy, " &
757 """__gl_queuing_policy"");");
758 WBI
(" Task_Dispatching_Policy : Character;");
759 WBI
(" pragma Import (C, Task_Dispatching_Policy, " &
760 """__gl_task_dispatching_policy"");");
761 WBI
(" Priority_Specific_Dispatching : System.Address;");
762 WBI
(" pragma Import (C, Priority_Specific_Dispatching, " &
763 """__gl_priority_specific_dispatching"");");
764 WBI
(" Num_Specific_Dispatching : Integer;");
765 WBI
(" pragma Import (C, Num_Specific_Dispatching, " &
766 """__gl_num_specific_dispatching"");");
767 WBI
(" Main_CPU : Integer;");
768 WBI
(" pragma Import (C, Main_CPU, " &
769 """__gl_main_cpu"");");
771 WBI
(" Interrupt_States : System.Address;");
772 WBI
(" pragma Import (C, Interrupt_States, " &
773 """__gl_interrupt_states"");");
774 WBI
(" Num_Interrupt_States : Integer;");
775 WBI
(" pragma Import (C, Num_Interrupt_States, " &
776 """__gl_num_interrupt_states"");");
777 WBI
(" Unreserve_All_Interrupts : Integer;");
778 WBI
(" pragma Import (C, Unreserve_All_Interrupts, " &
779 """__gl_unreserve_all_interrupts"");");
781 if Exception_Tracebacks
or Exception_Tracebacks_Symbolic
then
782 WBI
(" Exception_Tracebacks : Integer;");
783 WBI
(" pragma Import (C, Exception_Tracebacks, " &
784 """__gl_exception_tracebacks"");");
786 if Exception_Tracebacks_Symbolic
then
787 WBI
(" Exception_Tracebacks_Symbolic : Integer;");
788 WBI
(" pragma Import (C, Exception_Tracebacks_Symbolic, " &
789 """__gl_exception_tracebacks_symbolic"");");
793 WBI
(" Detect_Blocking : Integer;");
794 WBI
(" pragma Import (C, Detect_Blocking, " &
795 """__gl_detect_blocking"");");
796 WBI
(" Default_Stack_Size : Integer;");
797 WBI
(" pragma Import (C, Default_Stack_Size, " &
798 """__gl_default_stack_size"");");
800 if Sec_Stack_Used
then
801 WBI
(" Default_Secondary_Stack_Size : " &
802 "System.Parameters.Size_Type;");
803 WBI
(" pragma Import (C, Default_Secondary_Stack_Size, " &
804 """__gnat_default_ss_size"");");
807 if Leap_Seconds_Support
then
808 WBI
(" Leap_Seconds_Support : Integer;");
809 WBI
(" pragma Import (C, Leap_Seconds_Support, " &
810 """__gl_leap_seconds_support"");");
813 WBI
(" Bind_Env_Addr : System.Address;");
814 WBI
(" pragma Import (C, Bind_Env_Addr, " &
815 """__gl_bind_env_addr"");");
818 WBI
(" XDR_Stream : Integer;");
819 WBI
(" pragma Import (C, XDR_Stream, ""__gl_xdr_stream"");");
822 -- Import entry point for elaboration time signal handler
823 -- installation, and indication of if it's been called previously.
826 WBI
(" procedure Runtime_Initialize " &
827 "(Install_Handler : Integer);");
828 WBI
(" pragma Import (C, Runtime_Initialize, " &
829 """__gnat_runtime_initialize"");");
831 -- Import handlers attach procedure for sequential elaboration policy
833 if System_Interrupts_Used
834 and then Partition_Elaboration_Policy_Specified
= 'S'
836 WBI
(" procedure Install_Restricted_Handlers_Sequential;");
837 WBI
(" pragma Import (C," &
838 "Install_Restricted_Handlers_Sequential," &
839 " ""__gnat_attach_all_handlers"");");
843 -- Import task activation procedure for sequential elaboration
846 if System_Tasking_Restricted_Stages_Used
847 and then Partition_Elaboration_Policy_Specified
= 'S'
849 WBI
(" Partition_Elaboration_Policy : Character;");
850 WBI
(" pragma Import (C, Partition_Elaboration_Policy," &
851 " ""__gnat_partition_elaboration_policy"");");
853 WBI
(" procedure Activate_All_Tasks_Sequential;");
854 WBI
(" pragma Import (C, Activate_All_Tasks_Sequential," &
855 " ""__gnat_activate_all_tasks"");");
858 -- Import procedure to start slave cpus for bareboard runtime
860 if System_BB_CPU_Primitives_Multiprocessors_Used
then
861 WBI
(" procedure Start_Slave_CPUs;");
862 WBI
(" pragma Import (C, Start_Slave_CPUs," &
863 " ""__gnat_start_slave_cpus"");");
866 -- For restricted run-time libraries (ZFP and Ravenscar)
867 -- tasks are non-terminating, so we do not want finalization.
869 if not Configurable_Run_Time_On_Target
then
871 WBI
(" Finalize_Library_Objects : No_Param_Proc;");
872 WBI
(" pragma Import (C, Finalize_Library_Objects, " &
873 """__gnat_finalize_library_objects"");");
876 -- Initialize stack limit variable of the environment task if the
877 -- stack check method is stack limit and stack check is enabled.
879 if Stack_Check_Limits_On_Target
880 and then (Stack_Check_Default_On_Target
or Stack_Check_Switch_Set
)
883 WBI
(" procedure Initialize_Stack_Limit;");
884 WBI
(" pragma Import (C, Initialize_Stack_Limit, " &
885 """__gnat_initialize_stack_limit"");");
888 -- When dispatching domains are used then we need to signal it
889 -- before calling the main procedure.
891 if Dispatching_Domains_Used
then
892 WBI
(" procedure Freeze_Dispatching_Domains;");
893 WBI
(" pragma Import");
894 WBI
(" (Ada, Freeze_Dispatching_Domains, "
895 & """__gnat_freeze_dispatching_domains"");");
898 -- Secondary stack global variables
900 WBI
(" Binder_Sec_Stacks_Count : Natural;");
901 WBI
(" pragma Import (Ada, Binder_Sec_Stacks_Count, " &
902 """__gnat_binder_ss_count"");");
904 WBI
(" Default_Sized_SS_Pool : System.Address;");
905 WBI
(" pragma Import (Ada, Default_Sized_SS_Pool, " &
906 """__gnat_default_ss_pool"");");
910 -- Start of processing for Adainit
913 WBI
(" if Is_Elaborated then");
916 WBI
(" Is_Elaborated := True;");
918 -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if
919 -- restriction No_Standard_Allocators_After_Elaboration is active.
921 if Cumulative_Restrictions
.Set
922 (No_Standard_Allocators_After_Elaboration
)
924 WBI
(" System.Elaboration_Allocators."
925 & "Mark_Start_Of_Elaboration;");
928 -- Generate assignments to initialize globals
930 Set_String
(" Main_Priority := ");
931 Set_Int
(Main_Priority
);
933 Write_Statement_Buffer
;
935 Set_String
(" Time_Slice_Value := ");
937 if Task_Dispatching_Policy_Specified
= 'F'
938 and then ALIs
.Table
(ALIs
.First
).Time_Slice_Value
= -1
942 Set_Int
(ALIs
.Table
(ALIs
.First
).Time_Slice_Value
);
946 Write_Statement_Buffer
;
948 Set_String
(" WC_Encoding := '");
949 Set_Char
(Get_WC_Encoding
);
952 Write_Statement_Buffer
;
954 Set_String
(" Locking_Policy := '");
955 Set_Char
(Locking_Policy_Specified
);
957 Write_Statement_Buffer
;
959 Set_String
(" Queuing_Policy := '");
960 Set_Char
(Queuing_Policy_Specified
);
962 Write_Statement_Buffer
;
964 Set_String
(" Task_Dispatching_Policy := '");
965 Set_Char
(Task_Dispatching_Policy_Specified
);
967 Write_Statement_Buffer
;
969 if System_Tasking_Restricted_Stages_Used
970 and then Partition_Elaboration_Policy_Specified
= 'S'
972 Set_String
(" Partition_Elaboration_Policy := '");
973 Set_Char
(Partition_Elaboration_Policy_Specified
);
975 Write_Statement_Buffer
;
980 WBI
(" Priority_Specific_Dispatching :=");
981 WBI
(" Local_Priority_Specific_Dispatching'Address;");
983 Set_String
(" Num_Specific_Dispatching := ");
984 Set_Int
(PSD_Pragma_Settings
.Last
+ 1);
986 Write_Statement_Buffer
;
988 Set_String
(" Main_CPU := ");
991 Write_Statement_Buffer
;
993 WBI
(" Interrupt_States := Local_Interrupt_States'Address;");
995 Set_String
(" Num_Interrupt_States := ");
996 Set_Int
(IS_Pragma_Settings
.Last
+ 1);
998 Write_Statement_Buffer
;
1000 Set_String
(" Unreserve_All_Interrupts := ");
1002 if Unreserve_All_Interrupts_Specified
then
1009 Write_Statement_Buffer
;
1011 if Exception_Tracebacks
or Exception_Tracebacks_Symbolic
then
1012 WBI
(" Exception_Tracebacks := 1;");
1014 if Exception_Tracebacks_Symbolic
then
1015 WBI
(" Exception_Tracebacks_Symbolic := 1;");
1019 Set_String
(" Detect_Blocking := ");
1021 if Detect_Blocking
then
1028 Write_Statement_Buffer
;
1030 Set_String
(" Default_Stack_Size := ");
1031 Set_Int
(Default_Stack_Size
);
1033 Write_Statement_Buffer
;
1035 if Leap_Seconds_Support
then
1036 WBI
(" Leap_Seconds_Support := 1;");
1040 WBI
(" XDR_Stream := 1;");
1043 if Bind_Env_String_Built
then
1044 WBI
(" Bind_Env_Addr := Bind_Env'Address;");
1049 -- Generate default-sized secondary stack pool and set secondary
1052 if Sec_Stack_Used
then
1054 -- Elaborate the body of the binder to initialize the default-
1055 -- sized secondary stack pool.
1057 WBI
(" " & Get_Ada_Main_Name
& "'Elab_Body;");
1059 -- Generate the default-sized secondary stack pool and set the
1060 -- related secondary stack globals.
1062 Set_String
(" Default_Secondary_Stack_Size := ");
1064 if Opt
.Default_Sec_Stack_Size
/= Opt
.No_Stack_Size
then
1065 Set_Int
(Opt
.Default_Sec_Stack_Size
);
1067 Set_String
("System.Parameters.Runtime_Default_Sec_Stack_Size");
1071 Write_Statement_Buffer
;
1073 Set_String
(" Binder_Sec_Stacks_Count := ");
1074 Set_Int
(Num_Sec_Stacks
);
1076 Write_Statement_Buffer
;
1078 Set_String
(" Default_Sized_SS_Pool := ");
1080 if Num_Sec_Stacks
> 0 then
1081 Set_String
("Sec_Default_Sized_Stacks'Address;");
1083 Set_String
("System.Null_Address;");
1086 Write_Statement_Buffer
;
1090 -- Generate call to Runtime_Initialize
1092 WBI
(" Runtime_Initialize (1);");
1095 -- Generate call to set Initialize_Scalar values if active
1097 if Initialize_Scalars_Used
then
1099 Set_String
(" System.Scalar_Values.Initialize ('");
1100 Set_Char
(Initialize_Scalars_Mode1
);
1101 Set_String
("', '");
1102 Set_Char
(Initialize_Scalars_Mode2
);
1104 Write_Statement_Buffer
;
1107 -- Initialize stack limit variable of the environment task if the stack
1108 -- check method is stack limit and stack check is enabled.
1110 if Stack_Check_Limits_On_Target
1111 and then (Stack_Check_Default_On_Target
or Stack_Check_Switch_Set
)
1114 WBI
(" Initialize_Stack_Limit;");
1117 -- On CodePeer, the finalization of library objects is not relevant
1119 if CodePeer_Mode
then
1122 -- If this is the main program case, attach finalize_library to the soft
1123 -- link. Do it only when not using a restricted run time, in which case
1124 -- tasks are non-terminating, so we do not want library-level
1127 elsif not Bind_For_Library
1128 and then not Configurable_Run_Time_On_Target
1129 and then not Suppress_Standard_Library_On_Target
1133 if Lib_Final_Built
then
1134 Set_String
(" Finalize_Library_Objects := ");
1135 Set_String
("finalize_library'access;");
1137 Set_String
(" Finalize_Library_Objects := null;");
1140 Write_Statement_Buffer
;
1143 -- Generate elaboration calls
1145 if not CodePeer_Mode
then
1151 Gen_Elab_Calls
(Elab_Order
);
1153 if not CodePeer_Mode
then
1155 -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if
1156 -- restriction No_Standard_Allocators_After_Elaboration is active.
1158 if Cumulative_Restrictions
.Set
1159 (No_Standard_Allocators_After_Elaboration
)
1162 (" System.Elaboration_Allocators.Mark_End_Of_Elaboration;");
1165 -- From this point, no new dispatching domain can be created
1167 if Dispatching_Domains_Used
then
1168 WBI
(" Freeze_Dispatching_Domains;");
1171 -- Sequential partition elaboration policy
1173 if Partition_Elaboration_Policy_Specified
= 'S' then
1174 if System_Interrupts_Used
then
1175 WBI
(" Install_Restricted_Handlers_Sequential;");
1178 if System_Tasking_Restricted_Stages_Used
then
1179 WBI
(" Activate_All_Tasks_Sequential;");
1183 if System_BB_CPU_Primitives_Multiprocessors_Used
then
1184 WBI
(" Start_Slave_CPUs;");
1188 WBI
(" end " & Ada_Init_Name
.all & ";");
1192 -------------------------
1193 -- Gen_Bind_Env_String --
1194 -------------------------
1196 procedure Gen_Bind_Env_String
is
1197 procedure Write_Name_With_Len
(Nam
: Name_Id
);
1198 -- Write Nam as a string literal, prefixed with one
1199 -- character encoding Nam's length.
1201 -------------------------
1202 -- Write_Name_With_Len --
1203 -------------------------
1205 procedure Write_Name_With_Len
(Nam
: Name_Id
) is
1207 Get_Name_String
(Nam
);
1208 Write_Str
("Character'Val (");
1209 Write_Int
(Int
(Name_Len
));
1210 Write_Str
(") & """);
1211 Write_Str
(Name_Buffer
(1 .. Name_Len
));
1213 end Write_Name_With_Len
;
1217 First
: Boolean := True;
1218 KN
: Name_Id
:= No_Name
;
1219 VN
: Name_Id
:= No_Name
;
1221 -- Start of processing for Gen_Bind_Env_String
1224 Bind_Environment
.Get_First
(KN
, VN
);
1226 if VN
= No_Name
then
1230 Set_Special_Output
(Write_Bind_Line
'Access);
1232 WBI
(" Bind_Env : aliased constant String :=");
1234 while VN
/= No_Name
loop
1241 Write_Name_With_Len
(KN
);
1243 Write_Name_With_Len
(VN
);
1246 Bind_Environment
.Get_Next
(KN
, VN
);
1250 WBI
(" & ASCII.NUL;");
1252 Cancel_Special_Output
;
1253 Bind_Env_String_Built
:= True;
1254 end Gen_Bind_Env_String
;
1260 procedure Gen_CUDA_Defs
is
1261 Unit_Name
: constant String :=
1262 Get_Name_String
(Units
.Table
(First_Unit_Entry
).Uname
);
1263 Unit
: constant String :=
1264 Unit_Name
(Unit_Name
'First .. Unit_Name
'Last - 2);
1266 if not Enable_CUDA_Expansion
then
1273 WBI
(" procedure CUDA_Register_Function");
1274 WBI
(" (Fat_Binary_Handle : System.Address;");
1275 WBI
(" Func : System.Address;");
1276 WBI
(" Kernel_Name : Interfaces.C.Strings.chars_ptr;");
1277 WBI
(" Kernel_Name_2 : Interfaces.C.Strings.chars_ptr;");
1278 WBI
(" Minus_One : Integer;");
1279 WBI
(" Nullptr1 : System.Address;");
1280 WBI
(" Nullptr2 : System.Address;");
1281 WBI
(" Nullptr3 : System.Address;");
1282 WBI
(" Nullptr4 : System.Address;");
1283 WBI
(" Nullptr5 : System.Address);");
1284 WBI
(" pragma Import");
1285 WBI
(" (Convention => C,");
1286 WBI
(" Entity => CUDA_Register_Function,");
1287 WBI
(" External_Name => ""__cudaRegisterFunction"");");
1289 WBI
(" function CUDA_Register_Fat_Binary");
1290 WBI
(" (Fat_Binary : System.Address)");
1291 WBI
(" return System.Address;");
1292 WBI
(" pragma Import");
1293 WBI
(" (Convention => C,");
1294 WBI
(" Entity => CUDA_Register_Fat_Binary,");
1295 WBI
(" External_Name => ""__cudaRegisterFatBinary"");");
1297 WBI
(" procedure CUDA_Register_Fat_Binary_End");
1298 WBI
(" (Fat_Binary : System.Address);");
1299 WBI
(" pragma Import");
1300 WBI
(" (Convention => C,");
1301 WBI
(" Entity => CUDA_Register_Fat_Binary_End,");
1302 WBI
(" External_Name => ""__cudaRegisterFatBinaryEnd"");");
1304 WBI
(" type Fatbin_Wrapper is record");
1305 WBI
(" Magic : Interfaces.C.int;");
1306 WBI
(" Version : Interfaces.C.int;");
1307 WBI
(" Data : System.Address;");
1308 WBI
(" Filename_Or_Fatbins : System.Address;");
1309 WBI
(" end record;");
1311 WBI
(" Fat_Binary : System.Address;");
1312 WBI
(" pragma Import");
1313 WBI
(" (Convention => C,");
1314 WBI
(" Entity => Fat_Binary,");
1315 WBI
(" External_Name => ""_binary_" & Unit
& "_fatbin_start"");");
1317 WBI
(" Wrapper : Fatbin_Wrapper :=");
1318 WBI
(" (16#466243b1#,");
1320 WBI
(" Fat_Binary'Address,");
1321 WBI
(" System.Null_Address);");
1323 WBI
(" Fat_Binary_Handle : System.Address;");
1326 for K
in CUDA_Kernels
.First
.. CUDA_Kernels
.Last
loop
1328 K_String
: constant String := CUDA_Kernel_Id
'Image (K
);
1329 N
: constant String :=
1330 K_String
(K_String
'First + 1 .. K_String
'Last);
1331 Kernel_Symbol
: constant String := "Kernel_" & N
;
1332 -- K_Symbol is a unique identifier used to derive all symbol names
1333 -- related to kernel K.
1335 Kernel_Proc
: constant String := Kernel_Symbol
& "_Proc";
1336 -- Kernel_Proc is the name of the symbol representing the
1337 -- host-side procedure of the kernel. The address is
1338 -- pragma-imported and then used while registering the kernel with
1339 -- the CUDA runtime.
1340 Kernel_String
: constant String := Kernel_Symbol
& "_String";
1341 -- Kernel_String is the name of the C-string containing the name
1342 -- of the kernel. It is used for registering the kernel with the
1344 Kernel_Name
: constant String :=
1345 Get_Name_String
(CUDA_Kernels
.Table
(K
).Kernel_Name
);
1346 -- Kernel_Name is the name of the kernel, after package expansion.
1349 -- Import host-side kernel address.
1350 WBI
(" procedure " & Kernel_Proc
& ";");
1351 WBI
(" pragma Import");
1352 WBI
(" (Convention => C,");
1353 WBI
(" Entity => " & Kernel_Proc
& ",");
1354 WBI
(" External_Name => """ & Kernel_Name
& """);");
1357 -- Generate C-string containing name of kernel.
1359 (" " & Kernel_String
& " : Interfaces.C.Strings.Chars_Ptr;");
1365 WBI
(" procedure " & Device_Ada_Init_Subp_Name
& ";");
1366 WBI
(" pragma Export (C, " & Device_Ada_Init_Subp_Name
&
1367 ", Link_Name => """ & Device_Ada_Init_Link_Name
& """);");
1369 -- C-string declaration for adainit
1370 WBI
(" " & Adainit_String_Obj_Name
1371 & " : Interfaces.C.Strings.Chars_Ptr;");
1381 procedure Gen_CUDA_Init
is
1382 -- Generate call to register one function
1383 procedure Gen_CUDA_Register_Function_Call
1384 (Kernel_Name
: String;
1385 Kernel_String
: String;
1386 Kernel_Proc
: String);
1388 -------------------------------------
1389 -- Gen_CUDA_Register_Function_Call --
1390 -------------------------------------
1392 procedure Gen_CUDA_Register_Function_Call
1393 (Kernel_Name
: String;
1394 Kernel_String
: String;
1395 Kernel_Proc
: String) is
1397 WBI
(" " & Kernel_String
& " :=");
1398 WBI
(" Interfaces.C.Strings.New_Char_Array ("""
1402 -- Generate call to CUDA runtime to register function.
1403 WBI
(" CUDA_Register_Function (");
1404 WBI
(" Fat_Binary_Handle, ");
1405 WBI
(" " & Kernel_Proc
& "'Address,");
1406 WBI
(" " & Kernel_String
& ",");
1407 WBI
(" " & Kernel_String
& ",");
1409 WBI
(" System.Null_Address,");
1410 WBI
(" System.Null_Address,");
1411 WBI
(" System.Null_Address,");
1412 WBI
(" System.Null_Address,");
1413 WBI
(" System.Null_Address);");
1415 end Gen_CUDA_Register_Function_Call
;
1418 if not Enable_CUDA_Expansion
then
1422 WBI
(" Fat_Binary_Handle :=");
1423 WBI
(" CUDA_Register_Fat_Binary (Wrapper'Address);");
1425 for K
in CUDA_Kernels
.First
.. CUDA_Kernels
.Last
loop
1427 K_String
: constant String := CUDA_Kernel_Id
'Image (K
);
1428 N
: constant String :=
1429 K_String
(K_String
'First + 1 .. K_String
'Last);
1430 Kernel_Symbol
: constant String := "Kernel_" & N
;
1431 -- K_Symbol is a unique identifier used to derive all symbol names
1432 -- related to kernel K.
1434 Kernel_Proc
: constant String := Kernel_Symbol
& "_Proc";
1435 -- Kernel_Proc is the name of the symbol representing the
1436 -- host-side procedure of the kernel. The address is
1437 -- pragma-imported and then used while registering the kernel with
1438 -- the CUDA runtime.
1439 Kernel_String
: constant String := Kernel_Symbol
& "_String";
1440 -- Kernel_String is the name of the C-string containing the name
1441 -- of the kernel. It is used for registering the kernel with the
1443 Kernel_Name
: constant String :=
1444 Get_Name_String
(CUDA_Kernels
.Table
(K
).Kernel_Name
);
1445 -- Kernel_Name is the name of the kernel, after package expansion.
1447 Gen_CUDA_Register_Function_Call
1448 (Kernel_Name
=> Kernel_Name
,
1449 Kernel_String
=> Kernel_String
,
1450 Kernel_Proc
=> Kernel_Proc
);
1454 -- Register device-side Adainit
1455 Gen_CUDA_Register_Function_Call
1456 (Kernel_Name
=> Device_Ada_Init_Link_Name
,
1457 Kernel_String
=> Adainit_String_Obj_Name
,
1458 Kernel_Proc
=> Device_Ada_Init_Subp_Name
);
1460 WBI
(" CUDA_Register_Fat_Binary_End (Fat_Binary_Handle);");
1462 -- perform device (as opposed to host) elaboration
1463 WBI
(" pragma CUDA_Execute (" &
1464 Device_Ada_Init_Subp_Name
& ", 1, 1);");
1467 --------------------------
1468 -- Gen_CodePeer_Wrapper --
1469 --------------------------
1471 procedure Gen_CodePeer_Wrapper
is
1472 Callee_Name
: constant String := "Ada_Main_Program";
1475 if ALIs
.Table
(ALIs
.First
).Main_Program
= Proc
then
1476 WBI
(" procedure " & CodePeer_Wrapper_Name
& " is ");
1478 WBI
(" " & Callee_Name
& ";");
1481 WBI
(" function " & CodePeer_Wrapper_Name
& " return Integer is");
1483 WBI
(" return " & Callee_Name
& ";");
1486 WBI
(" end " & CodePeer_Wrapper_Name
& ";");
1488 end Gen_CodePeer_Wrapper
;
1490 --------------------
1491 -- Gen_Elab_Calls --
1492 --------------------
1494 procedure Gen_Elab_Calls
(Elab_Order
: Unit_Id_Array
) is
1495 Check_Elab_Flag
: Boolean;
1498 -- Loop through elaboration order entries
1500 for E
in Elab_Order
'Range loop
1502 Unum
: constant Unit_Id
:= Elab_Order
(E
);
1503 U
: Unit_Record
renames Units
.Table
(Unum
);
1505 Unum_Spec
: Unit_Id
;
1506 -- This is the unit number of the spec that corresponds to
1507 -- this entry. It is the same as Unum except when the body
1508 -- and spec are different and we are currently processing
1509 -- the body, in which case it is the spec (Unum + 1).
1512 if U
.Utype
= Is_Body
then
1513 Unum_Spec
:= Unum
+ 1;
1518 -- Nothing to do if predefined unit in no run time mode
1520 if No_Run_Time_Mode
and then Is_Predefined_File_Name
(U
.Sfile
) then
1523 -- Likewise if this is an interface to a stand alone library
1525 elsif U
.SAL_Interface
then
1528 -- Case of no elaboration code
1532 -- In CodePeer mode, we special case subprogram bodies which
1533 -- are handled in the 'else' part below, and lead to a call
1534 -- to <subp>'Elab_Subp_Body.
1536 and then (not CodePeer_Mode
1540 or else U
.Utype
= Is_Spec
1541 or else U
.Utype
= Is_Spec_Only
1542 or else U
.Unit_Kind
/= 's')
1544 -- In the case of a body with a separate spec, where the
1545 -- separate spec has an elaboration entity defined, this is
1546 -- where we increment the elaboration entity if one exists.
1548 -- Likewise for lone specs with an elaboration entity defined
1549 -- despite No_Elaboration_Code, e.g. when requested to preserve
1552 if (U
.Utype
= Is_Body
or else U
.Utype
= Is_Spec_Only
)
1553 and then Units
.Table
(Unum_Spec
).Set_Elab_Entity
1554 and then not CodePeer_Mode
1557 Set_Unit_Number
(Unum_Spec
);
1558 Set_String
(" := E");
1559 Set_Unit_Number
(Unum_Spec
);
1560 Set_String
(" + 1;");
1561 Write_Statement_Buffer
;
1564 -- Here if elaboration code is present. If binding a library
1565 -- or if there is a non-Ada main subprogram then we generate:
1567 -- if uname_E = 0 then
1568 -- uname'elab_[spec|body];
1570 -- uname_E := uname_E + 1;
1572 -- Otherwise, elaboration routines are called unconditionally:
1574 -- uname'elab_[spec|body];
1575 -- uname_E := uname_E + 1;
1577 -- The uname_E increment is skipped if this is a separate spec,
1578 -- since it will be done when we process the body.
1580 -- In CodePeer mode, we do not generate any reference to xxx_E
1581 -- variables, only calls to 'Elab* subprograms.
1584 -- Check incompatibilities with No_Multiple_Elaboration
1586 if not CodePeer_Mode
1587 and then Cumulative_Restrictions
.Set
(No_Multiple_Elaboration
)
1589 -- Force_Checking_Of_Elaboration_Flags (-F) not allowed
1591 if Force_Checking_Of_Elaboration_Flags
then
1593 ("-F (force elaboration checks) switch not allowed "
1594 & "with restriction No_Multiple_Elaboration active");
1596 -- Interfacing of libraries not allowed
1598 elsif Interface_Library_Unit
then
1600 ("binding of interfaced libraries not allowed "
1601 & "with restriction No_Multiple_Elaboration active");
1603 -- Non-Ada main program not allowed
1605 elsif not Bind_Main_Program
then
1607 ("non-Ada main program not allowed "
1608 & "with restriction No_Multiple_Elaboration active");
1612 -- OK, see if we need to test elaboration flag
1615 Units
.Table
(Unum_Spec
).Set_Elab_Entity
1616 and then Check_Elaboration_Flags
1617 and then not CodePeer_Mode
1618 and then (Force_Checking_Of_Elaboration_Flags
1619 or Interface_Library_Unit
1620 or not Bind_Main_Program
);
1622 if Check_Elab_Flag
then
1623 Set_String
(" if E");
1624 Set_Unit_Number
(Unum_Spec
);
1625 Set_String
(" = 0 then");
1626 Write_Statement_Buffer
;
1631 Get_Decoded_Name_String_With_Brackets
(U
.Uname
);
1633 if Name_Buffer
(Name_Len
) = 's' then
1634 Name_Buffer
(Name_Len
- 1 .. Name_Len
+ 8) :=
1636 Name_Len
:= Name_Len
+ 8;
1638 -- Special case in CodePeer mode for subprogram bodies
1639 -- which correspond to CodePeer 'Elab_Subp_Body special
1642 elsif U
.Unit_Kind
= 's' and CodePeer_Mode
then
1643 Name_Buffer
(Name_Len
- 1 .. Name_Len
+ 13) :=
1645 Name_Len
:= Name_Len
+ 13;
1648 Name_Buffer
(Name_Len
- 1 .. Name_Len
+ 8) :=
1650 Name_Len
:= Name_Len
+ 8;
1653 Set_Casing
(U
.Icasing
);
1656 Write_Statement_Buffer
;
1658 if Check_Elab_Flag
then
1662 if U
.Utype
/= Is_Spec
1663 and then not CodePeer_Mode
1664 and then Units
.Table
(Unum_Spec
).Set_Elab_Entity
1667 Set_Unit_Number
(Unum_Spec
);
1668 Set_String
(" := E");
1669 Set_Unit_Number
(Unum_Spec
);
1670 Set_String
(" + 1;");
1671 Write_Statement_Buffer
;
1678 ------------------------
1679 -- Gen_Elab_Externals --
1680 ------------------------
1682 procedure Gen_Elab_Externals
(Elab_Order
: Unit_Id_Array
) is
1684 if CodePeer_Mode
then
1688 for E
in Elab_Order
'Range loop
1690 Unum
: constant Unit_Id
:= Elab_Order
(E
);
1691 U
: Unit_Record
renames Units
.Table
(Unum
);
1694 -- Check for Elab_Entity to be set for this unit
1696 if U
.Set_Elab_Entity
1698 -- Don't generate reference for stand alone library
1700 and then not U
.SAL_Interface
1702 -- Don't generate reference for predefined file in No_Run_Time
1703 -- mode, since we don't include the object files in this case
1707 and then Is_Predefined_File_Name
(U
.Sfile
))
1709 Get_Name_String
(U
.Sfile
);
1712 Set_Unit_Number
(Unum
);
1713 Set_String
(" : Short_Integer; pragma Import (Ada, E");
1714 Set_Unit_Number
(Unum
);
1715 Set_String
(", """);
1716 Get_Name_String
(U
.Uname
);
1718 Set_String
("_E"");");
1719 Write_Statement_Buffer
;
1725 end Gen_Elab_Externals
;
1727 --------------------
1728 -- Gen_Elab_Order --
1729 --------------------
1731 procedure Gen_Elab_Order
(Elab_Order
: Unit_Id_Array
) is
1734 WBI
(" -- BEGIN ELABORATION ORDER");
1736 for J
in Elab_Order
'Range loop
1737 Set_String
(" -- ");
1738 Get_Name_String
(Units
.Table
(Elab_Order
(J
)).Uname
);
1740 Write_Statement_Buffer
;
1743 WBI
(" -- END ELABORATION ORDER");
1746 --------------------------
1747 -- Gen_Finalize_Library --
1748 --------------------------
1750 procedure Gen_Finalize_Library
(Elab_Order
: Unit_Id_Array
) is
1751 procedure Gen_Header
;
1752 -- Generate the header of the finalization routine
1758 procedure Gen_Header
is
1760 WBI
(" procedure finalize_library is");
1768 Uspec
: Unit_Record
;
1771 -- Start of processing for Gen_Finalize_Library
1774 if CodePeer_Mode
then
1778 for E
in reverse Elab_Order
'Range loop
1779 Unum
:= Elab_Order
(E
);
1780 U
:= Units
.Table
(Unum
);
1782 -- Dealing with package bodies is a little complicated. In such
1783 -- cases we must retrieve the package spec since it contains the
1784 -- spec of the body finalizer.
1786 if U
.Utype
= Is_Body
then
1788 Uspec
:= Units
.Table
(Unum
);
1793 Get_Name_String
(Uspec
.Uname
);
1795 -- We are only interested in non-generic packages
1797 if U
.Unit_Kind
/= 'p' or else U
.Is_Generic
then
1800 -- That aren't an interface to a stand alone library
1802 elsif U
.SAL_Interface
then
1805 -- Case of no finalization
1807 elsif not U
.Has_Finalizer
then
1809 -- The only case in which we have to do something is if this
1810 -- is a body, with a separate spec, where the separate spec
1811 -- has a finalizer. In that case, this is where we decrement
1812 -- the elaboration entity.
1814 if U
.Utype
= Is_Body
and then Uspec
.Has_Finalizer
then
1815 if not Lib_Final_Built
then
1817 Lib_Final_Built
:= True;
1821 Set_Unit_Number
(Unum
);
1822 Set_String
(" := E");
1823 Set_Unit_Number
(Unum
);
1824 Set_String
(" - 1;");
1825 Write_Statement_Buffer
;
1829 if not Lib_Final_Built
then
1831 Lib_Final_Built
:= True;
1836 -- procedure F<Count>;
1838 Set_String
(" declare");
1839 Write_Statement_Buffer
;
1841 Set_String
(" procedure F");
1844 Write_Statement_Buffer
;
1847 -- pragma Import (Ada, F<Count>,
1848 -- "xx__yy__finalize_[body|spec]");
1850 Set_String
(" pragma Import (Ada, F");
1852 Set_String
(", """);
1854 -- Perform name construction
1857 Set_String
("__finalize_");
1859 -- Package spec processing
1861 if U
.Utype
= Is_Spec
1862 or else U
.Utype
= Is_Spec_Only
1864 Set_String
("spec");
1866 -- Package body processing
1869 Set_String
("body");
1872 Set_String
(""");");
1873 Write_Statement_Buffer
;
1875 -- If binding a library or if there is a non-Ada main subprogram
1876 -- then we generate:
1879 -- uname_E := uname_E - 1;
1880 -- if uname_E = 0 then
1885 -- Otherwise, finalization routines are called unconditionally:
1888 -- uname_E := uname_E - 1;
1892 -- The uname_E decrement is skipped if this is a separate spec,
1893 -- since it will be done when we process the body.
1897 if U
.Utype
/= Is_Spec
then
1899 Set_Unit_Number
(Unum
);
1900 Set_String
(" := E");
1901 Set_Unit_Number
(Unum
);
1902 Set_String
(" - 1;");
1903 Write_Statement_Buffer
;
1906 if Interface_Library_Unit
or not Bind_Main_Program
then
1907 Set_String
(" if E");
1908 Set_Unit_Number
(Unum
);
1909 Set_String
(" = 0 then");
1910 Write_Statement_Buffer
;
1917 Write_Statement_Buffer
;
1919 if Interface_Library_Unit
or not Bind_Main_Program
then
1929 if Lib_Final_Built
then
1931 -- It is possible that the finalization of a library-level object
1932 -- raised an exception. In that case import the actual exception
1933 -- and the routine necessary to raise it.
1936 WBI
(" procedure Reraise_Library_Exception_If_Any;");
1938 Set_String
(" pragma Import (Ada, ");
1939 Set_String
("Reraise_Library_Exception_If_Any, ");
1940 Set_String
("""__gnat_reraise_library_exception_if_any"");");
1941 Write_Statement_Buffer
;
1944 WBI
(" Reraise_Library_Exception_If_Any;");
1946 WBI
(" end finalize_library;");
1949 end Gen_Finalize_Library
;
1955 procedure Gen_Main
is
1957 if not No_Main_Subprogram
then
1959 -- To call the main program, we declare it using a pragma Import
1960 -- Ada with the right link name.
1962 -- It might seem more obvious to "with" the main program, and call
1963 -- it in the normal Ada manner. We do not do this for three
1966 -- 1. It is more efficient not to recompile the main program
1967 -- 2. We are not entitled to assume the source is accessible
1968 -- 3. We don't know what options to use to compile it
1970 -- It is really reason 3 that is most critical (indeed we used
1971 -- to generate the "with", but several regression tests failed).
1973 if ALIs
.Table
(ALIs
.First
).Main_Program
= Func
then
1974 WBI
(" function Ada_Main_Program return Integer;");
1976 WBI
(" procedure Ada_Main_Program;");
1979 Set_String
(" pragma Import (Ada, Ada_Main_Program, """);
1980 Get_Name_String
(Units
.Table
(First_Unit_Entry
).Uname
);
1981 Set_Main_Program_Name
;
1982 Set_String
(""");");
1984 Write_Statement_Buffer
;
1987 -- For CodePeer, declare a wrapper for the user-defined main program
1989 if CodePeer_Mode
then
1990 Gen_CodePeer_Wrapper
;
1994 if Exit_Status_Supported_On_Target
then
1995 Set_String
(" function ");
1997 Set_String
(" procedure ");
2000 Set_String
(Get_Main_Name
);
2002 if Command_Line_Args_On_Target
then
2003 Write_Statement_Buffer
;
2004 WBI
(" (argc : Integer;");
2005 WBI
(" argv : System.Address;");
2006 WBI
(" envp : System.Address)");
2008 if Exit_Status_Supported_On_Target
then
2009 WBI
(" return Integer");
2015 if Exit_Status_Supported_On_Target
then
2016 Set_String
(" return Integer is");
2021 Write_Statement_Buffer
;
2024 if Opt
.Default_Exit_Status
/= 0
2025 and then Bind_Main_Program
2026 and then not Configurable_Run_Time_Mode
2028 WBI
(" procedure Set_Exit_Status (Status : Integer);");
2029 WBI
(" pragma Import (C, Set_Exit_Status, " &
2030 """__gnat_set_exit_status"");");
2034 -- Initialize and Finalize
2036 if not CodePeer_Mode
2037 and then not Cumulative_Restrictions
.Set
(No_Finalization
)
2039 WBI
(" procedure Initialize (Addr : System.Address);");
2040 WBI
(" pragma Import (C, Initialize, ""__gnat_initialize"");");
2042 WBI
(" procedure Finalize;");
2043 WBI
(" pragma Import (C, Finalize, ""__gnat_finalize"");");
2046 -- If we want to analyze the stack, we must import corresponding symbols
2048 if Dynamic_Stack_Measurement
then
2050 WBI
(" procedure Output_Results;");
2051 WBI
(" pragma Import (C, Output_Results, " &
2052 """__gnat_stack_usage_output_results"");");
2056 "procedure Initialize_Stack_Analysis (Buffer_Size : Natural);");
2057 WBI
(" pragma Import (C, Initialize_Stack_Analysis, " &
2058 """__gnat_stack_usage_initialize"");");
2061 -- Deal with declarations for main program case
2063 if not No_Main_Subprogram
then
2064 if ALIs
.Table
(ALIs
.First
).Main_Program
= Func
then
2065 WBI
(" Result : Integer;");
2069 if Bind_Main_Program
2070 and not Suppress_Standard_Library_On_Target
2071 and not CodePeer_Mode
2073 WBI
(" SEH : aliased array (1 .. 2) of Integer;");
2078 -- Generate a reference to Ada_Main_Program_Name. This symbol is not
2079 -- referenced elsewhere in the generated program, but is needed by
2080 -- the debugger (that's why it is generated in the first place). The
2081 -- reference stops Ada_Main_Program_Name from being optimized away by
2084 -- Because this variable is unused, we make this variable "aliased"
2085 -- with a pragma Volatile in order to tell the compiler to preserve
2086 -- this variable at any level of optimization.
2088 -- CodePeer and CCG do not need this extra code. The code is also not
2089 -- needed if the binder is in "Minimal Binder" mode.
2091 if Bind_Main_Program
2092 and then not Minimal_Binder
2093 and then not CodePeer_Mode
2094 and then not Generate_C_Code
2096 WBI
(" Ensure_Reference : aliased System.Address := " &
2097 "Ada_Main_Program_Name'Address;");
2098 WBI
(" pragma Volatile (Ensure_Reference);");
2104 -- Acquire command-line arguments if supported on the target and used
2107 if CodePeer_Mode
then
2110 elsif Command_Line_Args_On_Target
and then Command_Line_Used
then
2111 -- Initialize gnat_argc/gnat_argv only if not already initialized,
2112 -- to avoid losing the result of any command-line processing done by
2113 -- earlier GNAT run-time initialization.
2115 WBI
(" if gnat_argc = 0 then");
2116 WBI
(" gnat_argc := argc;");
2117 WBI
(" gnat_argv := argv;");
2119 WBI
(" gnat_envp := envp;");
2123 if Opt
.Default_Exit_Status
/= 0
2124 and then Bind_Main_Program
2125 and then not Configurable_Run_Time_Mode
2127 Set_String
(" Set_Exit_Status (");
2128 Set_Int
(Opt
.Default_Exit_Status
);
2130 Write_Statement_Buffer
;
2133 if Dynamic_Stack_Measurement
then
2134 Set_String
(" Initialize_Stack_Analysis (");
2135 Set_Int
(Dynamic_Stack_Measurement_Array_Size
);
2137 Write_Statement_Buffer
;
2140 if not Cumulative_Restrictions
.Set
(No_Finalization
)
2141 and then not CodePeer_Mode
2143 if not No_Main_Subprogram
2144 and then Bind_Main_Program
2145 and then not Suppress_Standard_Library_On_Target
2147 WBI
(" Initialize (SEH'Address);");
2149 WBI
(" Initialize (System.Null_Address);");
2153 WBI
(" " & Ada_Init_Name
.all & ";");
2155 if not No_Main_Subprogram
then
2156 if CodePeer_Mode
then
2157 if ALIs
.Table
(ALIs
.First
).Main_Program
= Proc
then
2158 WBI
(" " & CodePeer_Wrapper_Name
& ";");
2160 WBI
(" Result := " & CodePeer_Wrapper_Name
& ";");
2163 elsif ALIs
.Table
(ALIs
.First
).Main_Program
= Proc
then
2164 WBI
(" Ada_Main_Program;");
2167 WBI
(" Result := Ada_Main_Program;");
2171 -- Adafinal call is skipped if no finalization
2173 if not Cumulative_Restrictions
.Set
(No_Finalization
) then
2177 -- Prints the result of static stack analysis
2179 if Dynamic_Stack_Measurement
then
2180 WBI
(" Output_Results;");
2183 -- Finalize is only called if we have a run time
2185 if not Cumulative_Restrictions
.Set
(No_Finalization
)
2186 and then not CodePeer_Mode
2193 if Exit_Status_Supported_On_Target
then
2194 if No_Main_Subprogram
2195 or else ALIs
.Table
(ALIs
.First
).Main_Program
= Proc
2197 -- Return gnat_exit_status if Ada.Command_Line is used otherwise
2200 if Command_Line_Used
then
2201 WBI
(" return (gnat_exit_status);");
2203 WBI
(" return (0);");
2206 WBI
(" return (Result);");
2214 ------------------------------
2215 -- Gen_Object_Files_Options --
2216 ------------------------------
2218 procedure Gen_Object_Files_Options
(Elab_Order
: Unit_Id_Array
) is
2220 -- This keeps track of the position in the sorted set of entries in the
2221 -- Linker_Options table of where the first entry from an internal file
2224 Linker_Option_List_Started
: Boolean := False;
2225 -- Set to True when "LINKER OPTION LIST" is displayed
2227 procedure Write_Linker_Option
;
2228 -- Write binder info linker option
2230 -------------------------
2231 -- Write_Linker_Option --
2232 -------------------------
2234 procedure Write_Linker_Option
is
2239 -- Loop through string, breaking at null's
2242 while Start
< Name_Len
loop
2244 -- Find null ending this section
2247 while Name_Buffer
(Stop
) /= ASCII
.NUL
2248 and then Stop
<= Name_Len
loop
2252 -- Process section if non-null
2254 if Stop
> Start
then
2255 if Output_Linker_Option_List
then
2256 if not Zero_Formatting
then
2257 if not Linker_Option_List_Started
then
2258 Linker_Option_List_Started
:= True;
2260 Write_Str
(" LINKER OPTION LIST");
2268 Write_Str
(Name_Buffer
(Start
.. Stop
- 1));
2271 WBI
(" -- " & Name_Buffer
(Start
.. Stop
- 1));
2276 end Write_Linker_Option
;
2278 -- Start of processing for Gen_Object_Files_Options
2281 WBI
("-- BEGIN Object file/option list");
2283 if Object_List_Filename
/= null then
2284 Set_List_File
(Object_List_Filename
.all);
2287 for E
in Elab_Order
'Range loop
2289 -- If not spec that has an associated body, then generate a comment
2290 -- giving the name of the corresponding object file.
2292 if not Units
.Table
(Elab_Order
(E
)).SAL_Interface
2293 and then Units
.Table
(Elab_Order
(E
)).Utype
/= Is_Spec
2297 (Units
.Table
(Elab_Order
(E
)).My_ALI
).Ofile_Full_Name
);
2299 -- If the presence of an object file is necessary or if it exists,
2302 if not Hostparm
.Exclude_Missing_Objects
2304 System
.OS_Lib
.Is_Regular_File
(Name_Buffer
(1 .. Name_Len
))
2306 WBI
(" -- " & Name_Buffer
(1 .. Name_Len
));
2308 if Output_Object_List
then
2309 Write_Str
(Name_Buffer
(1 .. Name_Len
));
2316 if Object_List_Filename
/= null then
2320 -- Add a "-Ldir" for each directory in the object path
2322 for J
in 1 .. Nb_Dir_In_Obj_Search_Path
loop
2324 Dir
: constant String_Ptr
:= Dir_In_Obj_Search_Path
(J
);
2328 Add_Str_To_Name_Buffer
("-L");
2329 Add_Str_To_Name_Buffer
(Dir
.all);
2330 Write_Linker_Option
;
2334 if not (Opt
.No_Run_Time_Mode
or Opt
.No_Stdlib
) then
2337 if Opt
.Shared_Libgnat
then
2338 Add_Str_To_Name_Buffer
("-shared");
2340 Add_Str_To_Name_Buffer
("-static");
2343 -- Write directly to avoid inclusion in -K output as -static and
2344 -- -shared are not usually specified linker options.
2346 WBI
(" -- " & Name_Buffer
(1 .. Name_Len
));
2349 -- Sort linker options
2351 -- This sort accomplishes two important purposes:
2353 -- a) All application files are sorted to the front, and all GNAT
2354 -- internal files are sorted to the end. This results in a well
2355 -- defined dividing line between the two sets of files, for the
2356 -- purpose of inserting certain standard library references into
2357 -- the linker arguments list.
2359 -- b) Given two different units, we sort the linker options so that
2360 -- those from a unit earlier in the elaboration order comes later
2361 -- in the list. This is a heuristic designed to create a more
2362 -- friendly order of linker options when the operations appear in
2363 -- separate units. The idea is that if unit A must be elaborated
2364 -- before unit B, then it is more likely that B references
2365 -- libraries included by A, than vice versa, so we want libraries
2366 -- included by A to come after libraries included by B.
2368 -- These two criteria are implemented by function Lt_Linker_Option. Note
2369 -- that a special case of b) is that specs are elaborated before bodies,
2370 -- so linker options from specs come after linker options for bodies,
2371 -- and again, the assumption is that libraries used by the body are more
2372 -- likely to reference libraries used by the spec, than vice versa.
2375 (Linker_Options
.Last
,
2376 Move_Linker_Option
'Access,
2377 Lt_Linker_Option
'Access);
2379 -- Write user linker options, i.e. the set of linker options that come
2380 -- from all files other than GNAT internal files, Lgnat is left set to
2381 -- point to the first entry from a GNAT internal file, or past the end
2382 -- of the entries if there are no internal files.
2384 Lgnat
:= Linker_Options
.Last
+ 1;
2386 for J
in 1 .. Linker_Options
.Last
loop
2387 if not Linker_Options
.Table
(J
).Internal_File
then
2388 Get_Name_String
(Linker_Options
.Table
(J
).Name
);
2389 Write_Linker_Option
;
2396 -- Now we insert standard linker options that must appear after the
2397 -- entries from user files, and before the entries from GNAT run-time
2398 -- files. The reason for this decision is that libraries referenced
2399 -- by internal routines may reference these standard library entries.
2401 -- Note that we do not insert anything when pragma No_Run_Time has
2402 -- been specified or when the standard libraries are not to be used,
2403 -- otherwise on some platforms, we may get duplicate symbols when
2404 -- linking (not clear if this is still the case, but it is harmless).
2406 if not (Opt
.No_Run_Time_Mode
or else Opt
.No_Stdlib
) then
2410 if Opt
.Shared_Libgnat
then
2411 Add_Str_To_Name_Buffer
(Shared_Lib
("gnarl"));
2413 Add_Str_To_Name_Buffer
("-lgnarl");
2416 Write_Linker_Option
;
2421 if Opt
.Shared_Libgnat
then
2422 Add_Str_To_Name_Buffer
(Shared_Lib
("gnat"));
2424 Add_Str_To_Name_Buffer
("-lgnat");
2427 Write_Linker_Option
;
2430 -- Write linker options from all internal files
2432 for J
in Lgnat
.. Linker_Options
.Last
loop
2433 Get_Name_String
(Linker_Options
.Table
(J
).Name
);
2434 Write_Linker_Option
;
2437 if Output_Linker_Option_List
and then not Zero_Formatting
then
2441 WBI
("-- END Object file/option list ");
2442 end Gen_Object_Files_Options
;
2444 ---------------------
2445 -- Gen_Output_File --
2446 ---------------------
2448 procedure Gen_Output_File
2450 Elab_Order
: Unit_Id_Array
)
2453 -- Acquire settings for Interrupt_State pragmas
2455 Set_IS_Pragma_Table
;
2457 -- Acquire settings for Priority_Specific_Dispatching pragma
2459 Set_PSD_Pragma_Table
;
2461 -- Override time slice value if -T switch is set
2463 if Time_Slice_Set
then
2464 ALIs
.Table
(ALIs
.First
).Time_Slice_Value
:= Opt
.Time_Slice_Value
;
2467 -- Count number of elaboration calls
2469 for E
in Elab_Order
'Range loop
2470 if Units
.Table
(Elab_Order
(E
)).No_Elab
then
2473 Num_Elab_Calls
:= Num_Elab_Calls
+ 1;
2477 -- Count the number of statically allocated stacks to be generated by
2478 -- the binder. If the user has specified the number of default-sized
2479 -- secondary stacks, use that number. Otherwise start the count at one
2480 -- as the binder is responsible for creating a secondary stack for the
2483 if Opt
.Quantity_Of_Default_Size_Sec_Stacks
/= -1 then
2484 Num_Sec_Stacks
:= Quantity_Of_Default_Size_Sec_Stacks
;
2485 elsif Sec_Stack_Used
then
2486 Num_Sec_Stacks
:= 1;
2489 for J
in Units
.First
.. Units
.Last
loop
2490 Num_Primary_Stacks
:=
2491 Num_Primary_Stacks
+ Units
.Table
(J
).Primary_Stack_Count
;
2494 Num_Sec_Stacks
+ Units
.Table
(J
).Sec_Stack_Count
;
2497 -- Generate output file in appropriate language
2499 Gen_Output_File_Ada
(Filename
, Elab_Order
);
2500 end Gen_Output_File
;
2502 -------------------------
2503 -- Gen_Output_File_Ada --
2504 -------------------------
2506 procedure Gen_Output_File_Ada
2507 (Filename
: String; Elab_Order
: Unit_Id_Array
)
2509 Ada_Main
: constant String := Get_Ada_Main_Name
;
2510 -- Name to be used for generated Ada main program. See the body of
2511 -- function Get_Ada_Main_Name for details on the form of the name.
2513 Needs_Library_Finalization
: constant Boolean :=
2514 not Configurable_Run_Time_On_Target
2515 and then Has_Finalizer
(Elab_Order
);
2516 -- For restricted run-time libraries (ZFP and Ravenscar) tasks are
2517 -- non-terminating, so we do not want finalization.
2520 -- Name of generated bind file (spec)
2523 -- Name of generated bind file (body)
2526 -- Create spec first
2528 Create_Binder_Output
(Filename
, 's', Bfiles
);
2530 -- We always compile the binder file in Ada 95 mode so that we properly
2531 -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None
2532 -- of the Ada 2005 or Ada 2012 constructs are needed by the binder file.
2534 WBI
("pragma Warnings (Off);");
2535 WBI
("pragma Ada_95;");
2537 -- If we are operating in Restrictions (No_Exception_Handlers) mode,
2538 -- then we need to make sure that the binder program is compiled with
2539 -- the same restriction, so that no exception tables are generated.
2541 if Cumulative_Restrictions
.Set
(No_Exception_Handlers
) then
2542 WBI
("pragma Restrictions (No_Exception_Handlers);");
2545 -- Same processing for Restrictions (No_Exception_Propagation)
2547 if Cumulative_Restrictions
.Set
(No_Exception_Propagation
) then
2548 WBI
("pragma Restrictions (No_Exception_Propagation);");
2551 -- Same processing for pragma No_Run_Time
2553 if No_Run_Time_Mode
then
2554 WBI
("pragma No_Run_Time;");
2557 -- Generate with of System so we can reference System.Address
2559 WBI
("with System;");
2561 -- Generate with of System.Initialize_Scalars if active
2563 if Initialize_Scalars_Used
then
2564 WBI
("with System.Scalar_Values;");
2567 -- Generate withs of System.Secondary_Stack and System.Parameters to
2568 -- allow the generation of the default-sized secondary stack pool.
2570 if Sec_Stack_Used
then
2571 WBI
("with System.Parameters;");
2572 WBI
("with System.Secondary_Stack;");
2575 if Enable_CUDA_Expansion
then
2576 WBI
("with Interfaces.C;");
2577 WBI
("with Interfaces.C.Strings;");
2579 -- with of CUDA.Internal needed for CUDA_Execute pragma expansion
2580 WBI
("with CUDA.Internal;");
2583 Resolve_Binder_Options
(Elab_Order
);
2585 -- Generate standard with's
2587 if not Suppress_Standard_Library_On_Target
then
2588 if CodePeer_Mode
then
2589 WBI
("with System.Standard_Library;");
2593 WBI
("package " & Ada_Main
& " is");
2595 -- Main program case
2597 if Bind_Main_Program
then
2598 -- Generate argc/argv stuff unless suppressed
2600 -- A run-time configured to support command line arguments defines
2601 -- a number of internal symbols that need to be set by the binder.
2602 -- We do not do this in cases where the program does not use
2603 -- Ada.Command_Line, as the package and it's support files may not be
2606 if Command_Line_Args_On_Target
and then Command_Line_Used
then
2608 WBI
(" gnat_argc : Integer;");
2609 WBI
(" gnat_argv : System.Address;");
2610 WBI
(" gnat_envp : System.Address;");
2613 WBI
(" pragma Import (C, gnat_argc);");
2614 WBI
(" pragma Import (C, gnat_argv);");
2615 WBI
(" pragma Import (C, gnat_envp);");
2618 -- Define exit status if supported by the target. The exit status is
2619 -- stored in the run-time library to allow applications set the state
2620 -- through Ada.Command_Line and is initialized in the run-time. Like
2621 -- command line arguments, skip if Ada.Command_Line is not used in
2622 -- the enclosure of the partition because this package may not be
2623 -- available in the runtime.
2627 if Exit_Status_Supported_On_Target
and then Command_Line_Used
2629 WBI
(" gnat_exit_status : Integer;");
2630 WBI
(" pragma Import (C, gnat_exit_status);");
2633 -- Generate the GNAT_Version and Ada_Main_Program_Name info only for
2634 -- the main program. Otherwise, it can lead under some circumstances
2635 -- to a symbol duplication during the link (for instance when a C
2636 -- program uses two Ada libraries). Also zero terminate the string
2637 -- so that its end can be found reliably at run time.
2639 if not Minimal_Binder
then
2641 WBI
(" GNAT_Version : constant String :=");
2642 WBI
(" """ & Ver_Prefix
&
2643 Gnat_Version_String
&
2645 WBI
(" pragma Export (C, GNAT_Version, ""__gnat_version"");");
2647 WBI
(" GNAT_Version_Address : constant System.Address := " &
2648 "GNAT_Version'Address;");
2649 WBI
(" pragma Export (C, GNAT_Version_Address, " &
2650 """__gnat_version_address"");");
2652 Set_String
(" Ada_Main_Program_Name : constant String := """);
2653 Get_Name_String
(Units
.Table
(First_Unit_Entry
).Uname
);
2655 Set_Main_Program_Name
;
2656 Set_String
(""" & ASCII.NUL;");
2658 Write_Statement_Buffer
;
2661 (" pragma Export (C, Ada_Main_Program_Name, " &
2662 """__gnat_ada_main_program_name"");");
2667 WBI
(" procedure " & Ada_Init_Name
.all & ";");
2668 if Enable_CUDA_Device_Expansion
then
2669 WBI
(" pragma Export (C, " & Ada_Init_Name
.all &
2670 ", Link_Name => """ & Device_Link_Name_Prefix
2671 & Ada_Init_Name
.all & """);");
2672 WBI
(" pragma CUDA_Global (" & Ada_Init_Name
.all & ");");
2674 WBI
(" pragma Export (C, " & Ada_Init_Name
.all & ", """ &
2675 Ada_Init_Name
.all & """);");
2678 -- If -a has been specified use pragma Linker_Constructor for the init
2679 -- procedure and pragma Linker_Destructor for the final procedure.
2681 if Use_Pragma_Linker_Constructor
then
2682 WBI
(" pragma Linker_Constructor (" & Ada_Init_Name
.all & ");");
2685 if not Cumulative_Restrictions
.Set
(No_Finalization
) then
2687 WBI
(" procedure " & Ada_Final_Name
.all & ";");
2688 if Enable_CUDA_Device_Expansion
then
2689 WBI
(" pragma Export (C, " & Ada_Final_Name
.all &
2690 ", Link_Name => """ & Device_Link_Name_Prefix
&
2691 Ada_Final_Name
.all & """);");
2692 WBI
(" pragma CUDA_Global (" & Ada_Final_Name
.all & ");");
2694 WBI
(" pragma Export (C, " & Ada_Final_Name
.all & ", """ &
2695 Ada_Final_Name
.all & """);");
2698 if Use_Pragma_Linker_Constructor
then
2699 WBI
(" pragma Linker_Destructor (" & Ada_Final_Name
.all & ");");
2703 if Bind_Main_Program
then
2707 if Exit_Status_Supported_On_Target
then
2708 Set_String
(" function ");
2710 Set_String
(" procedure ");
2713 Set_String
(Get_Main_Name
);
2715 -- Generate argument list if present
2717 if Command_Line_Args_On_Target
then
2718 Write_Statement_Buffer
;
2719 WBI
(" (argc : Integer;");
2720 WBI
(" argv : System.Address;");
2722 (" envp : System.Address)");
2724 if Exit_Status_Supported_On_Target
then
2725 Write_Statement_Buffer
;
2726 WBI
(" return Integer;");
2728 Write_Statement_Buffer
(";");
2732 if Exit_Status_Supported_On_Target
then
2733 Write_Statement_Buffer
(" return Integer;");
2735 Write_Statement_Buffer
(";");
2739 WBI
(" pragma Export (C, " & Get_Main_Name
& ", """ &
2740 Get_Main_Name
& """);");
2745 -- Generate version numbers for units, only if needed. Be very safe on
2748 if not Configurable_Run_Time_On_Target
2749 or else System_Version_Control_Used
2750 or else not Bind_Main_Program
2755 Gen_Elab_Order
(Elab_Order
);
2760 WBI
("end " & Ada_Main
& ";");
2761 Close_Binder_Output
;
2763 -- Prepare to write body
2765 Create_Binder_Output
(Filename
, 'b', Bfileb
);
2767 -- We always compile the binder file in Ada 95 mode so that we properly
2768 -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None
2769 -- of the Ada 2005/2012 constructs are needed by the binder file.
2771 WBI
("pragma Warnings (Off);");
2772 WBI
("pragma Ada_95;");
2774 -- Output Source_File_Name pragmas which look like
2776 -- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss");
2777 -- pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb");
2779 -- where sss/bbb are the spec/body file names respectively
2781 Get_Name_String
(Bfiles
);
2782 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 3) := """);";
2784 WBI
("pragma Source_File_Name (" &
2786 ", Spec_File_Name => """ &
2787 Name_Buffer
(1 .. Name_Len
+ 3));
2789 Get_Name_String
(Bfileb
);
2790 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 3) := """);";
2792 WBI
("pragma Source_File_Name (" &
2794 ", Body_File_Name => """ &
2795 Name_Buffer
(1 .. Name_Len
+ 3));
2797 -- Generate pragma Suppress (Overflow_Check). This is needed for recent
2798 -- versions of the compiler which have overflow checks on by default.
2799 -- We do not want overflow checking enabled for the increments of the
2800 -- elaboration variables (since this can cause an unwanted reference to
2801 -- the last chance exception handler for limited run-times).
2803 WBI
("pragma Suppress (Overflow_Check);");
2805 -- Generate with of System.Restrictions to initialize
2806 -- Run_Time_Restrictions.
2808 if System_Restrictions_Used
then
2810 WBI
("with System.Restrictions;");
2813 -- Generate with of Ada.Exceptions if needs library finalization
2815 if Needs_Library_Finalization
then
2816 WBI
("with Ada.Exceptions;");
2819 -- Generate with of System.Elaboration_Allocators if the restriction
2820 -- No_Standard_Allocators_After_Elaboration was present.
2822 if Cumulative_Restrictions
.Set
2823 (No_Standard_Allocators_After_Elaboration
)
2825 WBI
("with System.Elaboration_Allocators;");
2828 -- Generate start of package body
2831 WBI
("package body " & Ada_Main
& " is");
2834 -- Generate externals for elaboration entities
2836 Gen_Elab_Externals
(Elab_Order
);
2838 -- Generate default-sized secondary stacks pool. At least one stack is
2839 -- created and assigned to the environment task if secondary stacks are
2840 -- used by the program.
2842 if Sec_Stack_Used
then
2843 Set_String
(" Sec_Default_Sized_Stacks");
2844 Set_String
(" : array (1 .. ");
2845 Set_Int
(Num_Sec_Stacks
);
2846 Set_String
(") of aliased System.Secondary_Stack.SS_Stack (");
2848 if Opt
.Default_Sec_Stack_Size
/= No_Stack_Size
then
2849 Set_Int
(Opt
.Default_Sec_Stack_Size
);
2851 Set_String
("System.Parameters.Runtime_Default_Sec_Stack_Size");
2855 Write_Statement_Buffer
;
2859 -- Generate reference
2861 if not CodePeer_Mode
then
2862 if not Suppress_Standard_Library_On_Target
then
2864 -- Generate Priority_Specific_Dispatching pragma string
2867 (" Local_Priority_Specific_Dispatching : " &
2868 "constant String := """);
2870 for J
in 0 .. PSD_Pragma_Settings
.Last
loop
2871 Set_Char
(PSD_Pragma_Settings
.Table
(J
));
2875 Write_Statement_Buffer
;
2877 -- Generate Interrupt_State pragma string
2879 Set_String
(" Local_Interrupt_States : constant String := """);
2881 for J
in 0 .. IS_Pragma_Settings
.Last
loop
2882 Set_Char
(IS_Pragma_Settings
.Table
(J
));
2886 Write_Statement_Buffer
;
2890 if not Suppress_Standard_Library_On_Target
then
2892 -- The B.1(39) implementation advice says that the adainit and
2893 -- adafinal routines should be idempotent. Generate a flag to
2894 -- ensure that. This is not needed if we are suppressing the
2895 -- standard library since it would never be referenced.
2897 WBI
(" Is_Elaborated : Boolean := False;");
2899 -- Generate bind environment string
2901 Gen_Bind_Env_String
;
2907 -- Generate the adafinal routine unless there is no finalization to do
2909 if not Cumulative_Restrictions
.Set
(No_Finalization
) then
2910 if Needs_Library_Finalization
then
2911 Gen_Finalize_Library
(Elab_Order
);
2917 Gen_Adainit
(Elab_Order
);
2919 if Enable_CUDA_Expansion
then
2920 WBI
(" procedure " & Device_Ada_Init_Subp_Name
& " is");
2922 WBI
(" raise Program_Error;");
2923 WBI
(" end " & Device_Ada_Init_Subp_Name
& ";");
2926 if Bind_Main_Program
then
2930 -- Output object file list and the Ada body is complete
2932 Gen_Object_Files_Options
(Elab_Order
);
2935 WBI
("end " & Ada_Main
& ";");
2937 Close_Binder_Output
;
2938 end Gen_Output_File_Ada
;
2940 ----------------------
2941 -- Gen_Restrictions --
2942 ----------------------
2944 procedure Gen_Restrictions
is
2948 if not System_Restrictions_Used
then
2952 WBI
(" System.Restrictions.Run_Time_Restrictions :=");
2958 for J
in Cumulative_Restrictions
.Set
'Range loop
2959 Set_Boolean
(Cumulative_Restrictions
.Set
(J
));
2963 if J
/= Cumulative_Restrictions
.Set
'Last and then Count
= 8 then
2964 Write_Statement_Buffer
;
2970 Set_String_Replace
("),");
2971 Write_Statement_Buffer
;
2972 Set_String
(" Value => (");
2974 for J
in Cumulative_Restrictions
.Value
'Range loop
2975 Set_Int
(Int
(Cumulative_Restrictions
.Value
(J
)));
2979 Set_String_Replace
("),");
2980 Write_Statement_Buffer
;
2981 WBI
(" Violated =>");
2985 for J
in Cumulative_Restrictions
.Violated
'Range loop
2986 Set_Boolean
(Cumulative_Restrictions
.Violated
(J
));
2990 if J
/= Cumulative_Restrictions
.Set
'Last and then Count
= 8 then
2991 Write_Statement_Buffer
;
2997 Set_String_Replace
("),");
2998 Write_Statement_Buffer
;
2999 Set_String
(" Count => (");
3001 for J
in Cumulative_Restrictions
.Count
'Range loop
3002 Set_Int
(Int
(Cumulative_Restrictions
.Count
(J
)));
3006 Set_String_Replace
("),");
3007 Write_Statement_Buffer
;
3008 Set_String
(" Unknown => (");
3010 for J
in Cumulative_Restrictions
.Unknown
'Range loop
3011 Set_Boolean
(Cumulative_Restrictions
.Unknown
(J
));
3015 Set_String_Replace
("))");
3017 Write_Statement_Buffer
;
3018 end Gen_Restrictions
;
3024 -- This routine generates lines such as:
3026 -- unnnnn : constant Integer := 16#hhhhhhhh#;
3027 -- pragma Export (C, unnnnn, unam);
3029 -- for each unit, where unam is the unit name suffixed by either B or S for
3030 -- body or spec, with dots replaced by double underscores, and hhhhhhhh is
3031 -- the version number, and nnnnn is a 5-digits serial number.
3033 procedure Gen_Versions
is
3034 Ubuf
: String (1 .. 6) := "u00000";
3036 procedure Increment_Ubuf
;
3037 -- Little procedure to increment the serial number
3039 --------------------
3040 -- Increment_Ubuf --
3041 --------------------
3043 procedure Increment_Ubuf
is
3045 for J
in reverse Ubuf
'Range loop
3046 Ubuf
(J
) := Character'Succ (Ubuf
(J
));
3047 exit when Ubuf
(J
) <= '9';
3052 -- Start of processing for Gen_Versions
3057 WBI
(" type Version_32 is mod 2 ** 32;");
3058 for U
in Units
.First
.. Units
.Last
loop
3059 if not Units
.Table
(U
).SAL_Interface
3060 and then (not Bind_For_Library
3061 or else Units
.Table
(U
).Directly_Scanned
)
3064 WBI
(" " & Ubuf
& " : constant Version_32 := 16#" &
3065 Units
.Table
(U
).Version
& "#;");
3066 Set_String
(" pragma Export (C, ");
3068 Set_String
(", """);
3070 Get_Name_String
(Units
.Table
(U
).Uname
);
3072 for K
in 1 .. Name_Len
loop
3073 if Name_Buffer
(K
) = '.' then
3077 elsif Name_Buffer
(K
) = '%' then
3081 Set_Char
(Name_Buffer
(K
));
3085 if Name_Buffer
(Name_Len
) = 's' then
3091 Set_String
(""");");
3092 Write_Statement_Buffer
;
3097 ------------------------
3098 -- Get_Main_Unit_Name --
3099 ------------------------
3101 function Get_Main_Unit_Name
(S
: String) return String is
3102 Result
: String := S
;
3105 for J
in S
'Range loop
3106 if Result
(J
) = '.' then
3112 end Get_Main_Unit_Name
;
3114 -----------------------
3115 -- Get_Ada_Main_Name --
3116 -----------------------
3118 function Get_Ada_Main_Name
return String is
3119 Suffix
: constant String := "_00";
3120 Name
: String (1 .. Opt
.Ada_Main_Name
.all'Length + Suffix
'Length) :=
3121 Opt
.Ada_Main_Name
.all & Suffix
;
3125 -- For CodePeer, we want reproducible names (independent of other mains
3126 -- that may or may not be present) that don't collide when analyzing
3127 -- multiple mains and which are easily recognizable as "ada_main" names.
3129 if CodePeer_Mode
then
3130 Get_Name_String
(Units
.Table
(First_Unit_Entry
).Uname
);
3134 Get_Main_Unit_Name
(Name_Buffer
(1 .. Name_Len
- 2));
3137 -- This loop tries the following possibilities in order
3143 -- where <Ada_Main> is equal to Opt.Ada_Main_Name. By default,
3144 -- it is set to 'ada_main'.
3146 for J
in 0 .. 99 loop
3148 Nlen
:= Name
'Length - Suffix
'Length;
3150 Nlen
:= Name
'Length;
3151 Name
(Name
'Last) := Character'Val (J
mod 10 + Character'Pos ('0'));
3152 Name
(Name
'Last - 1) :=
3153 Character'Val (J
/ 10 + Character'Pos ('0'));
3156 for K
in ALIs
.First
.. ALIs
.Last
loop
3157 for L
in ALIs
.Table
(K
).First_Unit
.. ALIs
.Table
(K
).Last_Unit
loop
3159 -- Get unit name, removing %b or %e at end
3161 Get_Name_String
(Units
.Table
(L
).Uname
);
3162 Name_Len
:= Name_Len
- 2;
3164 if Name_Buffer
(1 .. Name_Len
) = Name
(1 .. Nlen
) then
3170 return Name
(1 .. Nlen
);
3176 -- If we fall through, just use a peculiar unlikely name
3178 return ("Qwertyuiop");
3179 end Get_Ada_Main_Name
;
3185 function Get_Main_Name
return String is
3187 -- Explicit name given with -M switch
3189 if Bind_Alternate_Main_Name
then
3190 return Alternate_Main_Name
.all;
3192 -- Case of main program name to be used directly
3194 elsif Use_Ada_Main_Program_Name_On_Target
then
3196 -- Get main program name
3198 Get_Name_String
(Units
.Table
(First_Unit_Entry
).Uname
);
3200 -- If this is a child name, return only the name of the child, since
3201 -- we can't have dots in a nested program name. Note that we do not
3202 -- include the %b at the end of the unit name.
3204 for J
in reverse 1 .. Name_Len
- 2 loop
3205 if J
= 1 or else Name_Buffer
(J
- 1) = '.' then
3206 return Name_Buffer
(J
.. Name_Len
- 2);
3210 raise Program_Error
; -- impossible exit
3212 -- Case where "main" is to be used as default
3219 ---------------------
3220 -- Get_WC_Encoding --
3221 ---------------------
3223 function Get_WC_Encoding
return Character is
3225 -- If encoding method specified by -W switch, then return it
3227 if Wide_Character_Encoding_Method_Specified
then
3228 return WC_Encoding_Letters
(Wide_Character_Encoding_Method
);
3230 -- If no main program, and not specified, set brackets, we really have
3231 -- no better choice. If some other encoding is required when there is
3232 -- no main, it must be set explicitly using -Wx.
3234 -- Note: if the ALI file always passed the wide character encoding of
3235 -- every file, then we could use the encoding of the initial specified
3236 -- file, but this information is passed only for potential main
3237 -- programs. We could fix this sometime, but it is a very minor point
3238 -- (wide character default encoding for [Wide_[Wide_]]Text_IO when there
3239 -- is no main program).
3241 elsif No_Main_Subprogram
then
3244 -- Otherwise if there is a main program, take encoding from it
3247 return ALIs
.Table
(ALIs
.First
).WC_Encoding
;
3249 end Get_WC_Encoding
;
3255 function Has_Finalizer
(Elab_Order
: Unit_Id_Array
) return Boolean is
3260 for E
in reverse Elab_Order
'Range loop
3261 Unum
:= Elab_Order
(E
);
3262 U
:= Units
.Table
(Unum
);
3264 -- We are only interested in non-generic packages
3266 if U
.Unit_Kind
= 'p'
3267 and then U
.Has_Finalizer
3268 and then not U
.Is_Generic
3269 and then not U
.No_Elab
3282 function Hash
(Nam
: Name_Id
) return Header_Num
is
3284 return Int
(Nam
- Names_Low_Bound
) rem Header_Num
'Last;
3287 ----------------------
3288 -- Lt_Linker_Option --
3289 ----------------------
3291 function Lt_Linker_Option
(Op1
: Natural; Op2
: Natural) return Boolean is
3293 -- Sort internal files last
3295 if Linker_Options
.Table
(Op1
).Internal_File
3297 Linker_Options
.Table
(Op2
).Internal_File
3299 -- Note: following test uses False < True
3301 return Linker_Options
.Table
(Op1
).Internal_File
3303 Linker_Options
.Table
(Op2
).Internal_File
;
3305 -- If both internal or both non-internal, sort according to the
3306 -- elaboration position. A unit that is elaborated later should come
3307 -- earlier in the linker options list.
3310 return Units
.Table
(Linker_Options
.Table
(Op1
).Unit
).Elab_Position
3312 Units
.Table
(Linker_Options
.Table
(Op2
).Unit
).Elab_Position
;
3314 end Lt_Linker_Option
;
3316 ------------------------
3317 -- Move_Linker_Option --
3318 ------------------------
3320 procedure Move_Linker_Option
(From
: Natural; To
: Natural) is
3322 Linker_Options
.Table
(To
) := Linker_Options
.Table
(From
);
3323 end Move_Linker_Option
;
3325 ----------------------------
3326 -- Resolve_Binder_Options --
3327 ----------------------------
3329 procedure Resolve_Binder_Options
(Elab_Order
: Unit_Id_Array
) is
3330 procedure Check_Package
(Var
: in out Boolean; Name
: String);
3331 -- Set Var to true iff the current identifier in Namet is Name. Do
3332 -- nothing if it doesn't match. This procedure is just a helper to
3333 -- avoid explicitly dealing with length.
3339 procedure Check_Package
(Var
: in out Boolean; Name
: String) is
3341 if Name_Len
= Name
'Length
3342 and then Name_Buffer
(1 .. Name_Len
) = Name
3348 -- Start of processing for Resolve_Binder_Options
3351 for E
in Elab_Order
'Range loop
3352 Get_Name_String
(Units
.Table
(Elab_Order
(E
)).Uname
);
3354 -- This is not a perfect approach, but is the current protocol
3355 -- between the run-time and the binder to indicate that tasking is
3356 -- used: System.OS_Interface should always be used by any tasking
3359 Check_Package
(With_GNARL
, "system.os_interface%s");
3361 -- Ditto for the use of restricted tasking
3364 (System_Tasking_Restricted_Stages_Used
,
3365 "system.tasking.restricted.stages%s");
3367 -- Ditto for the use of interrupts
3369 Check_Package
(System_Interrupts_Used
, "system.interrupts%s");
3371 -- Ditto for the use of dispatching domains
3374 (Dispatching_Domains_Used
,
3375 "system.multiprocessors.dispatching_domains%s");
3377 -- Ditto for the use of restrictions
3379 Check_Package
(System_Restrictions_Used
, "system.restrictions%s");
3381 -- Ditto for use of an SMP bareboard runtime
3383 Check_Package
(System_BB_CPU_Primitives_Multiprocessors_Used
,
3384 "system.bb.cpu_primitives.multiprocessors%s");
3386 -- Ditto for System.Version_Control, which is used for Version and
3387 -- Body_Version attributes.
3389 Check_Package
(System_Version_Control_Used
,
3390 "system.version_control%s");
3392 -- Ditto for the use of Ada.Command_Line, except we always set
3393 -- Command_Line_Used to True if on a non-configurable run-time
3394 -- as parts of the compiler and run-time assume the GNAT command
3395 -- line symbols are available and can be imported directly (as
3396 -- long as No_Run_Time mode is not set).
3398 if Configurable_Run_Time_On_Target
then
3399 Check_Package
(Command_Line_Used
, "ada.command_line%s");
3400 elsif not No_Run_Time_Mode
then
3401 Command_Line_Used
:= True;
3404 end Resolve_Binder_Options
;
3410 procedure Set_Bind_Env
(Key
, Value
: String) is
3412 -- The lengths of Key and Value are stored as single bytes
3414 if Key
'Length > 255 then
3415 Osint
.Fail
("bind environment key """ & Key
& """ too long");
3418 if Value
'Length > 255 then
3419 Osint
.Fail
("bind environment value """ & Value
& """ too long");
3422 Bind_Environment
.Set
(Name_Find
(Key
), Name_Find
(Value
));
3429 procedure Set_Boolean
(B
: Boolean) is
3430 False_Str
: constant String := "False";
3431 True_Str
: constant String := "True";
3435 Statement_Buffer
(Stm_Last
+ 1 .. Stm_Last
+ True_Str
'Length) :=
3437 Stm_Last
:= Stm_Last
+ True_Str
'Length;
3439 Statement_Buffer
(Stm_Last
+ 1 .. Stm_Last
+ False_Str
'Length) :=
3441 Stm_Last
:= Stm_Last
+ False_Str
'Length;
3449 procedure Set_Char
(C
: Character) is
3451 Stm_Last
:= Stm_Last
+ 1;
3452 Statement_Buffer
(Stm_Last
) := C
;
3459 procedure Set_Int
(N
: Int
) is
3470 Stm_Last
:= Stm_Last
+ 1;
3471 Statement_Buffer
(Stm_Last
) :=
3472 Character'Val (N
mod 10 + Character'Pos ('0'));
3476 -------------------------
3477 -- Set_IS_Pragma_Table --
3478 -------------------------
3480 procedure Set_IS_Pragma_Table
is
3482 for F
in ALIs
.First
.. ALIs
.Last
loop
3483 for K
in ALIs
.Table
(F
).First_Interrupt_State
..
3484 ALIs
.Table
(F
).Last_Interrupt_State
3487 Inum
: constant Int
:=
3488 Interrupt_States
.Table
(K
).Interrupt_Id
;
3489 Stat
: constant Character :=
3490 Interrupt_States
.Table
(K
).Interrupt_State
;
3493 while IS_Pragma_Settings
.Last
< Inum
loop
3494 IS_Pragma_Settings
.Append
('n');
3497 IS_Pragma_Settings
.Table
(Inum
) := Stat
;
3501 end Set_IS_Pragma_Table
;
3503 ---------------------------
3504 -- Set_Main_Program_Name --
3505 ---------------------------
3507 procedure Set_Main_Program_Name
is
3509 -- Note that name has %b on the end which we ignore
3511 -- First we output the initial _ada_ since we know that the main program
3512 -- is a library level subprogram.
3514 Set_String
("_ada_");
3516 -- Copy name, changing dots to double underscores
3518 for J
in 1 .. Name_Len
- 2 loop
3519 if Name_Buffer
(J
) = '.' then
3522 Set_Char
(Name_Buffer
(J
));
3525 end Set_Main_Program_Name
;
3527 ---------------------
3528 -- Set_Name_Buffer --
3529 ---------------------
3531 procedure Set_Name_Buffer
is
3533 for J
in 1 .. Name_Len
loop
3534 Set_Char
(Name_Buffer
(J
));
3536 end Set_Name_Buffer
;
3538 -------------------------
3539 -- Set_PSD_Pragma_Table --
3540 -------------------------
3542 procedure Set_PSD_Pragma_Table
is
3544 for F
in ALIs
.First
.. ALIs
.Last
loop
3545 for K
in ALIs
.Table
(F
).First_Specific_Dispatching
..
3546 ALIs
.Table
(F
).Last_Specific_Dispatching
3549 DTK
: Specific_Dispatching_Record
3550 renames Specific_Dispatching
.Table
(K
);
3553 while PSD_Pragma_Settings
.Last
< DTK
.Last_Priority
loop
3554 PSD_Pragma_Settings
.Append
('F');
3557 for Prio
in DTK
.First_Priority
.. DTK
.Last_Priority
loop
3558 PSD_Pragma_Settings
.Table
(Prio
) := DTK
.Dispatching_Policy
;
3563 end Set_PSD_Pragma_Table
;
3569 procedure Set_String
(S
: String) is
3571 Statement_Buffer
(Stm_Last
+ 1 .. Stm_Last
+ S
'Length) := S
;
3572 Stm_Last
:= Stm_Last
+ S
'Length;
3575 ------------------------
3576 -- Set_String_Replace --
3577 ------------------------
3579 procedure Set_String_Replace
(S
: String) is
3581 Statement_Buffer
(Stm_Last
- S
'Length + 1 .. Stm_Last
) := S
;
3582 end Set_String_Replace
;
3588 procedure Set_Unit_Name
is
3590 for J
in 1 .. Name_Len
- 2 loop
3591 if Name_Buffer
(J
) = '.' then
3594 Set_Char
(Name_Buffer
(J
));
3599 ---------------------
3600 -- Set_Unit_Number --
3601 ---------------------
3603 procedure Set_Unit_Number
(U
: Unit_Id
) is
3604 Num_Units
: constant Nat
:= Nat
(Units
.Last
) - Nat
(Unit_Id
'First);
3605 Unum
: constant Nat
:= Nat
(U
) - Nat
(Unit_Id
'First);
3608 if Num_Units
>= 10 and then Unum
< 10 then
3612 if Num_Units
>= 100 and then Unum
< 100 then
3617 end Set_Unit_Number
;
3619 ---------------------
3620 -- Write_Bind_Line --
3621 ---------------------
3623 procedure Write_Bind_Line
(S
: String) is
3625 -- Need to strip trailing LF from S
3627 WBI
(S
(S
'First .. S
'Last - 1));
3628 end Write_Bind_Line
;
3630 ----------------------------
3631 -- Write_Statement_Buffer --
3632 ----------------------------
3634 procedure Write_Statement_Buffer
is
3636 WBI
(Statement_Buffer
(1 .. Stm_Last
));
3638 end Write_Statement_Buffer
;
3640 procedure Write_Statement_Buffer
(S
: String) is
3643 Write_Statement_Buffer
;
3644 end Write_Statement_Buffer
;