Merge pull request #823 from ThePortlandGroup/nv_stage

Pull 2019-11-07T08-16 Recent NVIDIA Changes

Author: sscalpone

runtime/flang/rdst.c

@@ -1,5 +1,5 @@
 /*
- * Copyright (c) 1995-2018, NVIDIA CORPORATION.  All rights reserved.
+ * Copyright (c) 1995-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.
@@ -24,12 +24,20 @@
 #include "stdioInterf.h"
 #include "fioMacros.h"
 
+extern char *__fstr2cstr();
+
 void
 ENTFTN(TEMPLATE, template)(F90_Desc *dd, __INT_T *p_rank,
        __INT_T *p_flags, ...);
 
+#include <string.h>
 #include "fort_vars.h"
-
+#if defined(TARGET_LINUX_X8664) || defined (TARGET_LINUX_POWER) || defined(TARGET_OSX_X8664)
+#include <unistd.h>
+#include <sys/wait.h>
+#endif
+static void store_int_kind(void *, __INT_T *, int);
+static void ftn_msgcpy(char*, const char*, int);
 static char *intents[] = {"INOUT", "IN", "OUT", "??"};
 
 /** \brief Compare alignments and local storage sequences.  Return true if all
@@ -2808,4 +2816,163 @@ ENTF90(CONTIGCHK, contigchk)(void *ptr, F90_Desc *pd, __INT_T lineno,
     ENTF90(CONTIGERROR, contigerror)(ptr, pd, lineno, ptrnam, srcfil, flags);
   }
 }
+
+/** \brief Execute a command line.
+  * 
+  * \param command is the command to be executed.
+  * \param wait controls to execute command synchronously or asynchronously.
+  * \param exitstatus is the value of exit status.
+  * \param cmdstat shows the status of command execution.
+  * \param cmdmsg is the assigned explanatory message.
+  * \param exitstat_int_kind is the integer kind for the exitstat.
+  * \param cmdstat_int_kind is the integer kind for the cmdstat.
+  * \param DCLEN64(command) is generated by compiler which contains the length
+  *        of the command string.
+  * \param DCLEN64(cmdmsg) is generated by compiler which contains the length
+           of the cmdmsg string.
+  */
+void
+ENTF90(EXECCMDLINE, execcmdline)(DCHAR(command), __LOG_T *wait,
+                                 __INT_T *exitstatus,
+                                 __INT_T *cmdstat, DCHAR (cmdmsg),
+                                 __INT_T *exitstat_int_kind, 
+                                 __INT_T *cmdstat_int_kind 
+                                 DCLEN64(command) DCLEN64(cmdmsg)) {
+  char *cmd, *cmdmes;
+  int cmdmes_len, stat;
+  int cmdflag = 0;
+  enum CMD_ERR{NO_SUPPORT_ERR=-1, FORK_ERR=1, EXECL_ERR=2, SIGNAL_ERR=3};
 
+  cmd = __fstr2cstr(CADR(command), CLEN(command));
+  cmdmes = (char*) CADR(cmdmsg);
+  cmdmes_len = CLEN(cmdmsg);
+
+  if (cmdstat)
+    store_int_kind(cmdstat, cmdstat_int_kind, 0);
+#if defined(TARGET_LINUX_X8664) || defined(TARGET_OSX_X8664) || defined (TARGET_LINUX_POWER)
+  pid_t pid, w;
+  int wstatus, ret;
+  
+  /* If WAIT is present with the value false, and the processor supports
+   * asynchronous execution of the command, the command is executed
+   * asynchronously; otherwise it is executed synchronously.
+   */
+  pid = fork();
+  if (pid < 0) {
+    if (cmdmes)
+      ftn_msgcpy(cmdmes, "Fork failed", cmdmsg_len); 
+    if (cmdstat)
+      store_int_kind(cmdstat, cmdstat_int_kind, FORK_ERR);
+  } else if (pid == 0) {
+    ret = execl("/bin/sh", "sh", "-c", cmd, (char *) NULL);
+    exit(ret);
+  } else {
+    // either wait is not specified or wait is true, then synchronous mode
+    if ( !wait || *wait == -1) {
+#if DEBUG
+      printf("either wait is not specified or Wait = .true.\n");
+      printf("Synchronous execution mode!\n");
+#endif
+      /* code executed by parent, wait for children */
+      w = waitpid(pid, &wstatus, WUNTRACED | WCONTINUED);
+      if (w == -1)
+        cmdflag = EXECL_ERR;
+    
+      if (WIFEXITED(wstatus)) { 
+        stat = WEXITSTATUS(wstatus);
+
+        if (exitstatus)
+          store_int_kind(exitstatus, exitstat_int_kind, stat);
+      }
+
+      if (WIFSIGNALED(wstatus))
+        cmdflag = SIGNAL_ERR;
+
+      if (cmdstat && cmdflag > 0)
+        store_int_kind(cmdstat, cmdstat_int_kind, cmdflag);
+
+      if (cmdmes) {
+        switch (cmdflag) {
+        case EXECL_ERR:
+          ftn_msgcpy(cmdmes, "Excel failed", cmdmsg_len); 
+          break;
+        case SIGNAL_ERR:
+          ftn_msgcpy(cmdmes, "Signal error", cmdmsg_len);
+          break;
+        }
+      }
+
+      /* If a condition occurs that would assign a nonzero value to CMDSTAT 
+         but the CMDSTAT variable is not present, error termination is
+         initiated.
+       */
+      if (!cmdstat && cmdflag > 0) {
+        fprintf(__io_stderr(), "ERROR STOP ");
+        exit(cmdflag);
+      }
+        
+#if DEBUG
+      if (WIFEXITED(wstatus)) {
+        printf("exited, status=%d\n", WEXITSTATUS(wstatus));
+      } else if (WIFSIGNALED(wstatus)) {
+        printf("killed by signal %d\n", WTERMSIG(wstatus));
+      } else if (WIFSTOPPED(wstatus)) {
+        printf("stopped by signal %d\n", WSTOPSIG(wstatus));
+      } else if (WIFCONTINUED(wstatus)) {
+        printf("continued\n");
+      }
+#endif
+    } // end else
+  }
+#else // defined(TARGET_WIN)
+  // Windows runtime work to be continued.
+  cmdflag = NO_SUPPORT_ERR;
+  if (cmdmes)
+    ftn_msgcpy(cmdmes, "No Windows support", cmdmsg_len); 
+  if (cmdstat)
+    store_int_kind(cmdstat, cmdstat_int_kind, cmdflag);
+  else
+    __fort_abort("execute_command_line: not yet supported on Windows\n");
+#endif
+   __cstr_free(cmd);
+}  
+
+// TODO: Code restructure needed to reduce redundant codes.
+/*
+ * helper function to store an int/logical value into a varying int/logical
+ */
+static void
+store_int_kind(void *b, __INT_T *int_kind, int v)
+{
+  switch (*int_kind) {
+  case 1:
+    *(__INT1_T *)b = (__INT1_T)v;
+    break;
+  case 2:
+    *(__INT2_T *)b = (__INT2_T)v;
+    break;
+  case 4:
+    *(__INT4_T *)b = (__INT4_T)v;
+    break;
+  case 8:
+    *(__INT8_T *)b = (__INT8_T)v;
+    break;
+  default:
+    __fort_abort("store_int_kind: unexpected int kind");
+  }
+}
+
+// TODO: Code restructure needed to reduce redundant codes.
+/** \brief Copy msg string to statmsg and padding with blank space at the end.
+  * 
+  * \param statmsg is the Fortran string we want to assign values.
+  * \param msg is the string contains error message.
+  * \param len is the length of statmsg. 
+  */
+static void 
+ftn_msgcpy(char *statmsg, const char *msg, int len) {
+  int i;
+  for (i=0; i<len; ++i) {
+    statmsg[i] = *msg ? *msg++ : ' ';
+  }
+}

tools/flang1/flang1exe/dtypeutl.c

@@ -1517,6 +1517,20 @@ tk_match_arg(int formal_dt, int actual_dt, LOGICAL flag)
     }
   }
   else if (!eq_dtype2(f_dt, a_dt, flag)) {
+    if (DTY(f_dt) == TY_PTR && DTY(a_dt) == TY_PTR && 
+        DTY(DTY(f_dt + 1)) == TY_PROC && DTY(DTY(a_dt + 1)) == TY_PROC) {
+      /* eq_dtype2 checks equality of the procedure pointers.
+       * If they are not the same (including the same name), then
+       * it returns false. This is correct for an equality test.
+       * However, in this case, we don't care about the names being
+       * the same if all other attributes are equal.
+       */
+       DTYPE d1 = DTY(f_dt + 1);
+       DTYPE d2 = DTY(a_dt + 1);
+       if (cmp_interfaces(DTY(d1 + 2), DTY(d2 + 2), FALSE)) {
+         return TRUE;
+       }
+    } 
     return FALSE;
   }
 

tools/flang1/flang1exe/func.c

@@ -1968,6 +1968,23 @@ rewrite_func_ast(int func_ast, int func_args, int lhs)
       ARGT_ARG(newargt, 3) = dim;
     }
     goto ret_new;
+  case I_EXECUTE_COMMAND_LINE:
+    nargs = 7;
+    rtlRtn = RTE_execcmdline;
+    newsym = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), DT_INT);
+    newargt = mk_argt(nargs);
+    for (i = 0; i < nargs - 1; i++) {
+      int arg = ARGT_ARG(func_args, i);
+      ARGT_ARG(newargt, i) = arg != 0 ? arg : i == 0 ? astb.ptr0c : astb.ptr0;
+    }
+    /* Add two extra arguments at the end of the execute_command_line argument
+       list. Those two integer kind for the exitstat and cmdstat argument
+       respectively.
+     */
+    ARGT_ARG(newargt, nargs - 2) = mk_cval(size_of(stb.user.dt_int), DT_INT4);    
+    ARGT_ARG(newargt, nargs - 1) = mk_cval(size_of(stb.user.dt_int), DT_INT4);    
+    is_icall = FALSE;
+    goto ret_call;
   case I_NORM2:     /* norm2(array, [dim]) */
     srcarray = ARGT_ARG(func_args, 0);
     dim = ARGT_ARG(func_args, 1);

tools/flang1/flang1exe/lower.h

@@ -136,9 +136,15 @@
  *              All of 1.53 +
  *              pass allocptr and ptrtarget values for default initialization
  *              of standalone pointers.
+ *
+ * 20.1         -- 1.55
+ *              All of 1.54 +
+ *              pass elemental field for subprogram when emitting ST_ENTRY.
+ *
+ *              For ST_PROC, pass IS_PROC_PTR_IFACE flag.
  */
 #define VersionMajor 1
-#define VersionMinor 54
+#define VersionMinor 55
 
 void lower(int);
 void lower_end_contains(void);

tools/flang1/flang1exe/lowersym.c

@@ -3951,6 +3951,7 @@ lower_symbol(int sptr)
 #endif
       putbit("pure", 0);
       putbit("recursive", 0);
+      putbit("elemental", 0);
       putval("returnval", 0);
       putbit("passbyval", 0);
       putbit("passbyref", 0);
@@ -4042,6 +4043,7 @@ lower_symbol(int sptr)
         putbit("is_interface", IS_INTERFACEG(sptr));
         putval("assocptr", ASSOC_PTRG(sptr));
         putval("ptrtarget",PTR_TARGETG(sptr));
+        putbit("prociface", IS_PROC_PTR_IFACEG(sptr));
       }
 
       strip = 1;
@@ -4077,6 +4079,7 @@ lower_symbol(int sptr)
     putbit("mscall", MSCALLG(sptr));
     putbit("pure", PUREG(sptr));
     putbit("recursive", RECURG(sptr));
+    putbit("elemental", ELEMENTALG(sptr));
     putsym("returnval", FVALG(sptr));
     putbit("passbyval", PASSBYVALG(sptr));
     putbit("passbyref", PASSBYREFG(sptr));
@@ -4271,6 +4274,7 @@ lower_symbol(int sptr)
 #endif
     putval("assocptr", ASSOC_PTRG(sptr));
     putval("ptrtarget", PTR_TARGETG(sptr));
+    putbit("prociface", IS_PROC_PTR_IFACEG(sptr));
     strip = 1;
     break;
 
@@ -4320,6 +4324,7 @@ lower_symbol(int sptr)
     putbit("is_interface", 0);
     putval("assocptr", 0);
     putval("ptrtarget", 0);
+    putbit("prociface", 0);
     strip = 1;
     break;
 
@@ -4521,6 +4526,7 @@ lower_symbol(int sptr)
       putval("descriptor", IS_PROC_DUMMYG(sptr) ? SDSCG(sptr) : 0);
     putsym("assocptr", ASSOC_PTRG(sptr));
     putsym("ptrtarget", PTR_TARGETG(sptr));
+    putbit("prociface", IS_PROC_PTR_IFACEG(sptr)); 
     if (gbl.stbfil && DTY(DTYPEG(sptr) + 2)) {
       if (fvalfirst) {
         putsym(NULL, FVALG(sptr));

tools/flang1/flang1exe/scopestack.c

@@ -421,17 +421,14 @@ void
 par_pop_scope(void)
 {
   SCOPE_SYM *symp;
-  int blksym;
   /*
-   * Restore the scope of any symbols which appeared in a SHARED
-   * clause -- this is only needed if the DEFAULT scope is 'PRIVATE' or
-   * 'NONE".
+   * Restore the scope of any symbols that appeared in a SHARED clause.
+   * This is only needed if the DEFAULT scope is 'PRIVATE' or 'NONE".
    */
   for (symp = curr_scope()->shared_list; symp != NULL; symp = symp->next) {
     SCOPEP(symp->sptr, symp->scope);
   }
-  blksym = curr_scope()->sym;
-  if (blksym) {
+  if (BLK_SYM(sem.scope_level)) {
     exit_lexical_block(flg.debug && !XBIT(123, 0x400));
   }
 

tools/flang1/flang1exe/semant.c

@@ -2479,7 +2479,7 @@ semant1(int rednum, SST *top)
        * body should never contain a procedure defined by a subprogram,
        * so this flag should never be set for an interface. Because
        * getsym() does not have access to sem.interface, we reset the
-       *  NTERNAL flag here.
+       * INTERNAL flag here.
        */
       INTERNALP(sptr, 0);
     }
@@ -3027,7 +3027,7 @@ semant1(int rednum, SST *top)
     set_construct_name(0);
     // fall through
   case BLOCK_STMT2:
-    if (DI_NEST(sem.doif_depth) >= DI_B(DI_FIRST_DIRECTIVE))
+    if (DI_NEST(sem.doif_depth) >= DI_B(DI_FIRST_DIRECTIVE) && !XBIT(59,8))
       error(1219, ERR_Severe, gbl.lineno,
             "BLOCK construct in the scope of a parallel directive", CNULL);
     sptr = sem.scope_stack[sem.scope_level].sptr;
@@ -11343,6 +11343,49 @@ semant1(int rednum, SST *top)
       if (POINTERG(sptr)) {
         attr |= ET_B(ET_POINTER);
       } 
+    if (!IS_PROC_DUMMYG(sptr) && IS_INTERFACEG(proc_interf_sptr) &&
+        !IS_PROC_PTR_IFACEG(proc_interf_sptr)) {
+      /* Create a unique symbol for the interface so it does not conflict with
+       * an external procedure symbol. For non-procedure dummy arguments,
+       * we need a unique symbol for the interface in order to preserve
+       * the interface flag (IS_PROC_PTR_IFACE). We need the interface flag in 
+       * the back-end so we properly generate the procedure descriptor
+       * actual arguments on the call-site (when we call the procedure pointer).
+       * This is only needed  by the LLVM back-end because the bridge uses the 
+       * interface to generate the LLVM IR for the actual arguments. 
+       */
+      char * buf;
+      int len;
+      SPTR sym;
+    
+      /* First, let's see if we aleady have a unique interface symbol */ 
+      len = strlen(SYMNAME(proc_interf_sptr)) + strlen("iface") + 1;
+      buf = getitem(0, len);
+      sprintf(buf,"%s$iface",SYMNAME(proc_interf_sptr));
+      sym = findByNameStypeScope(buf, ST_PROC, 0);
+      if (sym > NOSYM && !cmp_interfaces_strict(sym, proc_interf_sptr, 0)) { 
+        /* The interface is not compatible. We will now try to find one that
+         * is compatible in the symbol table.
+         */
+        SPTR sym2 = sym;
+        get_next_hash_link(sym2, 0);
+        while ((sym2=get_next_hash_link(sym2, 1)) > NOSYM) {
+          if (cmp_interfaces_strict(sym2, proc_interf_sptr, 0)) {
+            break;
+          }
+        }
+        sym = sym2;
+      }
+      if (sym <= NOSYM) {  
+        /* We don't yet have a unique interface symbol, so create it now */
+        sym  = get_next_sym(SYMNAME(proc_interf_sptr), "iface");
+        /* Propagate flags from the original symbol to the new symbol */
+        copy_sym_flags(sym, proc_interf_sptr);
+        HCCSYMP(sym, 1);
+        IS_PROC_PTR_IFACEP(sym, 1);
+      }
+      proc_interf_sptr = sym;
+    }
       sptr = decl_procedure_sym(sptr, proc_interf_sptr, attr);
       sptr =
           setup_procedure_sym(sptr, proc_interf_sptr, attr, entity_attr.access);