From 6ca2b0a0388c2944e222aab817db7f09bd2f96c4 Mon Sep 17 00:00:00 2001 From: Doug Rupp Date: Wed, 30 Jul 2008 13:06:45 +0000 Subject: [PATCH] gigi.h (build_vms_descriptor64): New function prototype. 2008-07-30 Doug Rupp * 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) : Use the appropriate mode for the thin pointer. * ada-tree.h (DECL_PARM_ALT, SET_DECL_PARM_ALT): New macros. From-SVN: r138307 --- gcc/ada/ChangeLog | 20 +++ gcc/ada/gcc-interface/ada-tree.h | 6 + gcc/ada/gcc-interface/decl.c | 34 ++++- gcc/ada/gcc-interface/gigi.h | 12 +- gcc/ada/gcc-interface/trans.c | 3 +- gcc/ada/gcc-interface/utils.c | 317 ++++++++++++++++++++++++++++++++++++++- gcc/ada/gcc-interface/utils2.c | 34 ++++- 7 files changed, 409 insertions(+), 17 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c5409d3..aa6615c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2008-07-30 Doug Rupp + + * 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) : Use the appropriate mode for the + thin pointer. + + * ada-tree.h (DECL_PARM_ALT, SET_DECL_PARM_ALT): New macros. + 2008-07-30 Robert Dewar * make.adb: Minor reformatting diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index 9c31e46..9472995 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -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)) diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index ebc2e5e..61ae653 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -4774,6 +4774,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, { 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, Mechanism_Type mech, 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, Mechanism_Type mech, 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 size_tree, bool for_biased) /* 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: diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index aaf5e7f..685bb38 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -678,7 +678,7 @@ extern void end_subprog_body (tree body, bool elab_p); 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 template_type, tree array_type, tree expr); 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, tree init, tree result_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. */ diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 88f9a20..3b15e30 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -2368,7 +2368,8 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) else gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE, fill_vms_descriptor (gnu_actual, - gnat_formal)); + gnat_formal, + gnat_actual)); } else { diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 4188d38..01cc9b8 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -2635,7 +2635,7 @@ build_template (tree template_type, tree array_type, tree expr) 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, Mechanism_Type mech, Entity_Id gnat_entity) 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 diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 300fbd3..1ed1b9f 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -2151,15 +2151,43 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, } /* 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); -- 2.7.4