Optimize every() and related functions

R/every-some-none.R

@@ -22,39 +22,32 @@
 #' # unsafe (e.g. in `if ()` conditions), make sure to use safe predicates:
 #' if (some(list(NA, FALSE), rlang::is_true)) "foo" else "bar"
 every <- function(.x, .p, ...) {
-  .p <- as_predicate(.p, ..., .mapper = TRUE, .allow_na = TRUE)
+  .p <- as_mapper(.p, ...)
 
-  val <- TRUE
-  for (i in seq_along(.x)) {
-    val <- val && .p(.x[[i]], ...)
+  n <- vec_size(.x)
+  i <- 0L
 
-    if (is_false(val)) {
-      return(FALSE)
-    }
-  }
-
-  val
+  .Call(every_impl, environment(), n, i)
 }
 
 #' @export
 #' @rdname every
 some <- function(.x, .p, ...) {
-  .p <- as_predicate(.p, ..., .mapper = TRUE, .allow_na = TRUE)
-
-  val <- FALSE
-  for (i in seq_along(.x)) {
-    val <- val || .p(.x[[i]], ...)
+  .p <- as_mapper(.p, ...)
 
-    if (is_true(val)) {
-      return(TRUE)
-    }
-  }
+  n <- vec_size(.x)
+  i <- 0L
 
-  val
+  .Call(some_impl, environment(), n, i)
 }
 
 #' @export
 #' @rdname every
 none <- function(.x, .p, ...) {
-  every(.x, negate(.p), ...)
+  .p <- as_mapper(.p, ...)
+
+  n <- vec_size(.x)
+  i <- 0L
+
+  .Call(none_impl, environment(), n, i)
 }

src/checks.c

@@ -0,0 +1,41 @@
+#include <Rinternals.h>
+#include <stdbool.h>
+
+/**
+ * Check any SEXP object for being a single TRUE/FALSE value; logical NA is excluded.
+ *
+ * @param value An R object (SEXP)
+ * @return 1 if bool, 0 otherwise
+ */
+bool is_bool(SEXP value) {
+  return TYPEOF(value) == LGLSXP && LENGTH(value) == 1 && LOGICAL(value)[0] != NA_LOGICAL;
+}
+
+/**
+ * Check any SEXP object for being any kind of NA.
+ *
+ * @param value An R object (SEXP)
+ * @return 1 if NA, 0 otherwise
+ */
+bool is_na(SEXP value) {
+  // NULL is not NA
+  if (value == R_NilValue) return false;
+
+  switch (TYPEOF(value)) {
+  case LGLSXP:
+    return LENGTH(value) == 1 && (LOGICAL(value)[0] == NA_LOGICAL);
+  case INTSXP:
+    return LENGTH(value) == 1 && (INTEGER(value)[0] == NA_INTEGER);
+  case REALSXP:
+    return LENGTH(value) == 1 && ISNA(REAL(value)[0]);
+  case CPLXSXP:
+    if (LENGTH(value) != 1) return false;
+    Rcomplex c = COMPLEX(value)[0];
+    return ISNA(c.r) || ISNA(c.i);
+  case STRSXP:
+    return LENGTH(value) == 1 &&  (STRING_ELT(value, 0) == NA_STRING);
+  default:
+    // Other types cannot be NA
+      return false;
+  }
+}

src/checks.h

@@ -0,0 +1,10 @@
+#ifndef CHECKS_H
+#define CHECKS_H
+
+#include <Rinternals.h>
+#include <stdbool.h>
+
+bool is_bool(SEXP value);
+bool is_na(SEXP value);
+
+#endif //CHECKS_H

src/every-some-none.c

@@ -0,0 +1,107 @@
+#define R_NO_REMAP
+#include <R.h>
+#include <Rinternals.h>
+#include <stdbool.h>
+
+#include "conditions.h"
+#include "checks.h"
+
+static SEXP make_call();
+static SEXP test_predicate(SEXP env, SEXP ffi_n, SEXP ffi_i, bool initial_value, bool early_stop_if);
+
+SEXP every_impl(SEXP env, SEXP ffi_n, SEXP ffi_i);
+SEXP some_impl(SEXP env, SEXP ffi_n, SEXP ffi_i);
+SEXP none_impl(SEXP env, SEXP ffi_n, SEXP ffi_i);
+
+SEXP every_impl(SEXP env, SEXP ffi_n, SEXP ffi_i) {
+  return test_predicate(env, ffi_n, ffi_i, true, false);
+}
+
+SEXP some_impl(SEXP env, SEXP ffi_n, SEXP ffi_i) {
+  return test_predicate(env, ffi_n, ffi_i, false, true);
+}
+
+SEXP none_impl(SEXP env, SEXP ffi_n, SEXP ffi_i) {
+  return test_predicate(env, ffi_n, ffi_i, true, true);
+}
+
+/**
+ * Perform the test of an R predicate .p over a set of values .x.
+ *
+ * @param env An R environment created inside the parent R function
+ * @param ffi_n Length of .x
+ * @param ffi_i Integer for iterating over elements of .x; should be equal to 0
+ * @param initial_value Answer if length of .x is 0
+ * @param early_stop_if Value to stop iterating on
+ * @return A single R logical value, one of TRUE/FALSE/NA
+ */
+static SEXP test_predicate(SEXP env, SEXP ffi_n, SEXP ffi_i, bool initial_value, bool early_stop_if) {
+  int n = INTEGER_ELT(ffi_n, 0);
+  int* p_i = INTEGER(ffi_i);
+
+  SEXP call = make_call();
+
+  SEXP out = PROTECT(Rf_allocVector(LGLSXP, 1));
+  int* p_out = LOGICAL(out);
+  *p_out = initial_value;
+
+  for (int i = 0; i < n; i++) {
+    *p_i = i + 1;
+
+    if (i % 1024 == 0) {
+      R_CheckUserInterrupt();
+    }
+
+    SEXP res = PROTECT(R_forceAndCall(call, 1, env));
+
+    if (is_na(res)) {
+      *p_out = NA_LOGICAL;
+      UNPROTECT(1);  // res
+      continue;
+    }
+
+    if (!is_bool(res)) {
+      r_abort(
+        "`.p()` must return a single `TRUE` or `FALSE`, not %s.",
+        rlang_obj_type_friendly_full(res, true, false)
+      );
+    }
+
+    int res_value = LOGICAL(res)[0];
+    UNPROTECT(1);  // res
+
+    if (res_value == early_stop_if) {
+      *p_out = !initial_value;
+      break;
+    }
+  }
+
+  *p_i = 0;
+
+  UNPROTECT(1);  // out
+  return out;
+}
+
+/**
+ * Create an R call of the form .p(.x[[i]], ...). Since the returned call is always the same,
+ * the return value is optimized to persist across calls.
+ *
+ * @return An R call that reads .p(.x[[i]], ...)
+ */
+static SEXP make_call() {
+  static SEXP call = NULL;
+  if (call == NULL) {
+    SEXP x_sym = Rf_install(".x");
+    SEXP p_sym = Rf_install(".p");
+    SEXP i_sym = Rf_install("i");
+
+    // Constructs a call of the form .p(.x[[i]], ...)
+    SEXP x_i_sym = PROTECT(Rf_lang3(R_Bracket2Symbol, x_sym, i_sym));
+
+    call = Rf_lang3(p_sym, x_i_sym, R_DotsSymbol);
+    R_PreserveObject(call);
+
+    UNPROTECT(1);  // x_i_sym
+  }
+  return call;
+}

src/init.c

@@ -13,6 +13,9 @@
 extern SEXP coerce_impl(SEXP, SEXP);
 extern SEXP pluck_impl(SEXP, SEXP, SEXP, SEXP);
 extern SEXP flatten_impl(SEXP);
+extern SEXP every_impl(SEXP, SEXP, SEXP);
+extern SEXP some_impl(SEXP, SEXP, SEXP);
+extern SEXP none_impl(SEXP, SEXP, SEXP);
 extern SEXP map_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
 extern SEXP map2_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
 extern SEXP pmap_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
@@ -24,6 +27,9 @@ static const R_CallMethodDef CallEntries[] = {
   {"coerce_impl",           (DL_FUNC) &coerce_impl,    2},
   {"pluck_impl",            (DL_FUNC) &pluck_impl,     4},
   {"flatten_impl",          (DL_FUNC) &flatten_impl,   1},
+  {"every_impl",            (DL_FUNC) &every_impl,     3},
+  {"some_impl",             (DL_FUNC) &some_impl,      3},
+  {"none_impl",             (DL_FUNC) &none_impl,      3},
   {"map_impl",              (DL_FUNC) &map_impl,       6},
   {"map2_impl",             (DL_FUNC) &map2_impl,      6},
   {"pmap_impl",             (DL_FUNC) &pmap_impl,      8},