1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
// Copyright (c) Viable Systems and TezEdge Contributors
// SPDX-License-Identifier: MIT

use crate::{
    conv::FromOCaml,
    mlvalues::{tag, DynBox, OCamlBytes, OCamlFloat, OCamlInt32, OCamlInt64, OCamlList, RawOCaml},
    runtime::OCamlRuntime,
    value::OCaml,
};
use core::{any::Any, cell::UnsafeCell, marker::PhantomData, mem, pin::Pin, ptr};
pub use ocaml_sys::{
    caml_alloc, local_roots as ocaml_sys_local_roots, set_local_roots as ocaml_sys_set_local_roots,
    store_field,
};
use ocaml_sys::{
    caml_alloc_string, caml_alloc_tuple, caml_copy_double, caml_copy_int32, caml_copy_int64,
    custom_operations, string_val, Size,
};

pub struct OCamlCell<T> {
    cell: UnsafeCell<RawOCaml>,
    _marker: PhantomData<T>,
}

static_assertions::assert_eq_size!(OCamlCell<bool>, OCaml<'static, bool>, RawOCaml);

/// An `OCamlRef<T>` is a reference to a location containing a [`OCaml`]`<T>` value.
///
/// Usually obtained as the result of rooting an OCaml value.
pub type OCamlRef<'a, T> = &'a OCamlCell<T>;

impl<T> OCamlCell<T> {
    #[doc(hidden)]
    pub unsafe fn create_ref<'a>(val: *const RawOCaml) -> OCamlRef<'a, T> {
        &*(val as *const OCamlCell<T>)
    }

    /// Converts this value into a Rust value.
    pub fn to_rust<RustT>(&self, cr: &OCamlRuntime) -> RustT
    where
        RustT: FromOCaml<T>,
    {
        RustT::from_ocaml(cr.get(self))
    }

    /// Borrows the raw value contained in this root.
    ///
    /// # Safety
    ///
    /// The [`RawOCaml`] value obtained may become invalid after the OCaml GC runs.
    pub unsafe fn get_raw(&self) -> RawOCaml {
        *self.cell.get()
    }
}

pub fn alloc_bytes<'a>(cr: &'a mut OCamlRuntime, s: &[u8]) -> OCaml<'a, OCamlBytes> {
    unsafe {
        let len = s.len();
        let value = caml_alloc_string(len);
        let ptr = string_val(value);
        core::ptr::copy_nonoverlapping(s.as_ptr(), ptr, len);
        OCaml::new(cr, value)
    }
}

pub fn alloc_string<'a>(cr: &'a mut OCamlRuntime, s: &str) -> OCaml<'a, String> {
    unsafe {
        let len = s.len();
        let value = caml_alloc_string(len);
        let ptr = string_val(value);
        core::ptr::copy_nonoverlapping(s.as_ptr(), ptr, len);
        OCaml::new(cr, value)
    }
}

pub fn alloc_int32(cr: &mut OCamlRuntime, i: i32) -> OCaml<OCamlInt32> {
    unsafe { OCaml::new(cr, caml_copy_int32(i)) }
}

pub fn alloc_int64(cr: &mut OCamlRuntime, i: i64) -> OCaml<OCamlInt64> {
    unsafe { OCaml::new(cr, caml_copy_int64(i)) }
}

pub fn alloc_double(cr: &mut OCamlRuntime, d: f64) -> OCaml<OCamlFloat> {
    unsafe { OCaml::new(cr, caml_copy_double(d)) }
}

// TODO: it is possible to directly alter the fields memory upon first allocation of
// small values (like tuples and conses are) without going through `caml_modify` to get
// a little bit of extra performance.

pub fn alloc_some<'a, 'b, A>(
    cr: &'a mut OCamlRuntime,
    value: OCamlRef<'b, A>,
) -> OCaml<'a, Option<A>> {
    unsafe {
        let ocaml_some = caml_alloc(1, tag::SOME);
        store_field(ocaml_some, 0, value.get_raw());
        OCaml::new(cr, ocaml_some)
    }
}

pub fn alloc_ok<'a, 'b, A, Err>(
    cr: &'a mut OCamlRuntime,
    value: OCamlRef<'b, A>,
) -> OCaml<'a, Result<A, Err>> {
    unsafe {
        let ocaml_ok = caml_alloc(1, tag::TAG_OK);
        store_field(ocaml_ok, 0, value.get_raw());
        OCaml::new(cr, ocaml_ok)
    }
}

pub fn alloc_error<'a, 'b, A, Err>(
    cr: &'a mut OCamlRuntime,
    err: OCamlRef<'b, Err>,
) -> OCaml<'a, Result<A, Err>> {
    unsafe {
        let ocaml_err = caml_alloc(1, tag::TAG_ERROR);
        store_field(ocaml_err, 0, err.get_raw());
        OCaml::new(cr, ocaml_err)
    }
}

#[doc(hidden)]
pub unsafe fn alloc_tuple<T>(cr: &mut OCamlRuntime, size: usize) -> OCaml<T> {
    let ocaml_tuple = caml_alloc_tuple(size);
    OCaml::new(cr, ocaml_tuple)
}

/// List constructor
///
/// Build a new list from a head and a tail list.
pub fn alloc_cons<'a, 'b, A>(
    cr: &'a mut OCamlRuntime,
    head: OCamlRef<'b, A>,
    tail: OCamlRef<'b, OCamlList<A>>,
) -> OCaml<'a, OCamlList<A>> {
    unsafe {
        let ocaml_cons = caml_alloc(2, tag::CONS);
        store_field(ocaml_cons, 0, head.get_raw());
        store_field(ocaml_cons, 1, tail.get_raw());
        OCaml::new(cr, ocaml_cons)
    }
}

#[inline]
pub unsafe fn store_raw_field_at<A>(
    cr: &mut OCamlRuntime,
    block: OCamlRef<A>,
    offset: Size,
    raw_value: RawOCaml,
) {
    store_field(cr.get(block).get_raw(), offset, raw_value);
}

const BOX_OPS_DYN_DROP: custom_operations = custom_operations {
    identifier: "_rust_box_dyn_drop\0".as_ptr() as *const ocaml_sys::Char,
    finalize: Some(drop_box_dyn),
    compare: None,
    hash: None,
    serialize: None,
    deserialize: None,
    compare_ext: None,
    fixed_length: ptr::null(),
};

extern "C" fn drop_box_dyn(oval: RawOCaml) {
    unsafe {
        let box_ptr = ocaml_sys::field(oval, 1) as *mut Pin<Box<dyn Any>>;
        ptr::drop_in_place(box_ptr);
    }
}

// Notes by @g2p:
//
// Implementation notes: is it possible to reduce indirection?
// Could we also skip the finalizer?
//
// While putting T immediately inside the custom block as field(1)
// is tempting, GC would misalign it (UB) when moving.  Put a pointer to T instead.
// That optimisation would only work when alignment is the same as OCaml,
// meaning size_of<uintnat>.  It would also need to use different types.
//
// Use Any for now.  This allows safe downcasting when converting back to Rust.
//
// mem::needs_drop can be used to detect drop glue.
// This could be used to skip the finalizer, but only when there's no box.
// Using a lighter finalizer won't work either, the GlobalAllocator trait needs
// to know the layout before freeing the referenced block.
// malloc won't use that info, but other allocators would.
//
// Also: caml_register_custom_operations is only useful for Marshall serialization,
// skip it

/// Allocate a `DynBox` for a value of type `A`.
pub fn alloc_box<A: 'static>(cr: &mut OCamlRuntime, data: A) -> OCaml<DynBox<A>> {
    let oval;
    // A fatter Box, points to data then to vtable
    type B = Pin<Box<dyn Any>>;
    unsafe {
        oval = ocaml_sys::caml_alloc_custom(&BOX_OPS_DYN_DROP, mem::size_of::<B>(), 0, 1);
        let box_ptr = ocaml_sys::field(oval, 1) as *mut B;
        std::ptr::write(box_ptr, Box::pin(data));
    }
    unsafe { OCaml::new(cr, oval) }
}