This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Fix obscur regression with VMS descriptors
- From: Eric Botcazou <ebotcazou at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Date: Thu, 3 Feb 2011 14:18:51 +0100
- Subject: [Ada] Fix obscur regression with VMS descriptors
This fixes a regression with VMS descriptors on 32-bit platforms (they are
sort of supported on non-VMS platforms for better coverage) caused by the
changed semantics of build_int_cstu, which now properly truncates.
Tested on i586-suse-linux, applied on the mainline.
2011-02-03 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/gigi.h (fill_vms_descriptor): Take GNU_TYPE instead of
GNAT_FORMAL.
* gcc-interface/utils2.c (fill_vms_descriptor): Move from here to...
* gcc-interface/utils.c (fill_vms_descriptor): ...here. Take GNU_TYPE
instead of GNAT_FORMAL. Protect the expression against multiple uses.
Do not generate the check directly, instead instantiate the template
check present in the descriptor.
(make_descriptor_field): Move around.
(build_vms_descriptor32): Build a template check in the POINTER field.
(build_vms_descriptor): Remove useless suffixes.
* gcc-interface/trans.c (call_to_gnu): Adjust fill_vms_descriptor call.
--
Eric Botcazou
Index: gcc-interface/utils.c
===================================================================
--- gcc-interface/utils.c (revision 169516)
+++ gcc-interface/utils.c (working copy)
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2010, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2011, 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- *
@@ -203,7 +203,6 @@ static tree split_plus (tree, tree *);
static tree float_type_for_precision (int, enum machine_mode);
static tree convert_to_fat_pointer (tree, tree);
static tree convert_to_thin_pointer (tree, tree);
-static tree make_descriptor_field (const char *,tree, tree, tree, tree);
static bool potential_alignment_gap (tree, tree, tree);
static void process_attributes (tree, struct attrib *);
@@ -2280,6 +2279,22 @@ build_template (tree template_type, tree
return gnat_build_constructor (template_type, template_elts);
}
+/* Helper routine to make a descriptor field. FIELD_LIST is the list of decls
+ being built; the new decl is chained on to the front of the list. */
+
+static tree
+make_descriptor_field (const char *name, tree type, tree rec_type,
+ tree initial, tree field_list)
+{
+ tree field
+ = create_field_decl (get_identifier (name), type, rec_type, NULL_TREE,
+ NULL_TREE, 0, 0);
+
+ DECL_INITIAL (field) = initial;
+ DECL_CHAIN (field) = field_list;
+ return field;
+}
+
/* Build a 32-bit VMS descriptor from a Mechanism_Type, which must specify a
descriptor type, and the GCC type of an object. Each FIELD_DECL in the
type contains in its DECL_INITIAL the expression to use when a constructor
@@ -2291,15 +2306,11 @@ tree
build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
{
tree record_type = make_node (RECORD_TYPE);
- tree pointer32_type;
+ tree pointer32_type, pointer64_type;
tree field_list = NULL_TREE;
- int klass;
- int dtype = 0;
- tree inner_type;
- int ndim;
- int i;
+ int klass, ndim, i, dtype = 0;
+ tree inner_type, tem;
tree *idx_arr;
- tree tem;
/* If TYPE is an unconstrained array, use the underlying array type. */
if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
@@ -2439,15 +2450,22 @@ build_vms_descriptor32 (tree type, Mecha
= make_descriptor_field ("CLASS", gnat_type_for_size (8, 1), record_type,
size_int (klass), field_list);
- /* Of course this will crash at run time if the address space is not
- within the low 32 bits, but there is nothing else we can do. */
pointer32_type = build_pointer_type_for_mode (type, SImode, false);
+ pointer64_type = build_pointer_type_for_mode (type, DImode, false);
+
+ /* Ensure that only 32-bit pointers are passed in 32-bit descriptors. Note
+ that we cannot build a template call to the CE routine as it would get a
+ wrong source location; instead we use a second placeholder for it. */
+ tem = build_unary_op (ADDR_EXPR, pointer64_type,
+ build0 (PLACEHOLDER_EXPR, type));
+ tem = build3 (COND_EXPR, pointer32_type,
+ build_binary_op (GE_EXPR, boolean_type_node, tem,
+ build_int_cstu (pointer64_type, 0x80000000)),
+ build0 (PLACEHOLDER_EXPR, void_type_node),
+ convert (pointer32_type, tem));
field_list
- = make_descriptor_field ("POINTER", pointer32_type, record_type,
- build_unary_op (ADDR_EXPR,
- pointer32_type,
- build0 (PLACEHOLDER_EXPR, type)),
+ = make_descriptor_field ("POINTER", pointer32_type, record_type, tem,
field_list);
switch (mech)
@@ -2488,7 +2506,6 @@ build_vms_descriptor32 (tree type, Mecha
= make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1),
record_type, size_zero_node, field_list);
-
field_list
= make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1),
record_type,
@@ -2587,16 +2604,12 @@ build_vms_descriptor32 (tree type, Mecha
tree
build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
{
- tree record64_type = make_node (RECORD_TYPE);
+ tree record_type = make_node (RECORD_TYPE);
tree pointer64_type;
- tree field_list64 = NULL_TREE;
- int klass;
- int dtype = 0;
- tree inner_type;
- int ndim;
- int i;
+ tree field_list = NULL_TREE;
+ int klass, ndim, i, dtype = 0;
+ tree inner_type, tem;
tree *idx_arr;
- tree tem;
/* If TYPE is an unconstrained array, use the underlying array type. */
if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
@@ -2718,32 +2731,32 @@ build_vms_descriptor (tree type, Mechani
/* Make the type for a 64-bit descriptor for VMS. The first six fields
are the same for all types. */
- field_list64
+ field_list
= make_descriptor_field ("MBO", gnat_type_for_size (16, 1),
- record64_type, size_int (1), field_list64);
- field_list64
+ record_type, size_int (1), field_list);
+ field_list
= make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1),
- record64_type, size_int (dtype), field_list64);
- field_list64
+ record_type, size_int (dtype), field_list);
+ field_list
= make_descriptor_field ("CLASS", gnat_type_for_size (8, 1),
- record64_type, size_int (klass), field_list64);
- field_list64
+ record_type, size_int (klass), field_list);
+ field_list
= make_descriptor_field ("MBMO", gnat_type_for_size (32, 1),
- record64_type, ssize_int (-1), field_list64);
- field_list64
+ record_type, ssize_int (-1), field_list);
+ field_list
= make_descriptor_field ("LENGTH", gnat_type_for_size (64, 1),
- record64_type,
+ record_type,
size_in_bytes (mech == By_Descriptor_A
? inner_type : type),
- field_list64);
+ field_list);
pointer64_type = build_pointer_type_for_mode (type, DImode, false);
- field_list64
- = make_descriptor_field ("POINTER", pointer64_type, record64_type,
+ field_list
+ = make_descriptor_field ("POINTER", pointer64_type, record_type,
build_unary_op (ADDR_EXPR, pointer64_type,
build0 (PLACEHOLDER_EXPR, type)),
- field_list64);
+ field_list);
switch (mech)
{
@@ -2752,31 +2765,31 @@ build_vms_descriptor (tree type, Mechani
break;
case By_Descriptor_SB:
- field_list64
+ field_list
= make_descriptor_field ("SB_L1", gnat_type_for_size (64, 1),
- record64_type,
+ record_type,
(TREE_CODE (type) == ARRAY_TYPE
? TYPE_MIN_VALUE (TYPE_DOMAIN (type))
: size_zero_node),
- field_list64);
- field_list64
+ field_list);
+ field_list
= make_descriptor_field ("SB_U1", gnat_type_for_size (64, 1),
- record64_type,
+ record_type,
(TREE_CODE (type) == ARRAY_TYPE
? TYPE_MAX_VALUE (TYPE_DOMAIN (type))
: size_zero_node),
- field_list64);
+ field_list);
break;
case By_Descriptor_A:
case By_Descriptor_NCA:
- field_list64
+ field_list
= make_descriptor_field ("SCALE", gnat_type_for_size (8, 1),
- record64_type, size_zero_node, field_list64);
+ record_type, size_zero_node, field_list);
- field_list64
+ field_list
= make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1),
- record64_type, size_zero_node, field_list64);
+ record_type, size_zero_node, field_list);
dtype = (mech == By_Descriptor_NCA
? 0
@@ -2785,22 +2798,22 @@ build_vms_descriptor (tree type, Mechani
: (TREE_CODE (type) == ARRAY_TYPE
&& TYPE_CONVENTION_FORTRAN_P (type)
? 224 : 192));
- field_list64
+ field_list
= make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1),
- record64_type, size_int (dtype),
- field_list64);
+ record_type, size_int (dtype),
+ field_list);
- field_list64
+ field_list
= make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1),
- record64_type, size_int (ndim), field_list64);
+ record_type, size_int (ndim), field_list);
- field_list64
+ field_list
= make_descriptor_field ("MBZ", gnat_type_for_size (32, 1),
- record64_type, size_int (0), field_list64);
- field_list64
+ record_type, size_int (0), field_list);
+ field_list
= make_descriptor_field ("ARSIZE", gnat_type_for_size (64, 1),
- record64_type, size_in_bytes (type),
- field_list64);
+ record_type, size_in_bytes (type),
+ field_list);
/* Now build a pointer to the 0,0,0... element. */
tem = build0 (PLACEHOLDER_EXPR, type);
@@ -2810,10 +2823,10 @@ build_vms_descriptor (tree type, Mechani
convert (TYPE_DOMAIN (inner_type), size_zero_node),
NULL_TREE, NULL_TREE);
- field_list64
- = make_descriptor_field ("A0", pointer64_type, record64_type,
+ field_list
+ = make_descriptor_field ("A0", pointer64_type, record_type,
build1 (ADDR_EXPR, pointer64_type, tem),
- field_list64);
+ field_list);
/* Next come the addressing coefficients. */
tem = size_one_node;
@@ -2830,9 +2843,9 @@ build_vms_descriptor (tree type, Mechani
fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
fname[1] = '0' + i, fname[2] = 0;
- field_list64
+ field_list
= make_descriptor_field (fname, gnat_type_for_size (64, 1),
- record64_type, idx_length, field_list64);
+ record_type, idx_length, field_list);
if (mech == By_Descriptor_NCA)
tem = idx_length;
@@ -2844,16 +2857,16 @@ build_vms_descriptor (tree type, Mechani
char fname[3];
fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
- field_list64
+ field_list
= make_descriptor_field (fname, gnat_type_for_size (64, 1),
- record64_type,
- TYPE_MIN_VALUE (idx_arr[i]), field_list64);
+ record_type,
+ TYPE_MIN_VALUE (idx_arr[i]), field_list);
fname[0] = 'U';
- field_list64
+ field_list
= make_descriptor_field (fname, gnat_type_for_size (64, 1),
- record64_type,
- TYPE_MAX_VALUE (idx_arr[i]), field_list64);
+ record_type,
+ TYPE_MAX_VALUE (idx_arr[i]), field_list);
}
break;
@@ -2861,26 +2874,41 @@ build_vms_descriptor (tree type, Mechani
post_error ("unsupported descriptor type for &", gnat_entity);
}
- TYPE_NAME (record64_type) = create_concat_name (gnat_entity, "DESC64");
- finish_record_type (record64_type, nreverse (field_list64), 0, false);
- return record64_type;
+ TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC64");
+ finish_record_type (record_type, nreverse (field_list), 0, false);
+ return record_type;
}
-/* Utility routine for above code to make a field. FIELD_LIST is the
- list of decls being built; the new decl is chained on to the front of
- the list. */
+/* Fill in a VMS descriptor of GNU_TYPE for GNU_EXPR and return the result.
+ GNAT_ACTUAL is the actual parameter for which the descriptor is built. */
-static tree
-make_descriptor_field (const char *name, tree type,
- tree rec_type, tree initial, tree field_list)
+tree
+fill_vms_descriptor (tree gnu_type, tree gnu_expr, Node_Id gnat_actual)
{
- tree field
- = create_field_decl (get_identifier (name), type, rec_type, NULL_TREE,
- NULL_TREE, 0, 0);
+ VEC(constructor_elt,gc) *v = NULL;
+ tree field;
- DECL_INITIAL (field) = initial;
- DECL_CHAIN (field) = field_list;
- return field;
+ gnu_expr = maybe_unconstrained_array (gnu_expr);
+ gnu_expr = gnat_protect_expr (gnu_expr);
+ gnat_mark_addressable (gnu_expr);
+
+ /* We may need to substitute both GNU_EXPR and a CALL_EXPR to the raise CE
+ routine in case we have a 32-bit descriptor. */
+ gnu_expr = build2 (COMPOUND_EXPR, void_type_node,
+ build_call_raise (CE_Range_Check_Failed, gnat_actual,
+ N_Raise_Constraint_Error),
+ gnu_expr);
+
+ for (field = TYPE_FIELDS (gnu_type); field; field = DECL_CHAIN (field))
+ {
+ tree value
+ = convert (TREE_TYPE (field),
+ SUBSTITUTE_PLACEHOLDER_IN_EXPR (DECL_INITIAL (field),
+ gnu_expr));
+ CONSTRUCTOR_APPEND_ELT (v, field, value);
+ }
+
+ return gnat_build_constructor (gnu_type, v);
}
/* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a
Index: gcc-interface/utils2.c
===================================================================
--- gcc-interface/utils2.c (revision 169516)
+++ gcc-interface/utils2.c (working copy)
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2010, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2011, 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- *
@@ -2216,58 +2216,6 @@ build_allocator (tree type, tree init, t
return convert (result_type, result);
}
-/* Fill in a VMS descriptor for EXPR and return a constructor for it.
- GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is
- how we derive the source location to raise C_E on an out of range
- pointer. */
-
-tree
-fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
-{
- tree parm_decl = get_gnu_tree (gnat_formal);
- tree record_type = TREE_TYPE (TREE_TYPE (parm_decl));
- tree field;
- const bool do_range_check
- = strcmp ("MBO",
- IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type))));
- VEC(constructor_elt,gc) *v = NULL;
-
- expr = maybe_unconstrained_array (expr);
- gnat_mark_addressable (expr);
-
- for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
- {
- tree conexpr = convert (TREE_TYPE (field),
- SUBSTITUTE_PLACEHOLDER_IN_EXPR
- (DECL_INITIAL (field), expr));
-
- /* Check to ensure that only 32-bit pointers are passed in
- 32-bit descriptors */
- if (do_range_check
- && strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), "POINTER") == 0)
- {
- tree pointer64type
- = build_pointer_type_for_mode (void_type_node, DImode, false);
- tree addr64expr = build_unary_op (ADDR_EXPR, pointer64type, expr);
- tree malloc64low
- = build_int_cstu (long_integer_type_node, 0x80000000);
-
- add_stmt (build3 (COND_EXPR, void_type_node,
- build_binary_op (GE_EXPR, boolean_type_node,
- convert (long_integer_type_node,
- addr64expr),
- malloc64low),
- build_call_raise (CE_Range_Check_Failed,
- gnat_actual,
- N_Raise_Constraint_Error),
- NULL_TREE));
- }
- CONSTRUCTOR_APPEND_ELT (v, field, conexpr);
- }
-
- return gnat_build_constructor (record_type, v);
-}
-
/* Indicate that we need to take the address of T and that it therefore
should not be allocated in a register. Returns true if successful. */
Index: gcc-interface/gigi.h
===================================================================
--- gcc-interface/gigi.h (revision 169516)
+++ gcc-interface/gigi.h (working copy)
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2010, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2011, 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- *
@@ -861,10 +861,9 @@ extern tree build_allocator (tree type,
Entity_Id gnat_proc, Entity_Id gnat_pool,
Node_Id gnat_node, bool);
-/* Fill in a VMS descriptor for EXPR and return a constructor for it.
- GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is how
- we derive the source location on a C_E */
-extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal,
+/* Fill in a VMS descriptor of GNU_TYPE for GNU_EXPR and return the result.
+ GNAT_ACTUAL is the actual parameter for which the descriptor is built. */
+extern tree fill_vms_descriptor (tree gnu_type, tree gnu_expr,
Node_Id gnat_actual);
/* Indicate that we need to take the address of T and that it therefore
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c (revision 169516)
+++ gcc-interface/trans.c (working copy)
@@ -3071,9 +3071,9 @@ call_to_gnu (Node_Id gnat_node, tree *gn
= convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
else
gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
- fill_vms_descriptor (gnu_actual,
- gnat_formal,
- gnat_actual));
+ fill_vms_descriptor
+ (TREE_TYPE (TREE_TYPE (gnu_formal)),
+ gnu_actual, gnat_actual));
}
else
{