Merge pull request #636 from ThePortlandGroup/nv_stage

Pull 2018-12-12T17-36 Recent NVIDIA Changes

Author: sscalpone

include/flang/Error/errmsg-in.n

@@ -1516,3 +1516,4 @@ A DO CONCURRENT variable with LOCAL_INIT locality must have a host variable of t
 .MS S 1203 "OpenMP GPU - Directive target exit data is used, map type [$] cannot be used. It should be one of 'from', 'release', or 'delete'"
 .MS S 1204 "OpenMP GPU - Directive target data is used, map type [$] cannot be used. It should be one of 'to', 'from', 'tofrom', 'alloc', 'release', or 'delete'"
 .MS S 1205 "OpenMP GPU - Directive target enter data is used, map type [$] cannot be used. It should be one of 'to', or 'alloc'"
+.MS W 1206 "OpenMP GPU - Using [map] clause is used with an array section for $ array is not supported, mapping will be done on entire array."

test/f90_correct/src/submod33.f90

@@ -19,17 +19,16 @@ module mod_set_foo_submod33
     Character*8,external :: FOO 
     Character*26 :: BAR
 interface
-module subroutine call_foo
-end subroutine
+  module subroutine call_foo
+  end subroutine
+
+  module subroutine  check_abc
+  end subroutine
 end interface
 end module
 
 submodule (mod_set_foo_submod33) submod_set_foo_submod33
     character*3 :: abc
-interface
-    module subroutine  check_abc
-    end subroutine
-end interface
 contains
     module procedure call_foo
         print *, FOO(BAR)

tools/flang1/flang1exe/exterf.c

@@ -378,6 +378,14 @@ static void export(FILE *export_fd, char *export_name, int cleanup)
           }
         }
         break;
+      case ST_IDENT:
+        if (for_module) {
+          if (SCG(sptr) == SC_DUMMY && SCOPEG(SCOPEG(sptr)) != sym_module &&
+              TBP_BOUND_TO_SMPG(SCOPEG(sptr))) {
+            queue_symbol(sptr);
+          }
+        }
+        break;
       default:
         break;
       }
@@ -2318,8 +2326,14 @@ export_symbol(int sptr)
       lzprintf(outlz, "C %d %d %s\n", sptr, STYPEG(sptr), SYMNAME(sptr));
       return;
     }
-    if (stype == ST_MODULE && sptr != sym_module && !for_inliner)
+    if (stype == ST_MODULE && sptr != sym_module && !for_inliner && 
+       /* No return when this module has a separate module procedure that
+        * implements a type bound procedure. We need to export modules 
+        * sptr next.
+        */
+        !HAS_TBP_BOUND_TO_SMPG(sptr) && ANCESTORG(sym_module) != sptr) {
       return;
+    }
   }
 
 

tools/flang1/flang1exe/interf.c

@@ -5145,7 +5145,7 @@ fill_ST_MODULE(SYMITEM *ps, int sptr)
   NEEDMODP(sptr, NEEDMODG(0));
   TYPDP(sptr, TYPDG(0));
   PRIVATEP(sptr, PRIVATEG(0));
-
+  HAS_TBP_BOUND_TO_SMPP(sptr, HAS_TBP_BOUND_TO_SMPG(0));
   stb.stg_base[0] = save_sym0;
 
 } /* fill_ST_MODULE */

tools/flang1/flang1exe/module.c

@@ -667,7 +667,7 @@ apply_use(MODULE_ID m_id)
       INKINDP(pr->local, INKINDG(pr->global));
       PDNUMP(pr->local, PDNUMG(pr->global));
       copy_specifics(ng, pr->local);
-    } else if (STYPEG(ng /*pr->global*/) == ST_USERGENERIC) {
+    } else if (STYPEG(ng /*pr->global*/) == ST_USERGENERIC && !GTYPEG(ng)) {
       if (NMPTRG(pr->local) == NMPTRG(pr->global)) {
         STYPEP(pr->local, ST_ALIAS);
         SYMLKP(pr->local, pr->global);

tools/flang1/flang1exe/semant.c

@@ -2339,6 +2339,17 @@ semant1(int rednum, SST *top)
          * ISSUBMODULEP is used for name mangling. 
          */
         SEPARATEMPP(sptr, TRUE);
+        if (IN_MODULE)
+          INMODULEP(sptr, TRUE);
+        if (SST_FIRSTG(RHS(rhstop))) {
+          TBP_BOUND_TO_SMPP(sptr, TRUE);
+          /* We also set the HAS_TBP_BOUND_TO_SMP flag on the separate module 
+           * procedure's module. This indicates that the module contains a 
+           * separate module procedure declaration to which at least one TBP
+           * has been bound.
+           */
+          HAS_TBP_BOUND_TO_SMPP(SCOPEG(sptr), TRUE);
+        }
       } else {
         SEPARATEMPP(sptr, TRUE);
 
@@ -11385,6 +11396,9 @@ semant1(int rednum, SST *top)
     } else {
       sptr2 = refsym(SST_SYMG(RHS(rhstop)), OC_OTHER);
     }
+  
+    if (SEPARATEMPG(sptr2))
+      TBP_BOUND_TO_SMPP(sptr2, TRUE);
 
     if (bindingNameRequiresOverloading(sptr)) {
       sptr = insert_sym(sptr);

tools/flang1/flang1exe/semsmp.c

@@ -4841,6 +4841,16 @@ semsmp(int rednum, SST *top)
    *	<accel data> ::= <accel data name> ( <accel sub list> ) |
    */
   case ACCEL_DATA1:
+#ifdef OMP_OFFLOAD_LLVM
+    if (SST_IDG(RHS(1)) == S_IDENT || SST_IDG(RHS(1)) == S_DERIVED) {
+      sptr = SST_SYMG(RHS(1));
+    } else {
+      sptr = SST_LSYMG(RHS(1));
+    }
+    error(1206, ERR_Warning, gbl.lineno, sptr ? SYMNAME(sptr) : CNULL, CNULL);
+    goto accel_data2;
+    break;
+#endif
   accel_data1:
     if (SST_IDG(RHS(1)) == S_IDENT || SST_IDG(RHS(1)) == S_DERIVED) {
       sptr = SST_SYMG(RHS(1));

tools/flang1/flang1exe/symtab.c

@@ -56,6 +56,11 @@ typedef struct {
   LOGICAL typ8;        /* True if the type is altered by -r8 */
 } DTIMPL[26 + 26 + 2];
 
+typedef struct {
+  SPTR dec_sptr;
+  SPTR def_sptr; 
+} DEC_DEF_MAP;
+
 static DTIMPL dtimplicit;
 static int dtimplicitsize = 0;
 static DTIMPL *save_dtimplicit = NULL;
@@ -64,7 +69,7 @@ static int dtimplicitstack = 0;
 static void cng_inttyp(int, int);
 static void cng_specific(int, int);
 static void generate_type_mismatch_errors(SPTR s1, SPTR s2);
-
+static void update_arrdsc(SPTR s, DEC_DEF_MAP *smap, int num_dummies);
 /* entry hack? */
 static ENTRY onlyentry;
 
@@ -2863,12 +2868,14 @@ SPTR
 instantiate_interface(SPTR iface)
 {
   int dummies;
-  SPTR fval, hashlk_sptr, proc; 
+  SPTR fval, hashlk_sptr, proc;
+  DEC_DEF_MAP *dec_def_map;
   proc = insert_dup_sym(iface);
   gbl.currsub = proc;
 
   SCOPEP(proc, SCOPEG(find_explicit_interface(proc)));
   dummies = PARAMCTG(iface);
+  NEW(dec_def_map, DEC_DEF_MAP, dummies);
   fval = NOSYM;
 
   STYPEP(proc, ST_ENTRY);
@@ -2907,7 +2914,9 @@ instantiate_interface(SPTR iface)
     for (j = 0; j < dummies; ++j) {
       SPTR arg = aux.dpdsc_base[iface_dpdsc + j];
       if (arg > NOSYM) {
+        dec_def_map[j].dec_sptr = arg;
         arg = insert_dup_sym(arg);
+        dec_def_map[j].def_sptr = arg;
         SCOPEP(arg, proc);
         if (DTY(DTYPEG(arg)) == TY_ARRAY && ASSUMSHPG(arg)) {
           DTYPE elem_dt = array_element_dtype(DTYPEG(arg));
@@ -2920,10 +2929,10 @@ instantiate_interface(SPTR iface)
           get_static_descriptor(arg);
         }
         if (ALLOCATTRG(arg) || POINTERG(arg)) {
-          newdsc = sym_get_arg_sec(arg);          
-          SDSCP(arg, newdsc);
-          SCP(newdsc, SC_DUMMY);
-          SCOPEP(newdsc, proc);
+          if (!SDSCG(arg))
+            get_static_descriptor(arg);
+          if (!PTROFFG(arg))
+            get_all_descriptors(arg);
         }
 
         HIDDENP(arg, 0);
@@ -2935,9 +2944,54 @@ instantiate_interface(SPTR iface)
       aux.dpdsc_base[proc_dpdsc + j] = arg;
     }
   }
+
+  if (ADJARRG(fval)) {
+    ADSC *ad;
+    int arr_dsc;
+    DTYPE elem_dt;
+    ad = AD_DPTR(DTYPEG(FVALG(iface)));
+    update_arrdsc(fval, dec_def_map, dummies);
+    elem_dt = array_element_dtype(DTYPEG(iface));
+    arr_dsc = mk_arrdsc();
+    DTY(arr_dsc + 1) = elem_dt;
+    DTYPEP(fval, arr_dsc); 
+    trans_mkdescr(fval);
+  }
+
+  FREE(dec_def_map);
+  
   return proc;
 }
 
+/** \brief Update array bound AST SPTRs (old_sptr) using newly created SPTRs 
+           (new_sptr) by referring to DEC_DEF_MAP. The DEC_DEF_MAP is a struct 
+           which contains mapping info from the old_sptr to new_sptr.
+ */
+static void 
+update_arrdsc(SPTR s, DEC_DEF_MAP *smap, int num_dummies) {
+  int i, j;
+  SPTR dec_sptr_lwbd, dec_sptr_upbd;
+  ADSC *ad;
+  ad = AD_DPTR(DTYPEG(s));
+  sem.arrdim.ndim = AD_NUMDIM(ad);
+  sem.arrdim.ndefer = AD_DEFER(ad);
+  for (i = 0; i < sem.arrdim.ndim; ++i) {
+    /* restore arrdsc bound ast info from *ad */
+    sem.bounds[i].lwast = AD_LWAST(ad, i);
+    sem.bounds[i].upast = AD_UPAST(ad, i);
+
+    /* update arrdsc bound ast info */
+    dec_sptr_lwbd = A_SPTRG(AD_LWBD(ad, i));
+    dec_sptr_upbd = A_SPTRG(AD_UPBD(ad, i));
+    for (j = 0; j < num_dummies; ++j) {  
+      if (dec_sptr_lwbd == smap[j].dec_sptr)
+        sem.bounds[i].lwast = mk_id(smap[j].def_sptr);
+      if (dec_sptr_upbd == smap[j].dec_sptr)
+        sem.bounds[i].upast = mk_id(smap[j].def_sptr);
+    }
+  }
+}
+
 /**
  * reinitialize a symbol
  */

tools/flang1/utils/symtab/symtab.n

@@ -1571,6 +1571,8 @@ for this symbol.
 Flags
 .FL SEPARATEMP
 MODULE SUBROUTINE, MODULE FUNCTION for a separate module procedure.
+.FL TBP_BOUND_TO_SMP f112
+At least one type bound procedure is bound to this separate module procedure.
 .FL IS_INTERFACE
 Set if the procedure symbol is in an interface block.
 .FL IS_PROC_DUMMY f109
@@ -2511,6 +2513,9 @@ Flags
 Used to mark the submodule SUBROUTINE, submodule FUNCTION that is defined 
 inside interface and used by submodules. This is used to differentiate 
 the normal module SUBROUTINE, FUNCTION, and PROCEDURE.
+.FL HAS_TBP_BOUND_TO_SMP f112
+This flag is set when this module has a derived type with a type bound 
+procedure that is implemented by a separate module procedure
 .FL NEEDMOD f1
 If set, an external reference to this module needs to be generated,
 so a link error will occur if a program that USEs this module is linked

tools/flang2/flang2exe/cgmain.cpp

@@ -10334,7 +10334,7 @@ needDebugInfoFilt(SPTR sptr)
     return true;
   /* Fortran case needs to be revisited when we start to support debug, for now
    * just the obvious case */
-  return (!CCSYMG(sptr) || (DCLDG(sptr) && (STYPEG(sptr) == ST_ARRAY)));
+  return (!CCSYMG(sptr) || DCLDG(sptr));
 }
 #ifdef OMP_OFFLOAD_LLVM
 INLINE static bool
@@ -11669,8 +11669,13 @@ gen_acon_expr(int ilix, LL_Type *expected_type)
     return make_constval_op(make_int_lltype(ptrbits), val[1], val[0]);
   }
   sym_is_refd(sptr);
-  process_sptr_offset(sptr, variable_offset_in_aggregate(
-                                sptr, ACONOFFG(opnd) < 0 ? 0 : ACONOFFG(opnd)));
+  /* In case of non-struct, e.g. a Fortran array may have ACON as sptr + offset,
+   * the "offset" works with "bound" and "index" together to calculate the 
+   * addresses of array elements. However, when generating debug metadata, the
+   * "offset" is not needed in the !DIExpression of the array variable. The
+   * array variable's location always starts from the beginning/first element. */
+  idx = (STYPEG(sptr) == ST_ARRAY || ACONOFFG(opnd) < 0) ? 0 : ACONOFFG(opnd);
+  process_sptr_offset(sptr, variable_offset_in_aggregate(sptr, idx));
   idx = ACONOFFG(opnd); /* byte offset */
 
   ty1 = make_lltype_from_dtype(DT_ADDR);