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-2008, 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 Fname; use Fname; 30with Lib; use Lib; 31with Namet; use Namet; 32with Nlists; use Nlists; 33with Nmake; use Nmake; 34with Opt; use Opt; 35with Rtsfind; use Rtsfind; 36with Sem_Aux; use Sem_Aux; 37with Sem_Eval; use Sem_Eval; 38with Sem_Util; use Sem_Util; 39with Sem_Warn; use Sem_Warn; 40with Sinfo; use Sinfo; 41with Stringt; use Stringt; 42with Tbuild; use Tbuild; 43 44package 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 : Nat; 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 498end Exp_Code; 499