Rcpp Version 1.0.7
barrier.cpp
Go to the documentation of this file.
1 
2 // barrier.cpp: Rcpp R/C++ interface class library -- write barrier
3 //
4 // Copyright (C) 2010 - 2020 Dirk Eddelbuettel and Romain Francois
5 // Copyright (C) 2021 Dirk Eddelbuettel, Romain Francois and IƱaki Ucar
6 //
7 // This file is part of Rcpp.
8 //
9 // Rcpp is free software: you can redistribute it and/or modify it
10 // under the terms of the GNU General Public License as published by
11 // the Free Software Foundation, either version 2 of the License, or
12 // (at your option) any later version.
13 //
14 // Rcpp is distributed in the hope that it will be useful, but
15 // WITHOUT ANY WARRANTY; without even the implied warranty of
16 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 // GNU General Public License for more details.
18 //
19 // You should have received a copy of the GNU General Public License
20 // along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
21 
22 #define COMPILING_RCPP
23 
24 #define USE_RINTERNALS
25 #include <Rinternals.h>
26 #include <Rcpp/barrier.h>
27 #include "internal.h"
28 #include <algorithm>
29 #include <Rcpp/protection/Shield.h>
30 
31 // [[Rcpp::register]]
32 SEXP get_string_elt(SEXP x, R_xlen_t i) { // #nocov start
33  return STRING_ELT(x, i);
34 }
35 
36 // [[Rcpp::register]]
37 const char* char_get_string_elt(SEXP x, R_xlen_t i) {
38  return CHAR(STRING_ELT(x, i));
39 }
40 
41 // [[Rcpp::register]]
42 void set_string_elt(SEXP x, R_xlen_t i, SEXP value) {
43  SET_STRING_ELT(x, i, value);
44 }
45 
46 // [[Rcpp::register]]
47 void char_set_string_elt(SEXP x, R_xlen_t i, const char* value) {
48  SET_STRING_ELT(x, i, Rf_mkChar(value));
49 }
50 
51 // [[Rcpp::register]]
52 SEXP* get_string_ptr(SEXP x) {
53  return STRING_PTR(x);
54 }
55 
56 // [[Rcpp::register]]
57 SEXP get_vector_elt(SEXP x, R_xlen_t i) {
58  return VECTOR_ELT(x, i);
59 }
60 
61 // [[Rcpp::register]]
62 void set_vector_elt(SEXP x, R_xlen_t i, SEXP value) {
63  SET_VECTOR_ELT(x, i, value);
64 }
65 
66 // [[Rcpp::register]]
67 SEXP* get_vector_ptr(SEXP x) {
68  return VECTOR_PTR(x); // #nocov end
69 }
70 
71 // [[Rcpp::register]]
72 void* dataptr(SEXP x) {
73  return DATAPTR(x);
74 }
75 
76 // [[Rcpp::register]]
77 const char* char_nocheck(SEXP x) {
78  return CHAR(x);
79 }
80 
81 static bool Rcpp_cache_know = false;
82 static SEXP Rcpp_cache = R_NilValue;
83 
84 #define RCPP_HASH_CACHE_INDEX 4
85 #define RCPP_CACHE_SIZE 5
86 
87 #ifndef RCPP_HASH_CACHE_INITIAL_SIZE
88 #define RCPP_HASH_CACHE_INITIAL_SIZE 1024
89 #endif
90 
91 namespace Rcpp {
92 static SEXP Rcpp_precious = R_NilValue;
93 // [[Rcpp::register]]
94 void Rcpp_precious_init() {
95  Rcpp_precious = CONS(R_NilValue, R_NilValue); // set up
96  R_PreserveObject(Rcpp_precious); // and protect
97 }
98 // [[Rcpp::register]]
100  R_ReleaseObject(Rcpp_precious); // release resource
101 }
102 // [[Rcpp::register]]
103 SEXP Rcpp_precious_preserve(SEXP object) {
104  if (object == R_NilValue) {
105  return R_NilValue;
106  }
107  PROTECT(object);
108  SEXP cell = PROTECT(CONS(Rcpp_precious, CDR(Rcpp_precious)));
109  SET_TAG(cell, object);
110  SETCDR(Rcpp_precious, cell);
111  if (CDR(cell) != R_NilValue) {
112  SETCAR(CDR(cell), cell);
113  }
114  UNPROTECT(2);
115  return cell;
116 }
117 // [[Rcpp::register]]
118 void Rcpp_precious_remove(SEXP token) {
119  if (token == R_NilValue || TYPEOF(token) != LISTSXP) {
120  return;
121  }
122  SEXP before = CAR(token);
123  SEXP after = CDR(token);
124  SETCDR(before, after);
125  if (after != R_NilValue) {
126  SETCAR(after, before);
127  }
128 }
129 }
130 
131 // only used for debugging
133  if (! Rcpp_cache_know) {
134 
135  SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
136  Rcpp::Shield<SEXP> RcppString(Rf_mkString("Rcpp"));
137  Rcpp::Shield<SEXP> call(Rf_lang2(getNamespaceSym, RcppString));
138  Rcpp::Shield<SEXP> RCPP(Rf_eval(call, R_GlobalEnv));
139 
140  Rcpp_cache = Rf_findVarInFrame(RCPP, Rf_install(".rcpp_cache"));
141  Rcpp_cache_know = true;
142  }
143  return Rcpp_cache;
144 }
145 
146 namespace Rcpp {
147  namespace internal {
148  // [[Rcpp::register]]
149  SEXP get_Rcpp_namespace() {
150  return VECTOR_ELT(get_rcpp_cache() , 0);
151  }
152  }
153 }
154 
155 // [[Rcpp::register]]
157  return VECTOR_ELT(get_rcpp_cache(), 3);
158 }
159 
160 // [[Rcpp::register]]
161 SEXP rcpp_set_stack_trace(SEXP e) {
162  SET_VECTOR_ELT(get_rcpp_cache(), 3, e);
163  return R_NilValue;
164 }
165 
166 SEXP set_error_occured(SEXP cache, SEXP e) {
167  SET_VECTOR_ELT(cache, 1, e);
168  return R_NilValue;
169 }
170 
171 SEXP set_current_error(SEXP cache, SEXP e) {
172  SET_VECTOR_ELT(cache, 2, e);
173  return R_NilValue;
174 }
175 
177  SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
178  Rcpp::Shield<SEXP> RcppString(Rf_mkString("Rcpp"));
179  Rcpp::Shield<SEXP> call(Rf_lang2(getNamespaceSym, RcppString));
180  Rcpp::Shield<SEXP> RCPP(Rf_eval(call, R_GlobalEnv));
181  Rcpp::Shield<SEXP> cache(Rf_allocVector(VECSXP, RCPP_CACHE_SIZE));
182 
183  // the Rcpp namespace
184  SET_VECTOR_ELT(cache, 0, RCPP);
185  set_error_occured(cache, Rf_ScalarLogical(FALSE)); // error occured
186  set_current_error(cache, R_NilValue); // current error
187  SET_VECTOR_ELT(cache, 3, R_NilValue); // stack trace
188  Rcpp::Shield<SEXP> tmp(Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE));
189  SET_VECTOR_ELT(cache, RCPP_HASH_CACHE_INDEX, tmp);
190  Rf_defineVar(Rf_install(".rcpp_cache"), cache, RCPP);
191 
192  return cache;
193 }
194 
195 // [[Rcpp::register]]
196 SEXP reset_current_error() { // #nocov start
197  SEXP cache = get_rcpp_cache();
198 
199  // error occured
200  set_error_occured(cache, Rf_ScalarLogical(FALSE));
201 
202  // current error
203  set_current_error(cache, R_NilValue);
204 
205  // stack trace
206  SET_VECTOR_ELT(cache, 3, R_NilValue);
207 
208  return R_NilValue;
209 }
210 
211 // [[Rcpp::register]]
213  SEXP err = VECTOR_ELT(get_rcpp_cache(), 1);
214  return LOGICAL(err)[0];
215 }
216 
217 // [[Rcpp::internal]]
218 SEXP rcpp_error_recorder(SEXP e) {
219  SEXP cache = get_rcpp_cache();
220 
221  // error occured
222  set_error_occured(cache, Rf_ScalarLogical(TRUE));
223 
224  // current error
225  set_current_error(cache, e);
226 
227  return R_NilValue;
228 }
229 
230 // [[Rcpp::register]]
232  return VECTOR_ELT(get_rcpp_cache(), 2); // #nocov end
233 }
234 
235 // [[Rcpp::register]]
236 int* get_cache(int m) {
237  SEXP cache = get_rcpp_cache();
238  SEXP hash_cache = VECTOR_ELT(cache, RCPP_HASH_CACHE_INDEX);
239  int n = Rf_length(hash_cache);
240  if (m > n) {
241  Rcpp::Shield<SEXP> new_hash_cache(Rf_allocVector(INTSXP, m));
242  hash_cache = new_hash_cache;
243  SET_VECTOR_ELT(cache,RCPP_HASH_CACHE_INDEX, hash_cache);
244  }
245  int *res = INTEGER(hash_cache);
246  std::fill(res, res+m, 0);
247  return res;
248 }
Rcpp::Rcpp_precious
static SEXP Rcpp_precious
Definition: barrier.cpp:92
Rcpp_cache_know
static bool Rcpp_cache_know
Definition: barrier.cpp:81
RCPP_CACHE_SIZE
#define RCPP_CACHE_SIZE
Definition: barrier.cpp:85
Rcpp_cache
static SEXP Rcpp_cache
Definition: barrier.cpp:82
get_cache
int * get_cache(int m)
Definition: barrier.cpp:236
Rcpp::Rcpp_precious_preserve
attribute_hidden SEXP Rcpp_precious_preserve(SEXP object)
Definition: routines.h:152
Rcpp::Rcpp_precious_remove
attribute_hidden void Rcpp_precious_remove(SEXP token)
Definition: routines.h:157
RCPP_HASH_CACHE_INITIAL_SIZE
#define RCPP_HASH_CACHE_INITIAL_SIZE
Definition: barrier.cpp:88
init_Rcpp_cache
SEXP init_Rcpp_cache()
Definition: barrier.cpp:176
char_nocheck
const char * char_nocheck(SEXP x)
Definition: barrier.cpp:77
error_occured
int error_occured()
Definition: barrier.cpp:212
rcpp_get_stack_trace
SEXP rcpp_get_stack_trace()
Definition: barrier.cpp:156
dataptr
void * dataptr(SEXP x)
Definition: barrier.cpp:72
rcpp_set_stack_trace
SEXP rcpp_set_stack_trace(SEXP e)
Definition: barrier.cpp:161
RCPP_HASH_CACHE_INDEX
#define RCPP_HASH_CACHE_INDEX
Definition: barrier.cpp:84
Rcpp::Shield
Definition: Shield.h:35
Rcpp
Rcpp API.
Definition: algo.h:28
get_string_elt
SEXP get_string_elt(SEXP x, R_xlen_t i)
Definition: barrier.cpp:32
set_string_elt
void set_string_elt(SEXP x, R_xlen_t i, SEXP value)
Definition: barrier.cpp:42
Rcpp::internal::get_Rcpp_namespace
attribute_hidden SEXP get_Rcpp_namespace()
Definition: routines.h:121
barrier.h
Shield.h
internal.h
rcpp_get_current_error
SEXP rcpp_get_current_error()
Definition: barrier.cpp:231
Rcpp::Rcpp_precious_init
attribute_hidden void Rcpp_precious_init()
Definition: routines.h:142
rcpp_error_recorder
SEXP rcpp_error_recorder(SEXP e)
Definition: barrier.cpp:218
set_error_occured
SEXP set_error_occured(SEXP cache, SEXP e)
Definition: barrier.cpp:166
get_string_ptr
SEXP * get_string_ptr(SEXP x)
Definition: barrier.cpp:52
set_current_error
SEXP set_current_error(SEXP cache, SEXP e)
Definition: barrier.cpp:171
get_vector_ptr
SEXP * get_vector_ptr(SEXP x)
Definition: barrier.cpp:67
reset_current_error
SEXP reset_current_error()
Definition: barrier.cpp:196
get_vector_elt
SEXP get_vector_elt(SEXP x, R_xlen_t i)
Definition: barrier.cpp:57
Rcpp::Rcpp_precious_teardown
attribute_hidden void Rcpp_precious_teardown()
Definition: routines.h:147
char_set_string_elt
void char_set_string_elt(SEXP x, R_xlen_t i, const char *value)
Definition: barrier.cpp:47
char_get_string_elt
const char * char_get_string_elt(SEXP x, R_xlen_t i)
Definition: barrier.cpp:37
get_rcpp_cache
SEXP get_rcpp_cache()
Definition: barrier.cpp:132
set_vector_elt
void set_vector_elt(SEXP x, R_xlen_t i, SEXP value)
Definition: barrier.cpp:62