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