Don't use illegal function accessors

Author: lionel-

crates/ark/src/modules.rs

@@ -326,13 +326,13 @@ pub extern "C-unwind" fn ark_log_error(msg: SEXP) -> harp::error::Result<SEXP> {
 #[cfg(test)]
 mod tests {
     use harp::environment::Environment;
-    use libr::CLOENV;
+    use harp::fn_env;
 
     use crate::r_task;
 
     fn get_namespace(exports: Environment, fun: &str) -> Environment {
         let fun = exports.find(fun).unwrap();
-        let ns = unsafe { CLOENV(fun) };
+        let ns = fn_env(fun);
         Environment::view(ns)
     }
 

crates/ark/src/srcref.rs

@@ -76,7 +76,7 @@ async fn ns_populate_srcref_without_vdoc_insertion(
 
     for b in ns.iter().filter_map(Result::ok) {
         span.in_scope(|| {
-            match generate_source(&b, vdoc.len(), &uri) {
+            match generate_source(&b, ns.inner.sexp, vdoc.len(), &uri) {
                 Ok(Some(mut lines)) => {
                     n_ok = n_ok + 1;
 
@@ -122,6 +122,7 @@ fn ark_ns_uri(ns_name: &str) -> String {
 #[tracing::instrument(level = "trace", skip_all, fields(name = %binding.name))]
 fn generate_source(
     binding: &Binding,
+    ns_env: SEXP,
     line: usize,
     uri: &String,
 ) -> anyhow::Result<Option<Vec<String>>> {
@@ -160,10 +161,8 @@ fn generate_source(
     // Inject source references in functions. This is slightly unsafe but we
     // couldn't think of a dire failure mode.
     unsafe {
-        // First replace the body which contains expressions tagged with srcrefs
-        // such as calls to `{`. Compiled functions are a little more tricky.
+        let body = harp::fn_body(old.sexp);
 
-        let body = BODY(old.sexp);
         if r_typeof(body) == BCODESXP {
             // This is a compiled function. We could recompile the fresh
             // function we just created but the compiler is very slow. Instead,
@@ -179,16 +178,35 @@ fn generate_source(
                 // Inject new body instrumented with source references
                 SET_VECTOR_ELT(consts, 0, R_ClosureExpr(new));
             }
+
+            Rf_setAttrib(
+                old.sexp,
+                r_symbol!("srcref"),
+                Rf_getAttrib(new, r_symbol!("srcref")),
+            );
         } else {
-            SET_BODY(old.sexp, BODY(new));
-        }
+            let new_body = harp::fn_body(new);
+            let out = RObject::new(harp::new_function(
+                harp::fn_formals(old.sexp),
+                new_body,
+                harp::fn_env(old.sexp),
+            ));
+
+            // TODO: Avoid `ATTRIB()`
+            let attrib = ATTRIB(old.sexp);
+            if attrib != R_NilValue {
+                let attrib = RObject::new(Rf_shallow_duplicate(attrib));
+                SET_ATTRIB(out.sexp, attrib.sexp);
+            }
 
-        // Finally push the srcref attribute for the whole function
-        Rf_setAttrib(
-            old.sexp,
-            r_symbol!("srcref"),
-            Rf_getAttrib(new, r_symbol!("srcref")),
-        );
+            Rf_setAttrib(
+                out.sexp,
+                r_symbol!("srcref"),
+                Rf_getAttrib(new, r_symbol!("srcref")),
+            );
+
+            harp::env_bind_force(ns_env, binding.name.sexp, out.sexp);
+        }
     }
 
     let text: Vec<String> = RObject::view(text).try_into()?;

crates/harp/src/attrib.rs

@@ -1,6 +1,10 @@
 use libr::SEXP;
 
 use crate::object::r_length;
+use crate::r::fn_body;
+use crate::r::fn_env;
+use crate::r::fn_formals;
+use crate::r::new_function;
 use crate::r_null;
 use crate::r_symbol;
 use crate::RObject;
@@ -18,12 +22,26 @@ pub fn zap_srcref(x: SEXP) -> RObject {
 
 fn zap_srcref_fn(x: SEXP) -> RObject {
     unsafe {
-        let x = RObject::view(x).shallow_duplicate();
-
-        x.set_attribute("srcref", r_null());
-        libr::SET_BODY(x.sexp, zap_srcref(libr::R_ClosureExpr(x.sexp)).sexp);
+        let formals = fn_formals(x);
+        let body = fn_body(x);
+        let env = fn_env(x);
+
+        let new_body = zap_srcref(body);
+        let out = RObject::new(new_function(formals, new_body.sexp, env));
+
+        // Copy attributes from the original, but zap `srcref`
+        let attrib = libr::ATTRIB(x);
+        if attrib != r_null() {
+            if libr::Rf_getAttrib(x, r_symbol!("srcref")) == r_null() {
+                libr::SET_ATTRIB(out.sexp, attrib);
+            } else {
+                let attrib = RObject::new(libr::Rf_duplicate(attrib));
+                libr::SET_ATTRIB(out.sexp, attrib.sexp);
+                libr::Rf_setAttrib(out.sexp, r_symbol!("srcref"), r_null());
+            }
+        }
 
-        x
+        out
     }
 }
 

crates/harp/src/lib.rs

@@ -7,6 +7,7 @@
 
 pub mod attrib;
 pub mod call;
+
 mod column_names;
 pub mod command;
 pub mod data_frame;
@@ -30,6 +31,7 @@ pub mod parse;
 pub mod parser;
 pub mod polled_events;
 pub mod protect;
+pub mod r;
 pub mod raii;
 pub mod routines;
 pub mod session;
@@ -55,6 +57,7 @@ pub use matrix::*;
 pub use object::*;
 pub use parse::*;
 pub use parser::*;
+pub use r::*;
 pub use source::*;
 pub use table::*;
 pub use vector::character_vector::*;

crates/harp/src/r.rs

@@ -0,0 +1,76 @@
+use libr::SEXP;
+
+pub fn fn_formals(x: SEXP) -> SEXP {
+    unsafe { libr::FORMALS(x) }
+}
+
+pub fn fn_body(x: SEXP) -> SEXP {
+    unsafe {
+        if libr::has::R_ClosureBody() {
+            libr::R_ClosureBody(x)
+        } else {
+            libr::BODY(x)
+        }
+    }
+}
+
+pub fn fn_env(x: SEXP) -> SEXP {
+    unsafe {
+        if libr::has::R_ClosureEnv() {
+            libr::R_ClosureEnv(x)
+        } else {
+            libr::CLOENV(x)
+        }
+    }
+}
+
+pub fn env_binding_is_locked(env: SEXP, sym: SEXP) -> bool {
+    unsafe { libr::R_BindingIsLocked(sym, env) != 0 }
+}
+
+pub fn env_binding_lock(env: SEXP, sym: SEXP) {
+    unsafe {
+        libr::R_LockBinding(sym, env);
+    }
+}
+
+pub fn env_binding_unlock(env: SEXP, sym: SEXP) {
+    unsafe {
+        libr::R_unLockBinding(sym, env);
+    }
+}
+
+/// Binds a value in an environment, temporarily unlocking the binding if needed.
+pub fn env_bind_force(env: SEXP, sym: SEXP, value: SEXP) {
+    let locked = env_binding_is_locked(env, sym);
+    if locked {
+        env_binding_unlock(env, sym);
+    }
+    unsafe {
+        libr::Rf_defineVar(sym, value, env);
+    }
+    if locked {
+        env_binding_lock(env, sym);
+    }
+}
+
+/// Creates a closure.
+pub unsafe fn new_function(formals: SEXP, body: SEXP, env: SEXP) -> SEXP {
+    if libr::has::R_mkClosure() {
+        libr::R_mkClosure(formals, body, env)
+    } else {
+        compat::alloc_closure(formals, body, env)
+    }
+}
+
+mod compat {
+    use libr::SEXP;
+
+    pub unsafe fn alloc_closure(formals: SEXP, body: SEXP, env: SEXP) -> SEXP {
+        let out = libr::Rf_allocSExp(libr::CLOSXP);
+        libr::SET_FORMALS(out, formals);
+        libr::SET_BODY(out, body);
+        libr::SET_CLOENV(out, env);
+        out
+    }
+}

crates/harp/src/size.rs

@@ -20,6 +20,9 @@ use crate::environment::R_ENVS;
 use crate::list_get;
 use crate::object::r_chr_get;
 use crate::object::r_length;
+use crate::r::fn_body;
+use crate::r::fn_env;
+use crate::r::fn_formals;
 use crate::r_is_altrep;
 use crate::r_symbol;
 use crate::r_typeof;
@@ -306,24 +309,23 @@ fn obj_size_tree(
         // Functions
         CLOSXP => {
             size += obj_size_tree(
-                unsafe { libr::FORMALS(x) },
+                fn_formals(x),
                 base_env,
                 sizeof_node,
                 sizeof_vector,
                 seen,
                 depth + 1,
             );
-            // BODY is either an expression or byte code
             size += obj_size_tree(
-                unsafe { libr::BODY(x) },
+                fn_body(x),
                 base_env,
                 sizeof_node,
                 sizeof_vector,
                 seen,
                 depth + 1,
             );
             size += obj_size_tree(
-                unsafe { libr::CLOENV(x) },
+                fn_env(x),
                 base_env,
                 sizeof_node,
                 sizeof_vector,

crates/harp/src/utils.rs

@@ -30,6 +30,7 @@ use crate::object::r_str_blank;
 use crate::object::r_str_na;
 use crate::object::RObject;
 use crate::protect::RProtect;
+use crate::r::fn_formals;
 use crate::r_char;
 use crate::r_lang;
 use crate::r_null;
@@ -330,7 +331,7 @@ pub fn r_formals(object: SEXP) -> Result<Vec<RArgument>> {
     r_assert_type(*object, &[CLOSXP])?;
 
     // get the formals
-    let mut formals = unsafe { FORMALS(*object) };
+    let mut formals = fn_formals(*object);
 
     // iterate through the entries
     let mut arguments = Vec::new();

crates/libr/src/r.rs

@@ -226,6 +226,8 @@ functions::generate! {
 
     pub fn ATTRIB(x: SEXP) -> SEXP;
 
+    pub fn SET_ATTRIB(x: SEXP, v: SEXP);
+
     pub fn CADDDR(e: SEXP) -> SEXP;
 
     pub fn CADDR(e: SEXP) -> SEXP;
@@ -334,12 +336,26 @@ functions::generate! {
 
     pub fn CLOENV(x: SEXP) -> SEXP;
 
+    pub fn SET_CLOENV(x: SEXP, v: SEXP);
+
     pub fn BODY(x: SEXP) -> SEXP;
 
     pub fn SET_BODY(x: SEXP, v: SEXP);
 
+    pub fn SET_FORMALS(x: SEXP, v: SEXP);
+
+    pub fn Rf_allocSExp(t: SEXPTYPE) -> SEXP;
+
+    pub fn R_ClosureBody(x: SEXP) -> SEXP;
+
+    pub fn R_ClosureEnv(x: SEXP) -> SEXP;
+
     pub fn R_ClosureExpr(x: SEXP) -> SEXP;
 
+    pub fn R_ClosureFormals(x: SEXP) -> SEXP;
+
+    pub fn R_mkClosure(formals: SEXP, body: SEXP, env: SEXP) -> SEXP;
+
     pub fn Rf_PrintValue(x: SEXP);
 
     pub fn R_PromiseExpr(p: SEXP) -> SEXP;