File : exp_code.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C O D E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1996-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 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Errout; use Errout;
29 with Fname; use Fname;
30 with Lib; use Lib;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Nmake; use Nmake;
34 with Opt; use Opt;
35 with Rtsfind; use Rtsfind;
36 with Sem_Aux; use Sem_Aux;
37 with Sem_Eval; use Sem_Eval;
38 with Sem_Util; use Sem_Util;
39 with Sem_Warn; use Sem_Warn;
40 with Sinfo; use Sinfo;
41 with Stringt; use Stringt;
42 with Tbuild; use Tbuild;
43
44 package body Exp_Code is
45
46 -----------------------
47 -- Local_Subprograms --
48 -----------------------
49
50 function Asm_Constraint (Operand_Var : Node_Id) return Node_Id;
51 -- Common processing for Asm_Input_Constraint and Asm_Output_Constraint.
52 -- Obtains the constraint argument from the global operand variable
53 -- Operand_Var, which must be non-Empty.
54
55 function Asm_Operand (Operand_Var : Node_Id) return Node_Id;
56 -- Common processing for Asm_Input_Value and Asm_Output_Variable. Obtains
57 -- the value/variable argument from Operand_Var, the global operand
58 -- variable. Returns Empty if no operand available.
59
60 function Get_String_Node (S : Node_Id) return Node_Id;
61 -- Given S, a static expression node of type String, returns the
62 -- string literal node. This is needed to deal with the use of constants
63 -- for these expressions, which is perfectly permissible.
64
65 procedure Next_Asm_Operand (Operand_Var : in out Node_Id);
66 -- Common processing for Next_Asm_Input and Next_Asm_Output, updates
67 -- the value of the global operand variable Operand_Var appropriately.
68
69 procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id);
70 -- Common processing for Setup_Asm_Inputs and Setup_Asm_Outputs. Arg
71 -- is the actual parameter from the call, and Operand_Var is the global
72 -- operand variable to be initialized to the first operand.
73
74 ----------------------
75 -- Global Variables --
76 ----------------------
77
78 Current_Input_Operand : Node_Id := Empty;
79 -- Points to current Asm_Input_Operand attribute reference. Initialized
80 -- by Setup_Asm_Inputs, updated by Next_Asm_Input, and referenced by
81 -- Asm_Input_Constraint and Asm_Input_Value.
82
83 Current_Output_Operand : Node_Id := Empty;
84 -- Points to current Asm_Output_Operand attribute reference. Initialized
85 -- by Setup_Asm_Outputs, updated by Next_Asm_Output, and referenced by
86 -- Asm_Output_Constraint and Asm_Output_Variable.
87
88 --------------------
89 -- Asm_Constraint --
90 --------------------
91
92 function Asm_Constraint (Operand_Var : Node_Id) return Node_Id is
93 begin
94 pragma Assert (Present (Operand_Var));
95 return Get_String_Node (First (Expressions (Operand_Var)));
96 end Asm_Constraint;
97
98 --------------------------
99 -- Asm_Input_Constraint --
100 --------------------------
101
102 -- Note: error checking on Asm_Input attribute done in Sem_Attr
103
104 function Asm_Input_Constraint return Node_Id is
105 begin
106 return Get_String_Node (Asm_Constraint (Current_Input_Operand));
107 end Asm_Input_Constraint;
108
109 ---------------------
110 -- Asm_Input_Value --
111 ---------------------
112
113 -- Note: error checking on Asm_Input attribute done in Sem_Attr
114
115 function Asm_Input_Value return Node_Id is
116 begin
117 return Asm_Operand (Current_Input_Operand);
118 end Asm_Input_Value;
119
120 -----------------
121 -- Asm_Operand --
122 -----------------
123
124 function Asm_Operand (Operand_Var : Node_Id) return Node_Id is
125 begin
126 if No (Operand_Var) then
127 return Empty;
128 elsif Error_Posted (Operand_Var) then
129 return Error;
130 else
131 return Next (First (Expressions (Operand_Var)));
132 end if;
133 end Asm_Operand;
134
135 ---------------------------
136 -- Asm_Output_Constraint --
137 ---------------------------
138
139 -- Note: error checking on Asm_Output attribute done in Sem_Attr
140
141 function Asm_Output_Constraint return Node_Id is
142 begin
143 return Asm_Constraint (Current_Output_Operand);
144 end Asm_Output_Constraint;
145
146 -------------------------
147 -- Asm_Output_Variable --
148 -------------------------
149
150 -- Note: error checking on Asm_Output attribute done in Sem_Attr
151
152 function Asm_Output_Variable return Node_Id is
153 begin
154 return Asm_Operand (Current_Output_Operand);
155 end Asm_Output_Variable;
156
157 ------------------
158 -- Asm_Template --
159 ------------------
160
161 function Asm_Template (N : Node_Id) return Node_Id is
162 Call : constant Node_Id := Expression (Expression (N));
163 Temp : constant Node_Id := First_Actual (Call);
164
165 begin
166 -- Require static expression for template. We also allow a string
167 -- literal (this is useful for Ada 83 mode where string expressions
168 -- are never static).
169
170 if Is_OK_Static_Expression (Temp)
171 or else (Ada_Version = Ada_83
172 and then Nkind (Temp) = N_String_Literal)
173 then
174 return Get_String_Node (Temp);
175
176 else
177 Flag_Non_Static_Expr ("asm template argument is not static!", Temp);
178 return Empty;
179 end if;
180 end Asm_Template;
181
182 ----------------------
183 -- Clobber_Get_Next --
184 ----------------------
185
186 Clobber_Node : Node_Id;
187 -- String literal node for clobber string. Initialized by Clobber_Setup,
188 -- and not modified by Clobber_Get_Next. Empty if clobber string was in
189 -- error (resulting in no clobber arguments being returned).
190
191 Clobber_Ptr : Pos;
192 -- Pointer to current character of string. Initialized to 1 by the call
193 -- to Clobber_Setup, and then updated by Clobber_Get_Next.
194
195 function Clobber_Get_Next return Address is
196 Str : constant String_Id := Strval (Clobber_Node);
197 Len : constant Nat := String_Length (Str);
198 C : Character;
199
200 begin
201 if No (Clobber_Node) then
202 return Null_Address;
203 end if;
204
205 -- Skip spaces and commas before next register name
206
207 loop
208 -- Return null string if no more names
209
210 if Clobber_Ptr > Len then
211 return Null_Address;
212 end if;
213
214 C := Get_Character (Get_String_Char (Str, Clobber_Ptr));
215 exit when C /= ',' and then C /= ' ';
216 Clobber_Ptr := Clobber_Ptr + 1;
217 end loop;
218
219 -- Acquire next register name
220
221 Name_Len := 0;
222 loop
223 Add_Char_To_Name_Buffer (C);
224 Clobber_Ptr := Clobber_Ptr + 1;
225 exit when Clobber_Ptr > Len;
226 C := Get_Character (Get_String_Char (Str, Clobber_Ptr));
227 exit when C = ',' or else C = ' ';
228 end loop;
229
230 Name_Buffer (Name_Len + 1) := ASCII.NUL;
231 return Name_Buffer'Address;
232 end Clobber_Get_Next;
233
234 -------------------
235 -- Clobber_Setup --
236 -------------------
237
238 procedure Clobber_Setup (N : Node_Id) is
239 Call : constant Node_Id := Expression (Expression (N));
240 Clob : constant Node_Id := Next_Actual (
241 Next_Actual (
242 Next_Actual (
243 First_Actual (Call))));
244 begin
245 if not Is_OK_Static_Expression (Clob) then
246 Flag_Non_Static_Expr ("asm clobber argument is not static!", Clob);
247 Clobber_Node := Empty;
248 else
249 Clobber_Node := Get_String_Node (Clob);
250 Clobber_Ptr := 1;
251 end if;
252 end Clobber_Setup;
253
254 ---------------------
255 -- Expand_Asm_Call --
256 ---------------------
257
258 procedure Expand_Asm_Call (N : Node_Id) is
259 Loc : constant Source_Ptr := Sloc (N);
260
261 procedure Check_IO_Operand (N : Node_Id);
262 -- Check for incorrect input or output operand
263
264 ----------------------
265 -- Check_IO_Operand --
266 ----------------------
267
268 procedure Check_IO_Operand (N : Node_Id) is
269 Err : Node_Id := N;
270
271 begin
272 -- The only identifier allowed is No_xxput_Operands. Since we
273 -- know the type is right, it is sufficient to see if the
274 -- referenced entity is in a runtime routine.
275
276 if Is_Entity_Name (N)
277 and then
278 Is_Predefined_File_Name (Unit_File_Name
279 (Get_Source_Unit (Entity (N))))
280 then
281 return;
282
283 -- An attribute reference is fine, again the analysis reasonably
284 -- guarantees that the attribute must be subtype'Asm_??put.
285
286 elsif Nkind (N) = N_Attribute_Reference then
287 return;
288
289 -- The only other allowed form is an array aggregate in which
290 -- all the entries are positional and are attribute references.
291
292 elsif Nkind (N) = N_Aggregate then
293 if Present (Component_Associations (N)) then
294 Err := First (Component_Associations (N));
295
296 elsif Present (Expressions (N)) then
297 Err := First (Expressions (N));
298 while Present (Err) loop
299 exit when Nkind (Err) /= N_Attribute_Reference;
300 Next (Err);
301 end loop;
302
303 if No (Err) then
304 return;
305 end if;
306 end if;
307 end if;
308
309 -- If we fall through, Err is pointing to the bad node
310
311 Error_Msg_N ("Asm operand has wrong form", Err);
312 end Check_IO_Operand;
313
314 -- Start of processing for Expand_Asm_Call
315
316 begin
317 -- Check that the input and output operands have the right
318 -- form, as required by the documentation of the Asm feature:
319
320 -- OUTPUT_OPERAND_LIST ::=
321 -- No_Output_Operands
322 -- | OUTPUT_OPERAND_ATTRIBUTE
323 -- | (OUTPUT_OPERAND_ATTRIBUTE @{,OUTPUT_OPERAND_ATTRIBUTE@})
324
325 -- OUTPUT_OPERAND_ATTRIBUTE ::=
326 -- SUBTYPE_MARK'Asm_Output (static_string_EXPRESSION, NAME)
327
328 -- INPUT_OPERAND_LIST ::=
329 -- No_Input_Operands
330 -- | INPUT_OPERAND_ATTRIBUTE
331 -- | (INPUT_OPERAND_ATTRIBUTE @{,INPUT_OPERAND_ATTRIBUTE@})
332
333 -- INPUT_OPERAND_ATTRIBUTE ::=
334 -- SUBTYPE_MARK'Asm_Input (static_string_EXPRESSION, EXPRESSION)
335
336 declare
337 Arg_Output : constant Node_Id := Next_Actual (First_Actual (N));
338 Arg_Input : constant Node_Id := Next_Actual (Arg_Output);
339 begin
340 Check_IO_Operand (Arg_Output);
341 Check_IO_Operand (Arg_Input);
342 end;
343
344 -- If we have the function call case, we are inside a code statement,
345 -- and the tree is already in the necessary form for gigi.
346
347 if Nkind (N) = N_Function_Call then
348 null;
349
350 -- For the procedure case, we convert the call into a code statement
351
352 else
353 pragma Assert (Nkind (N) = N_Procedure_Call_Statement);
354
355 -- Note: strictly we should change the procedure call to a function
356 -- call in the qualified expression, but since we are not going to
357 -- reanalyze (see below), and the interface subprograms in this
358 -- package don't care, we can leave it as a procedure call.
359
360 Rewrite (N,
361 Make_Code_Statement (Loc,
362 Expression =>
363 Make_Qualified_Expression (Loc,
364 Subtype_Mark => New_Occurrence_Of (RTE (RE_Asm_Insn), Loc),
365 Expression => Relocate_Node (N))));
366
367 -- There is no need to reanalyze this node, it is completely analyzed
368 -- already, at least sufficiently for the purposes of the abstract
369 -- procedural interface defined in this package. Furthermore if we
370 -- let it go through the normal analysis, that would include some
371 -- inappropriate checks that apply only to explicit code statements
372 -- in the source, and not to calls to intrinsics.
373
374 Set_Analyzed (N);
375 Check_Code_Statement (N);
376 end if;
377 end Expand_Asm_Call;
378
379 ---------------------
380 -- Get_String_Node --
381 ---------------------
382
383 function Get_String_Node (S : Node_Id) return Node_Id is
384 begin
385 if Nkind (S) = N_String_Literal then
386 return S;
387 else
388 pragma Assert (Ekind (Entity (S)) = E_Constant);
389 return Get_String_Node (Constant_Value (Entity (S)));
390 end if;
391 end Get_String_Node;
392
393 ---------------------
394 -- Is_Asm_Volatile --
395 ---------------------
396
397 function Is_Asm_Volatile (N : Node_Id) return Boolean is
398 Call : constant Node_Id := Expression (Expression (N));
399 Vol : constant Node_Id :=
400 Next_Actual (
401 Next_Actual (
402 Next_Actual (
403 Next_Actual (
404 First_Actual (Call)))));
405 begin
406 if not Is_OK_Static_Expression (Vol) then
407 Flag_Non_Static_Expr ("asm volatile argument is not static!", Vol);
408 return False;
409 else
410 return Is_True (Expr_Value (Vol));
411 end if;
412 end Is_Asm_Volatile;
413
414 --------------------
415 -- Next_Asm_Input --
416 --------------------
417
418 procedure Next_Asm_Input is
419 begin
420 Next_Asm_Operand (Current_Input_Operand);
421 end Next_Asm_Input;
422
423 ----------------------
424 -- Next_Asm_Operand --
425 ----------------------
426
427 procedure Next_Asm_Operand (Operand_Var : in out Node_Id) is
428 begin
429 pragma Assert (Present (Operand_Var));
430
431 if Nkind (Parent (Operand_Var)) = N_Aggregate then
432 Operand_Var := Next (Operand_Var);
433 else
434 Operand_Var := Empty;
435 end if;
436 end Next_Asm_Operand;
437
438 ---------------------
439 -- Next_Asm_Output --
440 ---------------------
441
442 procedure Next_Asm_Output is
443 begin
444 Next_Asm_Operand (Current_Output_Operand);
445 end Next_Asm_Output;
446
447 ----------------------
448 -- Setup_Asm_Inputs --
449 ----------------------
450
451 procedure Setup_Asm_Inputs (N : Node_Id) is
452 Call : constant Node_Id := Expression (Expression (N));
453 begin
454 Setup_Asm_IO_Args
455 (Next_Actual (Next_Actual (First_Actual (Call))),
456 Current_Input_Operand);
457 end Setup_Asm_Inputs;
458
459 -----------------------
460 -- Setup_Asm_IO_Args --
461 -----------------------
462
463 procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id) is
464 begin
465 -- Case of single argument
466
467 if Nkind (Arg) = N_Attribute_Reference then
468 Operand_Var := Arg;
469
470 -- Case of list of arguments
471
472 elsif Nkind (Arg) = N_Aggregate then
473 if Expressions (Arg) = No_List then
474 Operand_Var := Empty;
475 else
476 Operand_Var := First (Expressions (Arg));
477 end if;
478
479 -- Otherwise must be default (no operands) case
480
481 else
482 Operand_Var := Empty;
483 end if;
484 end Setup_Asm_IO_Args;
485
486 -----------------------
487 -- Setup_Asm_Outputs --
488 -----------------------
489
490 procedure Setup_Asm_Outputs (N : Node_Id) is
491 Call : constant Node_Id := Expression (Expression (N));
492 begin
493 Setup_Asm_IO_Args
494 (Next_Actual (First_Actual (Call)),
495 Current_Output_Operand);
496 end Setup_Asm_Outputs;
497
498 end Exp_Code;