Merge pull request #841 from ThePortlandGroup/nv_stage

sscalpone · web-flow · commit 619685549603 · 2019-11-28T18:21:36.000-06:00
Pull 2019-11-26T15-28 Recent NVIDIA Changes
diff --git a/runtime/flang/allo.c b/runtime/flang/allo.c
@@ -396,6 +396,17 @@ I8(__alloc04)(__NELEM_T nelem, dtype kind, size_t len,
   if (!ISPRESENT(errmsg))
     errmsg = NULL;
 
+  if (*pointer && I8(__fort_allocated)(*pointer)
+      && ISPRESENT(stat) && *stat == 2) {
+    int i;
+    char *mp;
+    MP_P_STDIO;
+    mp = "array already allocated";
+    for (i = 0; i < errlen; i++)
+      errmsg[i] = (*mp ? *mp++ : ' ');
+    MP_V_STDIO;
+  }
+
 #if (defined(WIN64) || defined(WIN32))
 #define ALN_LARGE
 #else
@@ -912,7 +923,13 @@ ENTF90(ALLOC03_CHKA, alloc03_chka)(__INT_T *nelem, __INT_T *kind, __INT_T *len,
 {
 
   if (*pointer && I8(__fort_allocated)(*pointer)) {
-    __fort_abort("ALLOCATE: array already allocated");
+    if (ISPRESENT(stat)) {
+      *stat = 2;
+    } else {
+      __fort_abort("ALLOCATE: array already allocated");
+    }
+  } else if (ISPRESENT(stat) && *firsttime) {
+    *stat = 0;
   }
   ENTF90(ALLOC03,alloc03)(nelem, kind, len, stat, pointer, offset,
                             firsttime,CADR(errmsg), CLEN(errmsg));
@@ -937,7 +954,7 @@ ENTF90(ALLOC04A, alloc04a)(__NELEM_T *nelem, __INT_T *kind, __INT_T *len,
 {
   ALLHDR();
 
-  if (ISPRESENT(stat) && *firsttime)
+  if (ISPRESENT(stat) && *firsttime && *stat != 2)
     *stat = 0;
 
   if (!ISPRESENT(stat) && !*align) {
@@ -977,7 +994,13 @@ ENTF90(ALLOC04_CHKA, alloc04_chka)(__NELEM_T *nelem, __INT_T *kind,
 {
 
   if (*pointer && I8(__fort_allocated)(*pointer)) {
-    __fort_abort("ALLOCATE: array already allocated");
+    if (ISPRESENT(stat)) {
+      *stat = 2;
+    } else {
+      __fort_abort("ALLOCATE: array already allocated");
+    }
+  } else if (ISPRESENT(stat) && *firsttime) {
+    *stat = 0;
   }
   ENTF90(ALLOC04,alloc04)(nelem, kind, len, stat, pointer, offset, firsttime,
            align, CADR(errmsg), CLEN(errmsg));
diff --git a/runtime/flang/rdst.c b/runtime/flang/rdst.c
@@ -32,7 +32,7 @@ ENTFTN(TEMPLATE, template)(F90_Desc *dd, __INT_T *p_rank,
 
 #include <string.h>
 #include "fort_vars.h"
-#if defined(TARGET_LINUX_X8664) || defined (TARGET_LINUX_POWER) || defined(TARGET_OSX_X8664)
+#if defined(TARGET_LINUX_X8664) || defined (TARGET_LINUX_POWER) || defined(TARGET_OSX_X8664)   || defined(TARGET_LINUX_ARM32)  || defined(TARGET_LINUX_ARM64)
 #include <unistd.h>
 #include <sys/wait.h>
 #endif
@@ -2849,7 +2849,7 @@ ENTF90(EXECCMDLINE, execcmdline)(DCHAR(command), __LOG_T *wait,
 
   if (cmdstat)
     store_int_kind(cmdstat, cmdstat_int_kind, 0);
-#if defined(TARGET_LINUX_X8664) || defined(TARGET_OSX_X8664) || defined (TARGET_LINUX_POWER)
+#if defined(TARGET_LINUX_X8664) || defined(TARGET_OSX_X8664) || defined(TARGET_LINUX_POWER) || defined(TARGET_LINUX_ARM32) || defined(TARGET_LINUX_ARM64)
   pid_t pid, w;
   int wstatus, ret;
   
diff --git a/runtime/flang/type.c b/runtime/flang/type.c
@@ -36,6 +36,7 @@ static void sourced_alloc_and_assign_array(int extent, char *ab, char *bb, TYPE_
 static void sourced_alloc_and_assign_array_from_scalar(int extent, char *ab, char *bb, TYPE_DESC *td);
 
 static void get_source_and_dest_sizes(F90_Desc *ad, F90_Desc *bd, int *dest_sz, int *src_sz, int *dest_is_array, int *src_is_array, TYPE_DESC **tad, TYPE_DESC **tbd, __INT_T flag);
+static int has_intrin_type(F90_Desc *dd);
 
 #define ARG1_PTR 0x1
 #define ARG1_ALLOC 0x2
@@ -1676,6 +1677,8 @@ static struct type_desc *I8(__f03_ty_to_id)[__NTYPES] = {
     0,
     0,
     0,
+    0,
+    0,
     0};
 
 void ENTF90(SET_INTRIN_TYPE, set_intrin_type)(F90_Desc *dd, __INT_T intrin_type)
@@ -1829,6 +1832,31 @@ void ENTF90(POLY_ASN_DEST_INTRIN,
   ENTF90(POLY_ASN, poly_asn)(ab, ad, bb, bd, flag);
 }
 
+/** \brief This routine checks whether a descriptor is associated with an
+ *         intrinsic type.
+ *
+ *  \param dd is the descriptor we are testing.
+ *
+ *  \return 1 if \param dd is associated with an intinsinc type, else 0.
+ */
+static int has_intrin_type(F90_Desc *dd)
+{
+  int i;
+  OBJECT_DESC *td = (OBJECT_DESC *)dd; 
+  int is_intrin_type = 0;
+
+  if (td->type == NULL)
+    return 0;
+  
+  for(i=0; i < __NTYPES; ++i) {
+    if (td->type == I8(__f03_ty_to_id)[i]) {
+      return 1;
+    }
+  }
+
+  return 0;
+}
+
 void ENTF90(INIT_UNL_POLY_DESC, init_unl_poly_desc)(F90_Desc *dd, F90_Desc *sd,
                                                     __INT_T kind)
 {
@@ -1842,12 +1870,16 @@ void ENTF90(INIT_UNL_POLY_DESC, init_unl_poly_desc)(F90_Desc *dd, F90_Desc *sd,
       }
       dd->kind = kind;
     } else {
-      dd->len = (sd && sd->tag == __DESC) ? sd->len : 0;
-      dd->tag = __DESC;
+      dd->len = (sd && (sd->tag == __DESC || sd->tag == __POLY)) ? sd->len : 0;
+      dd->tag = __POLY;
       dd->rank = 0;
       dd->lsize = 0;
       dd->gsize = 0;
       dd->kind = kind;
+      if (sd && (sd->tag == __DESC || sd->tag == __POLY || 
+          has_intrin_type(sd))) {
+        ENTF90(SET_TYPE, set_type)(dd, sd);
+      }
     }
 }
 
diff --git a/test/f90_correct/inc/pp73.mk b/test/f90_correct/inc/pp73.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 pp73  ########
+
+
+pp73: run
+	
+
+build:  $(SRC)/pp73.f90
+	-$(RM) pp73.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.*
+	@echo ------------------------------------ building test $@
+	-$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/pp73.f90 -o pp73.$(OBJX)
+	-$(FC) $(FFLAGS) $(LDFLAGS) pp73.$(OBJX) $(LIBS) -o pp73.$(EXESUFFIX)
+
+
+run: 
+	@echo ------------------------------------ executing test pp73
+	pp73.$(EXESUFFIX)
+
+verify: ;
+
diff --git a/test/f90_correct/lit/pp73.sh b/test/f90_correct/lit/pp73.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
diff --git a/test/f90_correct/src/pp73.f90 b/test/f90_correct/src/pp73.f90
@@ -0,0 +1,32 @@
+! 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.
+!
+! 
+! Tests subscripted pointer expressions that point to non-contiguous array
+! sections.
+
+program main
+  integer, pointer :: p1(:), p2(:)
+  integer, target :: a(20)
+  integer :: expect(8) = [3, 5, 7, 9, 11, 13, 15, 17]
+  integer :: j
+  a = [(j,j=1,20)]
+  p1 => a(::2)
+  p2(1:8) => p1(2:9)
+  if (all(p2 .eq. expect)) then
+    print *, 'PASS'
+  else
+    print *, 'FAIL'
+  endif
+end program main
diff --git a/tools/flang1/flang1exe/ast.c b/tools/flang1/flang1exe/ast.c
@@ -3429,6 +3429,10 @@ simply_contiguous(int arr_ast)
     }
     break;
   case A_SUBSCR:
+    sptr = memsym_of_ast(arr_ast);
+    if (POINTERG(sptr)) {
+      return CONTIGATTRG(sptr);
+    }
     return contiguous_array_section(arr_ast);
   }
 
diff --git a/tools/flang1/flang1exe/rest.c b/tools/flang1/flang1exe/rest.c
@@ -2050,6 +2050,10 @@ transform_call(int std, int ast)
           handle_seq_section(entry, ele, i, std, &retval, &descr, 1,
                              inface_arg);
         } else {
+          if (!DESCRG(sptr)) {
+            get_static_descriptor(sptr);
+            get_all_descriptors(sptr);
+          }
           SPTR descr_sptr = DESCRG(sptr);
           /* Set the INTERNREF flag of array descriptor to make sure host
              subroutines' array descriptor is accessible for contained
diff --git a/tools/flang1/flang1exe/semant.c b/tools/flang1/flang1exe/semant.c
@@ -11383,6 +11383,7 @@ semant1(int rednum, SST *top)
         copy_sym_flags(sym, proc_interf_sptr);
         HCCSYMP(sym, 1);
         IS_PROC_PTR_IFACEP(sym, 1);
+        INTERFACEP(sym, 1);
       }
       proc_interf_sptr = sym;
     }
diff --git a/tools/flang1/flang1exe/semant.h b/tools/flang1/flang1exe/semant.h
@@ -1609,6 +1609,7 @@ int has_poly_mbr(int sptr, int flag);
 void push_tbp_arg(ITEM *item);
 ITEM *pop_tbp_arg(void);
 void err307(char *, int, int);
+void gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast, int std);
 
 /* xref.c */
 void xrefinit(void);
diff --git a/tools/flang1/flang1exe/semant3.c b/tools/flang1/flang1exe/semant3.c
@@ -61,7 +61,6 @@ static int gen_derived_arr_init(int arr_dtype, int strt_std, int end_std);
 static int convert_to_block_forall(int old_forall_ast);
 
 static int find_non_tbp(char *);
-static void gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast);
 static int gen_sourced_allocation(int astdest, int astsrc);
 
 static int construct_association(int lhs_sptr, SST *rhs, int stmt_dtype,
@@ -4230,7 +4229,7 @@ semant3(int rednum, SST *top)
                                  ? src_sdsc_ast
                                  : mk_id(get_type_descr_arg(gbl.currsub, src));
 
-                  gen_init_unl_poly_desc(dast, sast);
+                  gen_init_unl_poly_desc(dast, sast, 0);
                 } else if (SDSCG(dest) && DTY(src_dtype) == TY_CHAR &&
                            is_unl_poly(dest)) {
 
@@ -6460,8 +6459,16 @@ convert_to_block_forall(int old_forall_ast)
   return mk_stmt(A_ENDFORALL, 0);
 }
 
-static void
-gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast)
+/** \brief Generate a call to init_unl_poly_desc which initializes a descriptor
+ *         for an unlimited polymorphic object with another descriptor.
+ *
+ *  \param dest_sdsc_ast is the AST of the destination's descriptor.
+ *  \param src_sdsc_ast is the AST of the source descriptor.
+ *  \param std is the statement descriptor to insert the call, or 0 to use
+ *         the default statement descriptor.
+ */
+void
+gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast, int std)
 {
   int fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_init_unl_poly_desc), DT_NONE);
   int argt = mk_argt(3);
@@ -6472,7 +6479,11 @@ gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast)
   val = mk_unop(OP_VAL, val, DT_INT);
   ARGT_ARG(argt, 2) = val;
   ast = mk_func_node(A_CALL, ast, 3, argt);
-  add_stmt(ast);
+  if (std == 0) {
+    add_stmt(ast);
+  } else {
+    add_stmt_after(ast, std);
+  }
 }
 
 static int
@@ -6801,7 +6812,7 @@ construct_association(int lhs_sptr, SST *rhs, int stmt_dtype, LOGICAL is_class)
     assert(rhs_descriptor_ast > 0, "no rhs descr for unl poly lhs", lhs_sptr,
            4);
 #endif
-    gen_init_unl_poly_desc(mk_id(SDSCG(lhs_sptr)), rhs_descriptor_ast);
+    gen_init_unl_poly_desc(mk_id(SDSCG(lhs_sptr)), rhs_descriptor_ast, 0);
   }
   if (set_up_a_pointer) {
     /* Construct association by means of a pointer to extant data, no
diff --git a/tools/flang1/flang1exe/semutil2.c b/tools/flang1/flang1exe/semutil2.c
@@ -14100,8 +14100,7 @@ gen_set_type(int dest_ast, int src_ast, int std, LOGICAL insert_before,
     arg0 = dest_ast;
   } else if (A_TYPEG(src_ast) == A_MEM) {
     sdsc = get_member_descriptor(sptr);
-    arg0 = mk_member(mk_id(sym_of_ast(A_PARENTG(dest_ast))), mk_id(sdsc),
-                     A_DTYPEG(dest_ast));
+    arg0 = check_member(dest_ast, mk_id(sdsc));
   } else {
     sdsc = SDSCG(sptr);
     if (sdsc == 0) {
@@ -14120,8 +14119,7 @@ gen_set_type(int dest_ast, int src_ast, int std, LOGICAL insert_before,
       arg1 = src_ast;
     } else if (A_TYPEG(src_ast) == A_MEM) {
       sdsc = get_member_descriptor(sptr);
-      arg1 = mk_member(mk_id(sym_of_ast(A_PARENTG(src_ast))), mk_id(sdsc),
-                       A_DTYPEG(src_ast));
+      arg1 = check_member(src_ast, mk_id(sdsc));
     } else {
       sdsc = SDSCG(sptr);
       if (sdsc == 0) {
diff --git a/tools/flang1/flang1exe/transfrm.c b/tools/flang1/flang1exe/transfrm.c
@@ -4305,6 +4305,11 @@ rewrite_allocatable_assignment(int astasgn, const int std,
           ast = mk_set_type_call(dest_sdsc_ast, intrin_type, TRUE);
           add_stmt_after(ast, std2); /* after call to poly_asn() */
         }
+      } else if (is_unl_poly(sptrdest)) {
+        /* Need to initialize destination's unlimited polymorphic descriptor 
+         * before calling poly_asn().
+         */
+        gen_init_unl_poly_desc(dest_sdsc_ast, src_sdsc_ast, alloc_std);
       }
       ast_to_comment(astasgn);
       return;
diff --git a/tools/flang2/docs/xflag.n b/tools/flang2/docs/xflag.n
@@ -3867,6 +3867,8 @@ Don't allow statements between the DO loops of a cuf kernels do construct
 reserved
 .XB 0x80000:
 reserved
+.XB 0x100000:
+reserved
 
 .XF "138:"
 vect prefetch limit

Original file line number	Diff line number	Diff line change
`@@ -3429,6 +3429,10 @@ simply_contiguous(int arr_ast)`
`3429`	`3429`	`}`
`3430`	`3430`	`break;`
`3431`	`3431`	`case A_SUBSCR:`
	`3432`	`+ sptr = memsym_of_ast(arr_ast);`
	`3433`	`+ if (POINTERG(sptr)) {`
	`3434`	`+ return CONTIGATTRG(sptr);`
	`3435`	`+ }`
`3432`	`3436`	`return contiguous_array_section(arr_ast);`
`3433`	`3437`	`}`
`3434`	`3438`
Original file line number	Diff line number	Diff line change
`@@ -11383,6 +11383,7 @@ semant1(int rednum, SST *top)`
`11383`	`11383`	`copy_sym_flags(sym, proc_interf_sptr);`
`11384`	`11384`	`HCCSYMP(sym, 1);`
`11385`	`11385`	`IS_PROC_PTR_IFACEP(sym, 1);`
	`11386`	`+ INTERFACEP(sym, 1);`
`11386`	`11387`	`}`
`11387`	`11388`	`proc_interf_sptr = sym;`
`11388`	`11389`	`}`