Skip to content
Permalink
Browse files

Merge pull request #823 from ThePortlandGroup/nv_stage

Pull 2019-11-07T08-16 Recent NVIDIA Changes
  • Loading branch information...
sscalpone committed Nov 7, 2019
2 parents eab3991 + 9dd4ed0 commit cbadb27675c4681c8a77eef73c1fbeafee155602
Showing with 597 additions and 110 deletions.
  1. +169 −2 runtime/flang/rdst.c
  2. +14 −0 tools/flang1/flang1exe/dtypeutl.c
  3. +17 −0 tools/flang1/flang1exe/func.c
  4. +7 −1 tools/flang1/flang1exe/lower.h
  5. +6 −0 tools/flang1/flang1exe/lowersym.c
  6. +3 −6 tools/flang1/flang1exe/scopestack.c
  7. +45 −2 tools/flang1/flang1exe/semant.c
  8. +2 −2 tools/flang1/flang1exe/semant.h
  9. +1 −0 tools/flang1/flang1exe/semfin.c
  10. +70 −0 tools/flang1/flang1exe/semfunc.c
  11. +35 −0 tools/flang1/flang1exe/symtab.c
  12. +1 −1 tools/flang1/utils/symtab/symini_ftn.n
  13. +1 −0 tools/flang1/utils/symtab/symtab.in.h
  14. +3 −0 tools/flang1/utils/symtab/symtab.n
  15. +2 −0 tools/flang2/docs/xflag.n
  16. +48 −21 tools/flang2/flang2exe/aarch64-Linux/ll_abi.cpp
  17. +0 −1 tools/flang2/flang2exe/cgmain.cpp
  18. +3 −0 tools/flang2/flang2exe/ili.h
  19. +22 −7 tools/flang2/flang2exe/ll_ftn.cpp
  20. +2 −1 tools/flang2/flang2exe/ll_structure.h
  21. +22 −8 tools/flang2/flang2exe/ll_write.cpp
  22. +2 −2 tools/flang2/flang2exe/llassem.cpp
  23. +1 −1 tools/flang2/flang2exe/llassem_common.cpp
  24. +12 −8 tools/flang2/flang2exe/lldebug.cpp
  25. +37 −0 tools/flang2/flang2exe/llutil.cpp
  26. +4 −0 tools/flang2/flang2exe/llutil.h
  27. +8 −0 tools/flang2/flang2exe/mwd.cpp
  28. +4 −40 tools/flang2/flang2exe/ppc64le-Linux/ll_abi.cpp
  29. +20 −4 tools/flang2/flang2exe/upper.cpp
  30. +7 −1 tools/flang2/flang2exe/upper.h
  31. +15 −2 tools/flang2/utils/ilitp/ilitp_atomic.n
  32. +12 −0 tools/flang2/utils/symtab/symtab.n
  33. +1 −0 tools/shared/rtlRtns.c
  34. +1 −0 tools/shared/rtlRtns.h
@@ -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++ : ' ';
}
}
@@ -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;
}

@@ -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);
@@ -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);
@@ -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));
@@ -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));
}

@@ -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);

0 comments on commit cbadb27

Please sign in to comment.
You can’t perform that action at this time.