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
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
/* 1. Allocation functions doing the same work as the macros in the
|
|
|
|
case where [Setup_for_gc] and [Restore_after_gc] are no-ops.
|
|
|
|
2. Convenience functions related to allocation.
|
|
|
|
*/
|
|
|
|
|
|
|
|
#include <string.h>
|
2014-12-27 06:41:49 -08:00
|
|
|
#include "caml/alloc.h"
|
|
|
|
#include "caml/custom.h"
|
|
|
|
#include "caml/major_gc.h"
|
|
|
|
#include "caml/memory.h"
|
|
|
|
#include "caml/mlvalues.h"
|
|
|
|
#include "caml/stacks.h"
|
2019-08-27 04:12:18 -07:00
|
|
|
#include "caml/signals.h"
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
#define Setup_for_gc
|
|
|
|
#define Restore_after_gc
|
|
|
|
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag)
|
1998-10-26 11:19:32 -08:00
|
|
|
{
|
|
|
|
value result;
|
|
|
|
mlsize_t i;
|
|
|
|
|
2017-03-10 08:29:21 -08:00
|
|
|
CAMLassert (tag < 256);
|
|
|
|
CAMLassert (tag != Infix_tag);
|
2017-05-04 23:22:28 -07:00
|
|
|
if (wosize <= Max_young_wosize){
|
|
|
|
if (wosize == 0){
|
|
|
|
result = Atom (tag);
|
|
|
|
}else{
|
|
|
|
Alloc_small (result, wosize, tag);
|
|
|
|
if (tag < No_scan_tag){
|
|
|
|
for (i = 0; i < wosize; i++) Field (result, i) = Val_unit;
|
|
|
|
}
|
1998-10-26 11:19:32 -08:00
|
|
|
}
|
|
|
|
}else{
|
2003-12-31 06:20:40 -08:00
|
|
|
result = caml_alloc_shr (wosize, tag);
|
2014-05-01 06:07:48 -07:00
|
|
|
if (tag < No_scan_tag){
|
|
|
|
for (i = 0; i < wosize; i++) Field (result, i) = Val_unit;
|
|
|
|
}
|
2019-10-09 11:18:44 -07:00
|
|
|
result = caml_check_urgent_gc (result);
|
1998-10-26 11:19:32 -08:00
|
|
|
}
|
|
|
|
return result;
|
|
|
|
}
|
|
|
|
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag)
|
1995-05-04 03:15:53 -07:00
|
|
|
{
|
|
|
|
value result;
|
1999-11-29 11:03:05 -08:00
|
|
|
|
2017-03-10 08:29:21 -08:00
|
|
|
CAMLassert (wosize > 0);
|
|
|
|
CAMLassert (wosize <= Max_young_wosize);
|
|
|
|
CAMLassert (tag < 256);
|
1995-05-04 03:15:53 -07:00
|
|
|
Alloc_small (result, wosize, tag);
|
|
|
|
return result;
|
|
|
|
}
|
|
|
|
|
2014-12-12 07:18:04 -08:00
|
|
|
/* [n] is a number of words (fields) */
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLexport value caml_alloc_tuple(mlsize_t n)
|
1995-05-04 03:15:53 -07:00
|
|
|
{
|
2003-12-29 14:15:02 -08:00
|
|
|
return caml_alloc(n, 0);
|
1995-05-04 03:15:53 -07:00
|
|
|
}
|
|
|
|
|
2014-12-12 07:18:04 -08:00
|
|
|
/* [len] is a number of bytes (chars) */
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLexport value caml_alloc_string (mlsize_t len)
|
1995-05-04 03:15:53 -07:00
|
|
|
{
|
|
|
|
value result;
|
|
|
|
mlsize_t offset_index;
|
|
|
|
mlsize_t wosize = (len + sizeof (value)) / sizeof (value);
|
|
|
|
|
|
|
|
if (wosize <= Max_young_wosize) {
|
|
|
|
Alloc_small (result, wosize, String_tag);
|
|
|
|
}else{
|
2003-12-31 06:20:40 -08:00
|
|
|
result = caml_alloc_shr (wosize, String_tag);
|
2019-10-09 11:18:44 -07:00
|
|
|
result = caml_check_urgent_gc (result);
|
1995-05-04 03:15:53 -07:00
|
|
|
}
|
|
|
|
Field (result, wosize - 1) = 0;
|
|
|
|
offset_index = Bsize_wsize (wosize) - 1;
|
|
|
|
Byte (result, offset_index) = offset_index - len;
|
|
|
|
return result;
|
|
|
|
}
|
|
|
|
|
2017-08-03 06:19:13 -07:00
|
|
|
/* [len] is a number of bytes (chars) */
|
|
|
|
CAMLexport value caml_alloc_initialized_string (mlsize_t len, const char *p)
|
|
|
|
{
|
|
|
|
value result = caml_alloc_string (len);
|
|
|
|
memcpy((char *)String_val(result), p, len);
|
|
|
|
return result;
|
|
|
|
}
|
|
|
|
|
2014-12-12 07:18:04 -08:00
|
|
|
/* [len] is a number of words.
|
|
|
|
[mem] and [max] are relative (without unit).
|
|
|
|
*/
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLexport value caml_alloc_final (mlsize_t len, final_fun fun,
|
|
|
|
mlsize_t mem, mlsize_t max)
|
2000-02-10 06:04:59 -08:00
|
|
|
{
|
2004-01-01 08:42:43 -08:00
|
|
|
return caml_alloc_custom(caml_final_custom_operations(fun),
|
|
|
|
len * sizeof(value), mem, max);
|
2000-02-10 06:04:59 -08:00
|
|
|
}
|
|
|
|
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLexport value caml_copy_string(char const *s)
|
1995-05-04 03:15:53 -07:00
|
|
|
{
|
Cleaning up the C code (#1812)
Running Clang 6.0 and GCC 8 with full warnings on suggests a few simple improvements and clean-ups to the C code of OCaml. This commit implements them.
* Remove old-style, unprototyped function declarations
It's `int f(void)`, not `int f()`. [-Wstrict-prototypes]
* Be more explicit about conversions involving `float` and `double`
byterun/bigarray.c, byterun/ints.c:
add explicit casts to clarify the intent
renamed float field of conversion union from `d` to `f`.
byterun/compact.c, byterun/gc_ctrl.c:
some local variables were of type `float` while all FP computations
here are done in double precision;
turned these variables into `double`.
[-Wdouble-promotion -Wfloat-conversion]
*Add explicit initialization of struct field `compare_ext`
[-Wmissing-field-initializers]
* Declare more functions "noreturn"
[-Wmissing-noreturn]
* Make CAMLassert compliant with ISO C
In `e1 ? e2 : e3`, expressions `e2` and `e3` must have the same type.
`e2` of type `void` and `e3` of type `int`, as in the original code,
is a GNU extension.
* Remove or conditionalize unused macros
Some macros were defined and never used.
Some other macros were always defined but conditionally used.
[-Wunused-macros]
* Replace some uses of `int` by more appropriate types like `intnat`
On a 64-bit platform, `int` is only 32 bits and may not represent correctly
the length of a string or the size of an OCaml heap block.
This commit replaces a number of uses of `int` by other types that
are 64-bit wide on 64-bit architectures, such as `intnat` or `uintnat`
or `size_t` or `mlsize_t`.
Sometimes an `intnat` was used as an `int` and is intended as a Boolean
(0 or 1); then it was replaced by an `int`.
There are many remaining cases where we assign a 64-bit quantity to a
32-bit `int` variable. Either I believe these cases are safe
(e.g. the 64-bit quantity is the difference between two pointers
within an I/O buffer, something that always fits in 32 bits), or
the code change was not obvious and too risky.
[-Wshorten-64-to-32]
* Put `inline` before return type
`static inline void f(void)` is cleaner than `static void inline f(void)`.
[-Wold-style-declaration]
* Unused assignment to unused parameter
Looks very useless. [-Wunused-but-set-parameter]
2018-06-07 03:55:09 -07:00
|
|
|
mlsize_t len;
|
1995-05-04 03:15:53 -07:00
|
|
|
value res;
|
|
|
|
|
|
|
|
len = strlen(s);
|
2017-08-03 06:19:13 -07:00
|
|
|
res = caml_alloc_initialized_string(len, s);
|
1995-05-04 03:15:53 -07:00
|
|
|
return res;
|
|
|
|
}
|
|
|
|
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLexport value caml_alloc_array(value (*funct)(char const *),
|
|
|
|
char const ** arr)
|
1995-05-04 03:15:53 -07:00
|
|
|
{
|
1999-11-29 11:03:05 -08:00
|
|
|
CAMLparam0 ();
|
1995-05-04 03:15:53 -07:00
|
|
|
mlsize_t nbr, n;
|
1999-11-29 11:03:05 -08:00
|
|
|
CAMLlocal2 (v, result);
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
nbr = 0;
|
|
|
|
while (arr[nbr] != 0) nbr++;
|
2017-05-04 23:22:28 -07:00
|
|
|
result = caml_alloc (nbr, 0);
|
|
|
|
for (n = 0; n < nbr; n++) {
|
|
|
|
/* The two statements below must be separate because of evaluation
|
|
|
|
order (don't take the address &Field(result, n) before
|
|
|
|
calling funct, which may cause a GC and move result). */
|
|
|
|
v = funct(arr[n]);
|
|
|
|
caml_modify(&Field(result, n), v);
|
1995-05-04 03:15:53 -07:00
|
|
|
}
|
2017-05-04 23:22:28 -07:00
|
|
|
CAMLreturn (result);
|
1995-05-04 03:15:53 -07:00
|
|
|
}
|
|
|
|
|
2016-04-05 13:07:38 -07:00
|
|
|
/* [len] is a number of floats */
|
2018-03-02 04:49:52 -08:00
|
|
|
value caml_alloc_float_array(mlsize_t len)
|
2016-04-05 13:07:38 -07:00
|
|
|
{
|
2017-08-31 06:25:15 -07:00
|
|
|
#ifdef FLAT_FLOAT_ARRAY
|
2016-04-05 13:07:38 -07:00
|
|
|
mlsize_t wosize = len * Double_wosize;
|
|
|
|
value result;
|
2017-03-03 02:40:19 -08:00
|
|
|
/* For consistency with [caml_make_vect], which can't tell whether it should
|
|
|
|
create a float array or not when the size is zero, the tag is set to
|
|
|
|
zero when the size is zero. */
|
2017-05-04 23:22:28 -07:00
|
|
|
if (wosize <= Max_young_wosize){
|
|
|
|
if (wosize == 0)
|
|
|
|
return Atom(0);
|
|
|
|
else
|
|
|
|
Alloc_small (result, wosize, Double_array_tag);
|
2016-04-05 13:07:38 -07:00
|
|
|
}else {
|
|
|
|
result = caml_alloc_shr (wosize, Double_array_tag);
|
2019-10-09 11:18:44 -07:00
|
|
|
result = caml_check_urgent_gc (result);
|
2016-04-05 13:07:38 -07:00
|
|
|
}
|
|
|
|
return result;
|
2017-08-31 06:25:15 -07:00
|
|
|
#else
|
|
|
|
return caml_alloc (len, 0);
|
|
|
|
#endif
|
2016-04-05 13:07:38 -07:00
|
|
|
}
|
|
|
|
|
|
|
|
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLexport value caml_copy_string_array(char const ** arr)
|
1995-05-04 03:15:53 -07:00
|
|
|
{
|
2003-12-29 14:15:02 -08:00
|
|
|
return caml_alloc_array(caml_copy_string, arr);
|
1995-05-04 03:15:53 -07:00
|
|
|
}
|
|
|
|
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLexport int caml_convert_flag_list(value list, int *flags)
|
1995-05-04 03:15:53 -07:00
|
|
|
{
|
|
|
|
int res;
|
|
|
|
res = 0;
|
1995-06-18 07:44:56 -07:00
|
|
|
while (list != Val_int(0)) {
|
|
|
|
res |= flags[Int_val(Field(list, 0))];
|
1995-05-04 03:15:53 -07:00
|
|
|
list = Field(list, 1);
|
|
|
|
}
|
|
|
|
return res;
|
|
|
|
}
|
1998-04-06 02:15:55 -07:00
|
|
|
|
|
|
|
/* For compiling let rec over values */
|
|
|
|
|
2014-12-12 07:18:04 -08:00
|
|
|
/* [size] is a [value] representing number of words (fields) */
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLprim value caml_alloc_dummy(value size)
|
1998-04-06 02:15:55 -07:00
|
|
|
{
|
2015-10-19 08:47:33 -07:00
|
|
|
mlsize_t wosize = Long_val(size);
|
2003-12-29 14:15:02 -08:00
|
|
|
return caml_alloc (wosize, 0);
|
1998-04-06 02:15:55 -07:00
|
|
|
}
|
|
|
|
|
2014-12-12 07:18:04 -08:00
|
|
|
/* [size] is a [value] representing number of words (fields) */
|
2014-11-17 04:21:49 -08:00
|
|
|
CAMLprim value caml_alloc_dummy_function(value size,value arity)
|
|
|
|
{
|
|
|
|
/* the arity argument is used by the js_of_ocaml runtime */
|
|
|
|
return caml_alloc_dummy(size);
|
|
|
|
}
|
|
|
|
|
2014-12-12 07:18:04 -08:00
|
|
|
/* [size] is a [value] representing number of floats. */
|
2007-02-09 05:31:15 -08:00
|
|
|
CAMLprim value caml_alloc_dummy_float (value size)
|
|
|
|
{
|
2015-10-19 08:47:33 -07:00
|
|
|
mlsize_t wosize = Long_val(size) * Double_wosize;
|
2007-02-09 05:31:15 -08:00
|
|
|
return caml_alloc (wosize, 0);
|
|
|
|
}
|
|
|
|
|
2019-06-04 02:30:15 -07:00
|
|
|
CAMLprim value caml_alloc_dummy_infix(value vsize, value voffset)
|
|
|
|
{
|
|
|
|
mlsize_t wosize = Long_val(vsize), offset = Long_val(voffset);
|
|
|
|
value v = caml_alloc(wosize, Closure_tag);
|
2020-06-17 07:03:51 -07:00
|
|
|
/* The following choice of closure info causes the GC to skip
|
|
|
|
the whole block contents. This is correct since the dummy
|
|
|
|
block contains no pointers into the heap. However, the block
|
|
|
|
cannot be marshaled or hashed, because not all closinfo fields
|
|
|
|
and infix header fields are correctly initialized. */
|
|
|
|
Closinfo_val(v) = Make_closinfo(0, wosize);
|
2019-06-04 02:30:15 -07:00
|
|
|
if (offset > 0) {
|
|
|
|
v += Bsize_wsize(offset);
|
|
|
|
Hd_val(v) = Make_header(offset, Infix_tag, Caml_white);
|
|
|
|
}
|
|
|
|
return v;
|
|
|
|
}
|
|
|
|
|
2003-12-29 14:15:02 -08:00
|
|
|
CAMLprim value caml_update_dummy(value dummy, value newval)
|
1998-04-06 02:15:55 -07:00
|
|
|
{
|
|
|
|
mlsize_t size, i;
|
2007-02-09 05:31:15 -08:00
|
|
|
tag_t tag;
|
|
|
|
|
|
|
|
tag = Tag_val (newval);
|
|
|
|
|
|
|
|
if (tag == Double_array_tag){
|
2019-06-04 02:30:15 -07:00
|
|
|
CAMLassert (Wosize_val(newval) == Wosize_val(dummy));
|
2019-06-05 01:31:05 -07:00
|
|
|
CAMLassert (Tag_val(dummy) != Infix_tag);
|
|
|
|
Tag_val(dummy) = Double_array_tag;
|
2007-02-09 05:31:15 -08:00
|
|
|
size = Wosize_val (newval) / Double_wosize;
|
2019-06-04 02:30:15 -07:00
|
|
|
for (i = 0; i < size; i++) {
|
2017-08-31 06:25:15 -07:00
|
|
|
Store_double_flat_field (dummy, i, Double_flat_field (newval, i));
|
2007-02-09 05:31:15 -08:00
|
|
|
}
|
2019-06-04 02:30:15 -07:00
|
|
|
} else if (tag == Infix_tag) {
|
|
|
|
value clos = newval - Infix_offset_hd(Hd_val(newval));
|
|
|
|
CAMLassert (Tag_val(clos) == Closure_tag);
|
|
|
|
CAMLassert (Tag_val(dummy) == Infix_tag);
|
|
|
|
CAMLassert (Infix_offset_val(dummy) == Infix_offset_val(newval));
|
|
|
|
dummy = dummy - Infix_offset_val(dummy);
|
|
|
|
size = Wosize_val(clos);
|
|
|
|
CAMLassert (size == Wosize_val(dummy));
|
2020-06-17 07:03:51 -07:00
|
|
|
/* It is safe to use [caml_modify] to copy code pointers
|
|
|
|
from [clos] to [dummy], because the value being overwritten is
|
|
|
|
an integer, and the new "value" is a pointer outside the minor
|
|
|
|
heap. */
|
2019-06-04 02:30:15 -07:00
|
|
|
for (i = 0; i < size; i++) {
|
|
|
|
caml_modify (&Field(dummy, i), Field(clos, i));
|
|
|
|
}
|
|
|
|
} else {
|
2019-06-04 03:42:49 -07:00
|
|
|
CAMLassert (tag < No_scan_tag);
|
2019-06-05 01:31:05 -07:00
|
|
|
CAMLassert (Tag_val(dummy) != Infix_tag);
|
2019-06-04 02:30:15 -07:00
|
|
|
Tag_val(dummy) = tag;
|
|
|
|
size = Wosize_val(newval);
|
|
|
|
CAMLassert (size == Wosize_val(dummy));
|
2020-06-17 07:03:51 -07:00
|
|
|
/* See comment above why this is safe even if [tag == Closure_tag]
|
|
|
|
and some of the "values" being copied are actually code pointers. */
|
2007-02-09 05:31:15 -08:00
|
|
|
for (i = 0; i < size; i++){
|
|
|
|
caml_modify (&Field(dummy, i), Field(newval, i));
|
|
|
|
}
|
|
|
|
}
|
1998-04-06 02:15:55 -07:00
|
|
|
return Val_unit;
|
|
|
|
}
|
2020-06-01 10:31:47 -07:00
|
|
|
|
|
|
|
CAMLexport value caml_alloc_some(value v)
|
|
|
|
{
|
|
|
|
CAMLparam1(v);
|
|
|
|
value some = caml_alloc_small(1, 0);
|
2020-08-03 02:44:49 -07:00
|
|
|
Field(some, 0) = v;
|
2020-06-01 10:31:47 -07:00
|
|
|
CAMLreturn(some);
|
|
|
|
}
|