Commit 9da62f75 authored by Radford Neal's avatar Radford Neal

speed up forcePromise, especially for self-eval code

parent 3791d408
......@@ -185,6 +185,8 @@
\code{unlist(list(x=list(2,a=3)))} and \code{unlist(list(x=c(2,a=3)))}
now return the same result (in which the name for the first element
is \code{x}, not \code{x1}).
\item The warning message "restarting interrupted promise evaluation" is
no longer produced.
\item The \code{\%\%} operator can no longer produce a warning of
"probable complete loss of accuracy in modulus", the possiblity
of which had prevented it being done in parallel in a helper thread.
......
......@@ -304,7 +304,7 @@
Rf_LogicalFromInteger
Rf_LogicalFromReal
Rf_LogicalFromString
Rf_PRSEEN_error_or_warning
Rf_PRSEEN_error
Rf_PrintDefaults
Rf_PrintGreeting
Rf_PrintValueEnv
......
......@@ -1312,7 +1312,7 @@ extern0 Rboolean known_to_be_utf8 INI_as(FALSE);
# define PrintVersion_part_1 Rf_PrintVersion_part_1
# define PrintVersionString Rf_PrintVersionString
# define PrintWarnings Rf_PrintWarnings
# define PRSEEN_error_or_warning Rf_PRSEEN_error_or_warning
# define PRSEEN_error Rf_PRSEEN_error
# define promiseArgs Rf_promiseArgs
# define promiseArgsWithValues Rf_promiseArgsWithValues
# define promiseArgsWith1Value Rf_promiseArgsWith1Value
......@@ -1646,7 +1646,7 @@ R_NORETURN void arg_missing_error(SEXP sym);
R_NORETURN void unbound_var_error(SEXP sym);
R_NORETURN void out_of_bounds_error(SEXP call);
R_NORETURN void nonsubsettable_error(SEXP call, SEXP x);
void PRSEEN_error_or_warning(SEXP e);
R_NORETURN void PRSEEN_error(SEXP e);
Rboolean Rf_strIsASCII(const char *str);
int utf8clen(char c);
......
......@@ -659,47 +659,56 @@ SEXP attribute_hidden Rf_evalv_other (SEXP e, SEXP rho, int variant)
/* e is protected here */
SEXP attribute_hidden forcePromiseUnbound (SEXP e, int variant)
{
RPRSTACK prstack;
SEXP val;
PROTECT(e);
val = PRCODE(e);
if (PRSEEN(e)) PRSEEN_error_or_warning(e);
if ( ! SELF_EVAL(TYPEOF(val)) ) {
/* Mark the promise as under evaluation and push it on a stack
that can be used to unmark pending promises if a jump out
of the evaluation occurs. */
RPRSTACK prstack;
prstack.promise = e;
prstack.next = R_PendingPromises;
R_PendingPromises = &prstack;
if (PRSEEN(e) == 1) PRSEEN_error(e);
SET_PRSEEN(e, 1);
/* Mark the promise as under evaluation and push it on a stack
that can be used to unmark pending promises if a jump out
of the evaluation occurs. */
val = EVALV (PRCODE(e), PRENV(e),
(variant & VARIANT_PENDING_OK) | VARIANT_MISSING_OK);
prstack.promise = e;
prstack.next = R_PendingPromises;
R_PendingPromises = &prstack;
/* Pop the stack, unmark the promise and set its value field. */
SET_PRSEEN(e, 1);
R_PendingPromises = prstack.next;
SET_PRSEEN(e, 0);
SET_PRVALUE(e, val);
INC_NAMEDCNT(val);
PROTECT(e);
val = EVALV (val, PRENV(e),
(variant & VARIANT_PENDING_OK) | VARIANT_MISSING_OK);
UNPROTECT(1);
/* Pop the stack, unmark the promise and set its value field. */
R_PendingPromises = prstack.next;
SET_PRSEEN(e, 0);
}
/* Attempt to mimic past behaviour... */
if (val == R_MissingArg) {
if ( ! (variant & VARIANT_MISSING_OK) && TYPEOF(PRCODE(e)) == SYMSXP
SET_PRVALUE(e, val);
if (val == R_MissingArg) { /* Attempt to mimic past behaviour... */
if ( ! (variant & VARIANT_MISSING_OK) && TYPEOF(PRCODE(e)) == SYMSXP
&& R_isMissing (PRCODE(e), PRENV(e)))
arg_missing_error(PRCODE(e));
}
else {
/* Set the environment to R_NilValue to allow GC to
reclaim the promise environment (unless value is R_MissingArg);
this is also useful for fancy games with delayedAssign() */
/* Set the environment to R_NilValue to allow GC to reclaim the
promise environment (unless value is R_MissingArg); this is
also useful for fancy games with delayedAssign() */
SET_PRENV(e, R_NilValue);
}
UNPROTECT(1);
INC_NAMEDCNT(val);
return val;
}
......
......@@ -715,14 +715,10 @@ R_NORETURN void attribute_hidden apply_non_function_error(void)
error(_("attempt to apply non-function"));
}
void attribute_hidden PRSEEN_error_or_warning(SEXP e)
R_NORETURN void attribute_hidden PRSEEN_error(SEXP e)
{
if (PRSEEN(e) == 1)
errorcall(R_GlobalContext->call,
_("promise already under evaluation: recursive default argument reference or earlier problems?"));
else
warningcall(R_GlobalContext->call,
_("restarting interrupted promise evaluation"));
errorcall (R_GlobalContext->call,
_("promise already under evaluation: recursive default argument reference or earlier problems?"));
}
R_NORETURN void attribute_hidden Rf_asLogicalNoNA_error (SEXP s, SEXP call)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment