protect.hpp

#pragma once

#include <csetjmp>    // for longjmp, setjmp, jmp_buf
#include <exception>  // for exception
#include <stdexcept>  // for std::runtime_error
#include <string>     // for string, basic_string
#include <tuple>      // for tuple, make_tuple

// NB: cpp11/R.hpp must precede R_ext/Error.h to ensure R_NO_REMAP is defined
#include "cpp11/R.hpp"  // for SEXP, SEXPREC, CDR, R_NilValue, CAR, R_Pres...

#include "R_ext/Boolean.h"  // for Rboolean
#include "R_ext/Error.h"    // for Rf_error, Rf_warning
#include "R_ext/Print.h"    // for REprintf
#include "R_ext/Utils.h"    // for R_CheckUserInterrupt
#include "Rversion.h"       // for R_VERSION, R_Version

#if defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0)
#define HAS_UNWIND_PROTECT
#endif

#ifdef CPP11_USE_FMT
#define FMT_HEADER_ONLY
#include "fmt/core.h"
#endif

namespace cpp11 {
class unwind_exception : public std::exception {
 public:
  SEXP token;
  unwind_exception(SEXP token_) : token(token_) {}
};

namespace detail {
// We deliberately avoid using safe[] in the below code, as this code runs
// when the shared library is loaded and will not be wrapped by
// `CPP11_UNWIND`, so if an error occurs we will not catch the C++ exception
// that safe emits.
inline void set_option(SEXP name, SEXP value) {
  static SEXP opt = SYMVALUE(Rf_install(".Options"));
  SEXP t = opt;
  while (CDR(t) != R_NilValue) {
    if (TAG(CDR(t)) == name) {
      opt = CDR(t);
      SET_TAG(opt, name);
      SETCAR(opt, value);
      return;
    }
    t = CDR(t);
  }
  SETCDR(t, Rf_allocList(1));
  opt = CDR(t);
  SET_TAG(opt, name);
  SETCAR(opt, value);
}

inline Rboolean* setup_should_unwind_protect() {
  SEXP should_unwind_protect_sym = Rf_install("cpp11_should_unwind_protect");
  SEXP should_unwind_protect_sexp = Rf_GetOption1(should_unwind_protect_sym);

  if (should_unwind_protect_sexp == R_NilValue) {
    // Allocate and initialize once, then let R manage it.
    // That makes this a shared global across all compilation units.
    should_unwind_protect_sexp = PROTECT(Rf_allocVector(LGLSXP, 1));
    SET_LOGICAL_ELT(should_unwind_protect_sexp, 0, TRUE);
    detail::set_option(should_unwind_protect_sym, should_unwind_protect_sexp);
    UNPROTECT(1);
  }

  return reinterpret_cast<Rboolean*>(LOGICAL(should_unwind_protect_sexp));
}

inline Rboolean* access_should_unwind_protect() {
  // Setup is run once per compilation unit, but all compilation units
  // share the same global option, so each compilation unit's static pointer
  // will point to the same object.
  static Rboolean* p_should_unwind_protect = setup_should_unwind_protect();
  return p_should_unwind_protect;
}

inline Rboolean get_should_unwind_protect() { return *access_should_unwind_protect(); }

inline void set_should_unwind_protect(Rboolean should_unwind_protect) {
  *access_should_unwind_protect() = should_unwind_protect;
}

}  // namespace detail

#ifdef HAS_UNWIND_PROTECT

/// Unwind Protection from C longjmp's, like those used in R error handling
///
/// @param code The code to which needs to be protected, as a nullary callable
template <typename Fun, typename = typename std::enable_if<std::is_same<
                            decltype(std::declval<Fun&&>()()), SEXP>::value>::type>
SEXP unwind_protect(Fun&& code) {
  if (detail::get_should_unwind_protect() == FALSE) {
    return std::forward<Fun>(code)();
  }

  detail::set_should_unwind_protect(FALSE);

  static SEXP token = [] {
    SEXP res = R_MakeUnwindCont();
    R_PreserveObject(res);
    return res;
  }();

  std::jmp_buf jmpbuf;
  if (setjmp(jmpbuf)) {
    detail::set_should_unwind_protect(TRUE);
    throw unwind_exception(token);
  }

  SEXP res = R_UnwindProtect(
      [](void* data) -> SEXP {
        auto callback = static_cast<decltype(&code)>(data);
        return static_cast<Fun&&>(*callback)();
      },
      &code,
      [](void* jmpbuf, Rboolean jump) {
        if (jump == TRUE) {
          // We need to first jump back into the C++ stacks because you can't safely
          // throw exceptions from C stack frames.
          longjmp(*static_cast<std::jmp_buf*>(jmpbuf), 1);
        }
      },
      &jmpbuf, token);

  // R_UnwindProtect adds the result to the CAR of the continuation token,
  // which implicitly protects the result. However if there is no error and
  // R_UwindProtect does a normal exit the memory shouldn't be protected, so we
  // unset it here before returning the value ourselves.
  SETCAR(token, R_NilValue);

  detail::set_should_unwind_protect(TRUE);

  return res;
}

template <typename Fun, typename = typename std::enable_if<std::is_same<
                            decltype(std::declval<Fun&&>()()), void>::value>::type>
void unwind_protect(Fun&& code) {
  (void)unwind_protect([&] {
    std::forward<Fun>(code)();
    return R_NilValue;
  });
}

template <typename Fun, typename R = decltype(std::declval<Fun&&>()())>
typename std::enable_if<!std::is_same<R, SEXP>::value && !std::is_same<R, void>::value,
                        R>::type
unwind_protect(Fun&& code) {
  R out;
  (void)unwind_protect([&] {
    out = std::forward<Fun>(code)();
    return R_NilValue;
  });
  return out;
}

#else
// Don't do anything if we don't have unwind protect. This will leak C++ resources,
// including those held by cpp11 objects, but the other alternatives are also not great.
template <typename Fun>
decltype(std::declval<Fun&&>()()) unwind_protect(Fun&& code) {
  return std::forward<Fun>(code)();
}
#endif

namespace detail {

template <size_t...>
struct index_sequence {
  using type = index_sequence;
};

template <typename, size_t>
struct appended_sequence;

template <std::size_t... I, std::size_t J>
struct appended_sequence<index_sequence<I...>, J> : index_sequence<I..., J> {};

template <size_t N>
struct make_index_sequence
    : appended_sequence<typename make_index_sequence<N - 1>::type, N - 1> {};

template <>
struct make_index_sequence<0> : index_sequence<> {};

template <typename F, typename... Aref, size_t... I>
decltype(std::declval<F&&>()(std::declval<Aref>()...)) apply(
    F&& f, std::tuple<Aref...>&& a, const index_sequence<I...>&) {
  return std::forward<F>(f)(std::get<I>(std::move(a))...);
}

template <typename F, typename... Aref>
decltype(std::declval<F&&>()(std::declval<Aref>()...)) apply(F&& f,
                                                             std::tuple<Aref...>&& a) {
  return apply(std::forward<F>(f), std::move(a), make_index_sequence<sizeof...(Aref)>{});
}

// overload to silence a compiler warning that the (empty) tuple parameter is set but
// unused
template <typename F>
decltype(std::declval<F&&>()()) apply(F&& f, std::tuple<>&&) {
  return std::forward<F>(f)();
}

template <typename F, typename... Aref>
struct closure {
  decltype(std::declval<F*>()(std::declval<Aref>()...)) operator()() && {
    return apply(ptr_, std::move(arefs_));
  }
  F* ptr_;
  std::tuple<Aref...> arefs_;
};

}  // namespace detail

struct protect {
  template <typename F>
  struct function {
    template <typename... A>
    decltype(std::declval<F*>()(std::declval<A&&>()...)) operator()(A&&... a) const {
      // workaround to support gcc4.8, which can't capture a parameter pack
      return unwind_protect(
          detail::closure<F, A&&...>{ptr_, std::forward_as_tuple(std::forward<A>(a)...)});
    }

    F* ptr_;
  };

  /// May not be applied to a function bearing attributes, which interfere with linkage on
  /// some compilers; use an appropriately attributed alternative. (For example, Rf_error
  /// bears the [[noreturn]] attribute and must be protected with safe.noreturn rather
  /// than safe.operator[]).
  template <typename F>
  constexpr function<F> operator[](F* raw) const {
    return {raw};
  }

  template <typename F>
  struct noreturn_function {
    template <typename... A>
    void operator() [[noreturn]] (A&&... a) const {
      // workaround to support gcc4.8, which can't capture a parameter pack
      unwind_protect(
          detail::closure<F, A&&...>{ptr_, std::forward_as_tuple(std::forward<A>(a)...)});
      // Compiler hint to allow [[noreturn]] attribute; this is never executed since
      // the above call will not return.
      throw std::runtime_error("[[noreturn]]");
    }
    F* ptr_;
  };

  template <typename F>
  constexpr noreturn_function<F> noreturn(F* raw) const {
    return {raw};
  }
};
constexpr struct protect safe = {};

inline void check_user_interrupt() { safe[R_CheckUserInterrupt](); }

#ifdef CPP11_USE_FMT
template <typename... Args>
void stop [[noreturn]] (const char* fmt_arg, Args&&... args) {
  std::string msg = fmt::format(fmt_arg, std::forward<Args>(args)...);
  safe.noreturn(Rf_errorcall)(R_NilValue, "%s", msg.c_str());
}

template <typename... Args>
void stop [[noreturn]] (const std::string& fmt_arg, Args&&... args) {
  std::string msg = fmt::format(fmt_arg, std::forward<Args>(args)...);
  safe.noreturn(Rf_errorcall)(R_NilValue, "%s", msg.c_str());
}

template <typename... Args>
void warning(const char* fmt_arg, Args&&... args) {
  std::string msg = fmt::format(fmt_arg, std::forward<Args>(args)...);
  safe[Rf_warningcall](R_NilValue, "%s", msg.c_str());
}

template <typename... Args>
void warning(const std::string& fmt_arg, Args&&... args) {
  std::string msg = fmt::format(fmt_arg, std::forward<Args>(args)...);
  safe[Rf_warningcall](R_NilValue, "%s", msg.c_str());
}
#else
template <typename... Args>
void stop [[noreturn]] (const char* fmt, Args... args) {
  safe.noreturn(Rf_errorcall)(R_NilValue, fmt, args...);
}

template <typename... Args>
void stop [[noreturn]] (const std::string& fmt, Args... args) {
  safe.noreturn(Rf_errorcall)(R_NilValue, fmt.c_str(), args...);
}

template <typename... Args>
void warning(const char* fmt, Args... args) {
  safe[Rf_warningcall](R_NilValue, fmt, args...);
}

template <typename... Args>
void warning(const std::string& fmt, Args... args) {
  safe[Rf_warningcall](R_NilValue, fmt.c_str(), args...);
}
#endif

/// A doubly-linked list of preserved objects, allowing O(1) insertion/release of
/// objects compared to O(N preserved) with R_PreserveObject.
static struct {
  SEXP insert(SEXP obj) {
    if (obj == R_NilValue) {
      return R_NilValue;
    }

#ifdef CPP11_USE_PRESERVE_OBJECT
    PROTECT(obj);
    R_PreserveObject(obj);
    UNPROTECT(1);
    return obj;
#endif

    PROTECT(obj);

    static SEXP list_ = get_preserve_list();

    // Get references to head, tail of the precious list.
    SEXP head = list_;
    SEXP tail = CDR(list_);

    // Add a new cell that points to the current head + tail.
    SEXP cell = PROTECT(Rf_cons(head, tail));
    SET_TAG(cell, obj);

    // Update the head + tail to point at the newly-created cell,
    // effectively inserting that cell between the current head + tail.
    SETCDR(head, cell);
    SETCAR(tail, cell);

    UNPROTECT(2);

    return cell;
  }

  void print() {
    static SEXP list_ = get_preserve_list();
    for (SEXP head = list_; head != R_NilValue; head = CDR(head)) {
      REprintf("%x CAR: %x CDR: %x TAG: %x\n", head, CAR(head), CDR(head), TAG(head));
    }
    REprintf("---\n");
  }

  // This is currently unused, but client packages could use it to free leaked resources
  // in older R versions if needed
  void release_all() {
#if !defined(CPP11_USE_PRESERVE_OBJECT)
    static SEXP list_ = get_preserve_list();
    SEXP first = CDR(list_);
    if (first != R_NilValue) {
      SETCAR(first, R_NilValue);
      SETCDR(list_, R_NilValue);
    }
#endif
  }

  void release(SEXP cell) {
    if (cell == R_NilValue) {
      return;
    }

#ifdef CPP11_USE_PRESERVE_OBJECT
    R_ReleaseObject(cell);
    return;
#endif

    // Get a reference to the cells before and after the token.
    SEXP lhs = CAR(cell);
    SEXP rhs = CDR(cell);

    // Remove the cell from the precious list -- effectively, we do this
    // by updating the 'lhs' and 'rhs' references to point at each-other,
    // effectively removing any references to the cell in the pairlist.
    SETCDR(lhs, rhs);
    SETCAR(rhs, lhs);
  }

 private:
  // The preserved list singleton is stored in a XPtr within an R global option.
  //
  // It is not constructed as a static variable directly since many
  // translation units may be compiled, resulting in unrelated instances of each
  // static variable.
  //
  // We cannot store it in the cpp11 namespace, as cpp11 likely will not be loaded by
  // packages.
  // We cannot store it in R's global environment, as that is against CRAN
  // policies.
  // We instead store it as an XPtr in the global options, which avoids issues
  // both copying and serializing.
  static SEXP get_preserve_xptr_addr() {
    static SEXP preserve_xptr_sym = Rf_install("cpp11_preserve_xptr");
    SEXP preserve_xptr = Rf_GetOption1(preserve_xptr_sym);

    if (TYPEOF(preserve_xptr) != EXTPTRSXP) {
      return R_NilValue;
    }
    auto addr = R_ExternalPtrAddr(preserve_xptr);
    if (addr == nullptr) {
      return R_NilValue;
    }
    return static_cast<SEXP>(addr);
  }

  static void set_preserve_xptr(SEXP value) {
    static SEXP preserve_xptr_sym = Rf_install("cpp11_preserve_xptr");

    SEXP xptr = PROTECT(R_MakeExternalPtr(value, R_NilValue, R_NilValue));
    detail::set_option(preserve_xptr_sym, xptr);
    UNPROTECT(1);
  }

  static SEXP get_preserve_list() {
    static SEXP preserve_list = R_NilValue;
    if (TYPEOF(preserve_list) != LISTSXP) {
      preserve_list = get_preserve_xptr_addr();
      if (TYPEOF(preserve_list) != LISTSXP) {
        preserve_list = Rf_cons(R_NilValue, Rf_cons(R_NilValue, R_NilValue));
        R_PreserveObject(preserve_list);
        set_preserve_xptr(preserve_list);
      }

      // NOTE: Because older versions of cpp11 (<= 0.4.2) initialized the
      // precious_list with a single cell, we might need to detect and update
      // an existing empty precious list so that we have a second cell following.
      if (CDR(preserve_list) == R_NilValue)
        SETCDR(preserve_list, Rf_cons(R_NilValue, R_NilValue));
    }

    return preserve_list;
  }

} preserved;

}  // namespace cpp11