Commit 90fa0471 authored by Radford Neal's avatar Radford Neal

more use of static boxes, moved error messages out of main line

parent e363aa65
......@@ -6,7 +6,11 @@ Fixes problem of variant field for fast ops not being big enough,
that disabled part of the static box optimizations. Also cleaned
up unused fields.
Updates R-ints for current SEXPREC layout.
Added a bit more use of static boxes (result of length, arg of
seq_len, conditions for if and while).
Moved some more error messages out of "eval" and related functions,
just in case this helps cache or other code aspects in time-critical
code.
Updates R-ints for current SEXPREC layout.
......@@ -312,6 +312,7 @@
Rf_LogicalFromInteger
Rf_LogicalFromReal
Rf_LogicalFromString
Rf_PRSEEN_error_or_warning
Rf_PrintDefaults
Rf_PrintGreeting
Rf_PrintValueEnv
......@@ -332,7 +333,10 @@
Rf_StringFromReal
Rf_VectorIndex
Rf_allocCharsxp
Rf_apply_non_function_error
Rf_arg_missing_error
Rf_asLogicalNoNA_error
Rf_asLogicalNoNA_warning
Rf_bd0
Rf_builtin_op
Rf_chebyshev_eval
......@@ -380,9 +384,11 @@
Rf_mkSYMSXP
Rf_name2col
Rf_needsparens
Rf_nonsubsettable_error
Rf_onsigusr1
Rf_onsigusr2
Rf_osDynSymbol
Rf_out_of_bounds_error
Rf_pbeta_raw
Rf_promiseArgs
Rf_qchisq_appr
......
......@@ -1037,7 +1037,10 @@ extern0 Rboolean known_to_be_utf8 INI_as(FALSE);
# define allocCharsxp Rf_allocCharsxp
# define alloc_or_reuse Rf_alloc_or_reuse
# define apply_non_functon_error Rf_apply_non_function_error
# define arg_missing_error Rf_arg_missing_error
# define asLogicalNoNA_error Rf_asLogicalNoNA_error
# define asLogicalNoNA_warning Rf_asLogicalNoNA_warning
# define beginbuiltincontext Rf_beginbuiltincontext
# define begincontext Rf_begincontext
# define check_stack_balance Rf_check_stack_balance
......@@ -1145,6 +1148,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 promiseArgs Rf_promiseArgs
# define promiseArgsWithValues Rf_promiseArgsWithValues
# define promiseArgsWith1Value Rf_promiseArgsWith1Value
......@@ -1458,10 +1462,14 @@ SEXP R_subassign3_dflt(SEXP, SEXP, SEXP, SEXP);
R_NORETURN void UNIMPLEMENTED_TYPE(const char *s, SEXP x);
R_NORETURN void UNIMPLEMENTED_TYPEt(const char *s, SEXPTYPE t);
R_NORETURN void dotdotdot_error(void);
R_NORETURN void apply_non_function_error(void);
R_NORETURN void arg_missing_error(SEXP sym);
R_NORETURN void asLogicalNoNA_error(SEXP s, SEXP call);
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 asLogicalNoNA_warning(SEXP s, SEXP call);
void PRSEEN_error_or_warning(SEXP e);
Rboolean Rf_strIsASCII(const char *str);
int utf8clen(char c);
......
......@@ -383,7 +383,12 @@ static SEXP do_drop(SEXP call, SEXP op, SEXP args, SEXP rho)
static SEXP do_fast_length (SEXP call, SEXP op, SEXP arg, SEXP rho, int variant)
{
R_len_t len = length(arg);
return ScalarIntegerMaybeConst (len <= INT_MAX ? len : NA_INTEGER);
if (variant & VARIANT_STATIC_BOX_OK) {
*INTEGER(R_ScalarIntegerBox) = len;
return R_ScalarIntegerBox;
}
else
return ScalarIntegerMaybeConst (len <= INT_MAX ? len : NA_INTEGER);
}
static SEXP do_length(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
......
......@@ -380,14 +380,7 @@ static SEXP forcePromiseUnbound(SEXP e) /* e is protected here */
PROTECT(e);
if (PRSEEN(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"));
}
if (PRSEEN(e)) PRSEEN_error_or_warning(e);
/* Mark the promise as under evaluation and push it on a stack
that can be used to unmark pending promises if a jump out
......@@ -595,7 +588,7 @@ SEXP attribute_hidden Rf_evalv2(SEXP e, SEXP rho, int variant)
else if (TYPEOF(op) == BUILTINSXP)
res = Rf_builtin_op (op, e, rho, variant);
else
error(_("attempt to apply non-function"));
apply_non_function_error();
int flag = PRIMPRINT(op);
if (flag == 0) R_Visible = TRUE;
......@@ -1249,21 +1242,6 @@ SEXP R_execMethod(SEXP op, SEXP rho)
return val;
}
static R_NORETURN void asLogicalNoNA_error (SEXP s, SEXP call)
{
errorcall (call,
length(s) == 0 ? _("argument is of length zero") :
isLogical(s) ? _("missing value where TRUE/FALSE needed") :
_("argument is not interpretable as logical"));
}
static void asLogicalNoNA_warning (SEXP s, SEXP call)
{
PROTECT(s);
warningcall (call,
_("the condition has length > 1 and only the first element will be used"));
UNPROTECT(1);
}
/* Caller needn't protect the s arg below */
static R_INLINE Rboolean asLogicalNoNA(SEXP s, SEXP call)
{
......@@ -1306,7 +1284,8 @@ static SEXP do_if (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
Cond = CAR(args); args = CDR(args);
Stmt = CAR(args); args = CDR(args);
if (!asLogicalNoNA (eval(Cond,rho), call)) { /* go to else part */
if (!asLogicalNoNA (evalv(Cond,rho,VARIANT_STATIC_BOX_OK), call)) {
/* go to else part */
if (args != R_NilValue)
Stmt = CAR(args);
else {
......@@ -1511,13 +1490,15 @@ static SEXP do_while(SEXP call, SEXP op, SEXP args, SEXP rho)
begincontext(&cntxt, CTXT_LOOP, R_NilValue, rho, R_BaseEnv, R_NilValue,
R_NilValue);
if (SETJMP(cntxt.cjmpbuf) != CTXT_BREAK) {
while (asLogicalNoNA(eval(CAR(args), rho), call)) {
if (SETJMP(cntxt.cjmpbuf) != CTXT_BREAK) { /* <- back here for "next" */
while (asLogicalNoNA
(evalv (CAR(args), rho, VARIANT_STATIC_BOX_OK), call)) {
DO_LOOP_RDEBUG(call, op, body, rho, bgn);
evalv (body, rho, VARIANT_NULL | VARIANT_PENDING_OK);
}
}
endcontext(&cntxt);
SET_RDEBUG(rho, dbg);
return R_NilValue;
......@@ -1544,13 +1525,14 @@ static SEXP do_repeat(SEXP call, SEXP op, SEXP args, SEXP rho)
begincontext(&cntxt, CTXT_LOOP, R_NilValue, rho, R_BaseEnv, R_NilValue,
R_NilValue);
if (SETJMP(cntxt.cjmpbuf) != CTXT_BREAK) {
if (SETJMP(cntxt.cjmpbuf) != CTXT_BREAK) { /* <- back here for "next" */
for (;;) {
DO_LOOP_RDEBUG(call, op, body, rho, bgn);
evalv (body, rho, VARIANT_NULL | VARIANT_PENDING_OK);
}
}
endcontext(&cntxt);
SET_RDEBUG(rho, dbg);
return R_NilValue;
......@@ -5091,7 +5073,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
value = GETSTACK(-1);
if (TYPEOF(value) != CLOSXP && TYPEOF(value) != BUILTINSXP &&
TYPEOF(value) != SPECIALSXP)
error(_("attempt to apply non-function"));
apply_non_function_error();
/* initialize the function type register, and push space for
creating the argument list. */
......
......@@ -521,15 +521,16 @@ void task_rep (helpers_op_t op, SEXP a, SEXP s, SEXP t)
}
}
/* do_fast_rep is not called directly at the moment, since had to revert
to rep.int being internal so that setGeneric would work for it. This
function is called from do_rep_int, however. */
#define T_rep THRESHOLD_ADJUST(20)
static SEXP do_fast_rep (SEXP call, SEXP op, SEXP s, SEXP ncopy, SEXP rho,
int variant)
static SEXP do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
static char *ap[2] = { "x", "times" };
PROTECT(args = matchArgs(R_NilValue, ap, 2, args, call));
SEXP s = CAR(args);
SEXP ncopy = CADR(args);
SEXP a;
int na;
......@@ -594,19 +595,10 @@ static SEXP do_fast_rep (SEXP call, SEXP op, SEXP s, SEXP ncopy, SEXP rho,
setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
}
UNPROTECT(1 + (ncopy!=NULL));
UNPROTECT(2 + (ncopy!=NULL));
return a;
}
static SEXP do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
{
static char *ap[2] = { "x", "times" };
PROTECT(args = matchArgs(R_NilValue, ap, 2, args, call));
SEXP ans = do_fast_rep (call, op, CAR(args), CADR(args), rho, variant);
UNPROTECT(1);
return ans;
}
/* We are careful to use evalListKeepMissing here (inside
DispatchOrEval) to avoid dropping missing arguments so e.g.
rep(1:3,,8) matches length.out */
......@@ -1028,7 +1020,6 @@ attribute_hidden FUNTAB R_FunTab_seq[] =
attribute_hidden FASTFUNTAB R_FastFunTab_seq[] = {
/*slow func fast func, code or -1 dsptch variant */
{ do_seq_len, do_fast_seq_len,-1, 0, 0 },
/* { do_rep_int,do_fast_rep, -1, 0, 0 }, */
{ do_seq_len, do_fast_seq_len,-1, 0, VARIANT_STATIC_BOX_OK },
{ 0, 0, 0, 0, 0 }
};
......@@ -422,17 +422,48 @@ R_NORETURN void attribute_hidden unbound_var_error(SEXP sym)
error(_("object '%s' not found"), CHAR(PRINTNAME(sym)));
}
R_NORETURN void nonsubsettable_error(SEXP call, SEXP x)
R_NORETURN void attribute_hidden nonsubsettable_error(SEXP call, SEXP x)
{
errorcall (call, _("object of type '%s' is not subsettable"),
type2char(TYPEOF(x)));
}
R_NORETURN void out_of_bounds_error(SEXP call)
R_NORETURN void attribute_hidden out_of_bounds_error(SEXP call)
{
errorcall(call, _("subscript out of bounds"));
}
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)
{
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"));
}
R_NORETURN void attribute_hidden asLogicalNoNA_error (SEXP s, SEXP call)
{
errorcall (call,
length(s) == 0 ? _("argument is of length zero") :
isLogical(s) ? _("missing value where TRUE/FALSE needed") :
_("argument is not interpretable as logical"));
}
void attribute_hidden asLogicalNoNA_warning (SEXP s, SEXP call)
{
PROTECT(s);
warningcall (call,
_("the condition has length > 1 and only the first element will be used"));
UNPROTECT(1);
}
# include <R_ext/Riconv.h>
# include <sys/param.h>
......
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