Merge pull request #587 from ThePortlandGroup/nv_stage

Pull 2018-09-12T18-00 Recent NVIDIA Changes

Author: sscalpone

include/flang/Error/errmsg-in.n

@@ -1168,9 +1168,8 @@ An actual argument that is an array element cannot be passed to a REFLECTED dumm
 .MS E 487 "Index variable $ does not appear in a subscript on the left hand side of the FORALL assignment"
 In a FORALL statement, each index variable in the FORALL must appear in some subscript of the left hand side of the FORALL assignment.
 Otherwise, the FORALL will assign the same left hand side elements for different values of that index.
-.MS E 488 "The function call in the FORALL does not have the PURE attribute - $"
-In a FORALL statement, all functions used must be PURE or ELEMENTAL.
-Otherwise, they cannot be called in parallel.
+.MS S 488 "$ is not PURE - $"
+DO CONCURRENT and FORALL subprogram calls must be PURE or ELEMENTAL.
 .MS I 489 "An ALLOCATE of a POINTER with transcriptive or inherited distribution causes replication - $"
 When an array with the POINTER attribute and with a distributed that is transcriptive or inherited is allocated,
 the alignment and distribution are ignored and the array pointer is treated as replicated,

tools/flang1/flang1exe/commopt.c

@@ -3584,10 +3584,11 @@ is_pcalls(int std, int fstd)
   ast = STD_AST(std);
   if (A_TYPEG(ast) == A_CALL) {
     sptr = A_SPTRG(A_LOPG(ast));
-    if (PUREG(sptr) || (ELEMENTALG(sptr) && !IMPUREG(sptr)))
-      return TRUE;
+    if (is_impure(sptr))
+      error(488, 4, STD_LINENO(fstd), "subprogram call in FORALL",
+            SYMNAME(sptr));
     else
-      error(488, 4, STD_LINENO(fstd), SYMNAME(sptr), CNULL);
+      return TRUE;
   }
   if (A_TYPEG(ast) == A_ICALL)
     return TRUE;

tools/flang1/flang1exe/dpm_out.c

@@ -2358,19 +2358,19 @@ emit_alnd(int sptr, int memberast, LOGICAL free_flag, LOGICAL for_allocate,
 }
 
 void
-make_temp_descriptor(int sptr_orig, int sptr_tmp, int before_std)
+make_temp_descriptor(int ast_ele, SPTR sptr_orig, SPTR sptr_tmp, int before_std)
 {
     /* call pgf90_temp_desc(tmp desc, orig desc) */
     SPTR sptr_descr;
-    int  sptrdescr_arg, ast;
+    int  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;
+    assert(sptr_descr,"missing descriptor for tmp",(int)sptr_tmp,ERR_Fatal);
+    ARGT_ARG(argt, 0) = mk_id(sptr_descr);
     sptr_descr = DESCRG(sptr_orig);
-    sptrdescr_arg = mk_id(sptr_descr);
-    ARGT_ARG(argt, 1) = sptrdescr_arg;
+    assert(sptr_descr,"missing descriptor for orig",(int)sptr_orig,ERR_Fatal);
+    ARGT_ARG(argt, 1) = check_member(ast_ele,mk_id(sptr_descr));
 
     ast =
         mk_func_node(A_CALL, 

tools/flang1/flang1exe/dtypeutl.c

@@ -1781,6 +1781,21 @@ has_finalized_component(SPTR sptr)
   return test_sym_components_only(sptr, is_finalized);
 }
 
+static LOGICAL
+is_impure_finalizer(int sptr, struct visit_list **visited)
+{
+  return sptr > NOSYM &&
+         ((STYPEG(sptr) == ST_MEMBER &&
+           FINALG(sptr) && is_impure(VTABLEG(sptr))) ||
+           search_type_members(DTYPEG(sptr), is_impure_finalizer, visited));
+}
+
+LOGICAL
+has_impure_finalizer(SPTR sptr)
+{
+  return test_sym_and_components(sptr, is_impure_finalizer);
+}
+
 static LOGICAL
 is_layout_desc(SPTR sptr, struct visit_list **visited)
 {

tools/flang1/flang1exe/extern.h

@@ -72,7 +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 */
+void make_temp_descriptor(int, SPTR, SPTR, 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/kwddf.h

@@ -75,21 +75,21 @@ typedef struct {
  * table and let alpha() do the rest.  (NOTE that 0 is returned by
  * keyword() if a name is not found in a keyword table).
  */
-#define TKF_BLOCK -1
-#define TKF_DOUBLE -2
-#define TKF_GO -3
-#define TKF_SELECT -4
-#define TKF_NO -5
-#define TKF_ARRAY -6
-#define TKF_ENDBLOCK -7
-#define TKF_ATOMIC -8
-#define TKF_DOWHILE -9
-#define TKF_DOCONCURRENT -10
-#define TKF_TARGETENTER -11
-#define TKF_TARGETEXIT -12
-#define TKF_CANCELLATION -13
-#define TKF_DISTPAR -14
-#define TKF_ENDDISTPAR -15
+#define TKF_ARRAY -1
+#define TKF_ATOMIC -2
+#define TKF_CANCELLATION -3
+#define TKF_DISTPAR -4
+#define TKF_DOCONCURRENT -5
+#define TKF_DOUBLE -6
+#define TKF_DOWHILE -7
+#define TKF_ENDDISTPAR -8
+#define TKF_GO -9
+#define TKF_NO -10
+#define TKF_SELECT -11
+#define TKF_TARGETENTER -12
+#define TKF_TARGETEXIT -13
+#define TKF_BLOCK -14
+#define TKF_ENDBLOCK -15
 
 static KWORD t1[] = {         /* normal keyword table */
                      {"", 0}, /* a keyword index must be nonzero */
@@ -115,15 +115,18 @@ static KWORD t1[] = {         /* normal keyword table */
                      {"close", TK_CLOSE},
                      {"common", TK_COMMON},
                      {"complex", TK_COMPLEX},
+                     {"concurrent", TK_CONCURRENT},
                      {"contains", TK_CONTAINS},
                      {"contiguous", TK_CONTIGUOUS},
                      {"continue", TK_CONTINUE},
                      {"cycle", TK_CYCLE},
                      {"data", TK_DATA},
                      {"deallocate", TK_DEALLOCATE},
                      {"decode", TK_DECODE},
+                     {"default", TK_DEFAULT},
                      {"dimension", TK_DIMENSION},
                      {"do", TK_DO},
+                     {"doconcurrent", TKF_DOCONCURRENT},
                      {"double", TKF_DOUBLE},
                      {"doublecomplex", TK_DBLECMPLX},
                      {"doubleprecision", TK_DBLEPREC},
@@ -182,13 +185,16 @@ static KWORD t1[] = {         /* normal keyword table */
                      {"intent", TK_INTENT},
                      {"interface", TK_INTERFACE},
                      {"intrinsic", TK_INTRINSIC},
+                     {"local", TK_LOCAL},
+                     {"local_init", TK_LOCAL_INIT},
                      {"logical", TK_LOGICAL},
                      {"map", TK_MAP},
                      {"module", TK_MODULE},
                      {"namelist", TK_NAMELIST},
                      {"ncharacter", TK_NCHARACTER},
                      {"no", TKF_NO},
                      {"non_intrinsic", TK_NON_INTRINSIC},
+                     {"none", TK_NONE},
                      {"nopass", TK_NOPASS},
                      {"nosequence", TK_NOSEQUENCE},
                      {"nullify", TK_NULLIFY},
@@ -217,6 +223,7 @@ static KWORD t1[] = {         /* normal keyword table */
                      {"selectcase", TK_SELECTCASE},
                      {"selecttype", TK_SELECTTYPE},
                      {"sequence", TK_SEQUENCE},
+                     {"shared", TK_SHARED},
                      {"stop", TK_STOP},
                      {"structure", TK_STRUCTURE},
                      {"submodule", TK_SUBMODULE},

tools/flang1/flang1exe/lowersym.c

@@ -1046,6 +1046,10 @@ lower_prepare_symbols()
         DTYPEP(sptr, dtype);
         lower_use_datatype(dtype, 1);
       }
+
+      if (IGNOREG(sptr))
+        break;
+
       if (DTY(dtype) == TY_ARRAY) {
         if ((POINTERG(sptr) || ALLOCG(sptr)) && SDSCG(sptr) &&
             STYPEG(SDSCG(sptr)) != ST_PARAM) {

tools/flang1/flang1exe/rest.c

@@ -1997,9 +1997,9 @@ transform_call(int std, int ast)
            * 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.
+           * is identified. 
            */
-          if(XBIT(58,0x400000)&&ASSUMSHPG(inface_arg)&&TARGETG(inface_arg))
+          if(XBIT(58,0x400000) && ASSUMSHPG(inface_arg) && TARGETG(inface_arg))
           {
             char nd[50];    /* new, substitute, descriptor for this arg */
             static int ndctr = 0;
@@ -2011,7 +2011,7 @@ transform_call(int std, int ast)
             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);
+            make_temp_descriptor(ele, sptr, sptrtmp, std);
             sptrdesc = DESCRG(sptrtmp);
             ARGT_ARG(newargt, newj) = check_member(ele, mk_id(sptrdesc));
           }
@@ -2092,9 +2092,9 @@ transform_call(int std, int ast)
             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);
+            make_temp_descriptor(ele, sptr, sptrtmp, std);
             sptrdesc = DESCRG(sptrtmp);
-            ARGT_ARG(newargt, newj) = check_member(lop_ele, mk_id(sptrdesc));
+            ARGT_ARG(newargt, newj) = check_member(ele, mk_id(sptrdesc));
           }
           else
             ARGT_ARG(newargt, newj) = descr;
@@ -2407,9 +2407,7 @@ pure_procedure(int ast)
 static void
 check_pure_interface(int entry, int std, int ast)
 {
-  if ((PUREG(gbl.currsub) ||
-       (ELEMENTALG(gbl.currsub) && !IMPUREG(gbl.currsub))) &&
-      !HCCSYMG(entry) && !pure_procedure(ast)) {
+  if (!is_impure(gbl.currsub) && !HCCSYMG(entry) && !pure_procedure(ast)) {
     switch (STYPEG(entry)) {
     case ST_INTRIN:
     case ST_GENERIC: