Merge pull request #585 from ThePortlandGroup/nv_stage

Pull 2018-09-12T11-48 Recent NVIDIA Changes

Author: sscalpone

include/flang/Error/pgerror.h

@@ -24,7 +24,9 @@
 
 #include "universal.h"
 
+#ifndef IN_FLANG2
 BEGIN_DECL_WITH_C_LINKAGE
+#endif
 
 /** \brief Severity of an error message.
  */
@@ -37,10 +39,18 @@ typedef enum error_severity {
   ERR_SEVERITY_SIZE  // must be last!
 } error_severity;
 
+#ifdef IN_FLANG2
+#include "errmsgdf.h"
+#endif
+
 /** \brief Error code type
  */
 typedef enum error_code error_code_t;
 
+#ifdef IN_FLANG2
+#include "error.h"
+#endif
+
 #ifdef FE90
 void errWithSrc(error_code_t ecode, enum error_severity sev, int eline,
                 const char *op1, const char *op2, int col, int deduceCol,
@@ -82,6 +92,8 @@ void dassert_err(const char *, int line, const char *exp, const char *txt);
 void asrt_failed(const char* file, int line);
 #endif
 
+#ifndef IN_FLANG2
 END_DECL_WITH_C_LINKAGE
+#endif
 
 #endif /* PGERROR_H_ */

lib/CMakeLists.txt

@@ -1,5 +1,5 @@
 #
-# Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
+# Copyright (c) 2015-2018, 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.
@@ -14,6 +14,8 @@
 # limitations under the License.
 #
 
+set(LIB_SOURCE_DIR ${CMAKE_CURRENT_SOURCE_DIR} PARENT_SCOPE)
+
 add_subdirectory(ADT)
 add_subdirectory(ArgParser)
 add_subdirectory(scutil)

runtime/flang/ptr.c

@@ -815,6 +815,61 @@ I8(ptr_assn)(char *pb, F90_Desc *pd, dtype kind, __CLEN_T len, char *tb,
   return res;
 }
 
+void
+ENTF90(TMP_DESC,tmp_desc)(F90_Desc *nd, F90_Desc *od)
+{
+  /* nd is the new, temporary argument descriptor, od is original descriptor */
+  dtype kind;
+  __CLEN_T len;
+
+  if (nd == NULL || od == NULL) {
+    __fort_abort("TMP_DESC: invalid descriptor");
+  } else if (F90_TAG_G(od) == __DESC) {
+    kind = F90_KIND_G(od);
+    len = F90_LEN_G(od);
+    __INT_T gsize;
+    __INT_T i, rank, flags, lbase;
+    DECL_F90_DIM_PTR(odd);
+    DECL_F90_DIM_PTR(ndd);
+    gsize = 1;
+    rank = F90_RANK_G(od);
+    flags = F90_FLAGS_G(od);
+    lbase = F90_LBASE_G(od);
+    /* tag, rank, kind, len, flags, gsize, lsize, gbase, lbase */
+    F90_TAG_P(nd, __DESC);
+    F90_RANK_P(nd, rank);
+    F90_KIND_P(nd, F90_KIND_G(od));
+    F90_LEN_P(nd, F90_LEN_G(od));
+    F90_LSIZE_P(nd, F90_LSIZE_G(od));
+    F90_GBASE_P(nd, F90_GBASE_G(od));
+
+    SET_DIM_PTRS(odd, od, 0);
+    SET_DIM_PTRS(ndd, nd, 0);
+    for (i = 0; i < rank; ++i) {
+      __INT_T __extent, __myoffset, __stride;
+      __extent = F90_DPTR_EXTENT_G(odd); /* section extent */
+      __myoffset = F90_DPTR_LBOUND_G(odd) - 1;
+      __stride = F90_DPTR_LSTRIDE_G(odd);
+      F90_DPTR_LBOUND_P(ndd, 1);    /* lower bound */
+      DPTR_UBOUND_P(ndd, __extent); /* upper bound */
+      F90_DPTR_SSTRIDE_P(ndd, 1);   /* placeholders */
+      F90_DPTR_SOFFSET_P(ndd, 0);
+      F90_DPTR_LSTRIDE_P(ndd, __stride);
+      lbase += __myoffset * __stride;
+      if (__stride != gsize)
+        flags &= ~__SEQUENTIAL_SECTION;
+      gsize *= __extent;
+      ++F90_DIM_NAME(odd);
+      ++F90_DIM_NAME(ndd);
+    }
+    F90_LBASE_P(nd, lbase);
+    F90_FLAGS_P(nd, flags);
+    F90_GSIZE_P(nd, gsize); /* global section size */
+  } else {
+    __fort_abort("TMP_DESC: invalid original");
+  }
+}
+
 void *
 ENTFTN(PTR_ASSN, ptr_assn)(char *pb, F90_Desc *pd, char *tb, F90_Desc *td,
                             __INT_T *sectflag)

tools/flang1/flang1exe/dpm_out.c

@@ -1223,7 +1223,7 @@ is_kopy_in_needed(int arg)
     /* only dummies, result variables passed like dummies */
     if (SCG(arg) != SC_DUMMY && !RESULTG(arg))
       return FALSE;
-    /* pointer need kopy-in, regardless of type */
+    /* pointer needs kopy-in, regardless of type */
     if (POINTERG(arg) || IS_PROC_DUMMYG(arg))
       return TRUE;
     /* other nonarrays need no kopy in */
@@ -2357,6 +2357,28 @@ emit_alnd(int sptr, int memberast, LOGICAL free_flag, LOGICAL for_allocate,
                            sptr, typed_alloc, 0 /* no parent AST */, Lbegin);
 }
 
+void
+make_temp_descriptor(int sptr_orig, int sptr_tmp, int before_std)
+{
+    /* call pgf90_temp_desc(tmp desc, orig desc) */
+    SPTR sptr_descr;
+    int  sptrdescr_arg, ast;
+    int nargs = 2;
+    int argt = mk_argt(nargs);
+    sptr_descr = DESCRG(sptr_tmp);
+    sptrdescr_arg = mk_id(sptr_descr);
+    ARGT_ARG(argt, 0) = sptrdescr_arg;
+    sptr_descr = DESCRG(sptr_orig);
+    sptrdescr_arg = mk_id(sptr_descr);
+    ARGT_ARG(argt, 1) = sptrdescr_arg;
+
+    ast =
+        mk_func_node(A_CALL, 
+                     mk_id(sym_mkfunc(mkRteRtnNm(RTE_tmp_desc), DT_NONE)),
+                     nargs, argt);
+    (void) add_stmt_before(ast, before_std);
+}
+
 void
 init_sdsc_from_dtype(int sptr, DTYPE dtype, int before_std)
 {
@@ -4091,7 +4113,8 @@ set_assumed_bounds(int arg, int entry, int actual)
     }
     /* also, arg is assumed shape, and since !TARGET mark as stride 1 */
     SDSCS1P(arg, 1); /* see comment below regarding these xbits */
-    update_shape_info(arg);
+    if( XBIT(55,0x80) )
+        update_shape_info(arg);
   }
 
   for (i = 0; i < r; ++i) {
@@ -4106,14 +4129,22 @@ set_assumed_bounds(int arg, int entry, int actual)
       ast1 = mk_isz_cval(1, astb.bnd.dtype);
     if (A_TYPEG(tmp_lb) == A_CNST) {
       sav = tmp_lb;
-    } else if (XBIT(54, 2) || (XBIT(58, 0x400000) && TARGETG(arg))) {
-      /* lower bound assignment */
-      /* lb = <global lower bound> */
-      ast_gbl = get_global_lower(newdsc, i);
+    } else if ((XBIT(58, 0x400000) && TARGETG(arg)) &&
+        tmp_lb == ast1 && A_TYPEG(tmp_lb) == A_ID) {
+      /*
+      FIX ME: setting the descriptor bounds to 1 here does not work since
+      there can be other references (such as loop bounds) which use the
+      symbolic lower bounds for each dimension.
+      ast1 = mk_isz_cval(1, astb.bnd.dtype);
+      sav = AD_LWAST(ad, i) = AD_LWBD(ad, i) = ast1;
+      */
+
+      /* so we just assign the symbolic lower bound ID to 1 */
+      ast1 = mk_isz_cval(1, astb.bnd.dtype);
       sav = ast1;
       ast2 = mk_stmt(A_ASN, 0);
       A_DESTP(ast2, tmp_lb);
-      A_SRCP(ast2, ast_gbl);
+      A_SRCP(ast2, ast1);
       std = add_stmt_after(ast2, std);
     } else if (tmp_lb != ast1) {
       /* output lower bound assignment */

tools/flang1/flang1exe/extern.h

@@ -72,6 +72,7 @@ void copy_surrogate_to_bnds_vars(DTYPE, int, DTYPE, int, int);
 void copy_desc_to_bnds_vars(int sptrdest, int desc, int memdesc, int std);
 void emit_fl(void);                       /* dpm_out.c */
 void init_sdsc_from_dtype(int sptr, DTYPE, int before_std); /* dpm_out.c */
+void make_temp_descriptor(int, int, int); /* dpm_out.c */
 int init_sdsc(int sptr, DTYPE dtype, int before_std, int parent_sptr);	/* semutil2.c */
 void ipa_restore_dtb(char *line);         /* dpm_out.c */
 void transform_call(int, int);

tools/flang1/flang1exe/outconv.c

@@ -2387,7 +2387,7 @@ _ptrassign(int astx)
       _ptrassign_copy(DESC_HDR_FLAGS, ptrsdx, tgtsdx, ptrsdtype);
       _ptrassign_copy(DESC_HDR_LSIZE, ptrsdx, tgtsdx, ptrsdtype);
       _ptrassign_copy(DESC_HDR_GSIZE, ptrsdx, tgtsdx, ptrsdtype);
-      if (ASSUMSHPG(tgtsptr)) {
+      if (ASSUMSHPG(tgtsptr) && !XBIT(58, 0x400000)) {
         _ptrassign_set(DESC_HDR_LBASE, ptrsdx, 1, ptrsdtype);
       } else {
         _ptrassign_copy(DESC_HDR_LBASE, ptrsdx, tgtsdx, ptrsdtype);
@@ -2402,7 +2402,7 @@ _ptrassign(int astx)
       rank = ADD_NUMDIM(DTYPEG(ptrsptr));
       for (i = 0; i < rank; ++i) {
         int lb;
-        if (!ASSUMSHPG(tgtsptr)) {
+        if (!ASSUMSHPG(tgtsptr) || XBIT(58, 0x400000)) {
           _ptrassign_copy(get_global_lower_index(i), ptrsdx, tgtsdx, ptrsdtype);
         } else {
           /* for assumed-shape arguments, use the declared bounds */
@@ -2413,7 +2413,7 @@ _ptrassign(int astx)
         _ptrassign_set(get_section_stride_index(i), ptrsdx, 0, ptrsdtype);
         _ptrassign_set(get_section_offset_index(i), ptrsdx, 0, ptrsdtype);
         _ptrassign_copy(get_multiplier_index(i), ptrsdx, tgtsdx, ptrsdtype);
-        if (ASSUMSHPG(tgtsptr)) {
+        if (ASSUMSHPG(tgtsptr) && !XBIT(58, 0x400000)) {
           /* adjust the LBASE */
           int a;
           a = mk_binop(OP_MUL,

tools/flang1/flang1exe/rest.c

@@ -1876,6 +1876,7 @@ transform_call(int std, int ast)
           break;
         }
       }
+
       if (is_ent &&
           (
 #if DEBUG
@@ -1975,6 +1976,46 @@ transform_call(int std, int ast)
           DESCUSEDP(sptr, 1);
           NODESCP(sptr, 0);
 
+          /* Fix for assumed-shape arrays arguments where callee has the
+           * argument marked as target (originally discovered at customer). 
+           * In this case the whole array is sent, but the callee code 
+           * still needs to use the address calculation method such that 
+           * the lower bound is folded into the lbase field of the descriptor 
+           * to make zero-based  offsets work (so-called; in practice 
+           * usually 1-based with Fortran).
+           * [see exp_ftn.c: compute_sdsc_subscr() & add_ptr_subscript()]
+           *
+           * Since a new section descriptor has not been generated in this
+           * case where we send the whole array as an argument we need to
+           * create a new, temporary, argument array descriptor which
+           * translates bounds to zero-based (per the Fortran standard with
+           * assumed-shape arguments) and adjusts the lbase field.
+           *
+           * NB: The new runtime routine, pgf90_tmp_desc(), used to create the
+           * argument desriptor is similar to a pointer assignment (which
+           * makes the ptr_assn() call), and which follows the same rules
+           * of zero-based array bounds and lbase calculation. Also, this type
+           * of lbase fixup can also be found in runtime routines like
+           * ptr_fix_assumeshp(), where a whole array, instead of a section,
+           * is identified.
+           */
+          if(XBIT(58,0x400000)&&ASSUMSHPG(inface_arg)&&TARGETG(inface_arg))
+          {
+            char nd[50];    /* new, substitute, descriptor for this arg */
+            static int ndctr = 0;
+            DTYPE dtype = DTYPEG(sptr);
+            SPTR sptrtmp, sptrdesc;
+            sprintf(nd, "ndesc%d_%d", A_SPTRG(ele), ndctr++);
+            sptrtmp = sym_get_array(nd, "", DDTG(dtype),
+                                    SHD_NDIM(A_SHAPEG(ele)));
+            get_static_descriptor(sptrtmp); /* add sdsc to sptrtmp; necessary */
+            get_all_descriptors(sptrtmp); /* add desc & bounds in dtype */
+            /* generate the runtime call pgf90_tmp_desc) */
+            make_temp_descriptor(sptr, sptrtmp, std);
+            sptrdesc = DESCRG(sptrtmp);
+            ARGT_ARG(newargt, newj) = check_member(ele, mk_id(sptrdesc));
+          }
+          else
             ARGT_ARG(newargt, newj) = descr;
           ++newj;
           s = memsym_of_ast(descr);
@@ -2027,6 +2068,35 @@ transform_call(int std, int ast)
         ++newi;
         if (needdescr) {
           int s;
+          /* situation where we are sending the whole array using
+           * subscript notation, e.g. x(:,:), but semantically 
+           * equivalent to the above A_ID case of 'x'. We know that 
+           * the whole array is being passed when the descriptor 
+           * generated from the call to transform_section_arg() 
+           * above (descr) is unchanged from the sptr descriptor.
+           */
+          if(XBIT(58,0x400000) && ASSUMSHPG(inface_arg) &&
+             TARGETG(inface_arg) && A_SPTRG(descr) &&
+             (DESCRG(sptr) == A_SPTRG(descr)) )
+          {
+            char nsd[50];    /* new, substitute, descriptor for this arg */
+            static int nsdctr = 0;
+            DTYPE dtype = DTYPEG(sptr);
+            SPTR sptrtmp, sptrdesc;
+            /* In this case ele is an A_SUBSCR, so need to use its A_LOP */
+            int lop_ele = A_LOPG(ele);
+
+            sprintf(nsd, "n2desc%d_%d", A_SPTRG(lop_ele), nsdctr++);
+            sptrtmp = sym_get_array(nsd, "", DDTG(dtype),
+                                    SHD_NDIM(A_SHAPEG(lop_ele)));
+            get_static_descriptor(sptrtmp); /* add sdsc to sptrtmp; necessary */
+            get_all_descriptors(sptrtmp); /* add desc & bounds in dtype */
+            /* generate the runtime call pgf90_tmp_desc) */
+            make_temp_descriptor(sptr, sptrtmp, std);
+            sptrdesc = DESCRG(sptrtmp);
+            ARGT_ARG(newargt, newj) = check_member(lop_ele, mk_id(sptrdesc));
+          }
+          else
             ARGT_ARG(newargt, newj) = descr;
           ++newj;
           s = memsym_of_ast(descr);
@@ -2400,10 +2470,12 @@ handle_seq_section(int entry, int arr, int loc, int std, int *retval,
         if (!arrayalign)
           is_seq_pointer = TRUE;
       }
+      if (TARGETG(arraysptr) && XBIT(58,0x400000))
+          is_seq_pointer = TRUE;
       /* for F90, an assumed-shape dummy array looks like
        * a sequential pointer, if copy-ins are removed */
       if (XBIT(57, 0x10000) && ASSUMSHPG(arraysptr) && SDSCS1G(arraysptr) &&
-          !XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(arraysptr)))
+          !XBIT(54, 2))
         is_seq_pointer = TRUE;
       break;
     case A_SUBSCR:
@@ -3680,7 +3752,7 @@ stride_1_section(int entry, int arr_ast, int pos, int std)
       return FALSE; /* leftmost triplet is not stride 1 */
   }
   sptr = memsym_of_ast(arr_ast);
-  if (POINTERG(sptr)) {
+  if (POINTERG(sptr) || (TARGETG(sptr) && XBIT(58,0x400000))) {
       /*
        * Is this a stride-1 pointer array section?  If the corresponding
        * dummy is assumed-shape, we cannot omit the copy arg calls.  The