static char* hh_store_ocaml(value data) { size_t data_size = caml_string_length(data); char* addr = hh_alloc(data_size); memcpy(addr, String_val(data), data_size); return addr; }
/* given a return value in OCaml land, translate it to the return_val_t C structure */ return_val_t translate_return_value(value ocaml_result) { CAMLparam1(ocaml_result); CAMLlocal5(ocaml_shape, ocaml_strides, ocaml_data, ocaml_cur, ocaml_type); CAMLlocal1(v); return_val_t ret; if (Is_long(ocaml_result)) { // In this case, we know that the return code must have been Pass, // since the other two return codes have data. ret.return_code = RET_PASS; ret.results_len = 0; } else if (Tag_val(ocaml_result) == RET_FAIL) { ret.return_code = RET_FAIL; ret.results_len = caml_string_length(Field(ocaml_result, 0)); ret.error_msg = malloc(ret.results_len + 1); strcpy(ret.error_msg, String_val(Field(ocaml_result, 0))); } else if (Tag_val(ocaml_result) == RET_SUCCESS) { ocaml_cur = Field(ocaml_result, 0); ret.return_code = RET_SUCCESS; ret.results_len = ocaml_list_length(ocaml_cur); ret.results = (ret_t*)malloc(sizeof(ret_t) * ret.results_len); int i, j; host_val h; for (i = 0; i < ret.results_len; ++i) { v = Field(ocaml_cur, 0); h = create_host_val(v); ocaml_cur = Field(ocaml_cur, 1); // returning a scalar if (value_is_scalar(h)) { ret.results[i].is_scalar = 1; ocaml_type = (scalar_type)value_type_of(h); ret.results[i].data.scalar.ret_type = get_scalar_element_type(ocaml_type); // WARNING: // Tiny Memory Leak Ahead // ----------------------- // When scalar data is returned to the host language // on the heap, it should be manually deleted by the // host frontend if (type_is_bool(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.boolean = get_bool(h); } else if (type_is_int32(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.int32 = get_int32(h); } else if (type_is_int64(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.int64 = get_int64(h); } else if (type_is_float32(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.float32 = get_float64(h); } else if (type_is_float64(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.float64 = get_float64(h); } else { caml_failwith("Unable to return scalar of this type\n"); } } else { // Pass the type ret.results[i].is_scalar = 0; ret.results[i].data.array.ret_type = array_type_of(h); // Pass the data ret.results[i].data.array.data = get_array_data(h); // Build the shape array ocaml_shape = value_get_shape(h); int shape_len = Wosize_val(ocaml_shape); ret.results[i].data.array.shape = (int*)malloc(shape_len * sizeof(int)); ret.results[i].data.array.shape_len = shape_len; for (j = 0; j < shape_len; ++j) { ret.results[i].data.array.shape[j] = Int_val(Field(ocaml_shape, j)); } // Build the strides array ocaml_strides = value_get_strides(h); int strides_len = Wosize_val(ocaml_strides); ret.results[i].data.array.strides_len = strides_len; ret.results[i].data.array.strides = (int*)malloc(strides_len * sizeof(int)); for (j = 0; j < strides_len; ++j) { ret.results[i].data.array.strides[j] = Int_val(Field(ocaml_strides, j)); } } } } CAMLreturnT(return_val_t, ret); }
static void extern_rec(value v) { tailcall: if (Is_long(v)) { intnat n = Long_val(v); if (n >= 0 && n < 0x40) { Write(PREFIX_SMALL_INT + n); } else if (n >= -(1 << 7) && n < (1 << 7)) { writecode8(CODE_INT8, n); } else if (n >= -(1 << 15) && n < (1 << 15)) { writecode16(CODE_INT16, n); #ifdef ARCH_SIXTYFOUR } else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) { writecode64(CODE_INT64, n); #endif } else writecode32(CODE_INT32, n); return; } if (Is_young(v) || Is_in_heap(v) || Is_atom(v)) { header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); mlsize_t sz = Wosize_hd(hd); if (tag == Forward_tag) { value f = Forward_val (v); if (Is_block (f) && (Is_young (f) || Is_in_heap (f)) && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ v = f; goto tailcall; } } /* Atoms are treated specially for two reasons: they are not allocated in the externed block, and they are automatically shared. */ if (sz == 0) { if (tag < 16) { Write(PREFIX_SMALL_BLOCK + tag); } else { writecode32(CODE_BLOCK32, hd); } return; } /* Check if already seen */ if (Color_hd(hd) == Caml_blue) { uintnat d = obj_counter - (uintnat) Field(v, 0); if (d < 0x100) { writecode8(CODE_SHARED8, d); } else if (d < 0x10000) { writecode16(CODE_SHARED16, d); } else { writecode32(CODE_SHARED32, d); } return; } /* Output the contents of the object */ switch(tag) { case String_tag: { mlsize_t len = caml_string_length(v); if (len < 0x20) { Write(PREFIX_SMALL_STRING + len); } else if (len < 0x100) { writecode8(CODE_STRING8, len); } else { writecode32(CODE_STRING32, len); } writeblock(String_val(v), len); size_32 += 1 + (len + 4) / 4; size_64 += 1 + (len + 8) / 8; extern_record_location(v); break; } case Double_tag: { if (sizeof(double) != 8) extern_invalid_argument("output_value: non-standard floats"); Write(CODE_DOUBLE_NATIVE); writeblock_float8((double *) v, 1); size_32 += 1 + 2; size_64 += 1 + 1; extern_record_location(v); break; } case Double_array_tag: { mlsize_t nfloats; if (sizeof(double) != 8) extern_invalid_argument("output_value: non-standard floats"); nfloats = Wosize_val(v) / Double_wosize; if (nfloats < 0x100) { writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats); } else { writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats); } writeblock_float8((double *) v, nfloats); size_32 += 1 + nfloats * 2; size_64 += 1 + nfloats; extern_record_location(v); break; } case Abstract_tag: extern_invalid_argument("output_value: abstract value (Abstract)"); break; case Infix_tag: writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd)); extern_rec(v - Infix_offset_hd(hd)); break; case Custom_tag: { uintnat sz_32, sz_64; char * ident = Custom_ops_val(v)->identifier; void (*serialize)(value v, uintnat * wsize_32, uintnat * wsize_64) = Custom_ops_val(v)->serialize; if (serialize == NULL) extern_invalid_argument("output_value: abstract value (Custom)"); Write(CODE_CUSTOM); writeblock(ident, strlen(ident) + 1); Custom_ops_val(v)->serialize(v, &sz_32, &sz_64); size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */ size_64 += 2 + ((sz_64 + 7) >> 3); extern_record_location(v); break; } default: { value field0; mlsize_t i; if (tag < 16 && sz < 8) { Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); #ifdef ARCH_SIXTYFOUR } else if (hd >= ((uintnat)1 << 32)) { writecode64(CODE_BLOCK64, Whitehd_hd (hd)); #endif } else { writecode32(CODE_BLOCK32, Whitehd_hd (hd)); } size_32 += 1 + sz; size_64 += 1 + sz; field0 = Field(v, 0); extern_record_location(v); if (sz == 1) { v = field0; } else { extern_rec(field0); for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i)); v = Field(v, i); } goto tailcall; } } }
/* Executes a pattern match with runtime options, a regular expression, a string offset, a string length, a subject string, a number of subgroup offsets, an offset vector and an optional callout function */ CAMLprim value pcre_exec_stub(value v_opt, value v_rex, value v_ofs, value v_subj, value v_subgroups2, value v_ovec, value v_maybe_cof) { const int ofs = Int_val(v_ofs), len = caml_string_length(v_subj); if (ofs > len || ofs < 0) caml_invalid_argument("Pcre.pcre_exec_stub: illegal offset"); { const pcre *code = (pcre *) Field(v_rex, 1); /* Compiled pattern */ const pcre_extra *extra = (pcre_extra *) Field(v_rex, 2); /* Extra info */ const char *ocaml_subj = String_val(v_subj); /* Subject string */ const int opt = Int_val(v_opt); /* Runtime options */ int subgroups2 = Int_val(v_subgroups2); const int subgroups2_1 = subgroups2 - 1; const int subgroups3 = (subgroups2 >> 1) + subgroups2; /* Special case when no callout functions specified */ if (v_maybe_cof == None) { int *ovec = (int *) &Field(v_ovec, 0); /* Performs the match */ const int ret = pcre_exec(code, extra, ocaml_subj, len, ofs, opt, ovec, subgroups3); if (ret < 0) { switch(ret) { case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found); case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial); case PCRE_ERROR_MATCHLIMIT : caml_raise_constant(*pcre_exc_MatchLimit); case PCRE_ERROR_BADPARTIAL : caml_raise_constant(*pcre_exc_BadPartial); case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8); case PCRE_ERROR_BADUTF8_OFFSET : caml_raise_constant(*pcre_exc_BadUTF8Offset); default : caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub"); } } else { const int *ovec_src = ovec + subgroups2_1; long int *ovec_dst = (long int *) ovec + subgroups2_1; /* Converts offsets from C-integers to OCaml-Integers This is a bit tricky, because there are 32- and 64-bit platforms around and OCaml chooses the larger possibility for representing integers when available (also in arrays) - not so the PCRE */ while (subgroups2--) { *ovec_dst = Val_int(*ovec_src); --ovec_src; --ovec_dst; } } } /* There are callout functions */ else { value v_cof = Field(v_maybe_cof, 0); value v_substrings; char *subj = caml_stat_alloc(sizeof(char) * len); int *ovec = caml_stat_alloc(sizeof(int) * subgroups3); int ret; struct cod cod = { (value *) NULL, (value *) NULL, (value) NULL }; struct pcre_extra new_extra = #ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 }; #else { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL }; #endif memcpy(subj, ocaml_subj, len); Begin_roots3(v_rex, v_cof, v_substrings); Begin_roots2(v_subj, v_ovec); v_substrings = caml_alloc_small(2, 0); End_roots(); Field(v_substrings, 0) = v_subj; Field(v_substrings, 1) = v_ovec; cod.v_substrings_p = &v_substrings; cod.v_cof_p = &v_cof; new_extra.callout_data = &cod; if (extra == NULL) { ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec, subgroups3); } else { new_extra.flags = PCRE_EXTRA_CALLOUT_DATA | extra->flags; new_extra.study_data = extra->study_data; new_extra.match_limit = extra->match_limit; new_extra.tables = extra->tables; #ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION new_extra.match_limit_recursion = extra->match_limit_recursion; #endif ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec, subgroups3); } free(subj); End_roots(); if (ret < 0) { free(ovec); switch(ret) { case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found); case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial); case PCRE_ERROR_MATCHLIMIT : caml_raise_constant(*pcre_exc_MatchLimit); case PCRE_ERROR_BADPARTIAL : caml_raise_constant(*pcre_exc_BadPartial); case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8); case PCRE_ERROR_BADUTF8_OFFSET : caml_raise_constant(*pcre_exc_BadUTF8Offset); case PCRE_ERROR_CALLOUT : caml_raise(cod.v_exn); default : caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub"); } } else { int *ovec_src = ovec + subgroups2_1; long int *ovec_dst = &Field(v_ovec, 0) + subgroups2_1; while (subgroups2--) { *ovec_dst = Val_int(*ovec_src); --ovec_src; --ovec_dst; } free(ovec); } } } return Val_unit; } /* Byte-code hook for pcre_exec_stub Needed, because there are more than 5 arguments */ CAMLprim value pcre_exec_stub_bc(value *argv, int __unused argn) { return pcre_exec_stub(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); } /* Generates a new set of chartables for the current locale (see man page of PCRE */ CAMLprim value pcre_maketables_stub(value __unused v_unit) { /* GC will do a full cycle every 100 table set allocations (one table set consumes 864 bytes -> maximum of 86400 bytes unreclaimed table sets) */ const value v_res = caml_alloc_final(2, pcre_dealloc_tables, 864, 86400); Field(v_res, 1) = (value) pcre_maketables(); return v_res; } /* Wraps around the isspace-function */ CAMLprim value pcre_isspace_stub(value v_c) { return Val_bool(isspace(Int_val(v_c))); } /* Returns number of substring associated with a name */ CAMLprim value pcre_get_stringnumber_stub(value v_rex, value v_name) { const int ret = pcre_get_stringnumber((pcre *) Field(v_rex, 1), String_val(v_name)); if (ret == PCRE_ERROR_NOSUBSTRING) caml_invalid_argument("Named string not found"); return Val_int(ret); } /* Returns array of names of named substrings in a regexp */ CAMLprim value pcre_names_stub(value v_rex) { CAMLparam0(); CAMLlocal1(v_res); int name_count; int entry_size; const char *tbl_ptr; int i; int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMECOUNT, &name_count); if (ret != 0) caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub"); ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size); if (ret != 0) caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub"); ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr); if (ret != 0) caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub"); v_res = caml_alloc(name_count, 0); for (i = 0; i < name_count; ++i) { value v_name = caml_copy_string(tbl_ptr + 2); Store_field(v_res, i, v_name); tbl_ptr += entry_size; } CAMLreturn(v_res); }
CAMLprim value mmdb_ml_lookup_path(value ip, value query_list, value mmdb) { CAMLparam3(ip, query_list, mmdb); CAMLlocal3(iter_count, caml_clean_result, query_r); int total_len = 0, copy_count = 0, gai_error = 0, mmdb_error = 0; char *clean_result; long int int_result; iter_count = query_list; unsigned int len = caml_string_length(ip); char *as_string = caml_strdup(String_val(ip)); if (strlen(as_string) != (size_t)len) { caml_failwith("Could not copy IP address properly"); } MMDB_s *as_mmdb = (MMDB_s*)Data_custom_val(mmdb); MMDB_lookup_result_s *result = caml_stat_alloc(sizeof(*result)); *result = MMDB_lookup_string(as_mmdb, as_string, &gai_error, &mmdb_error); check_error(gai_error, mmdb_error); caml_stat_free(as_string); while (iter_count != Val_emptylist) { total_len++; iter_count = Field(iter_count, 1); } char **query = caml_stat_alloc(sizeof(char *) * (total_len + 1)); while (query_list != Val_emptylist) { query[copy_count] = caml_strdup(String_val(Field(query_list, 0))); copy_count++; query_list = Field(query_list, 1); } query[total_len] = NULL; MMDB_entry_data_s entry_data; int status = MMDB_aget_value(&result->entry, &entry_data, (const char *const *const)query); check_status(status); check_data(entry_data); caml_stat_free(result); for (int i = 0; i < copy_count; caml_stat_free(query[i]), i++); caml_stat_free(query); query_r = caml_alloc(2, 0); as_mmdb = NULL; switch (entry_data.type) { case MMDB_DATA_TYPE_BYTES: clean_result = caml_stat_alloc(entry_data.data_size + 1); memcpy(clean_result, entry_data.bytes, entry_data.data_size); caml_clean_result = caml_copy_string(clean_result); caml_stat_free(clean_result); goto string_finish; case MMDB_DATA_TYPE_UTF8_STRING: clean_result = strndup(entry_data.utf8_string, entry_data.data_size); caml_clean_result = caml_copy_string(clean_result); free(clean_result); goto string_finish; case MMDB_DATA_TYPE_FLOAT: Store_field(query_r, 0, polymorphic_variants.poly_float); Store_field(query_r, 1, caml_copy_double(entry_data.float_value)); goto finish; case MMDB_DATA_TYPE_BOOLEAN: Store_field(query_r, 0, polymorphic_variants.poly_bool); Store_field(query_r, 1, Val_true ? entry_data.boolean : Val_false); goto finish; case MMDB_DATA_TYPE_DOUBLE: Store_field(query_r, 0, polymorphic_variants.poly_float); Store_field(query_r, 1, caml_copy_double(entry_data.double_value)); goto finish; case MMDB_DATA_TYPE_UINT16: Store_field(query_r, 0, polymorphic_variants.poly_int); int_result = Val_long(entry_data.uint16); goto int_finish; case MMDB_DATA_TYPE_UINT32: Store_field(query_r, 0, polymorphic_variants.poly_int); int_result = Val_long(entry_data.uint32); goto int_finish; case MMDB_DATA_TYPE_UINT64: Store_field(query_r, 0, polymorphic_variants.poly_int); int_result = Val_long(entry_data.uint32); goto int_finish; // look at /usr/bin/sed -n 1380,1430p src/maxminddb.c case MMDB_DATA_TYPE_ARRAY: case MMDB_DATA_TYPE_MAP: caml_failwith("Can't return a Map or Array yet"); } string_finish: Store_field(query_r, 0, polymorphic_variants.poly_string); Store_field(query_r, 1, caml_clean_result); CAMLreturn(query_r); int_finish: Store_field(query_r, 1, int_result); CAMLreturn(query_r); finish: CAMLreturn(query_r); }
CAMLprim value wrapLALInferenceIFOData(value options) { CAMLparam1(options); CAMLlocal2(data, option); LALInferenceIFOData *d = NULL; ProcessParamsTable *ppt = NULL; /* Set srate. */ option = Field(options, 0); ppt = addCommandLineOption(ppt, "--srate", String_val(option)); /* Flow's */ option = Field(options, 1); if (caml_string_length(option) == 0) { /* Do nothing. */ } else { ppt = addCommandLineOption(ppt, "--flow", String_val(option)); } /* Fhigh's */ option = Field(options, 2); if (caml_string_length(option) == 0) { /* Do nothing. */ } else { ppt = addCommandLineOption(ppt, "--fhigh", String_val(option)); } option = Field(options, 3); ppt = addCommandLineOption(ppt, "--cache", String_val(option)); option = Field(options, 4); ppt = addCommandLineOption(ppt, "--IFO", String_val(option)); option = Field(options, 5); ppt = addCommandLineOption(ppt, "--dataseed", String_val(option)); option = Field(options, 6); ppt = addCommandLineOption(ppt, "--PSDstart", String_val(option)); option = Field(options, 7); ppt = addCommandLineOption(ppt, "--trigtime", String_val(option)); option = Field(options, 8); ppt = addCommandLineOption(ppt, "--PSDlength", String_val(option)); option = Field(options, 9); ppt = addCommandLineOption(ppt, "--seglen", String_val(option)); option = Field(options, 10); if (Is_block(option)) { ppt = addCommandLineOption(ppt, "--injXML", String_val(Field(option,0))); } d = LALInferenceReadData(ppt); LALInferenceInjectInspiralSignal(d,ppt); LALInferenceIFOData *dElt = d; while (dElt != NULL) { /*If two IFOs have the same sampling rate, they should have the same timeModelh*, freqModelh*, and modelParams variables to avoid excess computation in model waveform generation in the future*/ LALInferenceIFOData * dEltCompare=d; int foundIFOwithSameSampleRate=0; while (dEltCompare != NULL && dEltCompare!=dElt) { if(dEltCompare->timeData->deltaT == dElt->timeData->deltaT){ dElt->timeModelhPlus=dEltCompare->timeModelhPlus; dElt->freqModelhPlus=dEltCompare->freqModelhPlus; dElt->timeModelhCross=dEltCompare->timeModelhCross; dElt->freqModelhCross=dEltCompare->freqModelhCross; dElt->modelParams=dEltCompare->modelParams; foundIFOwithSameSampleRate=1; break; } dEltCompare = dEltCompare->next; } if(!foundIFOwithSameSampleRate){ dElt->timeModelhPlus = XLALCreateREAL8TimeSeries("timeModelhPlus", &(dElt->timeData->epoch), 0.0, dElt->timeData->deltaT, &lalDimensionlessUnit, dElt->timeData->data->length); dElt->timeModelhCross = XLALCreateREAL8TimeSeries("timeModelhCross", &(dElt->timeData->epoch), 0.0, dElt->timeData->deltaT, &lalDimensionlessUnit, dElt->timeData->data->length); dElt->freqModelhPlus = XLALCreateCOMPLEX16FrequencySeries("freqModelhPlus", &(dElt->freqData->epoch), 0.0, dElt->freqData->deltaF, &lalDimensionlessUnit, dElt->freqData->data->length); dElt->freqModelhCross = XLALCreateCOMPLEX16FrequencySeries("freqModelhCross", &(dElt->freqData->epoch), 0.0, dElt->freqData->deltaF, &lalDimensionlessUnit, dElt->freqData->data->length); dElt->modelParams = calloc(1, sizeof(LALInferenceVariables)); } dElt = dElt->next; } deletePPT(ppt); data = alloc_ifo_data(d); CAMLreturn(data); }
static void extern_rec(value v) { struct code_fragment * cf; struct extern_item * sp; sp = extern_stack; while(1) { if (Is_long(v)) { intnat n = Long_val(v); if (n >= 0 && n < 0x40) { Write(PREFIX_SMALL_INT + n); } else if (n >= -(1 << 7) && n < (1 << 7)) { writecode8(CODE_INT8, n); } else if (n >= -(1 << 15) && n < (1 << 15)) { writecode16(CODE_INT16, n); #ifdef ARCH_SIXTYFOUR } else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) { writecode64(CODE_INT64, n); #endif } else writecode32(CODE_INT32, n); goto next_item; } if (Is_in_value_area(v)) { header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); mlsize_t sz = Wosize_hd(hd); if (tag == Forward_tag) { value f = Forward_val (v); if (Is_block (f) && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ v = f; continue; } } /* Atoms are treated specially for two reasons: they are not allocated in the externed block, and they are automatically shared. */ if (sz == 0) { if (tag < 16) { Write(PREFIX_SMALL_BLOCK + tag); } else { writecode32(CODE_BLOCK32, hd); } goto next_item; } /* Check if already seen */ if (Color_hd(hd) == Caml_blue) { uintnat d = obj_counter - (uintnat) Field(v, 0); if (d < 0x100) { writecode8(CODE_SHARED8, d); } else if (d < 0x10000) { writecode16(CODE_SHARED16, d); } else { writecode32(CODE_SHARED32, d); } goto next_item; } /* Output the contents of the object */ switch(tag) { case String_tag: { mlsize_t len = caml_string_length(v); if (len < 0x20) { Write(PREFIX_SMALL_STRING + len); } else if (len < 0x100) { writecode8(CODE_STRING8, len); } else { writecode32(CODE_STRING32, len); } writeblock(String_val(v), len); size_32 += 1 + (len + 4) / 4; size_64 += 1 + (len + 8) / 8; extern_record_location(v); break; } case Double_tag: { if (sizeof(double) != 8) extern_invalid_argument("output_value: non-standard floats"); Write(CODE_DOUBLE_NATIVE); writeblock_float8((double *) v, 1); size_32 += 1 + 2; size_64 += 1 + 1; extern_record_location(v); break; } case Double_array_tag: { mlsize_t nfloats; if (sizeof(double) != 8) extern_invalid_argument("output_value: non-standard floats"); nfloats = Wosize_val(v) / Double_wosize; if (nfloats < 0x100) { writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats); } else { writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats); } writeblock_float8((double *) v, nfloats); size_32 += 1 + nfloats * 2; size_64 += 1 + nfloats; extern_record_location(v); break; } case Abstract_tag: extern_invalid_argument("output_value: abstract value (Abstract)"); break; case Infix_tag: writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd)); extern_rec(v - Infix_offset_hd(hd)); break; case Custom_tag: { uintnat sz_32, sz_64; char * ident = Custom_ops_val(v)->identifier; void (*serialize)(value v, uintnat * wsize_32, uintnat * wsize_64) = Custom_ops_val(v)->serialize; if (serialize == NULL) extern_invalid_argument("output_value: abstract value (Custom)"); Write(CODE_CUSTOM); writeblock(ident, strlen(ident) + 1); Custom_ops_val(v)->serialize(v, &sz_32, &sz_64); size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */ size_64 += 2 + ((sz_64 + 7) >> 3); extern_record_location(v); break; } default: { value field0; if (tag < 16 && sz < 8) { Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); #ifdef ARCH_SIXTYFOUR } else if (hd >= ((uintnat)1 << 32)) { writecode64(CODE_BLOCK64, Whitehd_hd (hd)); #endif } else { writecode32(CODE_BLOCK32, Whitehd_hd (hd)); } size_32 += 1 + sz; size_64 += 1 + sz; field0 = Field(v, 0); extern_record_location(v); /* Remember that we still have to serialize fields 1 ... sz - 1 */ if (sz > 1) { sp++; if (sp >= extern_stack_limit) sp = extern_resize_stack(sp); sp->v = &Field(v,1); sp->count = sz-1; } /* Continue serialization with the first field */ v = field0; continue; } } } else if ((cf = extern_find_code((char *) v)) != NULL) { if (!extern_closures) extern_invalid_argument("output_value: functional value"); writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start); writeblock((char *) cf->digest, 16); } else { extern_invalid_argument("output_value: abstract value (outside heap)"); } next_item: /* Pop one more item to marshal, if any */ if (sp == extern_stack) { /* We are done. Cleanup the stack and leave the function */ extern_free_stack(); return; } v = *((sp->v)++); if (--(sp->count) == 0) sp--; }
static void extern_rec_r(CAML_R, value v) { struct code_fragment * cf; struct extern_item * sp; sp = extern_stack; while(1) { //?????DUMP("QQQ 0x%lx, or %li ", v, v); if (Is_long(v)) { intnat n = Long_val(v); if (n >= 0 && n < 0x40) { Write(PREFIX_SMALL_INT + n); } else if (n >= -(1 << 7) && n < (1 << 7)) { writecode8_r(ctx, CODE_INT8, n); } else if (n >= -(1 << 15) && n < (1 << 15)) { writecode16_r(ctx, CODE_INT16, n); #ifdef ARCH_SIXTYFOUR } else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) { writecode64_r(ctx, CODE_INT64, n); #endif } else writecode32_r(ctx, CODE_INT32, n); goto next_item; } if (Is_in_value_area(v)) { header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); mlsize_t sz = Wosize_hd(hd); //DUMP("dumping %p, tag %i, size %i", (void*)v, (int)tag, (int)sz); // !!!!!!!!!!!!!!! if (tag == Forward_tag) { value f = Forward_val (v); if (Is_block (f) && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ v = f; continue; } } /* Atoms are treated specially for two reasons: they are not allocated in the externed block, and they are automatically shared. */ if (sz == 0) { if (tag < 16) { Write(PREFIX_SMALL_BLOCK + tag); } else { writecode32_r(ctx, CODE_BLOCK32, hd); } goto next_item; } /* Check if already seen */ if (Color_hd(hd) == Caml_blue) { uintnat d = obj_counter - (uintnat) Field(v, 0); if (d < 0x100) { writecode8_r(ctx, CODE_SHARED8, d); } else if (d < 0x10000) { writecode16_r(ctx, CODE_SHARED16, d); } else { writecode32_r(ctx, CODE_SHARED32, d); } goto next_item; } /* Output the contents of the object */ switch(tag) { case String_tag: { mlsize_t len = caml_string_length(v); if (len < 0x20) { Write(PREFIX_SMALL_STRING + len); } else if (len < 0x100) { writecode8_r(ctx, CODE_STRING8, len); } else { writecode32_r(ctx, CODE_STRING32, len); } writeblock_r(ctx, String_val(v), len); size_32 += 1 + (len + 4) / 4; size_64 += 1 + (len + 8) / 8; extern_record_location_r(ctx, v); break; } case Double_tag: { if (sizeof(double) != 8) extern_invalid_argument_r(ctx, "output_value: non-standard floats"); Write(CODE_DOUBLE_NATIVE); writeblock_float8((double *) v, 1); size_32 += 1 + 2; size_64 += 1 + 1; extern_record_location_r(ctx,v); break; } case Double_array_tag: { mlsize_t nfloats; if (sizeof(double) != 8) extern_invalid_argument_r(ctx, "output_value: non-standard floats"); nfloats = Wosize_val(v) / Double_wosize; if (nfloats < 0x100) { writecode8_r(ctx, CODE_DOUBLE_ARRAY8_NATIVE, nfloats); } else { writecode32_r(ctx, CODE_DOUBLE_ARRAY32_NATIVE, nfloats); } writeblock_float8((double *) v, nfloats); size_32 += 1 + nfloats * 2; size_64 += 1 + nfloats; extern_record_location_r(ctx, v); break; } case Abstract_tag: extern_invalid_argument_r(ctx, "output_value: abstract value (Abstract)"); break; case Infix_tag: writecode32_r(ctx,CODE_INFIXPOINTER, Infix_offset_hd(hd)); extern_rec_r(ctx, v - Infix_offset_hd(hd)); break; case Custom_tag: { uintnat sz_32, sz_64; char * ident = Custom_ops_val(v)->identifier; void (*serialize)(value v, uintnat * wsize_32, uintnat * wsize_64); //printf("[object at %p, which is a %s custom: BEGIN\n", (void*)v, Custom_ops_val(v)->identifier); if(extern_cross_context){ //printf("About the object at %p, which is a %s custom: USING a cross-context serializer\n", (void*)v, Custom_ops_val(v)->identifier); serialize = Custom_ops_val(v)->cross_context_serialize; } else{ //printf("About the object at %p, which is a %s custom: NOT using a cross-context serializer\n", (void*)v, Custom_ops_val(v)->identifier); serialize = Custom_ops_val(v)->serialize; } //printf("Still alive 100\n"); if (serialize == NULL){ ////// //struct custom_operations *o = Custom_ops_val(v); //printf("About the object at %p, which is a %s custom\n", (void*)v, Custom_ops_val(v)->identifier); volatile int a = 1; a /= 0; /////////// extern_invalid_argument_r(ctx, "output_value: abstract value (Custom)"); } //printf("Still alive 200\n"); Write(CODE_CUSTOM); //printf("Still alive 300\n"); writeblock_r(ctx, ident, strlen(ident) + 1); //printf("Still alive 400\n"); serialize(v, &sz_32, &sz_64); //printf("Still alive 500\n"); size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */ size_64 += 2 + ((sz_64 + 7) >> 3); //printf("Still alive 600\n"); extern_record_location_r(ctx,v); // This temporarily breaks the object, by replacing it with a forwarding pointer //printf("object at %p, which is a custom: END\n", (void*)v); break; } default: { value field0; if (tag < 16 && sz < 8) { Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); #ifdef ARCH_SIXTYFOUR } else if (hd >= ((uintnat)1 << 32)) { writecode64_r(ctx, CODE_BLOCK64, Whitehd_hd (hd)); #endif } else { writecode32_r(ctx, CODE_BLOCK32, Whitehd_hd (hd)); } size_32 += 1 + sz; size_64 += 1 + sz; field0 = Field(v, 0); extern_record_location_r(ctx, v); /* Remember that we still have to serialize fields 1 ... sz - 1 */ if (sz > 1) { sp++; if (sp >= extern_stack_limit) sp = extern_resize_stack_r(ctx, sp); sp->v = &Field(v,1); sp->count = sz-1; } /* Continue serialization with the first field */ v = field0; continue; } } } else if ((cf = extern_find_code_r(ctx, (char *) v)) != NULL) { if (!extern_closures){ extern_invalid_argument_r(ctx, "output_value: functional value"); // FIXME: this is the correct version. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! //DUMP("output_value: functional value"); {volatile int a = 1; a /= 0;} } //fprintf(stderr, "ZZZZ dumping a code pointer: BEGIN\n"); //DUMP("dumping a code pointer 0x%lx, or %li; code start is at %p", v, v, cf->code_start); writecode32_r(ctx, CODE_CODEPOINTER, (char *) v - cf->code_start); writeblock_r(ctx, (char *) cf->digest, 16); //dump_digest(cf->digest); //fprintf(stderr, "ZZZZ dumping a code pointer: END\n"); } else { if(extern_cross_context){ fprintf(stderr, "ZZZZ working on the external pointer: %p, which is to say %li [cf is %p]\n", (void*)v, (long)v, cf); //fprintf(stderr, "ZZZZ I'm doing a horrible, horrible thing: serializing the pointer as a tagged 0.\n"); DUMP("about to crash in the strange case I'm debugging"); /* DUMP("the object is 0x%lx, or %li ", v, v); */ /* DUMP("probably crashing now"); */ /* DUMP("tag is %i", (int)Tag_val(v)); */ /* DUMP("size is %i", (int)Wosize_val(v)); */ //volatile int a = 1; a /= 0; //extern_rec_r(ctx, Val_int(0)); /* fprintf(stderr, "ZZZZ [This is probably wrong: I'm marshalling an out-of-heap pointer as an int64]\n"); */ /* writecode64_r(ctx, CODE_INT64, (v << 1) | 1); */ extern_invalid_argument_r(ctx, "output_value: abstract value (outside heap) [FIXME: implement]"); } else extern_invalid_argument_r(ctx, "output_value: abstract value (outside heap)"); } next_item: /* Pop one more item to marshal, if any */ if (sp == extern_stack) { /* We are done. Cleanup the stack and leave the function */ extern_free_stack_r(ctx); return; } v = *((sp->v)++); if (--(sp->count) == 0) sp--; }
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); }
extern "C" value ml_IGUIFont_getDimension(value v_font, value v_text) { int text_size = caml_string_length(v_text); wchar_t text[2 * (text_size + 1)]; mbstowcs(text, String_val(v_text), 2 * text_size); return copy_dimension2d_u32(((IGUIFont*) v_font)->getDimension(text)); }
static intnat compare_val(value v1, value v2, int total) { struct compare_item * sp; tag_t t1, t2; if (!compare_stack) compare_init_stack(); sp = compare_stack; while (1) { if (v1 == v2 && total) goto next_item; if (Is_long(v1)) { if (v1 == v2) goto next_item; if (Is_long(v2)) return Long_val(v1) - Long_val(v2); /* Subtraction above cannot overflow and cannot result in UNORDERED */ switch (Tag_val(v2)) { case Forward_tag: v2 = Forward_val(v2); continue; case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v2)->compare_ext; if (compare == NULL) break; /* for backward compatibility */ caml_compare_unordered = 0; res = compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; goto next_item; } default: /*fallthrough*/; } return LESS; /* v1 long < v2 block */ } if (Is_long(v2)) { switch (Tag_val(v1)) { case Forward_tag: v1 = Forward_val(v1); continue; case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare_ext; if (compare == NULL) break; /* for backward compatibility */ caml_compare_unordered = 0; res = compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; goto next_item; } default: /*fallthrough*/; } return GREATER; /* v1 block > v2 long */ } t1 = Tag_val(v1); t2 = Tag_val(v2); if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; } if (t2 == Forward_tag) { v2 = Forward_val (v2); continue; } if (t1 != t2) return (intnat)t1 - (intnat)t2; switch(t1) { case String_tag: { mlsize_t len1, len2; int res; if (v1 == v2) break; len1 = caml_string_length(v1); len2 = caml_string_length(v2); res = memcmp(String_val(v1), String_val(v2), len1 <= len2 ? len1 : len2); if (res < 0) return LESS; if (res > 0) return GREATER; if (len1 != len2) return len1 - len2; break; } case Double_tag: { double d1 = Double_val(v1); double d2 = Double_val(v2); if (d1 < d2) return LESS; if (d1 > d2) return GREATER; if (d1 != d2) { if (! total) return UNORDERED; /* One or both of d1 and d2 is NaN. Order according to the convention NaN = NaN and NaN < f for all other floats f. */ if (d1 == d1) return GREATER; /* d1 is not NaN, d2 is NaN */ if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */ /* d1 and d2 are both NaN, thus equal: continue comparison */ } break; } case Double_array_tag: { mlsize_t sz1 = Wosize_val(v1) / Double_wosize; mlsize_t sz2 = Wosize_val(v2) / Double_wosize; mlsize_t i; if (sz1 != sz2) return sz1 - sz2; for (i = 0; i < sz1; i++) { double d1 = Double_field(v1, i); double d2 = Double_field(v2, i); if (d1 < d2) return LESS; if (d1 > d2) return GREATER; if (d1 != d2) { if (! total) return UNORDERED; /* See comment for Double_tag case */ if (d1 == d1) return GREATER; if (d2 == d2) return LESS; } } break; } case Abstract_tag: compare_free_stack(); caml_invalid_argument("equal: abstract value"); case Closure_tag: case Infix_tag: compare_free_stack(); caml_invalid_argument("equal: functional value"); case Object_tag: { intnat oid1 = Oid_val(v1); intnat oid2 = Oid_val(v2); if (oid1 != oid2) return oid1 - oid2; break; } case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare; /* Hardening against comparisons between different types */ if (compare != Custom_ops_val(v2)->compare) { return strcmp(Custom_ops_val(v1)->identifier, Custom_ops_val(v2)->identifier) < 0 ? LESS : GREATER; } if (compare == NULL) { compare_free_stack(); caml_invalid_argument("equal: abstract value"); } caml_compare_unordered = 0; res = compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; break; } default: { mlsize_t sz1 = Wosize_val(v1); mlsize_t sz2 = Wosize_val(v2); /* Compare sizes first for speed */ if (sz1 != sz2) return sz1 - sz2; if (sz1 == 0) break; /* Remember that we still have to compare fields 1 ... sz - 1 */ if (sz1 > 1) { sp++; if (sp >= compare_stack_limit) sp = compare_resize_stack(sp); sp->v1 = Op_val(v1) + 1; sp->v2 = Op_val(v2) + 1; sp->count = sz1 - 1; } /* Continue comparison with first field */ v1 = Field(v1, 0); v2 = Field(v2, 0); continue; } } next_item: /* Pop one more item to compare, if any */ if (sp == compare_stack) return EQUAL; /* we're done */ v1 = *((sp->v1)++); v2 = *((sp->v2)++); if (--(sp->count) == 0) sp--; } }
CAMLprim value ml_text_recode_string(value enc_src, value enc_dst, value str) { CAMLparam3(str, enc_src, enc_dst); CAMLlocal1(result); iconv_t cd = iconv_open(String_val(enc_dst), String_val(enc_src)); if (cd == (iconv_t)-1) caml_failwith("Encoding.recode_string: invalid encoding"); /* Length of the output buffer. It is initialised to the length of the input string, which should be a good approximation: */ size_t len = caml_string_length(str); /* Pointer to the beginning of the output buffer. The +1 is for the NULL terminating byte. */ char *dst_buffer = malloc(len + 1); if (dst_buffer == NULL) caml_failwith("Encoding.recode_string: out of memory"); /* iconv arguments */ char *src_bytes = String_val(str); char *dst_bytes = dst_buffer; size_t src_remaining = len; size_t dst_remaining = len; while (src_remaining) { size_t count = iconv (cd, &src_bytes, &src_remaining, &dst_bytes, &dst_remaining); if (count == (size_t) -1) { switch (errno) { case EILSEQ: free(dst_buffer); iconv_close(cd); caml_failwith("Encoding.recode_string: invalid multibyte sequence found in the input"); case EINVAL: free(dst_buffer); iconv_close(cd); caml_failwith("Encoding.recode_string: incomplete multibyte sequence found in the input"); case E2BIG: { /* Ouput offest relative to the beginning of the destination buffer: */ size_t offset = dst_bytes - dst_buffer; /* Try with a buffer 2 times bigger: */ len *= 2; dst_buffer = realloc(dst_buffer, len + 1); if (dst_buffer == NULL) caml_failwith("Encoding.recode_string: out of memory"); dst_bytes = dst_buffer + offset; dst_remaining += len; break; } default: free(dst_buffer); iconv_close(cd); caml_failwith("Encoding.recode_string: unknown error"); } } }; *dst_bytes = 0; result = caml_alloc_string(dst_bytes - dst_buffer); memcpy(String_val(result), dst_buffer, dst_bytes - dst_buffer); /* Clean-up */ free(dst_buffer); iconv_close(cd); CAMLreturn(result); }
CAMLprim value caml_string_get(value str, value index) { intnat idx = Long_val(index); if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error(); return Val_int(Byte_u(str, idx)); }
value caml_gr_draw_string(value str) { caml_gr_check_open(); caml_gr_draw_text(String_val(str), caml_string_length(str)); return Val_unit; }