[RFC] Fix findloc prototype

[RFC] Fix findloc prototype

[Thomas Koenig]

[-- Attachment #1: Type: text/plain, Size: 1957 bytes --]

Hello world,

attached is a prototype patch to fix the findloc prototype.
So far, it is restricted to findloc, but other intrinsic functions
could be treated similarly.  The function decl now looks like this:

  <function_decl 0x7f07b1fa8b00 _gfortran_sfindloc0_r4
     type <function_type 0x7f07b1fbf348
         type <void_type 0x7f07b1debf18 void asm_written VOID
             align:8 warn_if_not_align:0 symtab:0 alias-set -1 
canonical-type 0x7f07b1debf18
             pointer_to_this <pointer_type 0x7f07b1df2000>>
         QI
         size <integer_cst 0x7f07b1dd6ca8 constant 8>
         unit-size <integer_cst 0x7f07b1dd6cc0 constant 1>
         align:8 warn_if_not_align:0 symtab:0 alias-set -1 
canonical-type 0x7f07b1fbf2a0
         attributes <tree_list 0x7f07b1fbe640
             purpose <identifier_node 0x7f07b1e48a00 fn spec>
             value <tree_list 0x7f07b1fbe618
                 value <string_cst 0x7f07b1fbe5f0 constant ". w r r r r ">>>
         arg-types <tree_list 0x7f07b1fbe500 value <reference_type 
0x7f07b1fb7738>
             chain <tree_list 0x7f07b1fbe4d8 value <reference_type 
0x7f07b1fbf0a8>
                 chain <tree_list 0x7f07b1fbe4b0 value <real_type 
0x7f07b1df22a0 real(kind=4)>
                     chain <tree_list 0x7f07b1fbe488 value <pointer_type 
0x7f07b1fac930>
                         chain <tree_list 0x7f07b1fbe460 value 
<boolean_type 0x7f07b1df8000 logical(kind=4)> chain <tree_list 
0x7f07b1deab18>>>>>>
         pointer_to_this <pointer_type 0x7f07b1fbf3f0>>
     addressable used public external QI findloc_2.f90:27:0 align:8 
warn_if_not_align:0 context <translation_unit_decl 0x7f07b1de0168 
findloc_2.f90> chain <function_decl 0x7f07b1fa8700 MAIN__>>

which looks saner to me. (The fn spec is obviously still wrong.)

@FX: Could you look at this and give some feedback if I am on the right
track here?

(BTY, I am not particularly proud of the %VAL trick here :-)

Best regards

	Thomas

[-- Attachment #2: p2a.diff --]
[-- Type: text/x-patch, Size: 7674 bytes --]

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d0cea838444..37fed61a679 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1664,6 +1664,9 @@ typedef struct gfc_symbol
   /* Set if the dummy argument of a procedure could be an array despite
      being called with a scalar actual argument. */
   unsigned maybe_array:1;
+  /* Set if this should be passed by value, but is not a VALUE argument
+     according to the Fortran standard.  */
+  unsigned pass_as_value:1;
 
   int refs;
   struct gfc_namespace *ns;	/* namespace containing this symbol */
@@ -3239,7 +3242,7 @@ bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
 bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
 
 void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *,
-				gfc_actual_arglist *);
+				gfc_actual_arglist *, bool copy_type = false);
 
 void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
 
@@ -3264,6 +3267,8 @@ void gfc_intrinsic_done_1 (void);
 
 char gfc_type_letter (bt, bool logical_equals_int = false);
 gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);
+gfc_symbol *gfc_get_intrinsic_function_symbol (gfc_expr *);
+gfc_symbol *gfc_find_intrinsic_symbol (gfc_expr *);
 bool gfc_convert_type (gfc_expr *, gfc_typespec *, int);
 bool gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int,
 			    bool array = false);
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index ef33587a774..938a2f3606b 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -122,6 +122,43 @@ gfc_get_intrinsic_sub_symbol (const char *name)
   return sym;
 }
 
+/* Get a symbol for a resolved function, with its special name.  The
+   actual argument list needs to be set by the caller.  */
+
+gfc_symbol *
+gfc_get_intrinsic_function_symbol (gfc_expr *expr)
+{
+  gfc_symbol *sym;
+
+  gfc_get_symbol (expr->value.function.name, gfc_intrinsic_namespace, &sym);
+  sym->attr.external = 1;
+  sym->attr.function = 1;
+  sym->attr.always_explicit = 1;
+  sym->attr.proc = PROC_INTRINSIC;
+  sym->attr.flavor = FL_PROCEDURE;
+  sym->result = sym;
+  if (expr->rank > 0)
+    {
+      sym->attr.dimension = 1;
+      sym->as = gfc_get_array_spec ();
+      sym->as->type = AS_ASSUMED_SHAPE;
+      sym->as->rank = expr->rank;
+    }
+  return sym;
+}
+
+/* Find a symbol for a resolved intrinsic procedure, return NULL if
+   not found.  */
+
+gfc_symbol *
+gfc_find_intrinsic_symbol (gfc_expr *expr)
+{
+  gfc_symbol *sym;
+  gfc_find_symbol (expr->value.function.name, gfc_intrinsic_namespace,
+		   0, &sym);
+  return sym;
+}
+
 
 /* Return a pointer to the name of a conversion function given two
    typespecs.  */
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index df1e8965daa..c26bb961e5d 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4650,7 +4650,7 @@ add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
 
 void
 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
-			   gfc_actual_arglist *actual)
+			   gfc_actual_arglist *actual, bool copy_type)
 {
   gfc_formal_arglist *head = NULL;
   gfc_formal_arglist *tail = NULL;
@@ -4677,13 +4677,27 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
 	      act_arg = act_arg->next;
 	      continue;
 	    }
-	  act_arg = act_arg->next;
 	}
       formal_arg = gfc_get_formal_arglist ();
       gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
 
       /* May need to copy more info for the symbol.  */
-      formal_arg->sym->ts = curr_arg->ts;
+      if (copy_type)
+	{
+	  formal_arg->sym->ts = act_arg->expr->ts;
+	  if (act_arg->expr->rank > 0)
+	    {
+	      formal_arg->sym->attr.dimension = 1;
+	      formal_arg->sym->as = gfc_get_array_spec();
+	      formal_arg->sym->as->rank = -1;
+	      formal_arg->sym->as->type = AS_ASSUMED_RANK;
+	    }
+	  if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0)
+	    formal_arg->sym->pass_as_value = 1;
+	}
+      else
+	formal_arg->sym->ts = curr_arg->ts;
+
       formal_arg->sym->attr.optional = curr_arg->optional;
       formal_arg->sym->attr.value = curr_arg->value;
       formal_arg->sym->attr.intent = curr_arg->intent;
@@ -4708,6 +4722,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
 
       /* Validate changes.  */
       gfc_commit_symbol (formal_arg->sym);
+      act_arg = act_arg->next;
     }
 
   /* Add the interface to the symbol.  */
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 3b3bd8629cd..cbd27d89a23 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4238,12 +4238,63 @@ gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
   return sym;
 }
 
+/* Remove empty actual arguments.  */
+
+static void
+remove_empty_actual_arguments (gfc_actual_arglist **ap)
+{
+  while (*ap)
+    {
+      if ((*ap)->expr == NULL)
+	{
+	  gfc_actual_arglist *r = *ap;
+	  *ap = r->next;
+	  r->next = NULL;
+	  gfc_free_actual_arglist (r);
+	}
+      else
+	ap = &((*ap)->next);
+    }
+}
+
+/* Generate the right symbol for the specific intrinsic function.  */
+
+void debug_tree (tree);
+
+static gfc_symbol *
+specific_intrinsic_symbol (gfc_se *se, gfc_expr *expr)
+{
+  gfc_symbol *sym;
+
+  gcc_assert (se->ignore_optional);
+  sym = gfc_find_intrinsic_symbol (expr);
+  if (sym == NULL)
+    {
+      sym = gfc_get_intrinsic_function_symbol (expr);
+      sym->ts = expr->ts;
+      if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
+	sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
+      
+      gfc_copy_formal_args_intr (sym, expr->value.function.isym,
+				 expr->value.function.actual, true);
+    }
+  else
+    {
+      // debug_tree (sym->backend_decl);
+    }
+  remove_empty_actual_arguments (&(expr->value.function.actual));
+  //  debug (expr);
+  // debug (sym);
+  return sym;
+}
+
 /* Generate a call to an external intrinsic function.  */
 static void
 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
 {
   gfc_symbol *sym;
   vec<tree, va_gc> *append_args;
+  bool is_findloc;
 
   gcc_assert (!se->ss || se->ss->info->expr == expr);
 
@@ -4252,7 +4303,15 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
   else
     gcc_assert (expr->rank == 0);
 
-  sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
+  is_findloc = expr->value.function.isym->id == GFC_ISYM_FINDLOC;
+
+  if (is_findloc)
+    {
+      expr = gfc_copy_expr (expr);
+      sym = specific_intrinsic_symbol (se, expr);
+    }
+  else
+    sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
 
   /* Calls to libgfortran_matmul need to be appended special arguments,
      to be able to call the BLAS ?gemm functions if required and possible.  */
@@ -4302,7 +4361,11 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
 
   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
 			  append_args);
-  gfc_free_symbol (sym);
+
+  if (is_findloc)
+    gfc_free_expr (expr);
+  else
+    gfc_free_symbol (sym);
 }
 
 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 17f3ccc1d4e..b15ea667411 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2246,7 +2246,8 @@ gfc_sym_type (gfc_symbol * sym)
   else
     type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);
 
-  if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
+  if (sym->attr.dummy && !sym->attr.function && !sym->attr.value
+      && !sym->pass_as_value)
     byref = 1;
   else
     byref = 0;

Re: [RFC] Fix findloc prototype

[FX]

Hi Thomas,

The approach is clear, and it’s also a bit of a hack. I don’t know how it could impact other code, obviously. What I am wondering is: for generating code calling intrinsics, the mechanism seems to be generic on the surface, but it is (ab)used in a weird way in a lot of cases. What I am wondering is: would it make more sense (and be more maintainable) to actually emit those special cases directly with ad hoc code (as we already do for some intrinsics) rather than (ab)use the generic mechanism in roundabout ways with tricks?

I’m not active enough these days to have a definitive opinion on the patch, let alone a review, sadly.

FX

Re: [RFC] Fix findloc prototype

[Thomas Koenig]

Am 04.10.20 um 21:32 schrieb FX:
> Hi Thomas,
> 
> The approach is clear, and it’s also a bit of a hack.

I concur :-)

> I don’t know how it could impact other code, obviously.

Not a lot, I guess.


> What I am wondering is: for generating code calling intrinsics,

> the mechanism seems to be generic on the surface, but it is > (ab)used in a weird way in a lot of cases.

That is a fairly good description of a lot of trans-*, I guess.

> What I am wondering is: would it make more sense (and be > more maintainable) to actually emit those special cases
> directly with ad hoc code (as we already do for some intrinsics) > rather than (ab)use the generic mechanism in roundabout ways with> 
tricks?

In principle, you're right. That was what I was setting out to
do, when I saw that the code could already work "as is"
for a proof of principle.

For generating the prototypes, we can indeed use the mechanisms that are
there.  For emitting the calls themselves, it would definitely be
cleaner to separate that into its own code path.

But even if we do nothing more than what was in the patch, with
just correcting the prototypes, we could at least factor out
se->ignore_optional, which would make the code a tiny little
bit clearer.

However, there is one important question:  Does this patch actually
work in the sense that it at least partially resolves the ABI issues
on the MacOS ARM?  Unfortunately, I don't have a machine to test this
on (or would it be possible to get access?).

Best regards

	Thomas