Merge pull request #817 from ThePortlandGroup/nv_stage

Pull 2019-10-22T14-00 Recent NVIDIA Changes

Author: sscalpone

runtime/flang/dist.c

@@ -1,5 +1,5 @@
 /*
- * Copyright (c) 1995-2018, NVIDIA CORPORATION.  All rights reserved.
+ * Copyright (c) 1995-2019, NVIDIA CORPORATION.  All rights reserved.
  *
  * Licensed under the Apache License, Version 2.0 (the "License");
  * you may not use this file except in compliance with the License.
@@ -2863,8 +2863,9 @@ ENTFTN(SIZE, size)(__INT_T *dim, F90_Desc *pd)
 {
   __INT_T size;
 
-  if (F90_TAG_G(pd) != __DESC)
-    __fort_abort("SIZE: arg not associated with array");
+  if (F90_TAG_G(pd) != __DESC) {
+    return 1;
+  }
   if (!ISPRESENT(dim))
     size = F90_GSIZE_G(pd);
   else if (*dim < 1 || *dim > F90_RANK_G(pd))

runtime/flang/type.c

@@ -830,6 +830,11 @@ void ENTF90(DEALLOC_POLY_MBR03A,
       if (!g1 && !I8(__fort_allocated)(cb)) {
         continue;
       }
+      if (ld->tag == 'T') {
+        /* Need to deallocate allocatable component */
+        ENTF90(DEALLOC_MBR03, dealloc_mbr03)
+        (stat, cb, firsttime, CADR(errmsg), CLEN(errmsg));
+      }
     }
   }
   ENTF90(DEALLOC_MBR03, dealloc_mbr03)
@@ -1085,7 +1090,7 @@ get_source_and_dest_sizes(F90_Desc *ad, F90_Desc *bd,
       *src_sz = 0;
     }
   } else if (bd && !flag && ISSCALAR(bd) && bd->tag != __POLY &&
-             bd->tag < __NTYPES) {
+             bd->tag != __STR && bd->tag < __NTYPES) {
 #if defined(WINNT)
     *src_sz = __get_fort_size_of(bd->tag);
 #else
@@ -1103,9 +1108,10 @@ get_source_and_dest_sizes(F90_Desc *ad, F90_Desc *bd,
                dest_td->obj.tag == __POLY && ad->len > 0 && !ad->lsize &&
                !ad->gsize && ad->kind > 0 && ad->kind < __NTYPES) {
       *dest_sz = (size_t)dest_td->obj.size * ad->len;
-    } else if (!*src_sz || ((flag == 1 || (ad && ad->tag == __DESC)) && 
+    } else if (!*src_sz || ((flag == 1 || (ad && ad->tag == __DESC)) &&
                            dest_td->obj.tag == __POLY)) { 
-      *dest_sz = (size_t)dest_td->obj.size;
+      *dest_sz = dest_td != I8(__f03_ty_to_id)[__STR] ? 
+                 (size_t)dest_td->obj.size : ad->len;
     } else {
       *dest_sz = 0;
     }

test/f90_correct/inc/en01.mk

@@ -0,0 +1,35 @@
+#
+# Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+#     http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+#
+#
+########## Make rule for test en01  ########
+
+
+en01: run
+	
+
+build:  $(SRC)/en01.f90
+	-$(RM) en01.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.*
+	@echo ------------------------------------ building test $@
+	-$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/en01.f90 -o en01.$(OBJX)
+	-$(FC) $(FFLAGS) $(LDFLAGS) en01.$(OBJX) $(LIBS) -o en01.$(EXESUFFIX)
+
+
+run: 
+	@echo ------------------------------------ executing test en01
+	en01.$(EXESUFFIX)
+
+verify: ;
+

test/f90_correct/lit/en01.sh

@@ -0,0 +1,19 @@
+#
+# Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+#     http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+# Shared lit script for each tests. Run bash commands that run tests with make.
+
+# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t 
+# RUN: cat %t | FileCheck %S/runmake

test/f90_correct/src/en01.f90

@@ -0,0 +1,36 @@
+! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+!
+
+subroutine foo()
+  print *, 'PASS'
+end subroutine foo
+
+subroutine bar(msg, func)
+  character(len=1) msg
+  external func
+  return
+  entry alt_bar(func)
+  call func()
+  return
+end subroutine bar
+
+interface
+   subroutine foo()
+   end subroutine foo
+end interface
+
+call alt_bar(foo)
+end program
+

tools/flang1/flang1exe/dtypeutl.c

@@ -2543,6 +2543,10 @@ getdtype(DTYPE dtype, char *ptr)
           strcpy(p, " assumedshape");
           p += strlen(p);
         }
+        if (AD_ASSUMRANK(ad) == 1) {
+          strcpy(p, " assumedrank");
+          p += strlen(p);
+        }
         if (AD_ASSUMSHP(ad) == 2) {
           strcpy(p, " wasassumedshape");
           p += strlen(p);
@@ -2776,6 +2780,7 @@ _dmp_dent(DTYPE dtypeind, FILE *outfile)
             numdim, AD_DEFER(ad), AD_ADJARR(ad), AD_ASSUMSZ(ad),
             AD_NOBOUNDS(ad));
     fprintf(outfile, "  assumshp:%d\n", AD_ASSUMSHP(ad));
+    fprintf(outfile, "  assumrank:%d\n", AD_ASSUMRANK(ad));
     fprintf(outfile, "        zbase: %d   numelm: %d\n", AD_ZBASE(ad),
             AD_NUMELM(ad));
     if (numdim < 1 || numdim > 7)

tools/flang1/flang1exe/dump.c

@@ -2825,6 +2825,8 @@ dsym(int sptr)
     ASSUMLENP(0, 0);
     putbit("assumshp", ASSUMSHPG(0));
     ASSUMSHPP(0, 0);
+    putbit("assumrank", ASSUMRANKG(0));
+    ASSUMRANKP(0, 0);
     putbit("asumsz", ASUMSZG(0));
     ASUMSZP(0, 0);
     putbit("ccsym", CCSYMG(0));
@@ -4296,6 +4298,7 @@ dumpdt(int dt)
       putbit("adjarr", ADD_ADJARR(dt));
       putbit("assumedsize", ADD_ASSUMSZ(dt));
       putbit("assumedshape", ADD_ASSUMSHP(dt));
+      putbit("assumedrank", ADD_ASSUMRANK(dt));
       putbit("defer", ADD_DEFER(dt));
       putbit("nobounds", ADD_NOBOUNDS(dt));
       putast("zbase", ADD_ZBASE(dt));

tools/flang1/flang1exe/func.c

@@ -3986,7 +3986,23 @@ rewrite_calls(void)
               is_or_has_poly(sptr_lhs) ||
               has_length_type_parameter_use(DTYPEG(sptr_lhs)) ||
               (sptr2 && !ALLOCATTRG(sptr_lhs) && has_poly_mbr(sptr_lhs, 1))) {
+            int alloc_source;
+            DTYPE source_dtype;
             check_alloc_ptr_type(sptr_lhs, std, a, 1, 1, A_SRCG(ast), astmem);
+            alloc_source = A_STARTG(ast);
+            source_dtype = DTYPEG(sptr2);
+            if (alloc_source > 0 && (DTY(DDTG(source_dtype)) == TY_CHAR ||
+                DTY(DDTG(source_dtype)) == TY_NCHAR)) {
+              /* This is a sourced allocation with a character source argument. 
+               * Need to make sure we assign the character object's length to
+               * the receiver's descriptor.
+               */
+              int len = ast_intr(I_LEN, astb.bnd.dtype, 1, 
+                                 A_TYPEG(alloc_source) == A_SUBSCR ?
+                                 A_LOPG(alloc_source) : alloc_source);
+              len = gen_set_len_ast(A_SRCG(ast), SDSCG(sptr_lhs), len);
+              add_stmt_after(len, std);
+            }
           }
         }
       }

tools/flang1/flang1exe/outconv.c

@@ -1106,6 +1106,7 @@ _simple_replacements(int ast, int *pany)
         int newast;
         char *fname;
         int in_device_code;
+        SPTR sptr;
         fname = SYMNAME(fsptr);
         newast = ast;
         in_device_code = 0;
@@ -1116,6 +1117,10 @@ _simple_replacements(int ast, int *pany)
         } else if (strcmp(fname, mkRteRtnNm(RTE_extent)) == 0) {
           newast = _pghpf_size(0, ast);
         } else if (strcmp(fname, mkRteRtnNm(RTE_sizeDsc)) == 0) {
+          newast = ARGT_ARG(A_ARGSG(ast), 1);
+          if (A_TYPEG(newast) == A_ID && ASSUMRANKG(A_SPTRG(newast))) {
+            return;
+          }
           newast = _pghpf_size(1, ast);
         } else if (strcmp(fname, mkRteRtnNm(RTE_size)) == 0) {
           newast = _RTE_size(ast);
@@ -2204,6 +2209,36 @@ _sd_member(int subscript, int sdx, int sdtype)
   return mk_subscr(sdx, subscr, 1, sdtype);
 } /* _sd_member */
 
+/** \brief This routine assigns a size to a descriptor's length field.
+ *
+ * \param ast is the expression that has the descriptor 
+ *        (e.g., an A_ID, A_MEM, etc.).
+ * \param ddesc is the symbol table pointer of the descriptor.
+ * \param sz is the AST representing the size.
+ *
+ * \return the resulting assignment AST.
+ */
+int
+gen_set_len_ast(int ast, SPTR ddesc, int sz)
+{
+
+  DTYPE dtype;
+  int ast2;
+
+  dtype = astb.bnd.dtype;
+
+  ast2 = mk_id(ddesc);
+  ast2 = _sd_member(DESC_HDR_BYTE_LEN, ast2, dtype);
+  A_DTYPEP(ast2, dtype);
+
+  ast2 = check_member(ast, ast2);
+
+  return mk_assn_stmt(ast2, sz, dtype);
+
+}
+
+
+
 LOGICAL
 inline_RTE_set_type(int ddesc, int sdesc, int stmt, int after,
                       DTYPE src_dtype, int astmem)

tools/flang1/flang1exe/rest.c

@@ -1962,7 +1962,50 @@ transform_call(int std, int ast)
           ARGT_ARG(newargt, newj) = pghpf_type(ty);
           ++newj;
         } else if (SDSCG(sptr)) {
-
+         /*
+          * If the array descriptor comes from the parent subprogram (Fortran
+          * term, host subprogram), the INTERNREF flag of array descriptor must
+          * be set. The missing case here is when the array is a static member
+          * of derived type var and the derived type var is defined in parent
+          * routine, the array descriptor is not set.  The following code is to
+          * detect such case.
+          */
+
+          SPTR sdsdsptr = SDSCG(sptr); 
+          
+         /* Condition gbl.internal > 1 is to make sure that the current
+          * function is a contained subprogram. 
+          *   gbl.internal = 0, there is no contained subprogram. 
+          *   gbl.internal = 1, the current routine at least has a contain 
+          *   statement.
+          *   gbl.internal > 1, the current routine is contained subprogram. 
+          * A_TYPEG(ele) == A_MEM && needdescr && gbl.internal > 1
+          * is to make sure that the descriptor is for an array
+          * member in a derived-type variable if it is not an array variable
+          * member in the derived-type, the INTERNREF flag of its descriptor
+          * should be set in routine set_internref_flag in semsym.c.
+          * 
+          * SCOPEG(sdsdsptr) && STYPEG(SCOPEG(sdsdsptr)) != ST_MODULE &&
+          * SCOPEG(sdsdsptr) == SCOPEG(gbl.currsub) is to make sure that the
+          * sdsc is a reference from the parent routine.
+          *
+          * Note that the fortran can only contain one-level depth of
+          * subprogram. The contained subprogram cannot contain any
+          * subprograms.
+          */       
+          if (gbl.internal > 1 && A_TYPEG(ele) == A_MEM && needdescr &&
+             SCOPEG(sdsdsptr) && STYPEG(SCOPEG(sdsdsptr)) != ST_MODULE && 
+             SCOPEG(sdsdsptr) == SCOPEG(gbl.currsub)) {
+             /* Pointer to the section descriptor created by the front-end 
+              * (or any phase before transform()). If the field is non-zero, 
+              * the transformer uses the descriptor located by this field; 
+              * the actual symbol located by this field is a based/allocatable
+              * array. 
+              */
+             if (SECDSCG(sdsdsptr))
+               sdsdsptr = SECDSCG(sdsdsptr);
+             INTERNREFP(sdsdsptr, TRUE);
+          }
           ARGT_ARG(newargt, newj) = check_member(ele, mk_id(SDSCG(sptr)));
           DESCUSEDP(sptr, 1);
           NODESCP(sptr, 0);
@@ -2007,6 +2050,20 @@ transform_call(int std, int ast)
           handle_seq_section(entry, ele, i, std, &retval, &descr, 1,
                              inface_arg);
         } else {
+          SPTR descr_sptr = DESCRG(sptr);
+          /* Set the INTERNREF flag of array descriptor to make sure host
+             subroutines' array descriptor is accessible for contained
+             subroutines. 
+           */
+          if (gbl.internal > 1 && A_TYPEG(ele) == A_MEM && needdescr && 
+              descr_sptr > NOSYM && SCOPEG(descr_sptr) && 
+              STYPEG(SCOPEG(descr_sptr)) != ST_MODULE &&
+              SCOPEG(descr_sptr) == SCOPEG(gbl.currsub)) {
+             if (SECDSCG(descr_sptr))
+               descr_sptr = SECDSCG(descr_sptr);
+
+             INTERNREFP(descr_sptr, TRUE);
+          }
           retval = ele;
           descr = check_member(retval, mk_id(DESCRG(sptr)));
         }
@@ -3690,7 +3747,8 @@ is_desc_needed(int entry, int arr_ast, int loc)
   /* only user procedure may not need descr */
   if (iface && HCCSYMG(iface))
     return TRUE;
-  if (iface && STYPEG(entry) != ST_PROC && STYPEG(entry) != ST_ENTRY)
+  if (iface && STYPEG(entry) != ST_PROC && STYPEG(entry) != ST_ENTRY
+  && (STYPEG(entry) != ST_MEMBER || !VTABLEG(entry)) && !is_procedure_ptr(entry))
     return TRUE;
   /* for F90, F77, C, need descriptor if copy-in is needed */
   if (!dscptr)