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); }