mlsize_t string_length(value s)
{
mlsize_t temp;
temp = Bosize_val(s) - 1;
Assert (Byte (s, temp - Byte (s, temp)) == 0);
return temp - Byte (s, temp);
}
CAMLprim value caml_ml_string_length(value s)
{
mlsize_t temp;
temp = Bosize_val(s) - 1;
Assert (Byte (s, temp - Byte (s, temp)) == 0);
return Val_long(temp - Byte (s, temp));
}
CAMLprim value ml_gsl_odeiv_evolve_apply(value e, value c, value s,
value syst, value t, value t1,
value h, value y)
{
CAMLparam5(e, c, s, syst, y);
double t_c = Double_val(t);
double h_c = Double_val(h);
LOCALARRAY(double, y_copy, Double_array_length(y));
int status;
memcpy(y_copy, Double_array_val(y), Bosize_val(y));
status = gsl_odeiv_evolve_apply(ODEIV_EVOLVE_VAL(e), ODEIV_CONTROL_VAL(c),
ODEIV_STEP_VAL(s), ODEIV_SYSTEM_VAL(syst),
&t_c, Double_val(t1), &h_c, y_copy);
/* GSL does not call the error handler for this function */
if (status)
GSL_ERROR_VAL ("gsl_odeiv_evolve_apply", status, Val_unit);
memcpy(Double_array_val(y), y_copy, Bosize_val(y));
CAMLreturn(copy_two_double(t_c, h_c));
}
void caml_maybe_expand_stack (value* gc_regs)
{
CAMLparamN(gc_regs, 5);
uintnat stack_available;
Assert(Tag_val(caml_current_stack) == Stack_tag);
stack_available = Bosize_val(caml_current_stack)
- (Stack_sp(caml_current_stack) + Stack_ctx_words * sizeof(value));
if (stack_available < 2 * Stack_threshold)
caml_realloc_stack ();
CAMLreturn0;
}
CAMLprim value ml_gsl_odeiv_step_apply(value step, value t, value h, value y,
value yerr, value odydt_in, value odydt_out,
value syst)
{
CAMLparam5(step, syst, y, yerr, odydt_out);
LOCALARRAY(double, y_copy, Double_array_length(y));
LOCALARRAY(double, yerr_copy, Double_array_length(yerr));
size_t len_dydt_in =
odydt_in == Val_none ? 0 : Double_array_length(Unoption(odydt_in)) ;
size_t len_dydt_out =
odydt_out == Val_none ? 0 : Double_array_length(Unoption(odydt_out)) ;
LOCALARRAY(double, dydt_in, len_dydt_in);
LOCALARRAY(double, dydt_out, len_dydt_out);
int status;
if(len_dydt_in)
memcpy(dydt_in, Double_array_val(Unoption(odydt_in)), Bosize_val(Unoption(odydt_in)));
memcpy(y_copy, Double_array_val(y), Bosize_val(y));
memcpy(yerr_copy, Double_array_val(yerr), Bosize_val(yerr));
status = gsl_odeiv_step_apply(ODEIV_STEP_VAL(step),
Double_val(t), Double_val(h),
y_copy, yerr_copy,
len_dydt_in ? dydt_in : NULL,
len_dydt_out ? dydt_out : NULL,
ODEIV_SYSTEM_VAL(syst));
/* GSL does not call the error handler for this function */
if (status)
GSL_ERROR_VAL ("gsl_odeiv_step_apply", status, Val_unit);
memcpy(Double_array_val(y), y_copy, sizeof(y_copy));
memcpy(Double_array_val(yerr), yerr_copy, sizeof(yerr_copy));
if(len_dydt_out)
memcpy(Double_array_val(Unoption(odydt_out)), dydt_out, Bosize_val(Unoption(odydt_out)));
CAMLreturn(Val_unit);
}
static void oldify (value *p, value v)
{
value result;
mlsize_t i;
tail_call:
if (IS_BLOCK(v) && Is_young (v)){
assert (Hp_val (v) < young_ptr);
if (Is_blue_val (v)){ /* Already forwarded ? */
*p = Field (v, 0); /* Then the forward pointer is the first field. */
}else if (Tag_val (v) >= No_scan_tag){
result = alloc_shr (Wosize_val (v), Tag_val (v));
bcopy (Bp_val (v), Bp_val (result), Bosize_val (v));
Hd_val (v) = Bluehd_hd (Hd_val (v)); /* Put the forward flag. */
Field (v, 0) = result; /* And the forward pointer. */
*p = result;
}else{
/* We can do recursive calls before all the fields are filled, because
we will not be calling the major GC. */
value field0 = Field (v, 0);
mlsize_t sz = Wosize_val (v);
result = alloc_shr (sz, Tag_val (v));
*p = result;
Hd_val (v) = Bluehd_hd (Hd_val (v)); /* Put the forward flag. */
Field (v, 0) = result; /* And the forward pointer. */
if (sz == 1){
p = &Field (result, 0);
v = field0;
goto tail_call;
}else{
oldify (&Field (result, 0), field0);
for (i = 1; i < sz - 1; i++){
oldify (&Field (result, i), Field (v, i));
}
p = &Field (result, i);
v = Field (v, i);
goto tail_call;
}
}
}else{
*p = v;
}
}
CAMLprim value caml_weak_get_copy (value ar, value n)
{
CAMLparam2 (ar, n);
mlsize_t offset = Long_val (n) + 1;
CAMLlocal2 (res, elt);
value v; /* Caution: this is NOT a local root. */
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get");
}
v = Field (ar, offset);
if (v == caml_weak_none) CAMLreturn (None_val);
if (Is_block (v) && Is_in_heap_or_young(v)) {
elt = caml_alloc (Wosize_val (v), Tag_val (v));
/* The GC may erase or move v during this call to caml_alloc. */
v = Field (ar, offset);
if (v == caml_weak_none) CAMLreturn (None_val);
if (Tag_val (v) < No_scan_tag){
mlsize_t i;
for (i = 0; i < Wosize_val (v); i++){
value f = Field (v, i);
if (caml_gc_phase == Phase_mark && Is_block (f) && Is_in_heap (f)){
caml_darken (f, NULL);
}
Modify (&Field (elt, i), f);
}
}else{
memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
}
}else{
elt = v;
}
res = caml_alloc_small (1, Some_tag);
Field (res, 0) = elt;
CAMLreturn (res);
}
static void hash_aux(value obj)
{
unsigned char * p;
mlsize_t i, j;
tag_t tag;
hash_univ_limit--;
if (hash_univ_count < 0 || hash_univ_limit < 0) return;
again:
if (Is_long(obj)) {
hash_univ_count--;
Combine(Long_val(obj));
return;
}
/* Pointers into the heap are well-structured blocks. So are atoms.
We can inspect the block contents. */
Assert (Is_block (obj));
if (Is_in_value_area(obj)) {
tag = Tag_val(obj);
switch (tag) {
case String_tag:
hash_univ_count--;
i = caml_string_length(obj);
for (p = &Byte_u(obj, 0); i > 0; i--, p++)
Combine_small(*p);
break;
case Double_tag:
/* For doubles, we inspect their binary representation, LSB first.
The results are consistent among all platforms with IEEE floats. */
hash_univ_count--;
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, 0), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
break;
case Double_array_tag:
hash_univ_count--;
for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, j), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
}
break;
case Abstract_tag:
/* We don't know anything about the contents of the block.
Better do nothing. */
break;
case Infix_tag:
hash_aux(obj - Infix_offset_val(obj));
break;
case Forward_tag:
obj = Forward_val (obj);
goto again;
case Object_tag:
hash_univ_count--;
Combine(Oid_val(obj));
break;
case Custom_tag:
/* If no hashing function provided, do nothing */
if (Custom_ops_val(obj)->hash != NULL) {
hash_univ_count--;
Combine(Custom_ops_val(obj)->hash(obj));
}
break;
default:
hash_univ_count--;
Combine_small(tag);
i = Wosize_val(obj);
while (i != 0) {
i--;
hash_aux(Field(obj, i));
}
break;
}
return;
}
/* Otherwise, obj is a pointer outside the heap, to an object with
a priori unknown structure. Use its physical address as hash key. */
Combine((intnat) obj);
}
