File : back_end.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- B A C K _ E N D --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. 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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 -- This is the version of the Back_End package for GCC back ends
27
28 with Atree; use Atree;
29 with Debug; use Debug;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Lib; use Lib;
33 with Osint; use Osint;
34 with Opt; use Opt;
35 with Osint.C; use Osint.C;
36 with Namet; use Namet;
37 with Nlists; use Nlists;
38 with Stand; use Stand;
39 with Sinput; use Sinput;
40 with Stringt; use Stringt;
41 with Switch; use Switch;
42 with Switch.C; use Switch.C;
43 with System; use System;
44 with Types; use Types;
45
46 with System.OS_Lib; use System.OS_Lib;
47
48 package body Back_End is
49
50 type Arg_Array is array (Nat) of Big_String_Ptr;
51 type Arg_Array_Ptr is access Arg_Array;
52 -- Types to access compiler arguments
53
54 flag_stack_check : Int;
55 pragma Import (C, flag_stack_check);
56 -- Indicates if stack checking is enabled, imported from misc.c
57
58 save_argc : Nat;
59 pragma Import (C, save_argc);
60 -- Saved value of argc (number of arguments), imported from misc.c
61
62 save_argv : Arg_Array_Ptr;
63 pragma Import (C, save_argv);
64 -- Saved value of argv (argument pointers), imported from misc.c
65
66 function Len_Arg (Arg : Pos) return Nat;
67 -- Determine length of argument number Arg on original gnat1 command line
68
69 -------------------
70 -- Call_Back_End --
71 -------------------
72
73 procedure Call_Back_End (Mode : Back_End_Mode_Type) is
74
75 -- The Source_File_Record type has a lot of components that are
76 -- meaningless to the back end, so a new record type is created
77 -- here to contain the needed information for each file.
78
79 type File_Info_Type is record
80 File_Name : File_Name_Type;
81 Instance : Instance_Id;
82 Num_Source_Lines : Nat;
83 end record;
84
85 File_Info_Array : array (1 .. Last_Source_File) of File_Info_Type;
86
87 procedure gigi
88 (gnat_root : Int;
89 max_gnat_node : Int;
90 number_name : Nat;
91 nodes_ptr : Address;
92 flags_ptr : Address;
93
94 next_node_ptr : Address;
95 prev_node_ptr : Address;
96 elists_ptr : Address;
97 elmts_ptr : Address;
98
99 strings_ptr : Address;
100 string_chars_ptr : Address;
101 list_headers_ptr : Address;
102 number_file : Nat;
103
104 file_info_ptr : Address;
105 gigi_standard_boolean : Entity_Id;
106 gigi_standard_integer : Entity_Id;
107 gigi_standard_character : Entity_Id;
108 gigi_standard_long_long_float : Entity_Id;
109 gigi_standard_exception_type : Entity_Id;
110 gigi_operating_mode : Back_End_Mode_Type);
111
112 pragma Import (C, gigi);
113
114 begin
115 -- Skip call if in -gnatdH mode
116
117 if Debug_Flag_HH then
118 return;
119 end if;
120
121 -- The back end needs to know the maximum line number that can appear
122 -- in a Sloc, in other words the maximum logical line number.
123
124 for J in 1 .. Last_Source_File loop
125 File_Info_Array (J).File_Name := Full_Debug_Name (J);
126 File_Info_Array (J).Instance := Instance (J);
127 File_Info_Array (J).Num_Source_Lines :=
128 Nat (Physical_To_Logical (Last_Source_Line (J), J));
129 end loop;
130
131 -- Deal with case of generating SCIL, we should not be here unless
132 -- debugging CodePeer mode in GNAT.
133
134 if Generate_SCIL then
135 Error_Msg_N ("'S'C'I'L generation not available", Cunit (Main_Unit));
136
137 if CodePeer_Mode
138 or else (Mode /= Generate_Object
139 and then not Back_Annotate_Rep_Info)
140 then
141 return;
142 end if;
143 end if;
144
145 -- We should be here in GNATprove mode only when debugging GNAT. Do not
146 -- call gigi in that case, as it is not prepared to handle the special
147 -- form of the tree obtained in GNATprove mode.
148
149 if GNATprove_Mode then
150 return;
151 end if;
152
153 -- The actual call to the back end
154
155 gigi
156 (gnat_root => Int (Cunit (Main_Unit)),
157 max_gnat_node => Int (Last_Node_Id - First_Node_Id + 1),
158 number_name => Name_Entries_Count,
159 nodes_ptr => Nodes_Address,
160 flags_ptr => Flags_Address,
161
162 next_node_ptr => Next_Node_Address,
163 prev_node_ptr => Prev_Node_Address,
164 elists_ptr => Elists_Address,
165 elmts_ptr => Elmts_Address,
166
167 strings_ptr => Strings_Address,
168 string_chars_ptr => String_Chars_Address,
169 list_headers_ptr => Lists_Address,
170 number_file => Num_Source_Files,
171
172 file_info_ptr => File_Info_Array'Address,
173 gigi_standard_boolean => Standard_Boolean,
174 gigi_standard_integer => Standard_Integer,
175 gigi_standard_character => Standard_Character,
176 gigi_standard_long_long_float => Standard_Long_Long_Float,
177 gigi_standard_exception_type => Standard_Exception_Type,
178 gigi_operating_mode => Mode);
179 end Call_Back_End;
180
181 -------------------------------
182 -- Gen_Or_Update_Object_File --
183 -------------------------------
184
185 procedure Gen_Or_Update_Object_File is
186 begin
187 null;
188 end Gen_Or_Update_Object_File;
189
190 -------------
191 -- Len_Arg --
192 -------------
193
194 function Len_Arg (Arg : Pos) return Nat is
195 begin
196 for J in 1 .. Nat'Last loop
197 if save_argv (Arg).all (Natural (J)) = ASCII.NUL then
198 return J - 1;
199 end if;
200 end loop;
201
202 raise Program_Error;
203 end Len_Arg;
204
205 -----------------------------
206 -- Scan_Compiler_Arguments --
207 -----------------------------
208
209 procedure Scan_Compiler_Arguments is
210 Next_Arg : Positive;
211 -- Next argument to be scanned
212
213 Output_File_Name_Seen : Boolean := False;
214 -- Set to True after having scanned file_name for switch "-gnatO file"
215
216 procedure Scan_Back_End_Switches (Switch_Chars : String);
217 -- Procedure to scan out switches stored in Switch_Chars. The first
218 -- character is known to be a valid switch character, and there are no
219 -- blanks or other switch terminator characters in the string, so the
220 -- entire string should consist of valid switch characters, except that
221 -- an optional terminating NUL character is allowed.
222 --
223 -- Back end switches have already been checked and processed by GCC in
224 -- toplev.c, so no errors can occur and control will always return. The
225 -- switches must still be scanned to skip "-o" or internal GCC switches
226 -- with their argument.
227
228 ----------------------------
229 -- Scan_Back_End_Switches --
230 ----------------------------
231
232 procedure Scan_Back_End_Switches (Switch_Chars : String) is
233 First : constant Positive := Switch_Chars'First + 1;
234 Last : constant Natural := Switch_Last (Switch_Chars);
235
236 begin
237 -- Skip -o, -G or internal GCC switches together with their argument.
238
239 if Switch_Chars (First .. Last) = "o"
240 or else Switch_Chars (First .. Last) = "G"
241 or else Is_Internal_GCC_Switch (Switch_Chars)
242 then
243 Next_Arg := Next_Arg + 1;
244
245 -- Do not record -quiet switch
246
247 elsif Switch_Chars (First .. Last) = "quiet" then
248 null;
249
250 -- Store any other GCC switches. Also do special processing for some
251 -- specific switches that the Ada front-end knows about.
252
253 else
254 Store_Compilation_Switch (Switch_Chars);
255
256 -- For gcc back ends, -fno-inline disables Inline pragmas only,
257 -- not Inline_Always to remain consistent with the always_inline
258 -- attribute behavior.
259
260 if Switch_Chars (First .. Last) = "fno-inline" then
261 Opt.Disable_FE_Inline := True;
262
263 -- Back end switch -fpreserve-control-flow also sets the front end
264 -- flag that inhibits improper control flow transformations.
265
266 elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then
267 Opt.Suppress_Control_Flow_Optimizations := True;
268
269 -- Back end switch -fdump-scos, which exists primarily for C, is
270 -- also accepted for Ada as a synonym of -gnateS.
271
272 elsif Switch_Chars (First .. Last) = "fdump-scos" then
273 Opt.Generate_SCO := True;
274 Opt.Generate_SCO_Instance_Table := True;
275
276 elsif Switch_Chars (First) = 'g' then
277 Debugger_Level := 2;
278
279 if First < Last then
280 case Switch_Chars (First + 1) is
281 when '0' =>
282 Debugger_Level := 0;
283 when '1' =>
284 Debugger_Level := 1;
285 when '2' =>
286 Debugger_Level := 2;
287 when '3' =>
288 Debugger_Level := 3;
289 when others =>
290 null;
291 end case;
292 end if;
293 end if;
294 end if;
295 end Scan_Back_End_Switches;
296
297 -- Local variables
298
299 Arg_Count : constant Natural := Natural (save_argc - 1);
300 Args : Argument_List (1 .. Arg_Count);
301
302 -- Start of processing for Scan_Compiler_Arguments
303
304 begin
305 -- Acquire stack checking mode directly from GCC. The reason we do this
306 -- is to make sure that the indication of stack checking being enabled
307 -- is the same in the front end and the back end. This status obtained
308 -- from gcc is affected by more than just the switch -fstack-check.
309
310 Opt.Stack_Checking_Enabled := (flag_stack_check /= 0);
311
312 -- Put the arguments in Args
313
314 for Arg in Pos range 1 .. save_argc - 1 loop
315 declare
316 Argv_Ptr : constant Big_String_Ptr := save_argv (Arg);
317 Argv_Len : constant Nat := Len_Arg (Arg);
318 Argv : constant String :=
319 Argv_Ptr (1 .. Natural (Argv_Len));
320 begin
321 Args (Positive (Arg)) := new String'(Argv);
322 end;
323 end loop;
324
325 -- Loop through command line arguments, storing them for later access
326
327 Next_Arg := 1;
328 while Next_Arg <= Args'Last loop
329 Look_At_Arg : declare
330 Argv : constant String := Args (Next_Arg).all;
331
332 begin
333 -- If the previous switch has set the Output_File_Name_Present
334 -- flag (that is we have seen a -gnatO), then the next argument
335 -- is the name of the output object file.
336
337 if Output_File_Name_Present and then not Output_File_Name_Seen then
338 if Is_Switch (Argv) then
339 Fail ("Object file name missing after -gnatO");
340 else
341 Set_Output_Object_File_Name (Argv);
342 Output_File_Name_Seen := True;
343 end if;
344
345 -- If the previous switch has set the Search_Directory_Present
346 -- flag (that is if we have just seen -I), then the next argument
347 -- is a search directory path.
348
349 elsif Search_Directory_Present then
350 if Is_Switch (Argv) then
351 Fail ("search directory missing after -I");
352 else
353 Add_Src_Search_Dir (Argv);
354 Search_Directory_Present := False;
355 end if;
356
357 -- If not a switch, must be a file name
358
359 elsif not Is_Switch (Argv) then
360 Add_File (Argv);
361
362 -- We must recognize -nostdinc to suppress visibility on the
363 -- standard GNAT RTL sources. This is also a gcc switch.
364
365 elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdinc" then
366 Opt.No_Stdinc := True;
367 Scan_Back_End_Switches (Argv);
368
369 -- We must recognize -nostdlib to suppress visibility on the
370 -- standard GNAT RTL objects.
371
372 elsif Argv (Argv'First + 1 .. Argv'Last) = "nostdlib" then
373 Opt.No_Stdlib := True;
374
375 elsif Is_Front_End_Switch (Argv) then
376 Scan_Front_End_Switches (Argv, Args, Next_Arg);
377
378 -- All non-front-end switches are back-end switches
379
380 else
381 Scan_Back_End_Switches (Argv);
382 end if;
383 end Look_At_Arg;
384
385 Next_Arg := Next_Arg + 1;
386 end loop;
387 end Scan_Compiler_Arguments;
388
389 end Back_End;