Commit a2df4dec authored by Radford Neal's avatar Radford Neal

faster subassign for simple cases

parent 41a097a5
......@@ -2,6 +2,7 @@ Ensure that evaluated arguments are not changed by evaluation
of later arguments. Adds tests for this.
Other performance improvements too, including introduction of
install_translated.
install_translated, and faster subassign for simple cases.
......@@ -882,10 +882,10 @@ static SEXP attribute_noinline evalv_other (SEXP e, SEXP rho, int variant)
/* Note: If called from evalv, R_Visible will've been set to TRUE */
if (type_etc == SPECIALSXP) {
res = PRIMFUNV(op) (e, op, args, rho, variant);
/* Note: Special primitives always take variant argument,
and are responsible for setting R_Visible as desired
themselves, with default of TRUE. */
res = PRIMFUNV(op) (e, op, args, rho, variant);
}
else if (type_etc == BUILTINSXP) {
res = R_Profiling ? Rf_builtin_op(op, e, rho, variant)
......@@ -5006,7 +5006,7 @@ static SEXP do_subassign(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
SEXP sv_scalar_stack = R_scalar_stack;
SEXP ans, x, sb1, sb2, subs, y;
SEXP ans, r, x, sb1, sb2, subs, y;
int argsevald = 0;
int64_t seq = 0;
......@@ -5031,6 +5031,47 @@ static SEXP do_subassign(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
seq = R_variant_seq_spec;
R_variant_result = 0;
}
else {
/* Do the very simplest cases here. */
if (isVectorAtomic(x) && TYPEOF(x) == TYPE_ETC(y)) {
R_len_t len = LENGTH(x);
R_len_t ix = 0;
if (TYPE_ETC(sb1) == INTSXP && *INTEGER(sb1) >= 1
&& *INTEGER(sb1) <= len)
ix = *INTEGER(sb1);
else if (TYPE_ETC(sb1) == REALSXP && *REAL(sb1) >= 1
&& *REAL(sb1) <= len)
ix = (int) *REAL(sb1);
if (ix != 0) {
ix -= 1;
WAIT_UNTIL_COMPUTED(x);
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(x)[ix] = *INTEGER(y);
break;
case REALSXP:
REAL(x)[ix] = *REAL(y);
break;
case CPLXSXP:
COMPLEX(x)[ix] = *COMPLEX(y);
break;
case STRSXP:
SET_STRING_ELT (x, ix, STRING_ELT(y,0));
break;
case RAWSXP:
RAW(x)[ix] = *RAW(y);
break;
}
SET_NAMEDCNT_0(x);
r = x;
goto ret;
}
}
}
sb2 = R_NoObject;
}
else {
......@@ -5113,10 +5154,10 @@ static SEXP do_subassign(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
/* ... path that bypasses DispatchOrEval ... */
dflt_seq: ;
SEXP r = do_subassign_dflt_seq (call, x, sb1, sb2, subs, rho, y, seq);
dflt_seq:
r = do_subassign_dflt_seq (call, x, sb1, sb2, subs, rho, y, seq);
ret:
R_scalar_stack = sv_scalar_stack;
return r;
}
......
......@@ -4694,12 +4694,7 @@ SEXP attribute_hidden do_subassign2_dflt_int
if (ix > 0 && ix <= lenx) {
ix -= 1;
switch (TYPEOF(x)) {
case RAWSXP:
RAW(x)[ix] = *RAW(y);
break;
case LGLSXP:
LOGICAL(x)[ix] = *LOGICAL(y);
break;
case INTSXP:
INTEGER(x)[ix] = *INTEGER(y);
break;
......@@ -4712,10 +4707,13 @@ SEXP attribute_hidden do_subassign2_dflt_int
case STRSXP:
SET_STRING_ELT (x, ix, STRING_ELT(y,0));
break;
case RAWSXP:
RAW(x)[ix] = *RAW(y);
break;
case VECSXP: case EXPRSXP:
DEC_NAMEDCNT (VECTOR_ELT (x, ix));
SET_VECTOR_ELEMENT_TO_VALUE (x, ix, y);
break;
break;
}
SET_NAMEDCNT_0(x);
RETURN_SEXP_INSIDE_PROTECT (x);
......
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