1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ V F P T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1997-2012, 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 Nlists; use Nlists; 29with Nmake; use Nmake; 30with Rtsfind; use Rtsfind; 31with Sem_Res; use Sem_Res; 32with Sinfo; use Sinfo; 33with Stand; use Stand; 34with Tbuild; use Tbuild; 35with Urealp; use Urealp; 36with Eval_Fat; use Eval_Fat; 37 38package body Exp_VFpt is 39 40 -- Vax floating point format (from Vax Architecture Reference Manual 41 -- version 6): 42 43 -- Float F: 44 -- -------- 45 46 -- 1 1 47 -- 5 4 7 6 0 48 -- +-+---------------+--------------+ 49 -- |S| exp | fraction | A 50 -- +-+---------------+--------------+ 51 -- | fraction | A + 2 52 -- +--------------------------------+ 53 54 -- bit 15 is the sign bit, 55 -- bits 14:7 is the excess 128 binary exponent, 56 -- bits 6:0 and 31:16 the normalized 24-bit fraction with the redundant 57 -- most significant fraction bit not represented. 58 59 -- An exponent value of 0 together with a sign bit of 0, is taken to 60 -- indicate that the datum has a value of 0. Exponent values of 1 through 61 -- 255 indicate true binary exponents of -127 to +127. An exponent value 62 -- of 0, together with a sign bit of 1, is taken as reserved. 63 64 -- Note that fraction bits are not continuous in memory, VAX is little 65 -- endian (LSB first). 66 67 -- Float D: 68 -- -------- 69 70 -- 1 1 71 -- 5 4 7 6 0 72 -- +-+---------------+--------------+ 73 -- |S| exp | fraction | A 74 -- +-+---------------+--------------+ 75 -- | fraction | A + 2 76 -- +--------------------------------+ 77 -- | fraction | A + 4 78 -- +--------------------------------+ 79 -- | fraction (low) | A + 6 80 -- +--------------------------------+ 81 82 -- Note that the fraction bits are not continuous in memory. Bytes in a 83 -- words are stored in little endian format, but words are stored using 84 -- big endian format (PDP endian). 85 86 -- Like Float F but with 55 bits for the fraction. 87 88 -- Float G: 89 -- -------- 90 91 -- 1 1 92 -- 5 4 4 3 0 93 -- +-+---------------------+--------+ 94 -- |S| exp | fract | A 95 -- +-+---------------------+--------+ 96 -- | fraction | A + 2 97 -- +--------------------------------+ 98 -- | fraction | A + 4 99 -- +--------------------------------+ 100 -- | fraction (low) | A + 6 101 -- +--------------------------------+ 102 103 -- Exponent values of 1 through 2047 indicate true binary exponents of 104 -- -1023 to +1023. 105 106 -- Main differences compared to IEEE 754: 107 108 -- * No denormalized numbers 109 -- * No infinity 110 -- * No NaN 111 -- * No -0.0 112 -- * Reserved values (exp = 0, sign = 1) 113 -- * Vax mantissa represent values [0.5, 1) 114 -- * Bias is shifted by 1 (for single float: 128 on Vax, 127 on IEEE) 115 116 VAXFF_Digits : constant := 6; 117 VAXDF_Digits : constant := 9; 118 VAXGF_Digits : constant := 15; 119 120 ---------------------- 121 -- Expand_Vax_Arith -- 122 ---------------------- 123 124 procedure Expand_Vax_Arith (N : Node_Id) is 125 Loc : constant Source_Ptr := Sloc (N); 126 Typ : constant Entity_Id := Base_Type (Etype (N)); 127 Typc : Character; 128 Atyp : Entity_Id; 129 Func : RE_Id; 130 Args : List_Id; 131 132 begin 133 -- Get arithmetic type, note that we do D stuff in G 134 135 if Digits_Value (Typ) = VAXFF_Digits then 136 Typc := 'F'; 137 Atyp := RTE (RE_F); 138 else 139 Typc := 'G'; 140 Atyp := RTE (RE_G); 141 end if; 142 143 case Nkind (N) is 144 145 when N_Op_Abs => 146 if Typc = 'F' then 147 Func := RE_Abs_F; 148 else 149 Func := RE_Abs_G; 150 end if; 151 152 when N_Op_Add => 153 if Typc = 'F' then 154 Func := RE_Add_F; 155 else 156 Func := RE_Add_G; 157 end if; 158 159 when N_Op_Divide => 160 if Typc = 'F' then 161 Func := RE_Div_F; 162 else 163 Func := RE_Div_G; 164 end if; 165 166 when N_Op_Multiply => 167 if Typc = 'F' then 168 Func := RE_Mul_F; 169 else 170 Func := RE_Mul_G; 171 end if; 172 173 when N_Op_Minus => 174 if Typc = 'F' then 175 Func := RE_Neg_F; 176 else 177 Func := RE_Neg_G; 178 end if; 179 180 when N_Op_Subtract => 181 if Typc = 'F' then 182 Func := RE_Sub_F; 183 else 184 Func := RE_Sub_G; 185 end if; 186 187 when others => 188 Func := RE_Null; 189 raise Program_Error; 190 191 end case; 192 193 Args := New_List; 194 195 if Nkind (N) in N_Binary_Op then 196 Append_To (Args, 197 Convert_To (Atyp, Left_Opnd (N))); 198 end if; 199 200 Append_To (Args, 201 Convert_To (Atyp, Right_Opnd (N))); 202 203 Rewrite (N, 204 Convert_To (Typ, 205 Make_Function_Call (Loc, 206 Name => New_Occurrence_Of (RTE (Func), Loc), 207 Parameter_Associations => Args))); 208 209 Analyze_And_Resolve (N, Typ, Suppress => All_Checks); 210 end Expand_Vax_Arith; 211 212 --------------------------- 213 -- Expand_Vax_Comparison -- 214 --------------------------- 215 216 procedure Expand_Vax_Comparison (N : Node_Id) is 217 Loc : constant Source_Ptr := Sloc (N); 218 Typ : constant Entity_Id := Base_Type (Etype (Left_Opnd (N))); 219 Typc : Character; 220 Func : RE_Id; 221 Atyp : Entity_Id; 222 Revrs : Boolean := False; 223 Args : List_Id; 224 225 begin 226 -- Get arithmetic type, note that we do D stuff in G 227 228 if Digits_Value (Typ) = VAXFF_Digits then 229 Typc := 'F'; 230 Atyp := RTE (RE_F); 231 else 232 Typc := 'G'; 233 Atyp := RTE (RE_G); 234 end if; 235 236 case Nkind (N) is 237 238 when N_Op_Eq => 239 if Typc = 'F' then 240 Func := RE_Eq_F; 241 else 242 Func := RE_Eq_G; 243 end if; 244 245 when N_Op_Ge => 246 if Typc = 'F' then 247 Func := RE_Le_F; 248 else 249 Func := RE_Le_G; 250 end if; 251 252 Revrs := True; 253 254 when N_Op_Gt => 255 if Typc = 'F' then 256 Func := RE_Lt_F; 257 else 258 Func := RE_Lt_G; 259 end if; 260 261 Revrs := True; 262 263 when N_Op_Le => 264 if Typc = 'F' then 265 Func := RE_Le_F; 266 else 267 Func := RE_Le_G; 268 end if; 269 270 when N_Op_Lt => 271 if Typc = 'F' then 272 Func := RE_Lt_F; 273 else 274 Func := RE_Lt_G; 275 end if; 276 277 when N_Op_Ne => 278 if Typc = 'F' then 279 Func := RE_Ne_F; 280 else 281 Func := RE_Ne_G; 282 end if; 283 284 when others => 285 Func := RE_Null; 286 raise Program_Error; 287 288 end case; 289 290 if not Revrs then 291 Args := New_List ( 292 Convert_To (Atyp, Left_Opnd (N)), 293 Convert_To (Atyp, Right_Opnd (N))); 294 295 else 296 Args := New_List ( 297 Convert_To (Atyp, Right_Opnd (N)), 298 Convert_To (Atyp, Left_Opnd (N))); 299 end if; 300 301 Rewrite (N, 302 Make_Function_Call (Loc, 303 Name => New_Occurrence_Of (RTE (Func), Loc), 304 Parameter_Associations => Args)); 305 306 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); 307 end Expand_Vax_Comparison; 308 309 --------------------------- 310 -- Expand_Vax_Conversion -- 311 --------------------------- 312 313 procedure Expand_Vax_Conversion (N : Node_Id) is 314 Loc : constant Source_Ptr := Sloc (N); 315 Expr : constant Node_Id := Expression (N); 316 S_Typ : constant Entity_Id := Base_Type (Etype (Expr)); 317 T_Typ : constant Entity_Id := Base_Type (Etype (N)); 318 319 CallS : RE_Id; 320 CallT : RE_Id; 321 Func : RE_Id; 322 323 function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id; 324 -- Given one of the two types T, determines the corresponding call 325 -- type, i.e. the type to be used for the call (or the result of 326 -- the call). The actual operand is converted to (or from) this type. 327 -- Otyp is the other type, which is useful in figuring out the result. 328 -- The result returned is the RE_Id value for the type entity. 329 330 function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id; 331 -- Find the predefined integer type that has the same size as the 332 -- fixed-point type T, for use in fixed/float conversions. 333 334 --------------- 335 -- Call_Type -- 336 --------------- 337 338 function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is 339 begin 340 -- Vax float formats 341 342 if Vax_Float (T) then 343 if Digits_Value (T) = VAXFF_Digits then 344 return RE_F; 345 346 elsif Digits_Value (T) = VAXGF_Digits then 347 return RE_G; 348 349 -- For D_Float, leave it as D float if the other operand is 350 -- G_Float, since this is the one conversion that is properly 351 -- supported for D_Float, but otherwise, use G_Float. 352 353 else pragma Assert (Digits_Value (T) = VAXDF_Digits); 354 355 if Vax_Float (Otyp) 356 and then Digits_Value (Otyp) = VAXGF_Digits 357 then 358 return RE_D; 359 else 360 return RE_G; 361 end if; 362 end if; 363 364 -- For all discrete types, use 64-bit integer 365 366 elsif Is_Discrete_Type (T) then 367 return RE_Q; 368 369 -- For all real types (other than Vax float format), we use the 370 -- IEEE float-type which corresponds in length to the other type 371 -- (which is Vax Float). 372 373 else pragma Assert (Is_Real_Type (T)); 374 375 if Digits_Value (Otyp) = VAXFF_Digits then 376 return RE_S; 377 else 378 return RE_T; 379 end if; 380 end if; 381 end Call_Type; 382 383 ------------------------------------------------- 384 -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed -- 385 ------------------------------------------------- 386 387 function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is 388 begin 389 if Esize (T) = Esize (Standard_Long_Long_Integer) then 390 return Standard_Long_Long_Integer; 391 elsif Esize (T) = Esize (Standard_Long_Integer) then 392 return Standard_Long_Integer; 393 else 394 return Standard_Integer; 395 end if; 396 end Equivalent_Integer_Type; 397 398 -- Start of processing for Expand_Vax_Conversion; 399 400 begin 401 -- If input and output are the same Vax type, we change the 402 -- conversion to be an unchecked conversion and that's it. 403 404 if Vax_Float (S_Typ) and then Vax_Float (T_Typ) 405 and then Digits_Value (S_Typ) = Digits_Value (T_Typ) 406 then 407 Rewrite (N, 408 Unchecked_Convert_To (T_Typ, Expr)); 409 410 -- Case of conversion of fixed-point type to Vax_Float type 411 412 elsif Is_Fixed_Point_Type (S_Typ) then 413 414 -- If Conversion_OK set, then we introduce an intermediate IEEE 415 -- target type since we are expecting the code generator to handle 416 -- the case of integer to IEEE float. 417 418 if Conversion_OK (N) then 419 Rewrite (N, 420 Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr))); 421 422 -- Otherwise, convert the scaled integer value to the target type, 423 -- and multiply by 'Small of type. 424 425 else 426 Rewrite (N, 427 Make_Op_Multiply (Loc, 428 Left_Opnd => 429 Make_Type_Conversion (Loc, 430 Subtype_Mark => New_Occurrence_Of (T_Typ, Loc), 431 Expression => 432 Unchecked_Convert_To ( 433 Equivalent_Integer_Type (S_Typ), Expr)), 434 Right_Opnd => 435 Make_Real_Literal (Loc, Realval => Small_Value (S_Typ)))); 436 end if; 437 438 -- Case of conversion of Vax_Float type to fixed-point type 439 440 elsif Is_Fixed_Point_Type (T_Typ) then 441 442 -- If Conversion_OK set, then we introduce an intermediate IEEE 443 -- target type, since we are expecting the code generator to handle 444 -- the case of IEEE float to integer. 445 446 if Conversion_OK (N) then 447 Rewrite (N, 448 OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr))); 449 450 -- Otherwise, multiply value by 'small of type, and convert to the 451 -- corresponding integer type. 452 453 else 454 Rewrite (N, 455 Unchecked_Convert_To (T_Typ, 456 Make_Type_Conversion (Loc, 457 Subtype_Mark => 458 New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc), 459 Expression => 460 Make_Op_Multiply (Loc, 461 Left_Opnd => Expr, 462 Right_Opnd => 463 Make_Real_Literal (Loc, 464 Realval => Ureal_1 / Small_Value (T_Typ)))))); 465 end if; 466 467 -- All other cases 468 469 else 470 -- Compute types for call 471 472 CallS := Call_Type (S_Typ, T_Typ); 473 CallT := Call_Type (T_Typ, S_Typ); 474 475 -- Get function and its types 476 477 if CallS = RE_D and then CallT = RE_G then 478 Func := RE_D_To_G; 479 480 elsif CallS = RE_G and then CallT = RE_D then 481 Func := RE_G_To_D; 482 483 elsif CallS = RE_G and then CallT = RE_F then 484 Func := RE_G_To_F; 485 486 elsif CallS = RE_F and then CallT = RE_G then 487 Func := RE_F_To_G; 488 489 elsif CallS = RE_F and then CallT = RE_S then 490 Func := RE_F_To_S; 491 492 elsif CallS = RE_S and then CallT = RE_F then 493 Func := RE_S_To_F; 494 495 elsif CallS = RE_G and then CallT = RE_T then 496 Func := RE_G_To_T; 497 498 elsif CallS = RE_T and then CallT = RE_G then 499 Func := RE_T_To_G; 500 501 elsif CallS = RE_F and then CallT = RE_Q then 502 Func := RE_F_To_Q; 503 504 elsif CallS = RE_Q and then CallT = RE_F then 505 Func := RE_Q_To_F; 506 507 elsif CallS = RE_G and then CallT = RE_Q then 508 Func := RE_G_To_Q; 509 510 else pragma Assert (CallS = RE_Q and then CallT = RE_G); 511 Func := RE_Q_To_G; 512 end if; 513 514 Rewrite (N, 515 Convert_To (T_Typ, 516 Make_Function_Call (Loc, 517 Name => New_Occurrence_Of (RTE (Func), Loc), 518 Parameter_Associations => New_List ( 519 Convert_To (RTE (CallS), Expr))))); 520 end if; 521 522 Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks); 523 end Expand_Vax_Conversion; 524 525 ------------------------------- 526 -- Expand_Vax_Foreign_Return -- 527 ------------------------------- 528 529 procedure Expand_Vax_Foreign_Return (N : Node_Id) is 530 Loc : constant Source_Ptr := Sloc (N); 531 Typ : constant Entity_Id := Base_Type (Etype (N)); 532 Func : RE_Id; 533 Args : List_Id; 534 Atyp : Entity_Id; 535 Rtyp : constant Entity_Id := Etype (N); 536 537 begin 538 if Digits_Value (Typ) = VAXFF_Digits then 539 Func := RE_Return_F; 540 Atyp := RTE (RE_F); 541 elsif Digits_Value (Typ) = VAXDF_Digits then 542 Func := RE_Return_D; 543 Atyp := RTE (RE_D); 544 else pragma Assert (Digits_Value (Typ) = VAXGF_Digits); 545 Func := RE_Return_G; 546 Atyp := RTE (RE_G); 547 end if; 548 549 Args := New_List (Convert_To (Atyp, N)); 550 551 Rewrite (N, 552 Convert_To (Rtyp, 553 Make_Function_Call (Loc, 554 Name => New_Occurrence_Of (RTE (Func), Loc), 555 Parameter_Associations => Args))); 556 557 Analyze_And_Resolve (N, Typ, Suppress => All_Checks); 558 end Expand_Vax_Foreign_Return; 559 560 -------------------------------- 561 -- Vax_Real_Literal_As_Signed -- 562 -------------------------------- 563 564 function Get_Vax_Real_Literal_As_Signed (N : Node_Id) return Uint is 565 Btyp : constant Entity_Id := 566 Base_Type (Underlying_Type (Etype (N))); 567 568 Value : constant Ureal := Realval (N); 569 Negative : Boolean; 570 Fraction : UI; 571 Exponent : UI; 572 Res : UI; 573 574 Exponent_Size : Uint; 575 -- Number of bits for the exponent 576 577 Fraction_Size : Uint; 578 -- Number of bits for the fraction 579 580 Uintp_Mark : constant Uintp.Save_Mark := Mark; 581 -- Use the mark & release feature to delete temporaries 582 begin 583 -- Extract the sign now 584 585 Negative := UR_Is_Negative (Value); 586 587 -- Decompose the number 588 589 Decompose_Int (Btyp, abs Value, Fraction, Exponent, Round_Even); 590 591 -- Number of bits for the fraction, leading fraction bit is implicit 592 593 Fraction_Size := Machine_Mantissa_Value (Btyp) - Int'(1); 594 595 -- Number of bits for the exponent (one bit for the sign) 596 597 Exponent_Size := RM_Size (Btyp) - Fraction_Size - Int'(1); 598 599 if Fraction = Uint_0 then 600 -- Handle zero 601 602 Res := Uint_0; 603 604 elsif Exponent <= -(Uint_2 ** (Exponent_Size - 1)) then 605 -- Underflow 606 607 Res := Uint_0; 608 else 609 -- Check for overflow 610 611 pragma Assert (Exponent < Uint_2 ** (Exponent_Size - 1)); 612 613 -- MSB of the fraction must be 1 614 615 pragma Assert (Fraction / Uint_2 ** Fraction_Size = Uint_1); 616 617 -- Remove the redudant most significant fraction bit 618 619 Fraction := Fraction - Uint_2 ** Fraction_Size; 620 621 -- Build the fraction part. Note that this field is in mixed 622 -- endianness: words are stored using little endianness, while bytes 623 -- in words are stored using big endianness. 624 625 Res := Uint_0; 626 for I in 1 .. UI_To_Int (RM_Size (Btyp)) / 16 loop 627 Res := (Res * (Uint_2 ** 16)) + (Fraction mod (Uint_2 ** 16)); 628 Fraction := Fraction / (Uint_2 ** 16); 629 end loop; 630 631 -- The sign bit 632 633 if Negative then 634 Res := Res + Int (2**15); 635 end if; 636 637 -- The exponent 638 639 Res := Res + (Exponent + Uint_2 ** (Exponent_Size - 1)) 640 * Uint_2 ** (15 - Exponent_Size); 641 642 -- Until now, we have created an unsigned number, but an underlying 643 -- type is a signed type. Convert to a signed number to avoid 644 -- overflow in gigi. 645 646 if Res >= Uint_2 ** (Exponent_Size + Fraction_Size) then 647 Res := Res - Uint_2 ** (Exponent_Size + Fraction_Size + 1); 648 end if; 649 end if; 650 651 Release_And_Save (Uintp_Mark, Res); 652 653 return Res; 654 end Get_Vax_Real_Literal_As_Signed; 655 656 ---------------------- 657 -- Expand_Vax_Valid -- 658 ---------------------- 659 660 procedure Expand_Vax_Valid (N : Node_Id) is 661 Loc : constant Source_Ptr := Sloc (N); 662 Pref : constant Node_Id := Prefix (N); 663 Ptyp : constant Entity_Id := Root_Type (Etype (Pref)); 664 Rtyp : constant Entity_Id := Etype (N); 665 Vtyp : RE_Id; 666 Func : RE_Id; 667 668 begin 669 if Digits_Value (Ptyp) = VAXFF_Digits then 670 Func := RE_Valid_F; 671 Vtyp := RE_F; 672 elsif Digits_Value (Ptyp) = VAXDF_Digits then 673 Func := RE_Valid_D; 674 Vtyp := RE_D; 675 else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits); 676 Func := RE_Valid_G; 677 Vtyp := RE_G; 678 end if; 679 680 Rewrite (N, 681 Convert_To (Rtyp, 682 Make_Function_Call (Loc, 683 Name => New_Occurrence_Of (RTE (Func), Loc), 684 Parameter_Associations => New_List ( 685 Convert_To (RTE (Vtyp), Pref))))); 686 687 Analyze_And_Resolve (N); 688 end Expand_Vax_Valid; 689 690end Exp_VFpt; 691