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

@@ -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.
     }
   }
 

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

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 :
 

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}
+

src/main/eval.c

@@ -2168,13 +2168,37 @@ 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);
 
 /* 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)

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}},

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")