1 #define R_NO_REMAP
2 #include <Rinternals.h>
3
4 #include "cleancall.h"
5
6
7 #if (defined(R_VERSION) && R_VERSION < R_Version(3, 4, 0))
R_MakeExternalPtrFn(DL_FUNC p,SEXP tag,SEXP prot)8 SEXP R_MakeExternalPtrFn(DL_FUNC p, SEXP tag, SEXP prot) {
9 fn_ptr ptr;
10 ptr.fn = p;
11 return R_MakeExternalPtr(ptr.p, tag, prot);
12 }
R_ExternalPtrAddrFn(SEXP s)13 DL_FUNC R_ExternalPtrAddrFn(SEXP s) {
14 fn_ptr ptr;
15 ptr.p = R_ExternalPtrAddr(s);
16 return ptr.fn;
17 }
18 #endif
19
20 // The R API does not have a setter for function pointers
21
cleancall_MakeExternalPtrFn(DL_FUNC p,SEXP tag,SEXP prot)22 SEXP cleancall_MakeExternalPtrFn(DL_FUNC p, SEXP tag, SEXP prot) {
23 fn_ptr tmp;
24 tmp.fn = p;
25 return R_MakeExternalPtr(tmp.p, tag, prot);
26 }
27
cleancall_SetExternalPtrAddrFn(SEXP s,DL_FUNC p)28 void cleancall_SetExternalPtrAddrFn(SEXP s, DL_FUNC p) {
29 fn_ptr ptr;
30 ptr.fn = p;
31 R_SetExternalPtrAddr(s, ptr.p);
32 }
33
34
35 // Initialised at load time with the `.Call` primitive
36 SEXP cleancall_fns_dot_call = NULL;
37
cleancall_init()38 void cleancall_init() {
39 cleancall_fns_dot_call = Rf_findVar(Rf_install(".Call"), R_BaseEnv);
40 }
41
42 struct eval_args {
43 SEXP call;
44 SEXP env;
45 };
46
eval_wrap(void * data)47 static SEXP eval_wrap(void* data) {
48 struct eval_args* args = (struct eval_args*) data;
49 return Rf_eval(args->call, args->env);
50 }
51
52
cleancall_call(SEXP args,SEXP env)53 SEXP cleancall_call(SEXP args, SEXP env) {
54 SEXP call = PROTECT(Rf_lcons(cleancall_fns_dot_call, args));
55 struct eval_args data = { call, env };
56
57 SEXP out = r_with_cleanup_context(&eval_wrap, &data);
58
59 UNPROTECT(1);
60 return out;
61 }
62
63
64 static SEXP callbacks = NULL;
65
66 // Preallocate a callback
push_callback(SEXP stack)67 static void push_callback(SEXP stack) {
68 SEXP top = CDR(stack);
69
70 SEXP early_handler = PROTECT(Rf_allocVector(LGLSXP, 1));
71 SEXP fn_extptr = PROTECT(cleancall_MakeExternalPtrFn(NULL, R_NilValue,
72 R_NilValue));
73 SEXP data_extptr = PROTECT(R_MakeExternalPtr(NULL, early_handler,
74 R_NilValue));
75 SEXP cb = Rf_cons(Rf_cons(fn_extptr, data_extptr), top);
76
77 SETCDR(stack, cb);
78
79 UNPROTECT(3);
80 }
81
82 struct data_wrapper {
83 SEXP (*fn)(void* data);
84 void *data;
85 SEXP callbacks;
86 int success;
87 };
88
call_exits(void * data)89 static void call_exits(void* data) {
90 // Remove protecting node. Don't remove the preallocated callback on
91 // the top as it might contain a handler when something went wrong.
92 SEXP top = CDR(callbacks);
93
94 // Restore old stack
95 struct data_wrapper* state = data;
96 callbacks = (SEXP) state->callbacks;
97
98 // Handlers should not jump
99 while (top != R_NilValue) {
100 SEXP cb = CAR(top);
101 top = CDR(top);
102
103 void (*fn)(void*) = (void (*)(void*)) R_ExternalPtrAddrFn(CAR(cb));
104 void *data = (void*) R_ExternalPtrAddr(CDR(cb));
105 int early_handler = LOGICAL(R_ExternalPtrTag(CDR(cb)))[0];
106
107 // Check for empty pointer in preallocated callbacks
108 if (fn) {
109 if (!early_handler || !state->success) fn(data);
110 }
111 }
112 }
113
with_cleanup_context_wrap(void * data)114 static SEXP with_cleanup_context_wrap(void *data) {
115 struct data_wrapper* cdata = data;
116 SEXP ret = cdata->fn(cdata->data);
117 cdata->success = 1;
118 return ret;
119 }
120
r_with_cleanup_context(SEXP (* fn)(void * data),void * data)121 SEXP r_with_cleanup_context(SEXP (*fn)(void* data), void* data) {
122 // Preallocate new stack before changing `callbacks` to avoid
123 // leaving the global variable in a bad state if alloc fails
124 SEXP new = PROTECT(Rf_cons(R_NilValue, R_NilValue));
125 push_callback(new);
126
127 if (!callbacks) callbacks = R_NilValue;
128
129 SEXP old = callbacks;
130 callbacks = new;
131
132 struct data_wrapper state = { fn, data, old, 0 };
133
134 SEXP out = R_ExecWithCleanup(with_cleanup_context_wrap, &state,
135 &call_exits, &state);
136
137 UNPROTECT(1);
138 return out;
139 }
140
r_cleancall_is_active()141 int r_cleancall_is_active() {
142 return callbacks != NULL;
143 }
144
call_save_handler(void (* fn)(void * data),void * data,int early)145 static void call_save_handler(void (*fn)(void *data), void* data,
146 int early) {
147 if (!callbacks) {
148 fn(data);
149 Rf_error("Internal error: Exit handler pushed outside "
150 "of an exit context");
151 }
152
153 SEXP cb = CADR(callbacks);
154
155 // Update pointers
156 cleancall_SetExternalPtrAddrFn(CAR(cb), (DL_FUNC) fn);
157 R_SetExternalPtrAddr(CDR(cb), data);
158 LOGICAL(R_ExternalPtrTag(CDR(cb)))[0] = early;
159
160 // Preallocate the next callback in case the allocator jumps
161 push_callback(callbacks);
162 }
163
r_call_on_exit(void (* fn)(void * data),void * data)164 void r_call_on_exit(void (*fn)(void* data), void* data) {
165 call_save_handler(fn, data, /* early = */ 0);
166 }
167
r_call_on_early_exit(void (* fn)(void * data),void * data)168 void r_call_on_early_exit(void (*fn)(void* data), void* data) {
169 call_save_handler(fn, data, /* early = */ 1);
170 }
171