[Ada] Add support for 64bit descriptors on VMS
Arnaud Charlet
charlet@adacore.com
Wed Jul 30 14:41:00 GMT 2008
A recent enhancement to the GNAT runtime on VMS enables use of the
64bit heap. Passing pointers allocated on the 64bit heap via descriptor
requires the use of a 64bit descriptor. This change implements that fix.
Manually tested on VMS with GCC 4.1, Tested on i686-pc-linux-gnu
Committed on trunk.
2008-07-30 Doug Rupp <rupp@adacore.com>
* gigi.h (build_vms_descriptor64): New function prototype.
(fill_vms_descriptor): Modified function prototype.
* utils.c (build_vms_descriptor64): New function.
* utils2.c (fill_vms_descriptor): Fix handling on 32bit systems.
* trans.c (call_to_gnu): Call fill_vms_descriptor with new third
argument.
* decl.c (gnat_to_gnu_tree): For By_Descriptor mech, build both a
64bit and 32bit descriptor and save the 64bit version as an alternate
TREE_TYPE in the parameter.
(make_type_from_size) <RECORD_TYPE>: Use the appropriate mode for the
thin pointer.
* ada-tree.h (DECL_PARM_ALT, SET_DECL_PARM_ALT): New macros.
-------------- next part --------------
Index: gigi.h
===================================================================
--- gigi.h (revision 138294)
+++ gigi.h (working copy)
@@ -678,7 +678,7 @@ extern void end_subprog_body (tree body,
Return a constructor for the template. */
extern tree build_template (tree template_type, tree array_type, tree expr);
-/* Build a VMS descriptor from a Mechanism_Type, which must specify
+/* Build a 32bit 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 is made for the type. GNAT_ENTITY is a gnat node used
@@ -687,6 +687,10 @@ extern tree build_template (tree templat
extern tree build_vms_descriptor (tree type, Mechanism_Type mech,
Entity_Id gnat_entity);
+/* Build a 64bit VMS descriptor from a Mechanism_Type. See above. */
+extern tree build_vms_descriptor64 (tree type, Mechanism_Type mech,
+ Entity_Id gnat_entity);
+
/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
and the GNAT node GNAT_SUBPROG. */
extern void build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog);
@@ -844,9 +848,9 @@ extern tree build_allocator (tree type,
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. */
-
-extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal);
+ GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is how we
+ find the size of the allocator. */
+extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual);
/* Indicate that we need to make the address of EXPR_NODE and it therefore
should not be allocated in a register. Return true if successful. */
Index: utils.c
===================================================================
--- utils.c (revision 138294)
+++ utils.c (working copy)
@@ -2635,7 +2635,7 @@ build_template (tree template_type, tree
return gnat_build_constructor (template_type, nreverse (template_elts));
}
-/* Build a VMS descriptor from a Mechanism_Type, which must specify
+/* Build a 32bit 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 is made for the type. GNAT_ENTITY is an entity used
@@ -2937,6 +2937,321 @@ build_vms_descriptor (tree type, Mechani
return record_type;
}
+/* Build a 64bit 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 is made for the type. GNAT_ENTITY is an entity used
+ to print out an error message if the mechanism cannot be applied to
+ an object of that type and also for the name. */
+
+tree
+build_vms_descriptor64 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
+{
+ tree record64_type = make_node (RECORD_TYPE);
+ tree pointer64_type;
+ tree field_list64 = 0;
+ int class;
+ int dtype = 0;
+ tree inner_type;
+ int ndim;
+ int i;
+ tree *idx_arr;
+ tree tem;
+
+ /* If TYPE is an unconstrained array, use the underlying array type. */
+ if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
+ type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
+
+ /* If this is an array, compute the number of dimensions in the array,
+ get the index types, and point to the inner type. */
+ if (TREE_CODE (type) != ARRAY_TYPE)
+ ndim = 0;
+ else
+ for (ndim = 1, inner_type = type;
+ TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
+ && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
+ ndim++, inner_type = TREE_TYPE (inner_type))
+ ;
+
+ idx_arr = (tree *) alloca (ndim * sizeof (tree));
+
+ if (mech != By_Descriptor_NCA
+ && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
+ for (i = ndim - 1, inner_type = type;
+ i >= 0;
+ i--, inner_type = TREE_TYPE (inner_type))
+ idx_arr[i] = TYPE_DOMAIN (inner_type);
+ else
+ for (i = 0, inner_type = type;
+ i < ndim;
+ i++, inner_type = TREE_TYPE (inner_type))
+ idx_arr[i] = TYPE_DOMAIN (inner_type);
+
+ /* Now get the DTYPE value. */
+ switch (TREE_CODE (type))
+ {
+ case INTEGER_TYPE:
+ case ENUMERAL_TYPE:
+ if (TYPE_VAX_FLOATING_POINT_P (type))
+ switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
+ {
+ case 6:
+ dtype = 10;
+ break;
+ case 9:
+ dtype = 11;
+ break;
+ case 15:
+ dtype = 27;
+ break;
+ }
+ else
+ switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
+ {
+ case 8:
+ dtype = TYPE_UNSIGNED (type) ? 2 : 6;
+ break;
+ case 16:
+ dtype = TYPE_UNSIGNED (type) ? 3 : 7;
+ break;
+ case 32:
+ dtype = TYPE_UNSIGNED (type) ? 4 : 8;
+ break;
+ case 64:
+ dtype = TYPE_UNSIGNED (type) ? 5 : 9;
+ break;
+ case 128:
+ dtype = TYPE_UNSIGNED (type) ? 25 : 26;
+ break;
+ }
+ break;
+
+ case REAL_TYPE:
+ dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
+ break;
+
+ case COMPLEX_TYPE:
+ if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
+ && TYPE_VAX_FLOATING_POINT_P (type))
+ switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
+ {
+ case 6:
+ dtype = 12;
+ break;
+ case 9:
+ dtype = 13;
+ break;
+ case 15:
+ dtype = 29;
+ }
+ else
+ dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
+ break;
+
+ case ARRAY_TYPE:
+ dtype = 14;
+ break;
+
+ default:
+ break;
+ }
+
+ /* Get the CLASS value. */
+ switch (mech)
+ {
+ case By_Descriptor_A:
+ class = 4;
+ break;
+ case By_Descriptor_NCA:
+ class = 10;
+ break;
+ case By_Descriptor_SB:
+ class = 15;
+ break;
+ case By_Descriptor:
+ case By_Descriptor_S:
+ default:
+ class = 1;
+ break;
+ }
+
+ /* Make the type for a 64bit descriptor for VMS. The first six fields
+ are the same for all types. */
+
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("MBO",
+ gnat_type_for_size (16, 1),
+ record64_type, size_int (1)));
+
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("DTYPE",
+ gnat_type_for_size (8, 1),
+ record64_type, size_int (dtype)));
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("CLASS",
+ gnat_type_for_size (8, 1),
+ record64_type, size_int (class)));
+
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("MBMO",
+ gnat_type_for_size (32, 1),
+ record64_type, ssize_int (-1)));
+
+ field_list64
+ = chainon (field_list64,
+ make_descriptor_field
+ ("LENGTH", gnat_type_for_size (64, 1), record64_type,
+ size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
+
+ pointer64_type = build_pointer_type_for_mode (type, DImode, false);
+
+ field_list64
+ = chainon (field_list64,
+ make_descriptor_field
+ ("POINTER", pointer64_type, record64_type,
+ build_unary_op (ADDR_EXPR,
+ pointer64_type,
+ build0 (PLACEHOLDER_EXPR, type))));
+
+ switch (mech)
+ {
+ case By_Descriptor:
+ case By_Descriptor_S:
+ break;
+
+ case By_Descriptor_SB:
+ field_list64
+ = chainon (field_list64,
+ make_descriptor_field
+ ("SB_L1", gnat_type_for_size (64, 1), record64_type,
+ TREE_CODE (type) == ARRAY_TYPE
+ ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
+ field_list64
+ = chainon (field_list64,
+ make_descriptor_field
+ ("SB_U1", gnat_type_for_size (64, 1), record64_type,
+ TREE_CODE (type) == ARRAY_TYPE
+ ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
+ break;
+
+ case By_Descriptor_A:
+ case By_Descriptor_NCA:
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("SCALE",
+ gnat_type_for_size (8, 1),
+ record64_type,
+ size_zero_node));
+
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("DIGITS",
+ gnat_type_for_size (8, 1),
+ record64_type,
+ size_zero_node));
+
+ field_list64
+ = chainon (field_list64,
+ make_descriptor_field
+ ("AFLAGS", gnat_type_for_size (8, 1), record64_type,
+ size_int (mech == By_Descriptor_NCA
+ ? 0
+ /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */
+ : (TREE_CODE (type) == ARRAY_TYPE
+ && TYPE_CONVENTION_FORTRAN_P (type)
+ ? 224 : 192))));
+
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("DIMCT",
+ gnat_type_for_size (8, 1),
+ record64_type,
+ size_int (ndim)));
+
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("MBZ",
+ gnat_type_for_size (32, 1),
+ record64_type,
+ size_int (0)));
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("ARSIZE",
+ gnat_type_for_size (64, 1),
+ record64_type,
+ size_in_bytes (type)));
+
+ /* Now build a pointer to the 0,0,0... element. */
+ tem = build0 (PLACEHOLDER_EXPR, type);
+ for (i = 0, inner_type = type; i < ndim;
+ i++, inner_type = TREE_TYPE (inner_type))
+ tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
+ convert (TYPE_DOMAIN (inner_type), size_zero_node),
+ NULL_TREE, NULL_TREE);
+
+ field_list64
+ = chainon (field_list64,
+ make_descriptor_field
+ ("A0",
+ build_pointer_type_for_mode (inner_type, DImode, false),
+ record64_type,
+ build1 (ADDR_EXPR,
+ build_pointer_type_for_mode (inner_type, DImode,
+ false),
+ tem)));
+
+ /* Next come the addressing coefficients. */
+ tem = size_one_node;
+ for (i = 0; i < ndim; i++)
+ {
+ char fname[3];
+ tree idx_length
+ = size_binop (MULT_EXPR, tem,
+ size_binop (PLUS_EXPR,
+ size_binop (MINUS_EXPR,
+ TYPE_MAX_VALUE (idx_arr[i]),
+ TYPE_MIN_VALUE (idx_arr[i])),
+ size_int (1)));
+
+ fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
+ fname[1] = '0' + i, fname[2] = 0;
+ field_list64
+ = chainon (field_list64,
+ make_descriptor_field (fname,
+ gnat_type_for_size (64, 1),
+ record64_type, idx_length));
+
+ if (mech == By_Descriptor_NCA)
+ tem = idx_length;
+ }
+
+ /* Finally here are the bounds. */
+ for (i = 0; i < ndim; i++)
+ {
+ char fname[3];
+
+ fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
+ field_list64
+ = chainon (field_list64,
+ make_descriptor_field
+ (fname, gnat_type_for_size (64, 1), record64_type,
+ TYPE_MIN_VALUE (idx_arr[i])));
+
+ fname[0] = 'U';
+ field_list64
+ = chainon (field_list64,
+ make_descriptor_field
+ (fname, gnat_type_for_size (64, 1), record64_type,
+ TYPE_MAX_VALUE (idx_arr[i])));
+ }
+ break;
+
+ default:
+ post_error ("unsupported descriptor type for &", gnat_entity);
+ }
+
+ finish_record_type (record64_type, field_list64, 0, true);
+ create_type_decl (create_concat_name (gnat_entity, "DESC64"), record64_type,
+ NULL, true, false, gnat_entity);
+
+ return record64_type;
+}
+
/* Utility routine for above code to make a field. */
static tree
Index: utils2.c
===================================================================
--- utils2.c (revision 138294)
+++ utils2.c (working copy)
@@ -2151,15 +2151,43 @@ build_allocator (tree type, tree init, t
}
/* Fill in a VMS descriptor for EXPR and return a constructor for it.
- GNAT_FORMAL is how we find the descriptor record. */
+ GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is
+ how we find the allocator size which determines whether to use the
+ alternate 64bit descriptor. */
tree
-fill_vms_descriptor (tree expr, Entity_Id gnat_formal)
+fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
{
- tree record_type = TREE_TYPE (TREE_TYPE (get_gnu_tree (gnat_formal)));
tree field;
+ tree parm_decl = get_gnu_tree (gnat_formal);
tree const_list = NULL_TREE;
+ int size;
+ tree record_type;
+ /* A string literal will always be in 32bit space on VMS. Where
+ will it be on other 64bit systems???
+ An identifier's allocation may be unknown at compile time.
+ An explicit dereference could be either in 32bit or 64bit space.
+ Don't know about other possibilities, so assume unknown which
+ will result in fetching the 64bit descriptor. ??? */
+ if (Nkind (gnat_actual) == N_String_Literal)
+ size = 32;
+ else if (Nkind (gnat_actual) == N_Identifier)
+ size = UI_To_Int (Esize (Etype (gnat_actual)));
+ else if (Nkind (gnat_actual) == N_Explicit_Dereference)
+ size = UI_To_Int (Esize (Etype (Prefix (gnat_actual))));
+ else
+ size = 0;
+
+ /* If size is unknown, make it POINTER_SIZE */
+ if (size == 0)
+ size = POINTER_SIZE;
+
+ /* If size is 64bits grab the alternate 64bit descriptor. */
+ if (size == 64)
+ TREE_TYPE (parm_decl) = DECL_PARM_ALT (parm_decl);
+
+ record_type = TREE_TYPE (TREE_TYPE (parm_decl));
expr = maybe_unconstrained_array (expr);
gnat_mark_addressable (expr);
Index: trans.c
===================================================================
--- trans.c (revision 138294)
+++ trans.c (working copy)
@@ -2368,7 +2368,8 @@ call_to_gnu (Node_Id gnat_node, tree *gn
else
gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
fill_vms_descriptor (gnu_actual,
- gnat_formal));
+ gnat_formal,
+ gnat_actual));
}
else
{
Index: decl.c
===================================================================
--- decl.c (revision 138294)
+++ decl.c (working copy)
@@ -4774,6 +4774,7 @@ gnat_to_gnu_param (Entity_Id gnat_param,
{
tree gnu_param_name = get_entity_name (gnat_param);
tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
+ tree gnu_param_type_alt = NULL_TREE;
bool in_param = (Ekind (gnat_param) == E_In_Parameter);
/* The parameter can be indirectly modified if its address is taken. */
bool ro_param = in_param && !Address_Taken (gnat_param);
@@ -4820,12 +4821,20 @@ gnat_to_gnu_param (Entity_Id gnat_param,
gnu_param_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
- /* VMS descriptors are themselves passed by reference. */
+ /* VMS descriptors are themselves passed by reference.
+ Build both a 32bit and 64bit descriptor, one of which will be chosen
+ in fill_vms_descriptor based on the allocator size */
if (mech == By_Descriptor)
- gnu_param_type
- = build_pointer_type (build_vms_descriptor (gnu_param_type,
- Mechanism (gnat_param),
- gnat_subprog));
+ {
+ gnu_param_type_alt
+ = build_pointer_type (build_vms_descriptor64 (gnu_param_type,
+ Mechanism (gnat_param),
+ gnat_subprog));
+ gnu_param_type
+ = build_pointer_type (build_vms_descriptor (gnu_param_type,
+ Mechanism (gnat_param),
+ gnat_subprog));
+ }
/* Arrays are passed as pointers to element type for foreign conventions. */
else if (foreign
@@ -4921,6 +4930,9 @@ gnat_to_gnu_param (Entity_Id gnat_param,
DECL_POINTS_TO_READONLY_P (gnu_param)
= (ro_param && (by_ref || by_component_ptr));
+ /* Save the 64bit descriptor for later. */
+ SET_DECL_PARM_ALT (gnu_param, gnu_param_type_alt);
+
/* If no Mechanism was specified, indicate what we're using, then
back-annotate it. */
if (mech == Default)
@@ -7155,9 +7167,15 @@ make_type_from_size (tree type, tree siz
/* Do something if this is a fat pointer, in which case we
may need to return the thin pointer. */
if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
- return
- build_pointer_type
- (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
+ {
+ enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
+ if (!targetm.valid_pointer_mode (p_mode))
+ p_mode = ptr_mode;
+ return
+ build_pointer_type_for_mode
+ (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
+ p_mode, 0);
+ }
break;
case POINTER_TYPE:
Index: ada-tree.h
===================================================================
--- ada-tree.h (revision 138294)
+++ ada-tree.h (working copy)
@@ -294,6 +294,12 @@ struct lang_type GTY(()) {tree t; };
#define SET_DECL_FUNCTION_STUB(NODE, X) \
SET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE), X)
+/* In a PARM_DECL, points to the alternate TREE_TYPE */
+#define DECL_PARM_ALT(NODE) \
+ GET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE))
+#define SET_DECL_PARM_ALT(NODE, X) \
+ SET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE), X)
+
/* In a FIELD_DECL corresponding to a discriminant, contains the
discriminant number. */
#define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE))
More information about the Gcc-patches
mailing list