[Rd] Speed improvement to evalList

[luke at stat.uiowa.edu]

Thanks for the suggestion.  I'll try to have a look later in the week
unless someone else gets there sooner.

luke

On Mon, 23 Aug 2010, Radford Neal wrote:

> Regarding my suggesting speed improvement to evalList, Martin Morgan
> has commented by email to me that at one point an object is left
> unprotected when COPY_TAG is called, and has wondered whether that is
> safe.  I think it is safe, but the code can be changed to protect this
> as well, which actually simplifies things, and could be more robust to
> changes to the garbage collector.  The cost is that sometimes there is
> one more call of PROTECT and UNPROTECT, but with the speed improvement
> to these that I just posted, this is a minor issue.
>
> Martin has also pointed me to where you can get R sources via
> subversion, but while I figure that out, and how to post up "diffs"
> for changes, I'll put the revised evalList code below for anyone
> interested...
>
>    Radford Neal
>
> ----------------------------------------------------------------------
>
> /* Used in eval and applyMethod (object.c) for builtin primitives,
>   do_internal (names.c) for builtin .Internals
>   and in evalArgs.
>
>   'n' is the number of arguments already evaluated and hence not
>   passed to evalArgs and hence to here.
> */
> SEXP attribute_hidden evalList(SEXP el, SEXP rho, SEXP call, int n)
> {
>    SEXP head, tail, ev, h;
>
>    head = R_NilValue;
>
>    while (el != R_NilValue) {
> 	n++;
>
> 	if (CAR(el) == R_DotsSymbol) {
> 	    /* If we have a ... symbol, we look to see what it is bound to.
> 	     * If its binding is Null (i.e. zero length),
> 	     *	we just ignore it and return the cdr with all its expressions
>             *  evaluated.
> 	     * If it is bound to a ... list of promises,
> 	     *	we force all the promises and then splice
> 	     *	the list of resulting values into the return value.
> 	     * Anything else bound to a ... symbol is an error.
> 	     */
> 	    h = findVar(CAR(el), rho);
> 	    if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
> 		while (h != R_NilValue) {
>                    ev = CONS(eval(CAR(h), rho), R_NilValue);
>                    if (head==R_NilValue)
>                        PROTECT(head = ev);
>                    else
>                        SETCDR(tail, ev);
>                    COPY_TAG(ev, h);
>                    tail = ev;
> 		    h = CDR(h);
> 		}
> 	    }
> 	    else if (h != R_MissingArg)
> 		error(_("'...' used in an incorrect context"));
> 	} else if (CAR(el) == R_MissingArg) {
> 	    /* It was an empty element: most likely get here from evalArgs
> 	       which may have been called on part of the args. */
> 	    errorcall(call, _("argument %d is empty"), n);
> 	} else if (isSymbol(CAR(el)) && R_isMissing(CAR(el), rho)) {
> 	    /* It was missing */
> 	    errorcall(call, _("'%s' is missing"), CHAR(PRINTNAME(CAR(el))));
> 	} else {
>            ev = CONS(eval(CAR(el), rho), R_NilValue);
>            if (head==R_NilValue)
>                PROTECT(head = ev);
>            else
>                SETCDR(tail, ev);
>            COPY_TAG(ev, el);
>            tail = ev;
> 	}
> 	el = CDR(el);
>    }
>
>    if (head!=R_NilValue)
>        UNPROTECT(1);
>
>    return head;
>
> } /* evalList() */
>
>
> /* A slight variation of evaluating each expression in "el" in "rho". */
>
> /* used in evalArgs, arithmetic.c, seq.c */
> SEXP attribute_hidden evalListKeepMissing(SEXP el, SEXP rho)
> {
>    SEXP head, tail, ev, h;
>
>    head = R_NilValue;
>
>    while (el != R_NilValue) {
>
> 	/* If we have a ... symbol, we look to see what it is bound to.
> 	 * If its binding is Null (i.e. zero length)
> 	 *	we just ignore it and return the cdr with all its expressions evaluated;
> 	 * if it is bound to a ... list of promises,
> 	 *	we force all the promises and then splice
> 	 *	the list of resulting values into the return value.
> 	 * Anything else bound to a ... symbol is an error
> 	*/
> 	if (CAR(el) == R_DotsSymbol) {
> 	    h = findVar(CAR(el), rho);
> 	    if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
> 		while (h != R_NilValue) {
>                    if (CAR(h) == R_MissingArg)
>                        ev = CONS(R_MissingArg, R_NilValue);
>                    else
>                        ev = CONS(eval(CAR(h), rho), R_NilValue);
>                    if (head==R_NilValue)
>                        PROTECT(head = ev);
>                    else
>                        SETCDR(tail, ev);
>                    COPY_TAG(ev, h);
>                    tail = ev;
> 		    h = CDR(h);
> 		}
> 	    }
> 	    else if(h != R_MissingArg)
> 		error(_("'...' used in an incorrect context"));
> 	}
> 	else {
>            if (CAR(el) == R_MissingArg ||
>                 (isSymbol(CAR(el)) && R_isMissing(CAR(el), rho)))
>                ev = CONS(R_MissingArg, R_NilValue);
>            else
>                ev = CONS(eval(CAR(el), rho), R_NilValue);
>            if (head==R_NilValue)
>                PROTECT(head = ev);
>            else
>                SETCDR(tail, ev);
>            COPY_TAG(ev, el);
>            tail = ev;
> 	}
> 	el = CDR(el);
>    }
>
>    if (head!=R_NilValue)
>        UNPROTECT(1);
>
>    return head;
> }
>
> ______________________________________________
> R-devel at r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel
>

-- 
Luke Tierney
Statistics and Actuarial Science
Ralph E. Wareham Professor of Mathematical Sciences
University of Iowa                  Phone:             319-335-3386
Department of Statistics and        Fax:               319-335-3017
    Actuarial Science
241 Schaeffer Hall                  email:      luke at stat.uiowa.edu
Iowa City, IA 52242                 WWW:  http://www.stat.uiowa.edu