Merge pull request #452 from ThePortlandGroup/nv_stage

Pull 2018-04-25T17-03 Recent NVIDIA Changes

Author: sscalpone

include/flang/Error/errmsg-in.n

@@ -1472,3 +1472,4 @@ Pragma operator errors.
 .MS S 1012 "Threadprivate variables are not supported in acc routine - $"
 .MS S 1013 "Static Threadprivate variables are not supported - $"
 .MS S 1014 "Global Threadprivate variables are not supported - $"
+.MS S 1015 "Cannot access private intrinsic - $"

runtime/flang/shmem_reduce.h

@@ -1,5 +1,5 @@
 /*
- * Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
+ * Copyright (c) 1995-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.
@@ -19,7 +19,7 @@
 
 #include "stdioInterf.h"
 #include "fioMacros.h"
-
+#include "type.h"
 /* transfer intrinsic */
 
 static int I8(next_index)(__INT_T *index, F90_Desc *s)
@@ -60,10 +60,28 @@ void ENTFTN(TRANSFER, transfer)(void *rb,         /* result base */
 
   result_scalar = F90_TAG_G(result) != __DESC;
   source_scalar = F90_TAG_G(source) != __DESC;
-  rsize = *rs;
+  if (*rs == 0 && (F90_TAG_G(result) == __POLY)) {
+    OBJECT_DESC *dest = (OBJECT_DESC *)result;
+    TYPE_DESC *dest_td = dest ? dest->type : 0;
+    if (dest_td != NULL) {
+      rsize = ((OBJECT_DESC*)dest_td)->size;
+    } else {
+      rsize = *rs;
+    }
+  } else {
+    rsize = *rs;
+  }
+      
   if (result_scalar && source_scalar) {
-    if (rsize > *ms)
+    OBJECT_DESC *src = (OBJECT_DESC *)source;
+    TYPE_DESC *src_td = src ? src->type : 0;
+    if (*ms == 0 && (F90_TAG_G(source) == __POLY) && src_td != NULL) {
+        if (rsize > ((OBJECT_DESC*)src_td)->size) {
+          rsize = ((OBJECT_DESC*)src_td)->size;
+        }
+    } else if (rsize > *ms) {
       rsize = *ms;
+    }
     __fort_bcopy(rb, sb, rsize);
     return;
   }

runtime/flang/transfer.c

@@ -1749,9 +1749,9 @@ undouble_callee_args_f90(void)
 static LOGICAL
 arg_has_descriptor(int oldarg)
 {
-  return oldarg > NOSYM && (ASSUMSHPG(oldarg) || POINTERG(oldarg) || 
-                            IS_PROC_DUMMYG(oldarg) ||
-                            ALLOCATTRG(oldarg) || is_kopy_in_needed(oldarg));
+  return oldarg > NOSYM &&
+         (ASSUMSHPG(oldarg) || POINTERG(oldarg) || IS_PROC_DUMMYG(oldarg) ||
+          ALLOCATTRG(oldarg) || is_kopy_in_needed(oldarg));
 }
 
 void
@@ -2613,7 +2613,7 @@ newargs_for_entry(int this_entry)
          */
         set_preserve_descriptor(CLASSG(arg) || is_procedure_ptr(arg) ||
                                 (sem.which_pass && IS_PROC_DUMMYG(arg)) ||
-                                ( ALLOCDESCG(arg) &&  RESULTG(arg)));
+                                (ALLOCDESCG(arg) && RESULTG(arg)));
 
         newdsc = sym_get_arg_sec(arg);
         set_preserve_descriptor(0);
@@ -3970,7 +3970,7 @@ set_assumed_bounds(int arg, int entry, int actual)
   int dtype;
   int r;
   int i, ndim;
-  int ast, ast1, ast2, ast_glb;
+  int ast, ast1, ast2, ast_gbl;
   int sav = 0;
   int tmp_lb, tmp_ub;
   int std;
@@ -4010,9 +4010,9 @@ set_assumed_bounds(int arg, int entry, int actual)
   if (XBIT(58, 0x400000) && TARGETG(arg)) {
     DESCUSEDP(arg, 1);
     ndim = rank_of_sym(arg);
-    assert(r==ndim,"set_assumed_bounds: rank mismatch", ndim,ERR_Fatal);
+    assert(r == ndim, "set_assumed_bounds: rank mismatch", ndim, ERR_Fatal);
     assert(ASSUMSHPG(arg), "set_assumed_bounds(): wrong shape", 0, ERR_Fatal);
-    assert(SCG(arg) == SC_DUMMY,"set_assumed_bounds(): expected dummy arg", 
+    assert(SCG(arg) == SC_DUMMY, "set_assumed_bounds(): expected dummy arg",
            SCG(arg), ERR_Fatal);
     ast_visit(1, 1);
     for (i = 0; i < ndim; i++) {
@@ -4022,7 +4022,6 @@ set_assumed_bounds(int arg, int entry, int actual)
       AD_LWAST(ad, i) = get_global_lower(newdsc, i);
       if (oldast)
         ast_replace(oldast, AD_LWAST(ad, i));
-      
 
       oldast = AD_UPAST(ad, i);
       a = get_extent(newdsc, i);
@@ -4043,7 +4042,6 @@ set_assumed_bounds(int arg, int entry, int actual)
       }
     }
 
-
     for (i = 0; i < ndim; ++i) {
       AD_MLPYR(ad, i) = get_local_multiplier(newdsc, i);
     }
@@ -4053,12 +4051,13 @@ set_assumed_bounds(int arg, int entry, int actual)
     if (ast)
       AD_ZBASE(ad) = ast_rewrite(ast);
     ast_unvisit();
-    goto check_optional;
+    /* goto check_optional; */
   }
 
   /* arg is assumed shape, need to set (and maybe fix if !TARGET) its bounds */
-  if( XBIT(58,0x400000) && !TARGETG(arg) )
-        SDSCS1P(arg, 1); /* see comment below regarding these xbits */
+  if (XBIT(58, 0x400000) && !TARGETG(arg)) {
+    SDSCS1P(arg, 1); /* see comment below regarding these xbits */
+  }
   for (i = 0; i < r; ++i) {
     tmp_lb = AD_LWAST(ad, i); /* temp for lower bound */
     /* declare it by changing the  scope */
@@ -4071,16 +4070,16 @@ 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))) {
+    } else if (XBIT(54, 2) || (XBIT(58, 0x400000) && TARGETG(arg))) {
       /* lower bound assignment */
       /* lb = <global lower bound> */
-      ast_glb = get_global_lower(newdsc, i);
+      ast_gbl = get_global_lower(newdsc, i);
       sav = ast1;
       ast2 = mk_stmt(A_ASN, 0);
       A_DESTP(ast2, tmp_lb);
-      A_SRCP(ast2, ast_glb);
+      A_SRCP(ast2, ast_gbl);
       std = add_stmt_after(ast2, std);
-    } else if (tmp_lb != ast1 ) {
+    } else if (tmp_lb != ast1) {
       /* output lower bound assignment */
       /* lb = <declared lower bound> */
       sav = ast1;
@@ -4091,19 +4090,17 @@ set_assumed_bounds(int arg, int entry, int actual)
     }
 
     /* did we not set lower bound to 1 in to_assumed_shape() or
-     * mk_assumed_shape() because TARGET was not yet available 
+     * mk_assumed_shape() because TARGET was not yet available
      * (still in parser) when this xbit was set?
      */
-    if( XBIT(58,0x400000) && !TARGETG(arg) )
-    {
-        if(AD_LWBD(ad, i) == AD_LWAST(ad, i))
-        {
-            AD_LWBD(ad, i) = astb.bnd.one; /* set in both routines */
-            /* following only set in mk_assumed_shape() */
-            if(AD_LWBD(ad, i) && A_TYPEG(AD_LWBD(ad, i)) != A_CNST && 
-               cc_tmp_var(AD_LWBD(ad, i)))
-                 AD_LWAST(ad, i) = astb.bnd.one; 
-        }
+    if (XBIT(58, 0x400000) && !TARGETG(arg)) {
+      if (AD_LWBD(ad, i) == AD_LWAST(ad, i)) {
+        AD_LWBD(ad, i) = astb.bnd.one; /* set in both routines */
+        /* following only set in mk_assumed_shape() */
+        if (AD_LWBD(ad, i) && A_TYPEG(AD_LWBD(ad, i)) != A_CNST &&
+            cc_tmp_var(AD_LWBD(ad, i)))
+          AD_LWAST(ad, i) = astb.bnd.one;
+      }
     }
 
     /* no need for upper bounds for pointer dummys */

tools/flang1/flang1exe/dpm_out.c

@@ -783,7 +783,8 @@ size_ast_of(int ast, DTYPE dtype)
   case TY_DERIVED:
     if (!sptr)
       sptr = DTY(dtype + 1);
-    if (DTY(dtype + 2) <= 0 && (!CLASSG(sptr) || !DTY(dtype + 1))) {
+    if (DTY(dtype + 2) <= 0 && !UNLPOLYG(DTY(dtype+3)) && 
+        (!CLASSG(sptr) || !DTY(dtype + 1))) {
       errsev(151);
       return mk_isz_cval(4, astb.bnd.dtype);
     } else {

tools/flang1/flang1exe/dtypeutl.c

@@ -1,5 +1,5 @@
 /*
- * Copyright (c) 1997-2017, NVIDIA CORPORATION.  All rights reserved.
+ * Copyright (c) 1997-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.
@@ -35,7 +35,7 @@
 static int errors;
 
 static void lower_start_subroutine(int);
-static void lower_end_subroutine();
+static void lower_end_subroutine(void);
 static void lower_program(int);
 static void save_contained(void);
 static void init_contained(void);
@@ -355,7 +355,7 @@ lower_start_subroutine(int rutype)
 } /* lower_start_subroutine */
 
 static void
-lower_end_subroutine()
+lower_end_subroutine(void)
 {
   fprintf(lowersym.lowerfile, "end\n");
   if (STB_LOWER()) {
@@ -423,7 +423,8 @@ markid(int astx, int *unused)
           SDSCG(sptr) < lowersym.last_outer_sym_orig)
         outerflags[SDSCG(sptr) - lowersym.first_outer_sym] |= 1;
       break;
-    default:;
+    default:
+      break;
     }
     dtype = DTYPEG(sptr);
     if (dtype && DTY(dtype) == TY_ARRAY) {
@@ -570,7 +571,8 @@ lower_end_contains(void)
                 }
               }
               break;
-            default:;
+            default:
+              break;
             }
           }
           outer = 0;

tools/flang1/flang1exe/lower.c

@@ -4434,6 +4434,8 @@ lower_symbol(int sptr)
     putbit("aret", ARETG(sptr));
     putbit("vararg", 0);
     putbit("parref", PARREFG(sptr));
+    if (SCG(sptr) == SC_DUMMY)
+      putval("descriptor", IS_PROC_DUMMYG(sptr) ? SDSCG(sptr) : 0);
     if (gbl.stbfil && DTY(DTYPEG(sptr) + 2)) {
       if (fvalfirst) {
         putsym(NULL, FVALG(sptr));

tools/flang1/flang1exe/lowersym.c

@@ -39,15 +39,15 @@
 
 /* ModuleId is an index into usedb.base[] */
 typedef enum {
-  NO_MODULE         = 0,
-  FIRST_MODULE      = 3,            /* 1 and 2 are not used */
-  ISO_C_MOD         = FIRST_MODULE, /* iso_c_binding module */
-  IEEE_ARITH_MOD,                   /* ieee_arithmetic module */
-  IEEE_FEATURES_MOD,                /* ieee_features module */
-  ISO_FORTRAN_ENV,                  /* iso_fortan_env module */
-  NML_MOD,                          /* namelist */
-  FIRST_USER_MODULE,                /* beginning of use modules */
-  MODULE_ID_MAX     = 0x7fffffff,
+  NO_MODULE = 0,
+  FIRST_MODULE = 3,         /* 1 and 2 are not used */
+  ISO_C_MOD = FIRST_MODULE, /* iso_c_binding module */
+  IEEE_ARITH_MOD,           /* ieee_arithmetic module */
+  IEEE_FEATURES_MOD,        /* ieee_features module */
+  ISO_FORTRAN_ENV,          /* iso_fortan_env module */
+  NML_MOD,                  /* namelist */
+  FIRST_USER_MODULE,        /* beginning of use modules */
+  MODULE_ID_MAX = 0x7fffffff,
 } MODULE_ID;
 
 /* The index into usedb of the module of the current USE statement.
@@ -283,8 +283,7 @@ add_use_rename(SPTR local, SPTR global, LOGICAL is_operator)
    */
   if (!VALID_RENAME_SYM(global)) {
     SPTR sptr;
-    for (sptr = first_hash(global); sptr;
-         sptr = HASHLKG(sptr)) {
+    for (sptr = first_hash(global); sptr; sptr = HASHLKG(sptr)) {
       if (NMPTRG(sptr) == NMPTRG(global) && SCOPEG(sptr) == SCOPEG(global) &&
           VALID_RENAME_SYM(sptr)) {
         if (ST_ISVAR(sptr) && SYMLKG(sptr) &&
@@ -716,7 +715,7 @@ apply_use(MODULE_ID m_id)
     while ((scope = next_scope(scope)) != 0 &&
            get_scope_level(scope) >= save_sem_scope_level) {
       int o, nexto;
-      scope->private = TRUE;
+      scope->Private = TRUE;
       for (o = onlylist; o; o = nexto) {
         nexto = SYMI_NEXT(o);
         if (SCOPEG(SYMI_SPTR(o)) == scope->sptr) {
@@ -1130,7 +1129,6 @@ mod_implicit(int firstc, int lastc, int dtype)
   impl.base[i].firstc = firstc;
   impl.base[i].lastc = lastc;
   impl.base[i].dtype = dtype;
-
 }
 
 static void
@@ -1461,7 +1459,7 @@ MOD_CMN_IDX(int xpriv, int xchar, int xlong, int xinitd, int thrd_priv,
 #define N_MOD_CMN sizeof(mod_cmn) / sizeof(int)
 static int mod_cmn_naln[N_MOD_CMN];
 
-typedef struct itemx {/* generic item record */
+typedef struct itemx { /* generic item record */
   int val;
   struct itemx *next;
 } ITEMX;
@@ -1783,8 +1781,9 @@ fix_module_common(void)
         }
         dty = DTYG(dtype);
         if ((dty == TY_CHAR || dty == TY_NCHAR) && ADJLENG(sptr)) {
-          error(310, 3, gbl.lineno, "Adjustable-length character variables are "
-                                    "not allowed in a MODULE -",
+          error(310, 3, gbl.lineno,
+                "Adjustable-length character variables are "
+                "not allowed in a MODULE -",
                 SYMNAME(sptr));
           err = 1;
         }
@@ -1800,8 +1799,9 @@ fix_module_common(void)
         dtype = DTYPEG(sptr);
         dty = DTYG(dtype);
         if ((dty == TY_CHAR || dty == TY_NCHAR) && ADJLENG(sptr)) {
-          error(310, 3, gbl.lineno, "Adjustable-length character variables are "
-                                    "not allowed in a MODULE -",
+          error(310, 3, gbl.lineno,
+                "Adjustable-length character variables are "
+                "not allowed in a MODULE -",
                 SYMNAME(sptr));
           err = 1;
         }
@@ -2382,10 +2382,10 @@ mod_add_subprogram(int subp)
       i++;
     }
   }
-  if (XBIT(52,0x80)) {
+  if (XBIT(52, 0x80)) {
     char linkage_name[2048];
-    snprintf(linkage_name, sizeof(linkage_name),
-             ".%s.%s", modu_name, SYMNAME(new_sb));
+    snprintf(linkage_name, sizeof(linkage_name), ".%s.%s", modu_name,
+             SYMNAME(new_sb));
     ALTNAMEP(new_sb, getstring(linkage_name, strlen(linkage_name)));
   }
   return new_sb;
@@ -2405,7 +2405,7 @@ export_public_used_modules(int scopelevel)
   if (sem.mod_public_flag && sem.scope_stack) {
     SCOPESTACK *scope = get_scope(scopelevel);
     for (; scope != 0; scope = next_scope(scope)) {
-      if (scope->kind == SCOPE_USE && !scope->private) {
+      if (scope->kind == SCOPE_USE && !scope->Private) {
         export_public_module(scope->sptr, scope->except);
       }
     }