CbC/CbC_gcc: gcc/ada/exp_ch5.adb comparison

comparison gcc/ada/exp_ch5.adb @ 145:1830386684a0

gcc-9.2.0

author	anatofuz
date	Thu, 13 Feb 2020 11:34:05 +0900
parents	84e7813d76e9
children

comparison

equal deleted inserted replaced

-:84e7813d76e9
+:1830386684a0
 --                                                                          --
 --                              E X P _ C H 5                               --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2019, 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- --
 --  Rev indicates if the loops run normally (Rev = False), or reversed
 --  (Rev = True). The value returned is the constructed loop statement.
 --  Auxiliary declarations are inserted before node N using the standard
 --  Insert_Actions mechanism.
+function Expand_Assign_Array_Bitfield
+(N      : Node_Id;
+Larray : Entity_Id;
+Rarray : Entity_Id;
+L_Type : Entity_Id;
+R_Type : Entity_Id;
+Rev    : Boolean) return Node_Id;
+--  Alternative to Expand_Assign_Array_Loop for packed bitfields. Generates
+--  a call to the System.Bitfields.Copy_Bitfield, which is more efficient
+--  than copying component-by-component.
+function Expand_Assign_Array_Loop_Or_Bitfield
+(N      : Node_Id;
+Larray : Entity_Id;
+Rarray : Entity_Id;
+L_Type : Entity_Id;
+R_Type : Entity_Id;
+Ndim   : Pos;
+Rev    : Boolean) return Node_Id;
+--  Calls either Expand_Assign_Array_Loop or Expand_Assign_Array_Bitfield as
+--  appropriate.
 procedure Expand_Assign_Record (N : Node_Id);
 --  N is an assignment of an untagged record value. This routine handles
 --  the case where the assignment must be made component by component,
 --  either because the target is not byte aligned, or there is a change
 --  of representation, or when we have a tagged type with a representation
 L_Slice : constant Boolean := Nkind (Act_Lhs) = N_Slice;
 R_Slice : constant Boolean := Nkind (Act_Rhs) = N_Slice;
 Crep : constant Boolean := Change_Of_Representation (N);
+pragma Assert
+(Crep
+or else Is_Bit_Packed_Array (L_Type) = Is_Bit_Packed_Array (R_Type));
 Larray  : Node_Id;
 Rarray  : Node_Id;
 Ndim : constant Pos := Number_Dimensions (L_Type);
 Parameter_Associations => Actuals));
 end;
 else
 Rewrite (N,
-Expand_Assign_Array_Loop
+Expand_Assign_Array_Loop_Or_Bitfield
 (N, Larray, Rarray, L_Type, R_Type, Ndim,
 Rev => not Forwards_OK (N)));
 end if;
 --  Case of both are false with No_Implicit_Conditionals
 Cright_Lo :=
 Unchecked_Convert_To (Etype (Left_Lo), Cright_Lo);
 end if;
 --  Reset the Analyzed flag, because the bounds of the index
---  type itself may be universal, and must must be reanalyzed
+--  type itself may be universal, and must be reanalyzed to
---  to acquire the proper type for the back end.
+--  acquire the proper type for the back end.
 Set_Analyzed (Cleft_Lo, False);
 Set_Analyzed (Cright_Lo, False);
 Condition :=
 Rewrite (N,
 Make_Implicit_If_Statement (N,
 Condition => Condition,
 Then_Statements => New_List (
-Expand_Assign_Array_Loop
+Expand_Assign_Array_Loop_Or_Bitfield
 (N, Larray, Rarray, L_Type, R_Type, Ndim,
 Rev => False)),
 Else_Statements => New_List (
-Expand_Assign_Array_Loop
+Expand_Assign_Array_Loop_Or_Bitfield
 (N, Larray, Rarray, L_Type, R_Type, Ndim,
 Rev => True))));
 end if;
 end if;
 Statements => New_List (Assign, Build_Step (J))))));
 end loop;
 return Assign;
 end Expand_Assign_Array_Loop;
+----------------------------------
+-- Expand_Assign_Array_Bitfield --
+----------------------------------
+function Expand_Assign_Array_Bitfield
+(N      : Node_Id;
+Larray : Entity_Id;
+Rarray : Entity_Id;
+L_Type : Entity_Id;
+R_Type : Entity_Id;
+Rev    : Boolean) return Node_Id
+is
+pragma Assert (not Rev);
+--  Reverse copying is not yet supported by Copy_Bitfield.
+pragma Assert (not Change_Of_Representation (N));
+--  This won't work, for example, to copy a packed array to an unpacked
+--  array.
+Loc  : constant Source_Ptr := Sloc (N);
+L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type));
+R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type));
+Left_Lo  : constant Node_Id := Type_Low_Bound  (L_Index_Typ);
+Right_Lo : constant Node_Id := Type_Low_Bound  (R_Index_Typ);
+L_Addr : constant Node_Id :=
+Make_Attribute_Reference (Loc,
+Prefix =>
+Make_Indexed_Component (Loc,
+Prefix =>
+Duplicate_Subexpr (Larray, True),
+Expressions => New_List (New_Copy_Tree (Left_Lo))),
+Attribute_Name => Name_Address);
+L_Bit : constant Node_Id :=
+Make_Attribute_Reference (Loc,
+Prefix =>
+Make_Indexed_Component (Loc,
+Prefix =>
+Duplicate_Subexpr (Larray, True),
+Expressions => New_List (New_Copy_Tree (Left_Lo))),
+Attribute_Name => Name_Bit);
+R_Addr : constant Node_Id :=
+Make_Attribute_Reference (Loc,
+Prefix =>
+Make_Indexed_Component (Loc,
+Prefix =>
+Duplicate_Subexpr (Rarray, True),
+Expressions => New_List (New_Copy_Tree (Right_Lo))),
+Attribute_Name => Name_Address);
+R_Bit : constant Node_Id :=
+Make_Attribute_Reference (Loc,
+Prefix =>
+Make_Indexed_Component (Loc,
+Prefix =>
+Duplicate_Subexpr (Rarray, True),
+Expressions => New_List (New_Copy_Tree (Right_Lo))),
+Attribute_Name => Name_Bit);
+--  Compute the Size of the bitfield
+--  Note that the length check has already been done, so we can use the
+--  size of either L or R; they are equal. We can't use 'Size here,
+--  because sometimes bit fields get copied into a temp, and the 'Size
+--  ends up being the size of the temp (e.g. an 8-bit temp containing
+--  a 4-bit bit field).
+Size : constant Node_Id :=
+Make_Op_Multiply (Loc,
+Make_Attribute_Reference (Loc,
+Prefix =>
+Duplicate_Subexpr (Name (N), True),
+Attribute_Name => Name_Length),
+Make_Attribute_Reference (Loc,
+Prefix =>
+Duplicate_Subexpr (Name (N), True),
+Attribute_Name => Name_Component_Size));
+begin
+return Make_Procedure_Call_Statement (Loc,
+Name => New_Occurrence_Of (RTE (RE_Copy_Bitfield), Loc),
+Parameter_Associations => New_List (
+R_Addr, R_Bit, L_Addr, L_Bit, Size));
+end Expand_Assign_Array_Bitfield;
+------------------------------------------
+-- Expand_Assign_Array_Loop_Or_Bitfield --
+------------------------------------------
+function Expand_Assign_Array_Loop_Or_Bitfield
+(N      : Node_Id;
+Larray : Entity_Id;
+Rarray : Entity_Id;
+L_Type : Entity_Id;
+R_Type : Entity_Id;
+Ndim   : Pos;
+Rev    : Boolean) return Node_Id
+is
+Slices : constant Boolean :=
+Nkind (Name (N)) = N_Slice or else Nkind (Expression (N)) = N_Slice;
+L_Prefix_Comp : constant Boolean :=
+--  True if the left-hand side is a slice of a component or slice
+Nkind (Name (N)) = N_Slice
+and then Nkind_In (Prefix (Name (N)),
+N_Selected_Component,
+N_Indexed_Component,
+N_Slice);
+R_Prefix_Comp : constant Boolean :=
+--  Likewise for the right-hand side
+Nkind (Expression (N)) = N_Slice
+and then Nkind_In (Prefix (Expression (N)),
+N_Selected_Component,
+N_Indexed_Component,
+N_Slice);
+begin
+--  Determine whether Copy_Bitfield is appropriate (will work, and will
+--  be more efficient than component-by-component copy). Copy_Bitfield
+--  doesn't work for reversed storage orders. It is efficient for slices
+--  of bit-packed arrays. Copy_Bitfield can read and write bits that are
+--  not part of the objects being copied, so we don't want to use it if
+--  there are volatile or independent components. If the Prefix of the
+--  slice is a component or slice, then it might be a part of an object
+--  with some other volatile or independent components, so we disable the
+--  optimization in that case as well.  We could complicate this code by
+--  actually looking for such volatile and independent components.
+if Is_Bit_Packed_Array (L_Type)
+and then Is_Bit_Packed_Array (R_Type)
+and then not Reverse_Storage_Order (L_Type)
+and then not Reverse_Storage_Order (R_Type)
+and then Ndim = 1
+and then not Rev
+and then Slices
+and then not Has_Volatile_Component (L_Type)
+and then not Has_Volatile_Component (R_Type)
+and then not Has_Independent_Components (L_Type)
+and then not Has_Independent_Components (R_Type)
+and then not L_Prefix_Comp
+and then not R_Prefix_Comp
+and then RTE_Available (RE_Copy_Bitfield)
+then
+return Expand_Assign_Array_Bitfield
+(N, Larray, Rarray, L_Type, R_Type, Rev);
+else
+return Expand_Assign_Array_Loop
+(N, Larray, Rarray, L_Type, R_Type, Ndim, Rev);
+end if;
+end Expand_Assign_Array_Loop_Or_Bitfield;
 --------------------------
 -- Expand_Assign_Record --
 --------------------------
 --  Deal with assignment checks unless suppressed
 if not Suppress_Assignment_Checks (N) then
---  First deal with generation of range check if required
+--  First deal with generation of range check if required,
+--  and then predicate checks if the type carries a predicate.
-if Do_Range_Check (Rhs) then
+--  If the Rhs is an expression these tests may have been applied
-Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
+--  already. This is the case if the RHS is a type conversion.
+--  Other such redundant checks could be removed ???
+if Nkind (Rhs) /= N_Type_Conversion
+or else Entity (Subtype_Mark (Rhs)) /= Typ
+then
+if Do_Range_Check (Rhs) then
+Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
+end if;
+Apply_Predicate_Check (Rhs, Typ);
 end if;
---  Then generate predicate check if required
-Apply_Predicate_Check (Rhs, Typ);
 end if;
 --  Check for a special case where a high level transformation is
 --  required. If we have either of:
 --  have a full view with discriminants, but those are nameable only
 --  in the underlying type, so convert the Rhs to it before potential
 --  checking. Convert Lhs as well, otherwise the actual subtype might
 --  not be constructible. If the discriminants have defaults the type
 --  is unconstrained and there is nothing to check.
+--  Ditto if a private type with unknown discriminants has a full view
-elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs)))
+--  that is an unconstrained array, in which case a length check is
-and then Has_Discriminants (Typ)
+--  needed.
-and then not Has_Defaulted_Discriminants (Typ)
-then
+elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs))) then
-Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
+if Has_Discriminants (Typ)
-Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
+and then not Has_Defaulted_Discriminants (Typ)
-Apply_Discriminant_Check (Rhs, Typ, Lhs);
+then
+Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
+Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
+Apply_Discriminant_Check (Rhs, Typ, Lhs);
+elsif Is_Array_Type (Typ) and then Is_Constrained (Typ)  then
+Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
+Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
+Apply_Length_Check (Rhs, Typ);
+end if;
 --  In the access type case, we need the same discriminant check, and
 --  also range checks if we have an access to constrained array.
 elsif Is_Access_Type (Etype (Lhs))
 -----------------------------
 -- Expand_N_Case_Statement --
 -----------------------------
 procedure Expand_N_Case_Statement (N : Node_Id) is
-Loc    : constant Source_Ptr := Sloc (N);
+Loc            : constant Source_Ptr := Sloc (N);
-Expr   : constant Node_Id    := Expression (N);
+Expr           : constant Node_Id    := Expression (N);
-Alt    : Node_Id;
+From_Cond_Expr : constant Boolean    := From_Conditional_Expression (N);
-Len    : Nat;
+Alt            : Node_Id;
-Cond   : Node_Id;
+Len            : Nat;
-Choice : Node_Id;
+Cond           : Node_Id;
-Chlist : List_Id;
+Choice         : Node_Id;
+Chlist         : List_Id;
 begin
 --  Check for the situation where we know at compile time which branch
 --  will be taken.
 Rewrite (N,
 Make_If_Statement (Loc,
 Condition => Cond,
 Then_Statements => Then_Stms,
 Else_Statements => Else_Stms));
+--  The rewritten if statement needs to inherit whether the
+--  case statement was expanded from a conditional expression,
+--  for proper handling of nested controlled objects.
+Set_From_Conditional_Expression (N, From_Cond_Expr);
 Analyze (N);
 return;
 end if;
 end if;
 --  If the last alternative is not an Others choice, replace it with
 New_List
 (Make_Block_Statement (Loc,
 Declarations => New_List (Elmt_Decl),
 Handled_Statement_Sequence =>
 Make_Handled_Sequence_Of_Statements (Loc,
-Statements =>  Stats))));
+Statements => Stats))));
 else
 Elmt_Ref :=
 Make_Assignment_Statement (Loc,
 Name       => New_Occurrence_Of (Element, Loc),
 New_Loop :=
 Make_Block_Statement (Loc,
 Declarations               => New_List (Elmt_Decl),
 Handled_Statement_Sequence =>
 Make_Handled_Sequence_Of_Statements (Loc,
-Statements =>  New_List (New_Loop)));
+Statements => New_List (New_Loop)));
 end if;
 --  The element is only modified in expanded code, so it appears as
 --  unassigned to the warning machinery. We must suppress this spurious
 --  warning explicitly.
 --      Iter : Reversible_Iterator'Class := Iterate (My_Vector);
 --      --  Reversible_Iterator is an interface. Iterate is the
 --      --  Default_Iterator aspect of Vector. This increments Lock,
 --      --  disallowing tampering with cursors. Unfortunately, it does not
 --      --  increment Busy. The result of Iterate is Limited_Controlled;
---      --  finalization will decrement Lock.  This is a build-in-place
+--      --  finalization will decrement Lock. This is a build-in-place
 --      --  dispatching call to Iterate.
 --      Cur : Cursor := First (Iter); -- or Last
 --      --  Dispatching call via interface.

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/exp_ch5.adb @ 145:1830386684a0