diff mbox

[Fortran] PR 41580 Add compile-time simplification for Same_Type_As and Extends_Type_Of

Message ID 4D271F7D.2040608@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Jan. 7, 2011, 2:13 p.m. UTC 
Hello Janus,

On 01/07/2011 02:03 PM, Janus Weil wrote:
> Some comments:
> 3) Could you expand a bit on why a BT_DERIVED would be simplified to
> .false.? I don't quite get that part ...

You mean the vtab part? Well, currently, for BT_CLASS one calls 
resolve_function. Via resolve_intrinsic the simplify function is first 
called - and as both arguments are BT_CLASS, "NULL" is returned.* Then 
one calls resolve_unknown_f, which via gfc_intrinsic_func_interface 
resolves the arguments - that is it replaces the variables of type 
BT_CLASS by the vtab entries which are of type BT_DERIVED. Afterwards, 
the gfc_simplify_{same_type_as,extends_type_of} function is called 
again. As then the arguments are BT_DERIVED and not BT_CLASS, they can 
directly be evaluated at compile time - and as the two vtab variable 
references are (usually) different, the result is (usually) false. -- 
Thus, one needs to exit if the arguments are already resolved to vtabs.

* For BT_CLASS a NULL is only returned if the types have the chance to 
be the same. Thus, if they have neither the same declared type nor one 
declared-type is the supertype of the other, one knows that the answer 
must be .FALSE., which is what the patch does.

Tobias

Comments

Janus Weil Jan. 7, 2011, 3:31 p.m. UTC | #1 
>> Some comments:
>> 3) Could you expand a bit on why a BT_DERIVED would be simplified to
>> .false.? I don't quite get that part ...
>
> You mean the vtab part? Well, currently, for BT_CLASS one calls
> resolve_function. Via resolve_intrinsic the simplify function is first
> called - and as both arguments are BT_CLASS, "NULL" is returned.* Then one
> calls resolve_unknown_f, which via gfc_intrinsic_func_interface resolves the
> arguments - that is it replaces the variables of type BT_CLASS by the vtab
> entries which are of type BT_DERIVED. Afterwards, the
> gfc_simplify_{same_type_as,extends_type_of} function is called again. As
> then the arguments are BT_DERIVED and not BT_CLASS, they can directly be
> evaluated at compile time - and as the two vtab variable references are
> (usually) different, the result is (usually) false. -- Thus, one needs to
> exit if the arguments are already resolved to vtabs.

Ok, got it. Thanks for the clarification.

The new version is ok for trunk from my side.

Cheers,
Janus
diff mbox

Patch

2011-01-07  Tobias Burnus  <burnus@net-b.de>

	PR fortran/41580
	* class.c (gfc_build_class_symbol): Mark __vtab as attr.vtab.
	* intrinsic.c (add_functions): Use simplify functions for
	EXTENDS_TYPE_OF and SAME_TYPE_AS.
	* intrinsic.h (gfc_simplify_extends_type_of,
	gfc_simplify_same_type_as): New prototypes.
	* simplify.c (is_last_ref_vtab, gfc_simplify_extends_type_of,
        gfc_simplify_same_type_as): New functions.

2011-01-07  Tobias Burnus  <burnus@net-b.de>

	PR fortran/41580
	* gfortran.dg/extends_type_of_3.f90: New.

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index d17544c..9458ca9 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1,7 +1,7 @@ 
 /* Build up a list of intrinsic subroutines and functions for the
    name-resolution stage.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-   2009, 2010
+   2009, 2010, 2011
    Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
@@ -1663,7 +1663,8 @@  add_functions (void)
 
   add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
 	     ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
-	     gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of,
+	     gfc_check_same_type_as, gfc_simplify_extends_type_of,
+	     gfc_resolve_extends_type_of,
 	     a, BT_UNKNOWN, 0, REQUIRED,
 	     mo, BT_UNKNOWN, 0, REQUIRED);
 
@@ -2481,7 +2482,7 @@  add_functions (void)
 
   add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO,
 	     BT_LOGICAL, dl, GFC_STD_F2003,
-	     gfc_check_same_type_as, NULL, NULL,
+	     gfc_check_same_type_as, gfc_simplify_same_type_as, NULL,
 	     a, BT_UNKNOWN, 0, REQUIRED,
 	     b, BT_UNKNOWN, 0, REQUIRED);
 
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index e9574e8..540cc8e 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -1,7 +1,7 @@ 
 /* Header file for intrinsics check, resolve and simplify function
    prototypes.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-   2010 Free Software Foundation, Inc.
+   2010, 2011 Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
 This file is part of GCC.
@@ -267,6 +267,7 @@  gfc_expr *gfc_simplify_erfc (gfc_expr *);
 gfc_expr *gfc_simplify_erfc_scaled (gfc_expr *);
 gfc_expr *gfc_simplify_exp (gfc_expr *);
 gfc_expr *gfc_simplify_exponent (gfc_expr *);
+gfc_expr *gfc_simplify_extends_type_of (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_float (gfc_expr *);
 gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_fraction (gfc_expr *);
@@ -351,6 +352,7 @@  gfc_expr *gfc_simplify_reshape (gfc_expr *, gfc_expr *, gfc_expr *,
 				gfc_expr *);
 gfc_expr *gfc_simplify_rrspacing (gfc_expr *);
 gfc_expr *gfc_simplify_rshift (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_same_type_as (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index e45ed40..3beac15 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -1,6 +1,6 @@ 
 /* Simplify intrinsic functions at compile-time.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-   2010 Free Software Foundation, Inc.
+   2010, 2011 Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
 This file is part of GCC.
@@ -2202,6 +2202,93 @@  gfc_simplify_float (gfc_expr *a)
 }
 
 
+static bool
+is_last_ref_vtab (gfc_expr *e)
+{
+  gfc_ref *ref;
+  gfc_component *comp = NULL;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      comp = ref->u.c.component;
+
+  if (!e->ref || !comp)
+    return e->symtree->n.sym->attr.vtab;
+
+  if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
+    return true;
+
+  return false;
+}
+
+
+gfc_expr *
+gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
+{
+  /* Avoid simplification of resolved symbols.  */
+  if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
+    return NULL;
+
+  if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+				 gfc_type_is_extension_of (mold->ts.u.derived,
+							   a->ts.u.derived));
+  /* Return .false. if the dynamic type can never be the same.  */
+  if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
+       && !gfc_type_is_extension_of
+			(mold->ts.u.derived->components->ts.u.derived,
+			 a->ts.u.derived->components->ts.u.derived)
+       && !gfc_type_is_extension_of
+			(a->ts.u.derived->components->ts.u.derived,
+			 mold->ts.u.derived->components->ts.u.derived))
+      || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
+	  && !gfc_type_is_extension_of
+			(a->ts.u.derived,
+			 mold->ts.u.derived->components->ts.u.derived)
+	  && !gfc_type_is_extension_of
+			(mold->ts.u.derived->components->ts.u.derived,
+			 a->ts.u.derived))
+      || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
+	  && !gfc_type_is_extension_of
+			(mold->ts.u.derived,
+			 a->ts.u.derived->components->ts.u.derived)))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+  if (mold->ts.type == BT_DERIVED
+      && gfc_type_is_extension_of (mold->ts.u.derived,
+				   a->ts.u.derived->components->ts.u.derived))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
+
+  return NULL;
+}
+
+
+gfc_expr *
+gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+  /* Avoid simplification of resolved symbols.  */
+  if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
+    return NULL;
+
+  /* Return .false. if the dynamic type can never be the
+     same.  */
+  if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS)
+      && !gfc_type_compatible (&a->ts, &b->ts)
+      && !gfc_type_compatible (&b->ts, &a->ts))
+    return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+  if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
+     return NULL;
+
+  return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+			       gfc_compare_derived_types (a->ts.u.derived,
+							  b->ts.u.derived));
+}
+
+
 gfc_expr *
 gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
 {
diff --git a/gcc/testsuite/gfortran.dg/extends_type_of_3.f90 b/gcc/testsuite/gfortran.dg/extends_type_of_3.f90
new file mode 100644
index 0000000..346542f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/extends_type_of_3.f90
@@ -0,0 +1,111 @@ 
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/41580
+!
+! Compile-time simplification of SAME_TYPE_AS
+! and EXTENDS_TYPE_OF.
+!
+
+implicit none
+type t1
+  integer :: a
+end type t1
+type, extends(t1):: t11
+  integer :: b
+end type t11
+type, extends(t11):: t111
+  integer :: c
+end type t111
+type t2
+  integer :: a
+end type t2
+
+type(t1) a1
+type(t11) a11
+type(t2) a2
+class(t1), allocatable :: b1
+class(t11), allocatable :: b11
+class(t2), allocatable :: b2
+
+logical, parameter :: p1 = same_type_as(a1,a2)  ! F
+logical, parameter :: p2 = same_type_as(a2,a1)  ! F
+logical, parameter :: p3 = same_type_as(a1,a11) ! F
+logical, parameter :: p4 = same_type_as(a11,a1) ! F
+logical, parameter :: p5 = same_type_as(a11,a11)! T
+logical, parameter :: p6 = same_type_as(a1,a1)  ! T
+
+if (p1 .or. p2 .or. p3 .or. p4 .or. .not. p5 .or. .not. p6) call should_not_exist()
+
+! Not (trivially) compile-time simplifiable:
+if (same_type_as(b1,a1)  .neqv. .true.) call abort()
+if (same_type_as(b1,a11) .neqv. .false.) call abort()
+allocate(t1 :: b1)
+if (same_type_as(b1,a1)  .neqv. .true.) call abort()
+if (same_type_as(b1,a11) .neqv. .false.) call abort()
+deallocate(b1)
+allocate(t11 :: b1)
+if (same_type_as(b1,a1)  .neqv. .false.) call abort()
+if (same_type_as(b1,a11) .neqv. .true.) call abort()
+deallocate(b1)
+
+! .true. -> same type
+if (extends_type_of(a1,a1)   .neqv. .true.) call should_not_exist()
+if (extends_type_of(a11,a11) .neqv. .true.) call should_not_exist()
+if (extends_type_of(a2,a2)   .neqv. .true.) call should_not_exist()
+
+! .false. -> type compatibility possible
+if (extends_type_of(a1,a2)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(a2,a1)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(a11,a2) .neqv. .false.) call should_not_exist()
+if (extends_type_of(a2,a11) .neqv. .false.) call should_not_exist()
+
+if (extends_type_of(b1,b2)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(b2,b1)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(b11,b2) .neqv. .false.) call should_not_exist()
+if (extends_type_of(b2,b11) .neqv. .false.) call should_not_exist()
+
+if (extends_type_of(b1,a2)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(b2,a1)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(b11,a2) .neqv. .false.) call should_not_exist()
+if (extends_type_of(b2,a11) .neqv. .false.) call should_not_exist()
+
+if (extends_type_of(a1,b2)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(a2,b1)  .neqv. .false.) call should_not_exist()
+if (extends_type_of(a11,b2) .neqv. .false.) call should_not_exist()
+if (extends_type_of(a2,b11) .neqv. .false.) call should_not_exist()
+
+! type extension possible, compile-time checkable
+if (extends_type_of(a1,a11) .neqv. .false.) call should_not_exist()
+if (extends_type_of(a11,a1) .neqv. .true.) call should_not_exist()
+if (extends_type_of(a1,a11) .neqv. .false.) call should_not_exist()
+
+if (extends_type_of(b1,a1)   .neqv. .true.) call should_not_exist()
+if (extends_type_of(b11,a1)  .neqv. .true.) call should_not_exist()
+if (extends_type_of(b11,a11) .neqv. .true.) call should_not_exist()
+if (extends_type_of(b1,a11)  .neqv. .false.) call should_not_exist()
+
+if (extends_type_of(a1,b11)  .neqv. .false.) call abort()
+
+! Special case, simplified at tree folding:
+if (extends_type_of(b1,b1)   .neqv. .true.) call abort()
+
+! All other possibilities are not compile-time checkable
+if (extends_type_of(b11,b1)  .neqv. .true.) call abort()
+!if (extends_type_of(b1,b11)  .neqv. .false.) call abort() ! FAILS due to PR 47189
+if (extends_type_of(a11,b11) .neqv. .true.) call abort()
+allocate(t11 :: b11)
+if (extends_type_of(a11,b11) .neqv. .true.) call abort()
+deallocate(b11)
+allocate(t111 :: b11)
+if (extends_type_of(a11,b11) .neqv. .false.) call abort()
+deallocate(b11)
+allocate(t11 :: b1)
+if (extends_type_of(a11,b1) .neqv. .true.) call abort()
+deallocate(b1)
+
+end
+
+! { dg-final { scan-tree-dump-times "abort" 13 "original" } }
+! { dg-final { scan-tree-dump-times "should_not_exist" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }