From a09b7e26453c7267dc1ed28da954db3a41d4497d Mon Sep 17 00:00:00 2001 From: luke Date: Mon, 2 Oct 2023 19:56:19 +0000 Subject: [PATCH] Added experimental primitives Exec and Tailcall. git-svn-id: https://svn.r-project.org/R/trunk@85253 00db46b3-68df-0310-9c12-caf00c1e9a41 --- doc/NEWS.Rd | 3 + src/include/Internal.h | 1 + src/library/base/R/zzz.R | 3 + src/library/base/man/Tailcall.Rd | 79 +++++++++++++++ src/main/eval.c | 159 +++++++++++++++++++++++++++++++ src/main/names.c | 2 + tests/primitives.R | 1 + 7 files changed, 248 insertions(+) create mode 100644 src/library/base/man/Tailcall.Rd diff --git a/doc/NEWS.Rd b/doc/NEWS.Rd index 1b3e0906363..bf376b7c1a0 100644 --- a/doc/NEWS.Rd +++ b/doc/NEWS.Rd @@ -161,6 +161,9 @@ We have simplified the internal code and now basically format the real and imaginary parts independently of each other. + + \item New experimental functions \code{Tailcall} and \code{Exec} + to support writing stack-space-effcient recursive functions. } } diff --git a/src/include/Internal.h b/src/include/Internal.h index 8eb34006967..eb70a2c6698 100644 --- a/src/include/Internal.h +++ b/src/include/Internal.h @@ -429,6 +429,7 @@ SEXP do_sysgetpid(SEXP, SEXP, SEXP, SEXP); SEXP do_system(SEXP, SEXP, SEXP, SEXP); SEXP do_systime(SEXP, SEXP, SEXP, SEXP); SEXP do_tabulate(SEXP, SEXP, SEXP, SEXP); +SEXP do_tailcall(SEXP, SEXP, SEXP, SEXP); SEXP do_tempdir(SEXP, SEXP, SEXP, SEXP); SEXP do_tempfile(SEXP, SEXP, SEXP, SEXP); SEXP do_tilde(SEXP, SEXP, SEXP, SEXP); diff --git a/src/library/base/R/zzz.R b/src/library/base/R/zzz.R index bbdd400b1d8..a76b5d7c8f0 100644 --- a/src/library/base/R/zzz.R +++ b/src/library/base/R/zzz.R @@ -150,6 +150,9 @@ assign("unCfillPOSIXlt", function(x) NULL, envir = .ArgsEnv) assign("unclass", function(x) NULL, envir = .ArgsEnv) assign("untracemem", function(x) NULL, envir = .ArgsEnv) +assign("Exec", function(expr, envir) NULL, envir = .ArgsEnv) +assign("Tailcall", function(FUN, ...) NULL, envir = .ArgsEnv) + ## 2) .GenericArgsEnv : The generic .Primitives : diff --git a/src/library/base/man/Tailcall.Rd b/src/library/base/man/Tailcall.Rd new file mode 100644 index 00000000000..f18408f1320 --- /dev/null +++ b/src/library/base/man/Tailcall.Rd @@ -0,0 +1,79 @@ +% File src/library/base/man/Tailcall.Rd +% Part of the R package, https://www.R-project.org +% Copyright 1995-2023 R Core Team +% Distributed under GPL 2 or later + +\name{Tailcall} +\alias{Tailcall} +\alias{Exec} +\title{Tailcall and Exec} +\description{ + \code{Tailcall} and \code{Exec} allow writing more + stack-space-efficient recursive functions in \R. + } +\usage{ +Tailcall(FUN, \dots) +Exec(expr, envir) +} +\arguments{ + \item{FUN}{a function or a non-empty character string naming the + function to be called.} + \item{\dots}{all the arguments to be passed.} + \item{expr}{a call expression.} + \item{envir}{environment for evaluating \code{expr}; default is the + environment from which \code{Exec} is called. + } +} +\details{ + \code{Tailcall} and \code{Exec} can only be used inside an \R function, + not at top level. They replace the currently executing call context + with a new one for the call to \code{FUN} or the call specified in + \code{expr}. + + Using \code{Tailcall} it is possible to define + tail-recursive functions that do not grow the evaluation stack. + Because of lazy evaluation it may be necessary to \code{force} some + arguments to avoid accumulating deferred evaluations. + + \code{Exec} can be used to simplify the call stack for functions that + create and then evaluate an expression. +} +\note{\code{Tailcall} and \code{Exec} are experimental and may not be + included in a released version of \R. +} +\seealso{ + \code{\link{Recall}} and \code{\link{force}}. +} +\examples{ +## tail-recursive log10-factorial +lfact <- function(n) { + lfact_iter <- function(val, n) { + if (n <= 0) + val + else { + val <- val + log10(n) # forces val + Tailcall(lfact_iter, val, n - 1) + } + } + lfact_iter(0, n) +} +10 ^ lfact(3) +lfact(100000) + +## simplified variant of do.call using Exec: +docall <- function (what, args, quote = FALSE) { + if (!is.list(args)) + stop("second argument must be a list") + if (quote) + args <- lapply(args, enquote) + Exec(as.call(c(list(substitute(what)), args)), parent.frame()) +} +## the call stack doe not contain the call to docall: +docall(function(x) sys.calls(), list(1)) |> + Find(function(x) identical(x[[1]], quote(docall)), x = _) +## contrast to do.call: +do.call(function(x) sys.calls(), list(1)) |> + Find(function(x) identical(x[[1]], quote(do.call)), x = _) +} +\keyword{programming} + diff --git a/src/main/eval.c b/src/main/eval.c index 9c54f9bb7eb..b5006173f5f 100644 --- a/src/main/eval.c +++ b/src/main/eval.c @@ -2168,6 +2168,17 @@ attribute_hidden void unpromiseArgs(SEXP pargs) attribute_hidden void unpromiseArgs(SEXP pargs) { } #endif +#define SUPPORT_TAILCALL +#ifdef SUPPORT_TAILCALL +static SEXP R_exec_token = NULL; /* initialized in R_initAssignSymbols below */ + +static R_INLINE Rboolean is_exec_continuation(SEXP val) +{ + return (TYPEOF(val) == VECSXP && XLENGTH(val) == 4 && + VECTOR_ELT(val, 0) == R_exec_token); +} +#endif + /* Note: GCC will not inline execClosure because it calls setjmp */ static R_INLINE SEXP R_execClosure(SEXP call, SEXP newrho, SEXP sysparent, SEXP rho, SEXP arglist, SEXP op); @@ -2175,6 +2186,19 @@ static R_INLINE SEXP R_execClosure(SEXP call, SEXP newrho, SEXP sysparent, /* Apply SEXP op of type CLOSXP to actuals */ SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedvars) { +#ifdef SUPPORT_TAILCALL + Rboolean tailcall = FALSE; + again: + /* applyClosure should be called with arguments protected, so + these variables will be protected on the first call but not on + tail calls */ + PROTECT(call); + PROTECT(op); + PROTECT(arglist); + PROTECT(rho); + PROTECT(suppliedvars); +#endif + SEXP formals, actuals, savedrho, newrho; SEXP f, a; @@ -2248,12 +2272,65 @@ SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedvars) R_GlobalContext->sysparent : rho, rho, arglist, op); #ifdef ADJUST_ENVIR_REFCNTS +# ifdef SUPPORT_TAILCALL + if (tailcall) + R_CleanupEnvir(rho, val); +# endif R_CleanupEnvir(newrho, val); if (is_getter_call && MAYBE_REFERENCED(val)) val = shallow_duplicate(val); #endif UNPROTECT(1); /* newrho */ + +#ifdef SUPPORT_TAILCALL + if (is_exec_continuation(val)) { + PROTECT(val); + call = VECTOR_ELT(val, 1); // replaces the original one + + rho = VECTOR_ELT(val, 2); // replaces the original one + SET_VECTOR_ELT(val, 2, R_NilValue); // to drop REFCNT + + op = VECTOR_ELT(val, 3); // replaces the original one + +# ifdef ADJUST_ENVIR_REFCNTS + unpromiseArgs(arglist); +# endif + + if (TYPEOF(op) != CLOSXP) { + /* Ideally this should handle BUILTINSXP/SPECIALSXP calls + in the standard way as in eval() or bceval(). For now, + just build a new call and eval. */ + SEXP expr = PROTECT(LCONS(op, CDR(call))); + val = eval(expr, rho); + UNPROTECT(2); /* expr, old val */ + UNPROTECT(5); /* old call, op, arglist, rho, suppliedvars */ + return val; + } + + arglist = promiseArgs(CDR(call), rho); // replaces the original one + + suppliedvars = R_NilValue; // replaces the original one + + UNPROTECT(1); /* val */ + UNPROTECT(5); /* old call, op, arglist, rho, suppliedvars */ + tailcall = TRUE; + goto again; + /* if the C compiler does tail-call optimization then we could + replace the label/goto by a tail call: + + return applyClosure(call, op, arglist, rho, suppliedvars); + + (would need to pass 'tailcall' argument also) + */ + } + + UNPROTECT(5); /* call, op, arglist, rho, suppliedvars */ +# ifdef ADJUST_ENVIR_REFCNTS + if (tailcall) + unpromiseArgs(arglist); +# endif +#endif return val; } @@ -2498,6 +2575,10 @@ SEXP R_execMethod(SEXP op, SEXP rho) R_CleanupEnvir(newrho, val); #endif UNPROTECT(1); +#ifdef SUPPORT_TAILCALL + if (is_exec_continuation(val)) + error("'Exec' and 'Tailcall' are not supported in methods yet"); +#endif return val; } @@ -2955,6 +3036,79 @@ attribute_hidden NORET SEXP do_return(SEXP call, SEXP op, SEXP args, SEXP rho) findcontext(CTXT_BROWSER | CTXT_FUNCTION, rho, v); } +static void MISSING_ARGUMENT_ERROR(SEXP symbol, SEXP rho); +attribute_hidden SEXP do_tailcall(SEXP call, SEXP op, SEXP args, SEXP rho) +{ +#ifdef SUPPORT_TAILCALL + SEXP expr, env; + + if (PRIMVAL(op) == 0) { // exec + static SEXP formals = NULL; + if (formals == NULL) + formals = allocFormalsList2(install("expr"), install("envir")); + + PROTECT_INDEX api; + PROTECT_WITH_INDEX(args = matchArgs_NR(formals, args, call), &api); + REPROTECT(args = evalListKeepMissing(args, rho), api); + expr = CAR(args); + if (expr == R_MissingArg) + MISSING_ARGUMENT_ERROR(install("expr"), rho); + if (TYPEOF(expr) == EXPRSXP && XLENGTH(expr) == 1) + expr = VECTOR_ELT(expr, 0); + if (TYPEOF(expr) != LANGSXP) + error(_("\"expr\" must be a call expression")); + env = CADR(args); + if (env == R_MissingArg) + env = rho; + UNPROTECT(1); /* args */ + } + else { // tailcall + /* could do argument matching here */ + if (args == R_NilValue) + error(_("'tailcall' requres at least one argument")); + expr = LCONS(CAR(args), CDR(args)); + env = rho; + } + + SEXP val; + PROTECT(expr); + PROTECT(env); + SEXP fun = CAR(expr); + if (TYPEOF(fun) == STRSXP && XLENGTH(fun) == 1) + fun = installTrChar(STRING_ELT(fun, 0)); + if (TYPEOF(fun) == SYMSXP) + /* might need to adjust the call here as in eval() */ + fun = findFun3(fun, env, call); + else + fun = eval(fun, env); + + /* allocating a vector result could be avoided by passing expr, + env, and fun in some in globals or on the byte code stack */ + PROTECT(fun); + val = allocVector(VECSXP, 4); + UNPROTECT(1); /* fun */ + SET_VECTOR_ELT(val, 0, R_exec_token); + SET_VECTOR_ELT(val, 1, expr); + SET_VECTOR_ELT(val, 2, env); + SET_VECTOR_ELT(val, 3, fun); + + /* This skips over browser frames. If that is not what we want we + would probably want to use R_NilValue as the return value for a + jump to browser so R_exec_token doesn't escape. */ + for (RCNTXT *cntxt = R_GlobalContext; + cntxt && cntxt->callflag != CTXT_TOPLEVEL; + cntxt = cntxt->nextcontext) { + if (cntxt->callflag & CTXT_FUNCTION && cntxt->cloenv == rho) + R_jumpctxt(cntxt, CTXT_FUNCTION, val); + } + error(_("'%s' called from outside a closure"), + PRIMVAL(op) == 0 ? "Exec" : "Tailcall"); +#else + error("recompile eval.c with -DSUPPORT_TAILCALL " + "to enable Exec and Tailcall"); +#endif +} + /* Declared with a variable number of args in names.c */ attribute_hidden SEXP do_function(SEXP call, SEXP op, SEXP args, SEXP rho) { @@ -3072,6 +3226,11 @@ attribute_hidden void R_initAssignSymbols(void) R_DollarGetsSymbol = install("$<-"); R_valueSym = install("value"); R_AssignSym = install("<-"); + +#ifdef SUPPORT_TAILCALL + R_exec_token = CONS(install(".__EXEC__."), R_NilValue); + R_PreserveObject(R_exec_token); +#endif } static R_INLINE SEXP lookupAssignFcnSymbol(SEXP fun) diff --git a/src/main/names.c b/src/main/names.c index 641e53a2c3d..f555df8b01e 100644 --- a/src/main/names.c +++ b/src/main/names.c @@ -711,6 +711,8 @@ FUNTAB R_FunTab[] = {"ls", do_ls, 1, 11, 3, {PP_FUNCALL, PREC_FN, 0}}, {"typeof", do_typeof, 1, 11, 1, {PP_FUNCALL, PREC_FN, 0}}, {"eval", do_eval, 0, 211, 3, {PP_FUNCALL, PREC_FN, 0}}, +{"Exec", do_tailcall, 0, 200, -1, {PP_FUNCALL, PREC_FN, 0}}, +{"Tailcall", do_tailcall, 1, 200, -1, {PP_FUNCALL, PREC_FN, 0}}, {"returnValue", do_returnValue,0, 11, 1, {PP_FUNCALL, PREC_FN, 0}}, {"sys.parent", do_sys, 1, 11, -1, {PP_FUNCALL, PREC_FN, 0}}, {"sys.call", do_sys, 2, 11, -1, {PP_FUNCALL, PREC_FN, 0}}, diff --git a/tests/primitives.R b/tests/primitives.R index 1e2439db327..f4e34831417 100644 --- a/tests/primitives.R +++ b/tests/primitives.R @@ -110,6 +110,7 @@ except <- c("call", "switch", ".C", ".Fortran", ".Call", ".External", ".subset", ".subset2", ".primTrace", ".primUntrace", "lazyLoadDBfetch", ".Internal", ".Primitive", "^", "|", "::", ":::", "%*%", "rep", "seq.int", "forceAndCall", + "Tailcall", ## these may not be enabled "tracemem", "retracemem", "untracemem")