2016-02-18 07:11:59 -08:00
|
|
|
/**************************************************************************/
|
|
|
|
/* */
|
|
|
|
/* OCaml */
|
|
|
|
/* */
|
|
|
|
/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */
|
|
|
|
/* */
|
|
|
|
/* Copyright 1996 Institut National de Recherche en Informatique et */
|
|
|
|
/* en Automatique. */
|
|
|
|
/* */
|
|
|
|
/* All rights reserved. This file is distributed under the terms of */
|
|
|
|
/* the GNU Lesser General Public License version 2.1, with the */
|
|
|
|
/* special exception on linking described in the file LICENSE. */
|
|
|
|
/* */
|
|
|
|
/**************************************************************************/
|
1995-08-09 08:06:35 -07:00
|
|
|
|
2016-07-04 10:00:57 -07:00
|
|
|
#define CAML_INTERNALS
|
|
|
|
|
2018-04-26 09:22:21 -07:00
|
|
|
#if _MSC_VER >= 1400 && _MSC_VER < 1700
|
|
|
|
/* Microsoft introduced a regression in Visual Studio 2005 (technically it's
|
|
|
|
not present in the Windows Server 2003 SDK which has a pre-release version)
|
|
|
|
and the abort function ceased to be declared __declspec(noreturn). This was
|
|
|
|
fixed in Visual Studio 2012. Trick stdlib.h into not defining abort (this
|
|
|
|
means exit and _exit are not defined either, but they aren't required). */
|
|
|
|
#define _CRT_TERMINATE_DEFINED
|
|
|
|
__declspec(noreturn) void __cdecl abort(void);
|
|
|
|
#endif
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
#include <stdio.h>
|
2014-04-15 10:09:13 -07:00
|
|
|
#include <string.h>
|
2017-02-27 08:32:44 -08:00
|
|
|
#include <stdarg.h>
|
2014-12-27 06:41:49 -08:00
|
|
|
#include "caml/config.h"
|
|
|
|
#include "caml/misc.h"
|
|
|
|
#include "caml/memory.h"
|
2017-06-23 08:32:50 -07:00
|
|
|
#include "caml/osdeps.h"
|
2015-11-20 08:54:26 -08:00
|
|
|
#include "caml/version.h"
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2015-07-17 07:31:05 -07:00
|
|
|
caml_timing_hook caml_major_slice_begin_hook = NULL;
|
|
|
|
caml_timing_hook caml_major_slice_end_hook = NULL;
|
|
|
|
caml_timing_hook caml_minor_gc_begin_hook = NULL;
|
|
|
|
caml_timing_hook caml_minor_gc_end_hook = NULL;
|
|
|
|
caml_timing_hook caml_finalise_begin_hook = NULL;
|
|
|
|
caml_timing_hook caml_finalise_end_hook = NULL;
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
#ifdef DEBUG
|
|
|
|
|
2018-04-26 08:30:10 -07:00
|
|
|
void caml_failed_assert (char * expr, char_os * file_os, int line)
|
1995-05-04 03:15:53 -07:00
|
|
|
{
|
2018-04-26 08:30:10 -07:00
|
|
|
char* file = caml_stat_strdup_of_os(file_os);
|
1999-11-08 09:07:05 -08:00
|
|
|
fprintf (stderr, "file %s; line %d ### Assertion failed: %s\n",
|
|
|
|
file, line, expr);
|
|
|
|
fflush (stderr);
|
2018-04-26 08:30:10 -07:00
|
|
|
caml_stat_free(file);
|
2016-12-06 08:18:04 -08:00
|
|
|
abort();
|
1995-05-04 03:15:53 -07:00
|
|
|
}
|
|
|
|
|
2018-04-12 07:13:45 -07:00
|
|
|
void caml_set_fields (value v, uintnat start, uintnat filler)
|
2008-02-29 04:56:15 -08:00
|
|
|
{
|
|
|
|
mlsize_t i;
|
2014-12-16 11:36:35 -08:00
|
|
|
for (i = start; i < Wosize_val (v); i++){
|
|
|
|
Field (v, i) = (value) filler;
|
2008-02-29 04:56:15 -08:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2004-01-08 14:28:48 -08:00
|
|
|
#endif /* DEBUG */
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2005-09-22 07:21:50 -07:00
|
|
|
uintnat caml_verb_gc = 0;
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2017-02-27 08:32:44 -08:00
|
|
|
void caml_gc_message (int level, char *msg, ...)
|
1995-05-04 03:15:53 -07:00
|
|
|
{
|
2015-11-20 08:54:26 -08:00
|
|
|
if ((caml_verb_gc & level) != 0){
|
2017-02-27 08:32:44 -08:00
|
|
|
va_list ap;
|
|
|
|
va_start(ap, msg);
|
|
|
|
vfprintf (stderr, msg, ap);
|
|
|
|
va_end(ap);
|
1995-05-04 03:15:53 -07:00
|
|
|
fflush (stderr);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2019-05-30 16:11:12 -07:00
|
|
|
void (*caml_fatal_error_hook) (char *msg, va_list args) = NULL;
|
|
|
|
|
2018-05-17 23:28:19 -07:00
|
|
|
CAMLexport void caml_fatal_error (char *msg, ...)
|
2001-08-28 07:47:48 -07:00
|
|
|
{
|
2018-05-17 23:28:19 -07:00
|
|
|
va_list ap;
|
|
|
|
va_start(ap, msg);
|
2019-05-30 16:11:12 -07:00
|
|
|
if(caml_fatal_error_hook != NULL) {
|
|
|
|
caml_fatal_error_hook(msg, ap);
|
|
|
|
} else {
|
|
|
|
fprintf (stderr, "Fatal error: ");
|
|
|
|
vfprintf (stderr, msg, ap);
|
|
|
|
fprintf (stderr, "\n");
|
|
|
|
}
|
2018-05-17 23:28:19 -07:00
|
|
|
va_end(ap);
|
2019-04-19 12:17:19 -07:00
|
|
|
abort();
|
2001-08-28 07:47:48 -07:00
|
|
|
}
|
|
|
|
|
2003-12-29 14:15:02 -08:00
|
|
|
void caml_ext_table_init(struct ext_table * tbl, int init_capa)
|
2001-08-28 07:47:48 -07:00
|
|
|
{
|
|
|
|
tbl->size = 0;
|
|
|
|
tbl->capacity = init_capa;
|
2003-12-31 06:20:40 -08:00
|
|
|
tbl->contents = caml_stat_alloc(sizeof(void *) * init_capa);
|
2001-08-28 07:47:48 -07:00
|
|
|
}
|
|
|
|
|
2016-01-05 10:10:21 -08:00
|
|
|
int caml_ext_table_add(struct ext_table * tbl, caml_stat_block data)
|
2001-08-28 07:47:48 -07:00
|
|
|
{
|
|
|
|
int res;
|
|
|
|
if (tbl->size >= tbl->capacity) {
|
|
|
|
tbl->capacity *= 2;
|
|
|
|
tbl->contents =
|
2003-12-31 06:20:40 -08:00
|
|
|
caml_stat_resize(tbl->contents, sizeof(void *) * tbl->capacity);
|
2001-08-28 07:47:48 -07:00
|
|
|
}
|
|
|
|
res = tbl->size;
|
|
|
|
tbl->contents[res] = data;
|
|
|
|
tbl->size++;
|
|
|
|
return res;
|
|
|
|
}
|
|
|
|
|
2016-01-05 10:10:21 -08:00
|
|
|
void caml_ext_table_remove(struct ext_table * tbl, caml_stat_block data)
|
2015-02-08 06:10:08 -08:00
|
|
|
{
|
|
|
|
int i;
|
|
|
|
for (i = 0; i < tbl->size; i++) {
|
|
|
|
if (tbl->contents[i] == data) {
|
|
|
|
caml_stat_free(tbl->contents[i]);
|
|
|
|
memmove(&tbl->contents[i], &tbl->contents[i + 1],
|
|
|
|
(tbl->size - i - 1) * sizeof(void *));
|
|
|
|
tbl->size--;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2016-06-27 00:38:32 -07:00
|
|
|
void caml_ext_table_clear(struct ext_table * tbl, int free_entries)
|
2001-08-28 07:47:48 -07:00
|
|
|
{
|
|
|
|
int i;
|
2016-06-27 00:38:32 -07:00
|
|
|
if (free_entries) {
|
2003-12-31 06:20:40 -08:00
|
|
|
for (i = 0; i < tbl->size; i++) caml_stat_free(tbl->contents[i]);
|
2016-06-27 00:38:32 -07:00
|
|
|
}
|
|
|
|
tbl->size = 0;
|
|
|
|
}
|
|
|
|
|
|
|
|
void caml_ext_table_free(struct ext_table * tbl, int free_entries)
|
|
|
|
{
|
|
|
|
caml_ext_table_clear(tbl, free_entries);
|
2003-12-31 06:20:40 -08:00
|
|
|
caml_stat_free(tbl->contents);
|
2001-08-28 07:47:48 -07:00
|
|
|
}
|
2014-04-15 10:09:13 -07:00
|
|
|
|
2014-05-28 16:11:47 -07:00
|
|
|
/* Integer arithmetic with overflow detection */
|
2017-02-25 08:56:58 -08:00
|
|
|
|
|
|
|
#if ! (__GNUC__ >= 5 || Caml_has_builtin(__builtin_mul_overflow))
|
|
|
|
CAMLexport int caml_umul_overflow(uintnat a, uintnat b, uintnat * res)
|
|
|
|
{
|
|
|
|
#define HALF_SIZE (sizeof(uintnat) * 4)
|
|
|
|
#define HALF_MASK (((uintnat)1 << HALF_SIZE) - 1)
|
|
|
|
#define LOW_HALF(x) ((x) & HALF_MASK)
|
|
|
|
#define HIGH_HALF(x) ((x) >> HALF_SIZE)
|
|
|
|
/* Cut in half words */
|
|
|
|
uintnat al = LOW_HALF(a);
|
|
|
|
uintnat ah = HIGH_HALF(a);
|
|
|
|
uintnat bl = LOW_HALF(b);
|
|
|
|
uintnat bh = HIGH_HALF(b);
|
|
|
|
/* Exact product is:
|
|
|
|
al * bl
|
|
|
|
+ ah * bl << HALF_SIZE
|
|
|
|
+ al * bh << HALF_SIZE
|
|
|
|
+ ah * bh << 2*HALF_SIZE
|
|
|
|
Overflow occurs if:
|
|
|
|
ah * bh is not 0, i.e. ah != 0 and bh != 0
|
|
|
|
OR ah * bl has high half != 0
|
|
|
|
OR al * bh has high half != 0
|
|
|
|
OR the sum al * bl + LOW_HALF(ah * bl) << HALF_SIZE
|
|
|
|
+ LOW_HALF(al * bh) << HALF_SIZE overflows.
|
|
|
|
This sum is equal to p = (a * b) modulo word size. */
|
|
|
|
uintnat p = a * b;
|
|
|
|
uintnat p1 = al * bh;
|
|
|
|
uintnat p2 = ah * bl;
|
|
|
|
*res = p;
|
|
|
|
if (ah == 0 && bh == 0) return 0;
|
|
|
|
if (ah != 0 && bh != 0) return 1;
|
|
|
|
if (HIGH_HALF(p1) != 0 || HIGH_HALF(p2) != 0) return 1;
|
|
|
|
p1 <<= HALF_SIZE;
|
|
|
|
p2 <<= HALF_SIZE;
|
|
|
|
p1 += p2;
|
|
|
|
if (p < p1 || p1 < p2) return 1; /* overflow in sums */
|
|
|
|
return 0;
|
|
|
|
#undef HALF_SIZE
|
|
|
|
#undef HALF_MASK
|
|
|
|
#undef LOW_HALF
|
|
|
|
#undef HIGH_HALF
|
|
|
|
}
|
|
|
|
#endif
|
|
|
|
|
2015-08-04 02:38:23 -07:00
|
|
|
/* Runtime warnings */
|
|
|
|
|
2015-11-30 01:18:10 -08:00
|
|
|
uintnat caml_runtime_warnings = 0;
|
2015-08-04 02:38:23 -07:00
|
|
|
static int caml_runtime_warnings_first = 1;
|
|
|
|
|
|
|
|
int caml_runtime_warnings_active(void)
|
|
|
|
{
|
|
|
|
if (!caml_runtime_warnings) return 0;
|
|
|
|
if (caml_runtime_warnings_first) {
|
2015-09-11 04:58:31 -07:00
|
|
|
fprintf(stderr, "[ocaml] (use Sys.enable_runtime_warnings to control "
|
|
|
|
"these warnings)\n");
|
2015-08-04 02:38:23 -07:00
|
|
|
caml_runtime_warnings_first = 0;
|
|
|
|
}
|
|
|
|
return 1;
|
|
|
|
}
|