gigi.h (build_vms_descriptor64): New function prototype.

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.

From-SVN: r138307

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c5409d3..aa6615c 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,23 @@
+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.
+
 2008-07-30  Robert Dewar  <dewar@adacore.com>
 
        * 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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));
 }
 \f
-/* 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 (file)
--- 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,
 }
 \f
 /* 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);