1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- L A Y O U T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Errout; use Errout;
with Opt; use Opt;
with Sem_Aux; use Sem_Aux;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Layout is
------------------------
-- Local Declarations --
------------------------
SSU : constant Int := Ttypes.System_Storage_Unit;
-- Short hand for System_Storage_Unit
-----------------------
-- Local Subprograms --
-----------------------
procedure Compute_Size_Depends_On_Discriminant (E : Entity_Id);
-- Given an array type or an array subtype E, compute whether its size
-- depends on the value of one or more discriminants and set the flag
-- Size_Depends_On_Discriminant accordingly. This need not be called
-- in front end layout mode since it does the computation on its own.
procedure Set_Composite_Alignment (E : Entity_Id);
-- This procedure is called for record types and subtypes, and also for
-- atomic array types and subtypes. If no alignment is set, and the size
-- is 2 or 4 (or 8 if the word size is 8), then the alignment is set to
-- match the size.
----------------------------
-- Adjust_Esize_Alignment --
----------------------------
procedure Adjust_Esize_Alignment (E : Entity_Id) is
Abits : Int;
Esize_Set : Boolean;
begin
-- Nothing to do if size unknown
if not Known_Esize (E) then
return;
end if;
-- Determine if size is constrained by an attribute definition clause
-- which must be obeyed. If so, we cannot increase the size in this
-- routine.
-- For a type, the issue is whether an object size clause has been set.
-- A normal size clause constrains only the value size (RM_Size)
if Is_Type (E) then
Esize_Set := Has_Object_Size_Clause (E);
-- For an object, the issue is whether a size clause is present
else
Esize_Set := Has_Size_Clause (E);
end if;
-- If size is known it must be a multiple of the storage unit size
if Esize (E) mod SSU /= 0 then
-- If not, and size specified, then give error
if Esize_Set then
Error_Msg_NE
("size for& not a multiple of storage unit size",
Size_Clause (E), E);
return;
-- Otherwise bump up size to a storage unit boundary
else
Set_Esize (E, (Esize (E) + SSU - 1) / SSU * SSU);
end if;
end if;
-- Now we have the size set, it must be a multiple of the alignment
-- nothing more we can do here if the alignment is unknown here.
if not Known_Alignment (E) then
return;
end if;
-- At this point both the Esize and Alignment are known, so we need
-- to make sure they are consistent.
Abits := UI_To_Int (Alignment (E)) * SSU;
if Esize (E) mod Abits = 0 then
return;
end if;
-- Here we have a situation where the Esize is not a multiple of the
-- alignment. We must either increase Esize or reduce the alignment to
-- correct this situation.
-- The case in which we can decrease the alignment is where the
-- alignment was not set by an alignment clause, and the type in
-- question is a discrete type, where it is definitely safe to reduce
-- the alignment. For example:
-- t : integer range 1 .. 2;
-- for t'size use 8;
-- In this situation, the initial alignment of t is 4, copied from
-- the Integer base type, but it is safe to reduce it to 1 at this
-- stage, since we will only be loading a single storage unit.
if Is_Discrete_Type (Etype (E)) and then not Has_Alignment_Clause (E)
then
loop
Abits := Abits / 2;
exit when Esize (E) mod Abits = 0;
end loop;
Set_Alignment (E, UI_From_Int (Abits / SSU));
return;
end if;
-- Now the only possible approach left is to increase the Esize but we
-- can't do that if the size was set by a specific clause.
if Esize_Set then
Error_Msg_NE
("size for& is not a multiple of alignment",
Size_Clause (E), E);
-- Otherwise we can indeed increase the size to a multiple of alignment
else
Set_Esize (E, ((Esize (E) + (Abits - 1)) / Abits) * Abits);
end if;
end Adjust_Esize_Alignment;
------------------------------------------
-- Compute_Size_Depends_On_Discriminant --
------------------------------------------
procedure Compute_Size_Depends_On_Discriminant (E : Entity_Id) is
Indx : Node_Id;
Ityp : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
Res : Boolean := False;
begin
-- Loop to process array indexes
Indx := First_Index (E);
while Present (Indx) loop
Ityp := Etype (Indx);
-- If an index of the array is a generic formal type then there is
-- no point in determining a size for the array type.
if Is_Generic_Type (Ityp) then
return;
end if;
Lo := Type_Low_Bound (Ityp);
Hi := Type_High_Bound (Ityp);
if (Nkind (Lo) = N_Identifier
and then Ekind (Entity (Lo)) = E_Discriminant)
or else
(Nkind (Hi) = N_Identifier
and then Ekind (Entity (Hi)) = E_Discriminant)
then
Res := True;
end if;
Next_Index (Indx);
end loop;
if Res then
Set_Size_Depends_On_Discriminant (E);
end if;
end Compute_Size_Depends_On_Discriminant;
-------------------
-- Layout_Object --
-------------------
procedure Layout_Object (E : Entity_Id) is
pragma Unreferenced (E);
begin
-- Nothing to do for now, assume backend does the layout
return;
end Layout_Object;
-----------------
-- Layout_Type --
-----------------
procedure Layout_Type (E : Entity_Id) is
Desig_Type : Entity_Id;
begin
-- For string literal types, kill the size always, because gigi does not
-- like or need the size to be set.
if Ekind (E) = E_String_Literal_Subtype then
Reinit_Esize (E);
Reinit_RM_Size (E);
return;
end if;
-- For access types, set size/alignment. This is system address size,
-- except for fat pointers (unconstrained array access types), where the
-- size is two times the address size, to accommodate the two pointers
-- that are required for a fat pointer (data and template). Note that
-- E_Access_Protected_Subprogram_Type is not an access type for this
-- purpose since it is not a pointer but is equivalent to a record. For
-- access subtypes, copy the size from the base type since Gigi
-- represents them the same way.
if Is_Access_Type (E) then
Desig_Type := Underlying_Type (Designated_Type (E));
-- If we only have a limited view of the type, see whether the
-- non-limited view is available.
if From_Limited_With (Designated_Type (E))
and then Ekind (Designated_Type (E)) = E_Incomplete_Type
and then Present (Non_Limited_View (Designated_Type (E)))
then
Desig_Type := Non_Limited_View (Designated_Type (E));
end if;
-- If Esize already set (e.g. by a size or value size clause), then
-- nothing further to be done here.
if Known_Esize (E) then
null;
-- Access to protected subprogram is a strange beast, and we let the
-- backend figure out what is needed (it may be some kind of fat
-- pointer, including the static link for example).
elsif Is_Access_Protected_Subprogram_Type (E) then
null;
-- For access subtypes, copy the size information from base type
elsif Ekind (E) = E_Access_Subtype then
Set_Size_Info (E, Base_Type (E));
Copy_RM_Size (To => E, From => Base_Type (E));
-- For other access types, we use either address size, or, if a fat
-- pointer is used (pointer-to-unconstrained array case), twice the
-- address size to accommodate a fat pointer.
elsif Present (Desig_Type)
and then Is_Array_Type (Desig_Type)
and then not Is_Constrained (Desig_Type)
and then not Has_Completion_In_Body (Desig_Type)
-- Debug Flag -gnatd6 says make all pointers to unconstrained thin
and then not Debug_Flag_6
then
Init_Size (E, 2 * System_Address_Size);
-- Check for bad convention set
if Warn_On_Export_Import
and then
(Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
then
Error_Msg_N
("?x?this access type does not correspond to C pointer", E);
end if;
-- If the designated type is a limited view it is unanalyzed. We can
-- examine the declaration itself to determine whether it will need a
-- fat pointer.
elsif Present (Desig_Type)
and then Present (Parent (Desig_Type))
and then Nkind (Parent (Desig_Type)) = N_Full_Type_Declaration
and then Nkind (Type_Definition (Parent (Desig_Type))) =
N_Unconstrained_Array_Definition
and then not Debug_Flag_6
then
Init_Size (E, 2 * System_Address_Size);
-- If unnesting subprograms, subprogram access types contain the
-- address of both the subprogram and an activation record. But if we
-- set that, we'll get a warning on different unchecked conversion
-- sizes in the RTS. So leave unset in that case.
elsif Unnest_Subprogram_Mode
and then Is_Access_Subprogram_Type (E)
then
null;
-- Normal case of thin pointer
else
Init_Size (E, System_Address_Size);
end if;
Set_Elem_Alignment (E);
-- Scalar types: set size and alignment
elsif Is_Scalar_Type (E) then
-- For discrete types, the RM_Size and Esize must be set already,
-- since this is part of the earlier processing and the front end is
-- always required to lay out the sizes of such types (since they are
-- available as static attributes). All we do is to check that this
-- rule is indeed obeyed.
if Is_Discrete_Type (E) then
-- If the RM_Size is not set, then here is where we set it
-- Note: an RM_Size of zero looks like not set here, but this
-- is a rare case, and we can simply reset it without any harm.
if not Known_RM_Size (E) then
Set_Discrete_RM_Size (E);
end if;
-- If Esize for a discrete type is not set then set it
if not Known_Esize (E) then
declare
S : Pos := 8;
begin
loop
-- If size is big enough, set it and exit
if S >= RM_Size (E) then
Set_Esize (E, UI_From_Int (S));
exit;
-- If the RM_Size is greater than System_Max_Integer_Size
-- (happens only when strange values are specified by the
-- user), then Esize is simply a copy of RM_Size, it will
-- be further refined later on.
elsif S = System_Max_Integer_Size then
Set_Esize (E, RM_Size (E));
exit;
-- Otherwise double possible size and keep trying
else
S := S * 2;
end if;
end loop;
end;
end if;
-- For non-discrete scalar types, if the RM_Size is not set, then set
-- it now to a copy of the Esize if the Esize is set.
else
if Known_Esize (E) and then not Known_RM_Size (E) then
Set_RM_Size (E, Esize (E));
end if;
end if;
Set_Elem_Alignment (E);
-- Non-elementary (composite) types
else
-- For packed arrays, take size and alignment values from the packed
-- array type if a packed array type has been created and the fields
-- are not currently set.
if Is_Array_Type (E)
and then Present (Packed_Array_Impl_Type (E))
then
declare
PAT : constant Entity_Id := Packed_Array_Impl_Type (E);
begin
if not Known_Esize (E) then
Copy_Esize (To => E, From => PAT);
end if;
if not Known_RM_Size (E) then
Copy_RM_Size (To => E, From => PAT);
end if;
if not Known_Alignment (E) then
Copy_Alignment (To => E, From => PAT);
end if;
end;
end if;
-- For array base types, set the component size if object size of the
-- component type is known and is a small power of 2 (8, 16, 32, 64
-- or 128), since this is what will always be used, except if a very
-- large alignment was specified and so Adjust_Esize_For_Alignment
-- gave up because, in this case, the object size is not a multiple
-- of the alignment and, therefore, cannot be the component size.
if Ekind (E) = E_Array_Type and then not Known_Component_Size (E) then
declare
CT : constant Entity_Id := Component_Type (E);
begin
-- For some reason, access types can cause trouble, So let's
-- just do this for scalar types.
if Present (CT)
and then Is_Scalar_Type (CT)
and then Known_Static_Esize (CT)
and then not (Known_Alignment (CT)
and then Alignment_In_Bits (CT) >
System_Max_Integer_Size)
then
declare
S : constant Uint := Esize (CT);
begin
if Addressable (S) then
Set_Component_Size (E, S);
end if;
end;
end if;
end;
end if;
-- For non-packed arrays set the alignment of the array to the
-- alignment of the component type if it is unknown. Skip this
-- in full access case since a larger alignment may be needed.
if Is_Array_Type (E)
and then not Is_Packed (E)
and then not Known_Alignment (E)
and then Known_Alignment (Component_Type (E))
and then Known_Static_Component_Size (E)
and then Known_Static_Esize (Component_Type (E))
and then Component_Size (E) = Esize (Component_Type (E))
and then not Is_Full_Access (E)
then
Set_Alignment (E, Alignment (Component_Type (E)));
end if;
-- If packing was requested, the one-dimensional array is constrained
-- with static bounds, the component size was set explicitly, and
-- the alignment is known, we can set (if not set explicitly) the
-- RM_Size and the Esize of the array type, as RM_Size is equal to
-- (arr'length * arr'component_size) and Esize is the same value
-- rounded to the next multiple of arr'alignment. This is not
-- applicable to packed arrays that are implemented specially
-- in GNAT, i.e. when Packed_Array_Impl_Type is set.
if Is_Array_Type (E)
and then Present (First_Index (E)) -- Skip types in error
and then Number_Dimensions (E) = 1
and then not Present (Packed_Array_Impl_Type (E))
and then Has_Pragma_Pack (E)
and then Is_Constrained (E)
and then Compile_Time_Known_Bounds (E)
and then Known_Component_Size (E)
and then Known_Alignment (E)
then
declare
Abits : constant Int := UI_To_Int (Alignment (E)) * SSU;
Lo, Hi : Node_Id;
Siz : Uint;
begin
Get_Index_Bounds (First_Index (E), Lo, Hi);
-- Even if the bounds are known at compile time, they could
-- have been replaced by an error node. Check each bound
-- explicitly.
if Compile_Time_Known_Value (Lo)
and then Compile_Time_Known_Value (Hi)
then
Siz := (Expr_Value (Hi) - Expr_Value (Lo) + 1)
* Component_Size (E);
-- Do not overwrite a different value of 'Size specified
-- explicitly by the user. In that case, also do not set
-- Esize.
if not Known_RM_Size (E) or else RM_Size (E) = Siz then
Set_RM_Size (E, Siz);
if not Known_Esize (E) then
Siz := ((Siz + (Abits - 1)) / Abits) * Abits;
Set_Esize (E, Siz);
end if;
end if;
end if;
end;
end if;
end if;
-- Even if the backend performs the layout, we still do a little in
-- the front end
-- Processing for record types
if Is_Record_Type (E) then
-- Special remaining processing for record types with a known
-- size of 16, 32, or 64 bits whose alignment is not yet set.
-- For these types, we set a corresponding alignment matching
-- the size if possible, or as large as possible if not.
if Convention (E) = Convention_Ada and then not Debug_Flag_Q then
Set_Composite_Alignment (E);
end if;
-- Processing for array types
elsif Is_Array_Type (E) then
-- For arrays that are required to be full access, we do the same
-- processing as described above for short records, since we really
-- need to have the alignment set for the whole array.
if Is_Full_Access (E) and then not Debug_Flag_Q then
Set_Composite_Alignment (E);
end if;
-- For unpacked array types, set an alignment of 1 if we know
-- that the component alignment is not greater than 1. The reason
-- we do this is to avoid unnecessary copying of slices of such
-- arrays when passed to subprogram parameters (see special test
-- in Exp_Ch6.Expand_Actuals).
if not Is_Packed (E) and then not Known_Alignment (E) then
if Known_Static_Component_Size (E)
and then Component_Size (E) = 1
then
Set_Alignment (E, Uint_1);
end if;
end if;
-- We need to know whether the size depends on the value of one
-- or more discriminants to select the return mechanism. Skip if
-- errors are present, to prevent cascaded messages.
if Serious_Errors_Detected = 0 then
Compute_Size_Depends_On_Discriminant (E);
end if;
end if;
-- Final step is to check that Esize and RM_Size are compatible
if Known_Static_Esize (E) and then Known_Static_RM_Size (E) then
if Esize (E) < RM_Size (E) then
-- Esize is less than RM_Size. That's not good. First we test
-- whether this was set deliberately with an Object_Size clause
-- and if so, object to the clause.
if Has_Object_Size_Clause (E) then
Error_Msg_Uint_1 := RM_Size (E);
Error_Msg_F
("object size is too small, minimum allowed is ^",
Expression (Get_Attribute_Definition_Clause
(E, Attribute_Object_Size)));
end if;
-- Adjust Esize up to RM_Size value
declare
Size : constant Uint := RM_Size (E);
begin
Set_Esize (E, Size);
-- For scalar types, increase Object_Size to power of 2, but
-- not less than a storage unit in any case (i.e., normally
-- this means it will be storage-unit addressable).
if Is_Scalar_Type (E) then
if Size <= SSU then
Set_Esize (E, UI_From_Int (SSU));
elsif Size <= 16 then
Set_Esize (E, Uint_16);
elsif Size <= 32 then
Set_Esize (E, Uint_32);
else
Set_Esize (E, (Size + 63) / 64 * 64);
end if;
-- Finally, make sure that alignment is consistent with
-- the newly assigned size.
while Alignment (E) * SSU < Esize (E)
and then Alignment (E) < Maximum_Alignment
loop
Set_Alignment (E, 2 * Alignment (E));
end loop;
-- For the other types, apply standard adjustments
else
Adjust_Esize_Alignment (E);
end if;
end;
end if;
end if;
end Layout_Type;
-----------------------------
-- Set_Composite_Alignment --
-----------------------------
procedure Set_Composite_Alignment (E : Entity_Id) is
Siz : Uint;
Align : Nat;
begin
-- If alignment is already set, then nothing to do
if Known_Alignment (E) then
return;
end if;
-- Alignment is not known, see if we can set it, taking into account
-- the setting of the Optimize_Alignment mode.
-- If Optimize_Alignment is set to Space, then we try to give packed
-- records an aligmment of 1, unless there is some reason we can't.
if Optimize_Alignment_Space (E)
and then Is_Record_Type (E)
and then Is_Packed (E)
then
-- No effect for record with full access components
if Is_Full_Access (E) then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
if Is_Atomic (E) then
Error_Msg_N
("\pragma ignored for atomic record??", E);
else
Error_Msg_N
("\pragma ignored for bolatile full access record??", E);
end if;
return;
end if;
-- No effect if independent components
if Has_Independent_Components (E) then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
Error_Msg_N
("\pragma ignored for record with independent components??", E);
return;
end if;
-- No effect if a component is full access or of a by-reference type
declare
Ent : Entity_Id;
begin
Ent := First_Component_Or_Discriminant (E);
while Present (Ent) loop
if Is_By_Reference_Type (Etype (Ent))
or else Is_Full_Access (Etype (Ent))
or else Is_Full_Access (Ent)
then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
if Is_Atomic (Etype (Ent)) or else Is_Atomic (Ent) then
Error_Msg_N
("\pragma is ignored if atomic "
& "components present??", E);
else
Error_Msg_N
("\pragma is ignored if volatile full access "
& "components present??", E);
end if;
return;
else
Next_Component_Or_Discriminant (Ent);
end if;
end loop;
end;
-- Optimize_Alignment has no effect on variable length record
if not Size_Known_At_Compile_Time (E) then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
Error_Msg_N ("\pragma is ignored for variable length record??", E);
return;
end if;
-- All tests passed, we can set alignment to 1
Align := 1;
-- Not a record, or not packed
else
-- The only other cases we worry about here are where the size is
-- statically known at compile time.
if Known_Static_Esize (E) then
Siz := Esize (E);
elsif not Known_Esize (E) and then Known_Static_RM_Size (E) then
Siz := RM_Size (E);
else
return;
end if;
-- Size is known, alignment is not set
-- Reset alignment to match size if the known size is exactly 2, 4,
-- or 8 storage units.
if Siz = 2 * SSU then
Align := 2;
elsif Siz = 4 * SSU then
Align := 4;
elsif Siz = 8 * SSU then
Align := 8;
-- If Optimize_Alignment is set to Space, then make sure the
-- alignment matches the size, for example, if the size is 17
-- bytes then we want an alignment of 1 for the type.
elsif Optimize_Alignment_Space (E) then
if Siz mod (8 * SSU) = 0 then
Align := 8;
elsif Siz mod (4 * SSU) = 0 then
Align := 4;
elsif Siz mod (2 * SSU) = 0 then
Align := 2;
else
Align := 1;
end if;
-- If Optimize_Alignment is set to Time, then we reset for odd
-- "in between sizes", for example a 17 bit record is given an
-- alignment of 4.
elsif Optimize_Alignment_Time (E)
and then Siz > SSU
and then Siz <= 8 * SSU
then
if Siz <= 2 * SSU then
Align := 2;
elsif Siz <= 4 * SSU then
Align := 4;
else -- Siz <= 8 * SSU then
Align := 8;
end if;
-- No special alignment fiddling needed
else
return;
end if;
end if;
-- Here we have Set Align to the proposed improved value. Make sure the
-- value set does not exceed Maximum_Alignment for the target.
if Align > Maximum_Alignment then
Align := Maximum_Alignment;
end if;
-- Further processing for record types only to reduce the alignment
-- set by the above processing in some specific cases. We do not
-- do this for full access records, since we need max alignment there,
if Is_Record_Type (E) and then not Is_Full_Access (E) then
-- For records, there is generally no point in setting alignment
-- higher than word size since we cannot do better than move by
-- words in any case. Omit this if we are optimizing for time,
-- since conceivably we may be able to do better.
if Align > System_Word_Size / SSU
and then not Optimize_Alignment_Time (E)
then
Align := System_Word_Size / SSU;
end if;
-- Check components. If any component requires a higher alignment,
-- then we set that higher alignment in any case. Don't do this if we
-- have Optimize_Alignment set to Space. Note that covers the case of
-- packed records, where we already set alignment to 1.
if not Optimize_Alignment_Space (E) then
declare
Comp : Entity_Id;
begin
Comp := First_Component (E);
while Present (Comp) loop
if Known_Alignment (Etype (Comp)) then
declare
Calign : constant Uint := Alignment (Etype (Comp));
begin
-- The cases to process are when the alignment of the
-- component type is larger than the alignment we have
-- so far, and either there is no component clause for
-- the component, or the length set by the component
-- clause matches the length of the component type.
if Calign > Align
and then
(not Known_Esize (Comp)
or else (Known_Static_Esize (Comp)
and then
Esize (Comp) = Calign * SSU))
then
Align := UI_To_Int (Calign);
end if;
end;
end if;
Next_Component (Comp);
end loop;
end;
end if;
end if;
-- Set chosen alignment, and increase Esize if necessary to match the
-- chosen alignment.
Set_Alignment (E, UI_From_Int (Align));
if Known_Static_Esize (E)
and then Esize (E) < Align * SSU
then
Set_Esize (E, UI_From_Int (Align * SSU));
end if;
end Set_Composite_Alignment;
--------------------------
-- Set_Discrete_RM_Size --
--------------------------
procedure Set_Discrete_RM_Size (Def_Id : Entity_Id) is
FST : constant Entity_Id := First_Subtype (Def_Id);
begin
-- All discrete types except for the base types in standard are
-- constrained, so indicate this by setting Is_Constrained.
Set_Is_Constrained (Def_Id);
-- Set generic types to have an unknown size, since the representation
-- of a generic type is irrelevant, in view of the fact that they have
-- nothing to do with code.
if Is_Generic_Type (Root_Type (FST)) then
Reinit_RM_Size (Def_Id);
-- If the subtype statically matches the first subtype, then it is
-- required to have exactly the same layout. This is required by
-- aliasing considerations.
elsif Def_Id /= FST and then
Subtypes_Statically_Match (Def_Id, FST)
then
Set_RM_Size (Def_Id, RM_Size (FST));
Set_Size_Info (Def_Id, FST);
-- In all other cases the RM_Size is set to the minimum size. Note that
-- this routine is never called for subtypes for which the RM_Size is
-- set explicitly by an attribute clause.
else
Set_RM_Size (Def_Id, UI_From_Int (Minimum_Size (Def_Id)));
end if;
end Set_Discrete_RM_Size;
------------------------
-- Set_Elem_Alignment --
------------------------
procedure Set_Elem_Alignment (E : Entity_Id; Align : Nat := 0) is
begin
-- Do not set alignment for packed array types, this is handled in the
-- backend.
if Is_Packed_Array_Impl_Type (E) then
return;
-- If there is an alignment clause, then we respect it
elsif Has_Alignment_Clause (E) then
return;
-- If the size is not set, then don't attempt to set the alignment. This
-- happens in the backend layout case for access-to-subprogram types.
elsif not Known_Static_Esize (E) then
return;
-- For access types, do not set the alignment if the size is less than
-- the allowed minimum size. This avoids cascaded error messages.
elsif Is_Access_Type (E) and then Esize (E) < System_Address_Size then
return;
end if;
-- We attempt to set the alignment in all the other cases
declare
S : Int;
A : Nat;
M : Nat;
begin
-- The given Esize may be larger that int'last because of a previous
-- error, and the call to UI_To_Int will fail, so use default.
if Esize (E) / SSU > Ttypes.Maximum_Alignment then
S := Ttypes.Maximum_Alignment;
-- If this is an access type and the target doesn't have strict
-- alignment, then cap the alignment to that of a regular access
-- type. This will avoid giving fat pointers twice the usual
-- alignment for no practical benefit since the misalignment doesn't
-- really matter.
elsif Is_Access_Type (E)
and then not Target_Strict_Alignment
then
S := System_Address_Size / SSU;
else
S := UI_To_Int (Esize (E)) / SSU;
end if;
-- If the default alignment of "double" floating-point types is
-- specifically capped, enforce the cap.
if Ttypes.Target_Double_Float_Alignment > 0
and then S = 8
and then Is_Floating_Point_Type (E)
then
M := Ttypes.Target_Double_Float_Alignment;
-- If the default alignment of "double" or larger scalar types is
-- specifically capped, enforce the cap.
elsif Ttypes.Target_Double_Scalar_Alignment > 0
and then S >= 8
and then Is_Scalar_Type (E)
then
M := Ttypes.Target_Double_Scalar_Alignment;
-- Otherwise enforce the overall alignment cap
else
M := Ttypes.Maximum_Alignment;
end if;
-- We calculate the alignment as the largest power-of-two multiple
-- of System.Storage_Unit that does not exceed the object size of
-- the type and the maximum allowed alignment, if none was specified.
-- Otherwise we only cap it to the maximum allowed alignment.
if Align = 0 then
A := 1;
while 2 * A <= S and then 2 * A <= M loop
A := 2 * A;
end loop;
else
A := Nat'Min (Align, M);
end if;
-- If alignment is currently not set, then we can safely set it to
-- this new calculated value.
if not Known_Alignment (E) then
Set_Alignment (E, UI_From_Int (A));
-- Cases where we have inherited an alignment
-- For constructed types, always reset the alignment, these are
-- generally invisible to the user anyway, and that way we are
-- sure that no constructed types have weird alignments.
elsif not Comes_From_Source (E) then
Set_Alignment (E, UI_From_Int (A));
-- If this inherited alignment is the same as the one we computed,
-- then obviously everything is fine, and we do not need to reset it.
elsif Alignment (E) = A then
null;
else
-- Now we come to the difficult cases of subtypes for which we
-- have inherited an alignment different from the computed one.
-- We resort to the presence of alignment and size clauses to
-- guide our choices. Note that they can generally be present
-- only on the first subtype (except for Object_Size) and that
-- we need to look at the Rep_Item chain to correctly handle
-- derived types.
declare
FST : constant Entity_Id := First_Subtype (E);
function Has_Attribute_Clause
(E : Entity_Id;
Id : Attribute_Id) return Boolean;
-- Wrapper around Get_Attribute_Definition_Clause which tests
-- for the presence of the specified attribute clause.
--------------------------
-- Has_Attribute_Clause --
--------------------------
function Has_Attribute_Clause
(E : Entity_Id;
Id : Attribute_Id) return Boolean is
begin
return Present (Get_Attribute_Definition_Clause (E, Id));
end Has_Attribute_Clause;
begin
-- If the alignment comes from a clause, then we respect it.
-- Consider for example:
-- type R is new Character;
-- for R'Alignment use 1;
-- for R'Size use 16;
-- subtype S is R;
-- Here R has a specified size of 16 and a specified alignment
-- of 1, and it seems right for S to inherit both values.
if Has_Attribute_Clause (FST, Attribute_Alignment) then
null;
-- Now we come to the cases where we have inherited alignment
-- and size, and overridden the size but not the alignment.
elsif Has_Attribute_Clause (FST, Attribute_Size)
or else Has_Attribute_Clause (FST, Attribute_Object_Size)
or else Has_Attribute_Clause (E, Attribute_Object_Size)
then
-- This is tricky, it might be thought that we should try to
-- inherit the alignment, since that's what the RM implies,
-- but that leads to complex rules and oddities. Consider
-- for example:
-- type R is new Character;
-- for R'Size use 16;
-- It seems quite bogus in this case to inherit an alignment
-- of 1 from the parent type Character. Furthermore, if that
-- is what the programmer really wanted for some odd reason,
-- then he could specify the alignment directly.
-- Moreover we really don't want to inherit the alignment in
-- the case of a specified Object_Size for a subtype, since
-- there would be no way of overriding to give a reasonable
-- value (as we don't have an Object_Alignment attribute).
-- Consider for example:
-- subtype R is Character;
-- for R'Object_Size use 16;
-- If we inherit the alignment of 1, then it will be very
-- inefficient for the subtype and this cannot be fixed.
-- So we make the decision that if Size (or Object_Size) is
-- given and the alignment is not specified with a clause,
-- we reset the alignment to the appropriate value for the
-- specified size. This is a nice simple rule to implement
-- and document.
-- There is a theoretical glitch, which is that a confirming
-- size clause could now change the alignment, which, if we
-- really think that confirming rep clauses should have no
-- effect, could be seen as a no-no. However that's already
-- implemented by Alignment_Check_For_Size_Change so we do
-- not change the philosophy here.
-- Historical note: in versions prior to Nov 6th, 2011, an
-- odd distinction was made between inherited alignments
-- larger than the computed alignment (where the larger
-- alignment was inherited) and inherited alignments smaller
-- than the computed alignment (where the smaller alignment
-- was overridden). This was a dubious fix to get around an
-- ACATS problem which seems to have disappeared anyway, and
-- in any case, this peculiarity was never documented.
Set_Alignment (E, UI_From_Int (A));
-- If no Size (or Object_Size) was specified, then we have
-- inherited the object size, so we should also inherit the
-- alignment and not modify it.
else
null;
end if;
end;
end if;
end;
end Set_Elem_Alignment;
end Layout;
|