Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

add -no-flat-float-array configure option

master
Damien Doligez 2017-08-31 15:25:15 +02:00 committed by Damien Doligez
parent cd3dbe79be
commit f086eda9c0
52 changed files with 905 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
.gitignore vendored
View File

@ -309,6 +309,10 @@
/testsuite/tests/tool-lexyacc/grammar.mli
/testsuite/tests/tool-lexyacc/grammar.ml
/testsuite/tests/typing-misc/false.flat-float
/testsuite/tests/typing-misc/true.flat-float
/testsuite/tests/typing-misc/pr6939.ml
/testsuite/tests/typing-multifile/a.ml
/testsuite/tests/typing-multifile/b.ml
/testsuite/tests/typing-multifile/c.ml
@ -318,6 +322,15 @@
/testsuite/tests/typing-multifile/g.ml
/testsuite/tests/typing-multifile/test
/testsuite/tests/typing-unboxed-types/false.flat-float
/testsuite/tests/typing-unboxed-types/true.flat-float
/testsuite/tests/typing-unboxed-types/test.ml.reference
/testsuite/tests/translprim/false.flat-float
/testsuite/tests/translprim/true.flat-float
/testsuite/tests/translprim/array_spec.ml.reference
/testsuite/tests/translprim/module_coercion.ml.reference
/testsuite/tests/unboxed-primitive-args/main.ml
/testsuite/tests/unboxed-primitive-args/stubs.c

6
Changes
View File

@ -106,6 +106,12 @@ Working version
to GPR#1250.)
(Mark Shinwell)
- GPR#1294: Add a configure-time option to remove the dynamic float array
optimization and add a floatarray type to let the user choose when to
flatten float arrays. Note that float-only records are unchanged: they
are still optimized by unboxing their fields.
(Damien Doligez, review by Alain Frisch and Mark Shinwell)
- GPR#1304: Mark registers clobbered by PLT stubs as destroyed across
allocations.
(Mark Shinwell, Xavier Clerc, report and initial debugging by

1
Makefile
View File

@ -355,6 +355,7 @@ utils/config.ml: utils/config.mlp config/Makefile
-e 's|%%WITH_PROFINFO%%|$(WITH_PROFINFO)|' \
-e 's|%%WITH_SPACETIME%%|$(WITH_SPACETIME)|' \
-e 's|%%WITH_SPACETIME_CALL_COUNTS%%|$(WITH_SPACETIME_CALL_COUNTS)|' \
-e 's|%%FLAT_FLOAT_ARRAY%%|$(FLAT_FLOAT_ARRAY)|' \
$< > $@
ifeq "$(UNIX_OR_WIN32)" "unix"

4
asmrun/spacetime_snapshot.c
View File

@ -258,7 +258,7 @@ static value take_snapshot(double time_override, int use_time_override)
CAMLassert(sizeof(double) == sizeof(value));
v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag);
Double_field(v_time, 0) = time;
Store_double_val(v_time, time);
v_snapshot = allocate_outside_heap(sizeof(snapshot));
heap_snapshot = (snapshot*) v_snapshot;
@ -394,7 +394,7 @@ value caml_spacetime_timestamp(double time_override, int use_time_override)
}
v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag);
Double_field(v_time, 0) = time;
Store_double_val(v_time, time);
return v_time;
}

8
bytecomp/bytegen.ml
View File

@ -376,16 +376,16 @@ let comp_primitive p args =
| Pstring_set_64(_) -> Kccall("caml_string_set64", 3)
| Parraylength _ -> Kvectlength
| Parrayrefs Pgenarray -> Kccall("caml_array_get", 2)
| Parrayrefs Pfloatarray -> Kccall("caml_array_get_float", 2)
| Parrayrefs Pfloatarray -> Kccall("caml_floatarray_get", 2)
| Parrayrefs _ -> Kccall("caml_array_get_addr", 2)
| Parraysets Pgenarray -> Kccall("caml_array_set", 3)
| Parraysets Pfloatarray -> Kccall("caml_array_set_float", 3)
| Parraysets Pfloatarray -> Kccall("caml_floatarray_set", 3)
| Parraysets _ -> Kccall("caml_array_set_addr", 3)
| Parrayrefu Pgenarray -> Kccall("caml_array_unsafe_get", 2)
| Parrayrefu Pfloatarray -> Kccall("caml_array_unsafe_get_float", 2)
| Parrayrefu Pfloatarray -> Kccall("caml_floatarray_unsafe_get", 2)
| Parrayrefu _ -> Kgetvectitem
| Parraysetu Pgenarray -> Kccall("caml_array_unsafe_set", 3)
| Parraysetu Pfloatarray -> Kccall("caml_array_unsafe_set_float", 3)
| Parraysetu Pfloatarray -> Kccall("caml_floatarray_unsafe_set", 3)
| Parraysetu _ -> Ksetvectitem
| Pctconst c ->
let const_name = match c with

5
bytecomp/symtable.ml
View File

@ -220,7 +220,10 @@ let rec transl_const = function
fields;
block
| Const_float_array fields ->
Obj.repr(Array.of_list(List.map (fun f -> float_of_string f) fields))
let res = Array.Floatarray.create (List.length fields) in
List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f))
fields;
Obj.repr res
(* Build the initial table of globals *)

56
bytecomp/translcore.ml
View File

@ -162,6 +162,9 @@ let comparisons_table = create_hashtable 11 [
false)
]
let gen_array_kind =
if Config.flat_float_array then Pgenarray else Paddrarray
let primitives_table = create_hashtable 57 [
"%identity", Pidentity;
"%bytes_to_string", Pbytes_to_string;
@ -239,14 +242,14 @@ let primitives_table = create_hashtable 57 [
"%bytes_safe_set", Pbytessets;
"%bytes_unsafe_get", Pbytesrefu;
"%bytes_unsafe_set", Pbytessetu;
"%array_length", Parraylength Pgenarray;
"%array_safe_get", Parrayrefs Pgenarray;
"%array_safe_set", Parraysets Pgenarray;
"%array_unsafe_get", Parrayrefu Pgenarray;
"%array_unsafe_set", Parraysetu Pgenarray;
"%obj_size", Parraylength Pgenarray;
"%obj_field", Parrayrefu Pgenarray;
"%obj_set_field", Parraysetu Pgenarray;
"%array_length", Parraylength gen_array_kind;
"%array_safe_get", Parrayrefs gen_array_kind;
"%array_safe_set", Parraysets gen_array_kind;
"%array_unsafe_get", Parrayrefu gen_array_kind;
"%array_unsafe_set", Parraysetu gen_array_kind;
"%obj_size", Parraylength gen_array_kind;
"%obj_field", Parrayrefu gen_array_kind;
"%obj_set_field", Parraysetu gen_array_kind;
"%floatarray_length", Parraylength Pfloatarray;
"%floatarray_safe_get", Parrayrefs Pfloatarray;
"%floatarray_safe_set", Parraysets Pfloatarray;
@ -382,6 +385,28 @@ let specialize_comparison table env ty =
| () when is_base_type env ty Predef.path_int64 -> int64comp
| () -> gencomp
(* The following function computes the greatest lower bound in the
semilattice of array kinds:
gen
/ \
addr float
|
int
Note that the GLB is not guaranteed to exist, in which case we return
our first argument instead of raising a fatal error because, although
it cannot happen in a well-typed program, (ab)use of Obj.magic can
probably trigger it.
*)
let glb_array_type t1 t2 =
match t1, t2 with
| Pfloatarray, (Paddrarray | Pintarray)
| (Paddrarray | Pintarray), Pfloatarray -> t1
| Pgenarray, x | x, Pgenarray -> x
| Paddrarray, x | x, Paddrarray -> x
| Pintarray, Pintarray -> Pintarray
| Pfloatarray, Pfloatarray -> Pfloatarray
(* Specialize a primitive from available type information,
raise Not_found if primitive is unknown *)
@ -408,11 +433,16 @@ let specialize_primitive p env ty ~has_constant_constructor =
match (p, params) with
(Psetfield(n, _, init), [_p1; p2]) ->
Psetfield(n, maybe_pointer_type env p2, init)
| (Parraylength Pgenarray, [p]) -> Parraylength(array_type_kind env p)
| (Parrayrefu Pgenarray, p1 :: _) -> Parrayrefu(array_type_kind env p1)
| (Parraysetu Pgenarray, p1 :: _) -> Parraysetu(array_type_kind env p1)
| (Parrayrefs Pgenarray, p1 :: _) -> Parrayrefs(array_type_kind env p1)
| (Parraysets Pgenarray, p1 :: _) -> Parraysets(array_type_kind env p1)
| (Parraylength t, [p]) ->
Parraylength(glb_array_type t (array_type_kind env p))
| (Parrayrefu t, p1 :: _) ->
Parrayrefu(glb_array_type t (array_type_kind env p1))
| (Parraysetu t, p1 :: _) ->
Parraysetu(glb_array_type t (array_type_kind env p1))
| (Parrayrefs t, p1 :: _) ->
Parrayrefs(glb_array_type t (array_type_kind env p1))
| (Parraysets t, p1 :: _) ->
Parraysets(glb_array_type t (array_type_kind env p1))
| (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout),
p1 :: _) ->
let (k, l) = bigarray_type_kind_and_layout env p1 in

11
bytecomp/typeopt.ml
View File

@ -101,12 +101,14 @@ let array_type_kind env ty =
| Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
when Path.same p Predef.path_array ->
begin match classify env elt_ty with
| Any -> Pgenarray
| Float -> Pfloatarray
| Any -> if Config.flat_float_array then Pgenarray else Paddrarray
| Float -> if Config.flat_float_array then Pfloatarray else Paddrarray
| Addr | Lazy -> Paddrarray
| Int -> Pintarray
end
| Tconstr(p, [], _) | Tpoly({desc = Tconstr(p, [], _)}, _)
when Path.same p Predef.path_floatarray ->
Pfloatarray
| _ ->
(* This can happen with e.g. Obj.field *)
Pgenarray
@ -170,5 +172,6 @@ let value_kind env ty =
let lazy_val_requires_forward env ty =
match classify env ty with
| Any | Float | Lazy -> true
| Any | Lazy -> true
| Float -> Config.flat_float_array
| Addr | Int -> false

6
byterun/alloc.c
View File

@ -161,6 +161,7 @@ CAMLexport value caml_alloc_array(value (*funct)(char const *),
/* [len] is a number of floats */
CAMLprim value caml_alloc_float_array(mlsize_t len)
{
#ifdef FLAT_FLOAT_ARRAY
mlsize_t wosize = len * Double_wosize;
value result;
/* For consistency with [caml_make_vect], which can't tell whether it should
@ -176,6 +177,9 @@ CAMLprim value caml_alloc_float_array(mlsize_t len)
result = caml_check_urgent_gc (result);
}
return result;
#else
return caml_alloc (len, 0);
#endif
}
@ -232,7 +236,7 @@ CAMLprim value caml_update_dummy(value dummy, value newval)
if (tag == Double_array_tag){
size = Wosize_val (newval) / Double_wosize;
for (i = 0; i < size; i++){
Store_double_field (dummy, i, Double_field (newval, i));
Store_double_flat_field (dummy, i, Double_flat_field (newval, i));
}
}else{
for (i = 0; i < size; i++){

171
byterun/array.c
View File

@ -29,11 +29,14 @@
static const mlsize_t mlsize_t_max = -1;
/* returns number of elements (either fields or floats) */
/* [ 'a array -> int ] */
CAMLexport mlsize_t caml_array_length(value array)
{
#ifdef FLAT_FLOAT_ARRAY
if (Tag_val(array) == Double_array_tag)
return Wosize_val(array) / Double_wosize;
else
#endif
return Wosize_val(array);
}
@ -42,6 +45,12 @@ CAMLexport int caml_is_double_array(value array)
return (Tag_val(array) == Double_array_tag);
}
/* Note: the OCaml types on the following primitives will work both with
and without the -no-flat-float-array configure-time option. If you
respect them, your C code should work in both configurations.
*/
/* [ 'a array -> int -> 'a ] where 'a != float */
CAMLprim value caml_array_get_addr(value array, value index)
{
intnat idx = Long_val(index);
@ -49,15 +58,54 @@ CAMLprim value caml_array_get_addr(value array, value index)
return Field(array, idx);
}
/* [ float array -> int -> float ] */
CAMLprim value caml_array_get_float(value array, value index)
{
intnat idx = Long_val(index);
#ifdef FLAT_FLOAT_ARRAY
double d;
value res;
if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
caml_array_bound_error();
d = Double_field(array, idx);
d = Double_flat_field(array, idx);
#define Setup_for_gc
#define Restore_after_gc
Alloc_small(res, Double_wosize, Double_tag);
#undef Setup_for_gc
#undef Restore_after_gc
Store_double_val(res, d);
return res;
#else
CAMLassert (Tag_val (array) != Double_array_tag);
if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error();
return Field(array, idx);
#endif /* FLAT_FLOAT_ARRAY */
}
/* [ 'a array -> int -> 'a ] */
CAMLprim value caml_array_get(value array, value index)
{
#ifdef FLAT_FLOAT_ARRAY
if (Tag_val(array) == Double_array_tag)
return caml_array_get_float(array, index);
#else
CAMLassert (Tag_val(array) != Double_array_tag);
#endif
return caml_array_get_addr(array, index);
}
/* [ floatarray -> int -> float ] */
CAMLprim value caml_floatarray_get(value array, value index)
{
intnat idx = Long_val(index);
double d;
value res;
CAMLassert (Tag_val(array) == Double_array_tag);
if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
caml_array_bound_error();
d = Double_flat_field(array, idx);
#define Setup_for_gc
#define Restore_after_gc
Alloc_small(res, Double_wosize, Double_tag);
@ -67,14 +115,7 @@ CAMLprim value caml_array_get_float(value array, value index)
return res;
}
CAMLprim value caml_array_get(value array, value index)
{
if (Tag_val(array) == Double_array_tag)
return caml_array_get_float(array, index);
else
return caml_array_get_addr(array, index);
}
/* [ 'a array -> int -> 'a -> unit ] where 'a != float */
CAMLprim value caml_array_set_addr(value array, value index, value newval)
{
intnat idx = Long_val(index);
@ -83,29 +124,56 @@ CAMLprim value caml_array_set_addr(value array, value index, value newval)
return Val_unit;
}
/* [ float array -> int -> float -> unit ] */
CAMLprim value caml_array_set_float(value array, value index, value newval)
{
intnat idx = Long_val(index);
#ifdef FLAT_FLOAT_ARRAY
double d = Double_val (newval);
if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
caml_array_bound_error();
Store_double_field(array, idx, Double_val(newval));
Store_double_flat_field(array, idx, d);
#else
CAMLassert (Tag_val (array) != Double_array_tag);
if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error();
Modify(&Field(array, idx), newval);
#endif
return Val_unit;
}
/* [ 'a array -> int -> 'a -> unit ] */
CAMLprim value caml_array_set(value array, value index, value newval)
{
#ifdef FLAT_FLOAT_ARRAY
if (Tag_val(array) == Double_array_tag)
return caml_array_set_float(array, index, newval);
else
return caml_array_set_addr(array, index, newval);
#else
CAMLassert (Tag_val(array) != Double_array_tag);
#endif
return caml_array_set_addr(array, index, newval);
}
/* [ floatarray -> int -> float -> unit ] */
CAMLprim value caml_floatarray_set(value array, value index, value newval)
{
intnat idx = Long_val(index);
double d = Double_val (newval);
CAMLassert (Tag_val(array) == Double_array_tag);
if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
caml_array_bound_error();
Store_double_flat_field(array, idx, d);
return Val_unit;
}
/* [ float array -> int -> float ] */
CAMLprim value caml_array_unsafe_get_float(value array, value index)
{
intnat idx = Long_val (index);
#ifdef FLAT_FLOAT_ARRAY
double d;
value res;
d = Double_field(array, Long_val(index));
d = Double_flat_field(array, idx);
#define Setup_for_gc
#define Restore_after_gc
Alloc_small(res, Double_wosize, Double_tag);
@ -113,14 +181,22 @@ CAMLprim value caml_array_unsafe_get_float(value array, value index)
#undef Restore_after_gc
Store_double_val(res, d);
return res;
#else /* FLAT_FLOAT_ARRAY */
CAMLassert (Tag_val(array) != Double_array_tag);
return Field(array, idx);
#endif /* FLAT_FLOAT_ARRAY */
}
/* [ 'a array -> int -> 'a ] */
CAMLprim value caml_array_unsafe_get(value array, value index)
{
#ifdef FLAT_FLOAT_ARRAY
if (Tag_val(array) == Double_array_tag)
return caml_array_unsafe_get_float(array, index);
else
return Field(array, Long_val(index));
#else
CAMLassert (Tag_val(array) != Double_array_tag);
#endif
return Field(array, Long_val(index));
}
/* [ floatarray -> int -> float ] */
@ -141,6 +217,7 @@ CAMLprim value caml_floatarray_unsafe_get(value array, value index)
return res;
}
/* [ 'a array -> int -> 'a -> unit ] where 'a != float */
CAMLprim value caml_array_unsafe_set_addr(value array, value index,value newval)
{
intnat idx = Long_val(index);
@ -148,18 +225,29 @@ CAMLprim value caml_array_unsafe_set_addr(value array, value index,value newval)
return Val_unit;
}
/* [ float array -> int -> float -> unit ] */
CAMLprim value caml_array_unsafe_set_float(value array,value index,value newval)
{
Store_double_field(array, Long_val(index), Double_val(newval));
intnat idx = Long_val(index);
#ifdef FLAT_FLOAT_ARRAY
double d = Double_val (newval);
Store_double_flat_field(array, idx, d);
#else
Modify(&Field(array, idx), newval);
#endif
return Val_unit;
}
/* [ 'a array -> int -> 'a -> unit ] */
CAMLprim value caml_array_unsafe_set(value array, value index, value newval)
{
#ifdef FLAT_FLOAT_ARRAY
if (Tag_val(array) == Double_array_tag)
return caml_array_unsafe_set_float(array, index, newval);
else
return caml_array_unsafe_set_addr(array, index, newval);
#else
CAMLassert (Tag_val(array) != Double_array_tag);
#endif
return caml_array_unsafe_set_addr(array, index, newval);
}
/* [ floatarray -> int -> float -> unit ] */
@ -187,7 +275,7 @@ CAMLprim value caml_floatarray_create(value len)
#undef Setup_for_gc
#undef Restore_after_gc
}else if (wosize > Max_wosize)
caml_invalid_argument("Array.create_float");
caml_invalid_argument("Array.Floatarray.create");
else {
result = caml_alloc_shr (wosize, Double_array_tag);
result = caml_check_urgent_gc (result);
@ -196,9 +284,14 @@ CAMLprim value caml_floatarray_create(value len)
}
/* [len] is a [value] representing number of floats */
/* [ int -> float array ] */
CAMLprim value caml_make_float_vect(value len)
{
#ifdef FLAT_FLOAT_ARRAY
return caml_floatarray_create (len);
#else
return caml_alloc (Long_val (len), 0);
#endif
}
/* [len] is a [value] representing number of words or floats */
@ -207,23 +300,25 @@ CAMLprim value caml_make_vect(value len, value init)
{
CAMLparam2 (len, init);
CAMLlocal1 (res);
mlsize_t size, wsize, i;
double d;
mlsize_t size, i;
size = Long_val(len);
if (size == 0) {
res = Atom(0);
}
else if (Is_block(init)
#ifdef FLAT_FLOAT_ARRAY
} else if (Is_block(init)
&& Is_in_value_area(init)
&& Tag_val(init) == Double_tag) {
mlsize_t wsize;
double d;
d = Double_val(init);
wsize = size * Double_wosize;
if (wsize > Max_wosize) caml_invalid_argument("Array.make");
res = caml_alloc(wsize, Double_array_tag);
for (i = 0; i < size; i++) {
Store_double_field(res, i, d);
Store_double_flat_field(res, i, d);
}
#endif
} else {
if (size <= Max_young_wosize) {
uintnat profinfo;
@ -251,8 +346,15 @@ CAMLprim value caml_make_vect(value len, value init)
CAMLreturn (res);
}
/* This primitive is used internally by the compiler to compile
explicit array expressions.
For float arrays when FLAT_FLOAT_ARRAY is true, it takes an array of
boxed floats and returns the corresponding flat-allocated [float array].
In all other cases, it just returns its argument unchanged.
*/
CAMLprim value caml_make_array(value init)
{
#ifdef FLAT_FLOAT_ARRAY
CAMLparam1 (init);
mlsize_t wsize, size, i;
CAMLlocal2 (v, res);
@ -275,11 +377,15 @@ CAMLprim value caml_make_array(value init)
res = caml_check_urgent_gc(res);
}
for (i = 0; i < size; i++) {
Store_double_field(res, i, Double_val(Field(init, i)));
double d = Double_val(Field(init, i));
Store_double_flat_field(res, i, d);
}
CAMLreturn (res);
}
}
#else
return init;
#endif
}
/* Blitting */
@ -290,6 +396,7 @@ CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2,
value * src, * dst;
intnat count;
#ifdef FLAT_FLOAT_ARRAY
if (Tag_val(a2) == Double_array_tag) {
/* Arrays of floats. The values being copied are floats, not
pointer, so we can do a direct copy. memmove takes care of
@ -299,6 +406,8 @@ CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2,
Long_val(n) * sizeof(double));
return Val_unit;
}
#endif
CAMLassert (Tag_val(a2) != Double_array_tag);
if (Is_young(a2)) {
/* Arrays of values, destination is in young generation.
Here too we can do a direct copy since this cannot create
@ -343,22 +452,27 @@ static value caml_array_gather(intnat num_arrays,
{
CAMLparamN(arrays, num_arrays);
value res; /* no need to register it as a root */
int isfloat;
mlsize_t i, size, wsize, count, pos;
#ifdef FLAT_FLOAT_ARRAY
int isfloat = 0;
mlsize_t wsize;
#endif
mlsize_t i, size, count, pos;
value * src;
/* Determine total size and whether result array is an array of floats */
size = 0;
isfloat = 0;
for (i = 0; i < num_arrays; i++) {
if (mlsize_t_max - lengths[i] < size) caml_invalid_argument("Array.concat");
size += lengths[i];
#ifdef FLAT_FLOAT_ARRAY
if (Tag_val(arrays[i]) == Double_array_tag) isfloat = 1;
#endif
}
if (size == 0) {
/* If total size = 0, just return empty array */
res = Atom(0);
}
#ifdef FLAT_FLOAT_ARRAY
else if (isfloat) {
/* This is an array of floats. We can use memcpy directly. */
if (size > Max_wosize/Double_wosize) caml_invalid_argument("Array.concat");
@ -372,6 +486,7 @@ static value caml_array_gather(intnat num_arrays,
}
CAMLassert(pos == size);
}
#endif
else if (size <= Max_young_wosize) {
/* Array of values, small enough to fit in young generation.
We can use memcpy directly. */

41
byterun/caml/mlvalues.h
View File

@ -277,16 +277,47 @@ CAMLextern void caml_Store_double_val (value,double);
/* Arrays of floating-point numbers. */
#define Double_array_tag 254
#define Double_field(v,i) Double_val((value)((double *)(v) + (i)))
#define Store_double_field(v,i,d) do{ \
/* The [_flat_field] macros are for [floatarray] values and float-only records.
*/
#define Double_flat_field(v,i) Double_val((value)((double *)(v) + (i)))
#define Store_double_flat_field(v,i,d) do{ \
mlsize_t caml__temp_i = (i); \
double caml__temp_d = (d); \
Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \
}while(0)
/* temporary definitions for bootstrapping */
#define Double_flat_field Double_field
#define Store_double_flat_field Store_double_field
/* The [_array_field] macros are for [float array]. */
#ifdef FLAT_FLOAT_ARRAY
#define Double_array_field(v,i) Double_flat_field(v,i)
#define Store_double_array_field(v,i,d) Store_double_flat_field(v,i,d)
#else
#define Double_array_field(v,i) Double_val (Field(v,i))
CAMLextern void caml_Store_double_array_field (value, mlsize_t, double);
#define Store_double_array_field(v,i,d) caml_Store_double_array_field (v,i,d)
#endif
/* The old [_field] macros are for backward compatibility only.
They work with [floatarray], float-only records, and [float array]. */
#ifdef FLAT_FLOAT_ARRAY
#define Double_field(v,i) Double_flat_field(v,i)
#define Store_double_field(v,i,d) Store_double_flat_field(v,i,d)
#else
static inline double Double_field (value v, mlsize_t i) {
if (Tag_val (v) == Double_array_tag){
return Double_flat_field (v, i);
}else{
return Double_array_field (v, i);
}
}
static inline void Store_double_field (value v, mlsize_t i, double d) {
if (Tag_val (v) == Double_array_tag){
Store_double_flat_field (v, i, d);
}else{
Store_double_array_field (v, i, d);
}
}
#endif /* FLAT_FLOAT_ARRAY */
CAMLextern mlsize_t caml_array_length (value); /* size in items */
CAMLextern int caml_is_double_array (value); /* 0 is false, 1 is true */

12
byterun/compare.c
View File

@ -228,9 +228,9 @@ static intnat do_compare_val(struct compare_stack* stk,
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);
#ifdef LACKS_SANE_NAN
double d1 = Double_flat_field(v1, i);
double d2 = Double_flat_field(v2, i);
#ifdef LACKS_SANE_NAN
if (isnan(d2)) {
if (! total) return UNORDERED;
if (isnan(d1)) break;
@ -239,17 +239,17 @@ static intnat do_compare_val(struct compare_stack* stk,
if (! total) return UNORDERED;
return LESS;
}
#endif
#endif
if (d1 < d2) return LESS;
if (d1 > d2) return GREATER;
#ifndef LACKS_SANE_NAN
#ifndef LACKS_SANE_NAN
if (d1 != d2) {
if (! total) return UNORDERED;
/* See comment for Double_tag case */
if (d1 == d1) return GREATER;
if (d2 == d2) return LESS;
}
#endif
#endif
}
break;
}

2
byterun/debugger.c
View File

@ -411,7 +411,7 @@ void caml_debugger(enum event_kind event)
caml_putch(dbg_out, 0);
putval(dbg_out, Field(val, i));
} else {
double d = Double_field(val, i);
double d = Double_flat_field(val, i);
caml_putch(dbg_out, 1);
caml_really_putblock(dbg_out, (char *) &d, 8);
}

6
byterun/extern.c
View File

@ -421,7 +421,11 @@ static void extern_rec(value v)
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)){
|| Tag_val (f) == Lazy_tag
#ifdef FLAT_FLOAT_ARRAY
|| Tag_val (f) == Double_tag
#endif
)){
/* Do not short-circuit the pointer. */
}else{
v = f;

2
byterun/finalise.c
View File

@ -375,7 +375,9 @@ static void generic_final_register (struct finalisable *final, value f, value v)
if (!Is_block (v)
|| !Is_in_heap_or_young(v)
|| Tag_val (v) == Lazy_tag
#ifdef FLAT_FLOAT_ARRAY
|| Tag_val (v) == Double_tag
#endif
|| Tag_val (v) == Forward_tag) {
caml_invalid_argument ("Gc.finalise");
}

12
byterun/floats.c
View File

@ -79,6 +79,18 @@ CAMLexport value caml_copy_double(double d)
return res;
}
#ifndef FLAT_FLOAT_ARRAY
CAMLexport void caml_Store_double_array_field(value val, mlsize_t i, double dbl)
{
CAMLparam1 (val);
value d = caml_copy_double (dbl);
CAMLassert (Tag_val (val) != Double_array_tag);
caml_modify (&Field(val, i), d);
CAMLreturn0;
}
#endif /* ! FLAT_FLOAT_ARRAY */
CAMLprim value caml_format_float(value fmt, value arg)
{
value res;

2
byterun/hash.c
View File

@ -217,7 +217,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj)
break;
case Double_array_tag:
for (i = 0, len = Wosize_val(v) / Double_wosize; i < len; i++) {
h = caml_hash_mix_double(h, Double_field(v, i));
h = caml_hash_mix_double(h, Double_flat_field(v, i));
num--;
if (num <= 0) break;
}

2
byterun/instrtrace.c
View File

@ -219,7 +219,7 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f)
case Double_array_tag:
fprintf (f, "=floatarray[s%d]", s);
for (i = 0; i < ((s>0xf)?0xf:s); i++)
fprintf (f, " %g", Double_field (v, i));
fprintf (f, " %g", Double_flat_field (v, i));
goto displayfields;
case Abstract_tag:
fprintf (f, "=abstract[s%d]", s);

11
byterun/interp.c
View File

@ -700,9 +700,9 @@ value caml_interprete(code_t prog, asize_t prog_size)
} else {
block = caml_alloc_shr(size * Double_wosize, Double_array_tag);
}
Store_double_field(block, 0, Double_val(accu));
Store_double_flat_field(block, 0, Double_val(accu));
for (i = 1; i < size; i++){
Store_double_field(block, i, Double_val(*sp));
Store_double_flat_field(block, i, Double_val(*sp));
++ sp;
}
accu = block;
@ -722,7 +722,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
Instruct(GETFIELD):
accu = Field(accu, *pc); pc++; Next;
Instruct(GETFLOATFIELD): {
double d = Double_field(accu, *pc);
double d = Double_flat_field(accu, *pc);
Alloc_small(accu, Double_wosize, Double_tag);
Store_double_val(accu, d);
pc++;
@ -751,7 +751,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
pc++;
Next;
Instruct(SETFLOATFIELD):
Store_double_field(accu, *pc, Double_val(*sp));
Store_double_flat_field(accu, *pc, Double_val(*sp));
accu = Val_unit;
sp++;
pc++;
@ -760,6 +760,9 @@ value caml_interprete(code_t prog, asize_t prog_size)
/* Array operations */
Instruct(VECTLENGTH): {
/* Todo: when FLAT_FLOAT_ARRAY is false, this instruction should
be split into VECTLENGTH and FLOATVECTLENGTH because we know
statically which one it is. */
mlsize_t size = Wosize_val(accu);
if (Tag_val(accu) == Double_array_tag) size = size / Double_wosize;
accu = Val_long(size);

12
byterun/major_gc.c
View File

@ -258,7 +258,11 @@ static inline value* mark_slice_darken(value *gray_vals_ptr, value v, int i,
if ((in_ephemeron && Is_long(f)) ||
(Is_block (f)
&& (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){
|| Tag_val (f) == Lazy_tag
#ifdef FLAT_FLOAT_ARRAY
|| Tag_val (f) == Double_tag
#endif
))){
/* Do not short-circuit the pointer. */
}else{
/* The variable child is not changed because it must be mark alive */
@ -326,7 +330,11 @@ static value* mark_ephe_aux (value *gray_vals_ptr, intnat *work,
if (Is_long (f) ||
(Is_block (f) &&
(!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){
|| Tag_val (f) == Lazy_tag
#ifdef FLAT_FLOAT_ARRAY
|| Tag_val (f) == Double_tag
#endif
))){
/* Do not short-circuit the pointer. */
}else{
Field (v, i) = key = f;

6
byterun/minor_gc.c
View File

@ -237,7 +237,11 @@ void caml_oldify_one (value v, value *p)
}
}
}
if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
if (!vv || ft == Forward_tag || ft == Lazy_tag
#ifdef FLAT_FLOAT_ARRAY
|| ft == Double_tag
#endif
){
/* Do not short-circuit the pointer. Copy as a normal block. */
CAMLassert (Wosize_hd (hd) == 1);
result = caml_alloc_shr_preserving_profinfo (1, Forward_tag, hd);

3
byterun/obj.c
View File

@ -128,7 +128,8 @@ CAMLprim value caml_obj_dup(value arg)
before the block is reallocated (since there must be a minor
collection within each major cycle).
[newsize] is a value encoding a number of words.
[newsize] is a value encoding a number of fields (words, except
for float arrays on 32-bit architectures).
*/
CAMLprim value caml_obj_truncate (value v, value newsize)
{

15
configure vendored
View File

@ -67,6 +67,7 @@ afl_instrument=false
max_testsuite_dir_retries=0
with_cplugins=false
with_fpic=false
flat_float_array=true
# Try to turn internationalization off, can cause config.guess to malfunction!
unset LANG
@ -214,6 +215,10 @@ while : ; do
with_fpic=true;;
-safe-string|--safe-string)
safe_string=true;;
-flat-float-array|--flat-float-array)
flat_float_array=true;;
-no-flat-float-array|--no-flat-float-array)
flat_float_array=false;;
-afl-instrument)
afl_instrument=true;;
*) if echo "$1" | grep -q -e '^--\?[a-zA-Z0-9-]\+='; then
@ -2009,6 +2014,10 @@ if $safe_string; then
echo "#define CAML_SAFE_STRING" >> m.h
fi
if $flat_float_array; then
echo "#define FLAT_FLOAT_ARRAY" >> m.h
fi
# Finish generated files
cclibs="$cclibs $mathlib"
@ -2097,6 +2106,7 @@ config FLAMBDA "$flambda"
config SAFE_STRING "$safe_string"
config AFL_INSTRUMENT "$afl_instrument"
config MAX_TESTSUITE_DIR_RETRIES "$max_testsuite_dir_retries"
config FLAT_FLOAT_ARRAY "$flat_float_array"
rm -f tst hasgot.c
@ -2218,6 +2228,11 @@ else
else
inf " safe strings ............. no"
fi
if $flat_float_array; then
inf " flat float arrays ........ yes"
else
inf " flat float arrays ........ no"
fi
if test "$afl_instrument" = "true"; then
inf " afl-fuzz always enabled .. yes"
else

21
debugger/debugcom.ml
View File

@ -201,6 +201,8 @@ module Remote_value =
struct
type t = Remote of string | Local of Obj.t
let repr x = Local (Obj.repr x)
let obj = function
| Local obj -> Obj.obj obj
| Remote v ->
@ -255,6 +257,25 @@ module Remote_value =
Local(Obj.repr floatbuf)
end
let double_field v n =
match v with
| Local obj -> Obj.double_field obj n
| Remote v ->
output_char !conn.io_out 'F';
output_remote_value !conn.io_out v;
output_binary_int !conn.io_out n;
flush !conn.io_out;
if input_byte !conn.io_in = 0 then
raise Marshalling_error
else begin
let buf = really_input_string !conn.io_in 8 in
let floatbuf = float n (* force allocation of a new float *) in
String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8;
floatbuf
end
let double_array_tag = Obj.double_array_tag
let of_int n =
Local(Obj.repr n)

3
debugger/debugcom.mli
View File

@ -93,11 +93,14 @@ module Remote_value :
sig
type t
val repr : 'a -> t
val obj : t -> 'a
val is_block : t -> bool
val tag : t -> int
val size : t -> int
val field : t -> int -> t
val double_field : t -> int -> float
val double_array_tag : int
val same : t -> t -> bool
val of_int : int -> t

14
middle_end/inline_and_simplify.ml
View File

@ -1027,18 +1027,20 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t =
Location.prerr_warning (Debuginfo.to_location dbg)
Warnings.Assignment_to_non_mutable_value
end;
let kind = match A.descr block_approx, A.descr value_approx with
| (Value_float_array _, _)
| (_, Value_float _) ->
begin match kind with
let kind =
let check () =
match kind with
| Pfloatarray | Pgenarray -> ()
| Paddrarray | Pintarray ->
(* CR pchambart: Do a proper warning here *)
Misc.fatal_errorf "Assignment of a float to a specialised \
non-float array: %a"
Flambda.print_named tree
end;
Lambda.Pfloatarray
in
match A.descr block_approx, A.descr value_approx with
| (Value_float_array _, _) -> check (); Lambda.Pfloatarray
| (_, Value_float _) when Config.flat_float_array ->
check (); Lambda.Pfloatarray
(* CR pchambart: This should be accounted by the benefit *)
| _ ->
kind

10
stdlib/array.ml
View File

@ -30,6 +30,16 @@ external unsafe_blit :
external create_float: int -> float array = "caml_make_float_vect"
let make_float = create_float
module Floatarray = struct
external create : int -> floatarray = "caml_floatarray_create"
external length : floatarray -> int = "%floatarray_length"
external get : floatarray -> int -> float = "%floatarray_safe_get"
external set : floatarray -> int -> float -> unit = "%floatarray_safe_set"
external unsafe_get : floatarray -> int -> float = "%floatarray_unsafe_get"
external unsafe_set : floatarray -> int -> float -> unit
= "%floatarray_unsafe_set"
end
let init l f =
if l = 0 then [||] else
if l < 0 then invalid_arg "Array.init"

10
stdlib/array.mli
View File

@ -263,3 +263,13 @@ val fast_sort : ('a -> 'a -> int) -> 'a array -> unit
external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
module Floatarray : sig
external create : int -> floatarray = "caml_floatarray_create"
external length : floatarray -> int = "%floatarray_length"
external get : floatarray -> int -> float = "%floatarray_safe_get"
external set : floatarray -> int -> float -> unit = "%floatarray_safe_set"
external unsafe_get : floatarray -> int -> float = "%floatarray_unsafe_get"
external unsafe_set : floatarray -> int -> float -> unit
= "%floatarray_unsafe_set"
end

10
stdlib/arrayLabels.mli
View File

@ -264,3 +264,13 @@ val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
module Floatarray : sig
external create : int -> floatarray = "caml_floatarray_create"
external length : floatarray -> int = "%floatarray_length"
external get : floatarray -> int -> float = "%floatarray_safe_get"
external set : floatarray -> int -> float -> unit = "%floatarray_safe_set"
external unsafe_get : floatarray -> int -> float = "%floatarray_unsafe_get"
external unsafe_set : floatarray -> int -> float -> unit
= "%floatarray_unsafe_set"
end

2
stdlib/lazy.ml
View File

@ -36,6 +36,8 @@
The GC will magically change things from (2) to (3) according to its
fancy.
If OCaml was configured with the -flat-float-array option (which is
currently the default), the following is also true:
We cannot use representation (3) for a [float Lazy.t] because
[caml_make_array] assumes that only a [float] value can have tag
[Double_tag].

9
stdlib/obj.ml
View File

@ -28,11 +28,12 @@ external size : t -> int = "%obj_size"
external reachable_words : t -> int = "caml_obj_reachable_words"
external field : t -> int -> t = "%obj_field"
external set_field : t -> int -> t -> unit = "%obj_set_field"
external array_get: 'a array -> int -> 'a = "%array_safe_get"
external array_set: 'a array -> int -> 'a -> unit = "%array_safe_set"
let [@inline always] double_field x i = array_get (obj x : float array) i
external floatarray_get : floatarray -> int -> float = "caml_floatarray_get"
external floatarray_set :
floatarray -> int -> float -> unit = "caml_floatarray_set"
let [@inline always] double_field x i = floatarray_get (obj x : floatarray) i
let [@inline always] set_double_field x i v =
array_set (obj x : float array) i v
floatarray_set (obj x : floatarray) i v
external new_block : int -> int -> t = "caml_obj_block"
external dup : t -> t = "caml_obj_dup"
external truncate : t -> int -> unit = "caml_obj_truncate"

3
testsuite/tests/array-functions/Makefile
View File

@ -13,6 +13,9 @@
#* *
#**************************************************************************
ADD_COMPFLAGS = -I $(OTOPDIR)/utils
MODULES = config
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common

2
testsuite/tests/array-functions/test.ml
View File

@ -176,7 +176,7 @@ let () =
assert (not (Array.memq (ref 1) (Array.make 100 (ref 1))));
let f = Array.create_float 10 in
Array.fill f 0 10 1.0;
assert (not (Array.memq 1.0 f));
if Config.flat_float_array then assert (not (Array.memq 1.0 f));
;;
let () = print_endline "OK"

21
testsuite/tests/asmcomp/Makefile
View File

@ -15,6 +15,8 @@
BASEDIR=../..
include $(BASEDIR)/../config/Makefile
INCLUDES=\
-I $(OTOPDIR)/parsing \
-I $(OTOPDIR)/utils \
@ -55,8 +57,9 @@ MLCASES=optargs staticalloc bind_tuples is_static register_typing \
register_typing_switch
ARGS_optargs=-g
ARGS_is_static=-I $(OTOPDIR)/byterun is_in_static_data.c
MLCASES_FLAMBDA=is_static_flambda unrolling_flambda unrolling_flambda2 \
static_float_array_flambda static_float_array_flambda_opaque
MLCASES_FLAMBDA=is_static_flambda unrolling_flambda unrolling_flambda2
MLCASES_FLAMBDA_FLOAT=static_float_array_flambda \
static_float_array_flambda_opaque
ARGS_is_static_flambda=\
-I $(OTOPDIR)/byterun is_in_static_data.c is_static_flambda_dep.ml
ARGS_static_float_array_flambda=\
@ -87,7 +90,8 @@ ARGS_even-odd-spill=-DINT_INT -DFUN=is_even main.c
ARGS_pgcd=-DINT_INT -DFUN=pgcd_30030 main.c
skips:
@for c in $(CASES) $(MLCASES) $(MLCASES_FLAMBDA); do \
@for c in $(CASES) $(MLCASES) $(MLCASES_FLAMBDA) \
$(MLCASES_FLAMBDA_FLOAT); do \
echo " ... testing '$$c': => skipped"; \
done
@ -95,8 +99,8 @@ one_ml:
@$(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \
./$(NAME).exe && echo " => passed" || echo " => failed"
one_ml_flambda:
@if $(FLAMBDA); then \
one_ml_cond:
@if $(COND); then \
$(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \
./$(NAME).exe && echo " => passed" || echo " => failed"; \
else \
@ -142,7 +146,12 @@ tests: $(CASES:=.$(O))
done
@for c in $(MLCASES_FLAMBDA); do \
printf " ... testing '$$c':"; \
$(MAKE) one_ml_flambda NAME=$$c; \
$(MAKE) one_ml_cond NAME=$$c COND=$(FLAMBDA); \
done
@for c in $(MLCASES_FLAMBDA_FLOAT); do \
printf " ... testing '$$c':"; \
$(MAKE) one_ml_cond NAME=$$c \
COND='$(FLAMBDA) && $(FLAT_FLOAT_ARRAY)'; \
done
promote:

6
testsuite/tests/misc/gcwords.ml
View File

@ -1,6 +1,8 @@
type t = Leaf of int | Branch of t * t
let a = [| 0.0 |]
type floatref = { mutable f : float }
let a = { f = 0.0 }
let rec allocate_lots m = function
| 0 -> Leaf m
@ -13,7 +15,7 @@ let measure f =
c -. a
let () =
let n = measure (fun () -> a.(0) <- Gc.minor_words ()) in
let n = measure (fun () -> a.f <- Gc.minor_words ()) in
(* Gc.minor_words should not allocate, although bytecode
generally boxes the floats *)
assert (n < 10.);

24
testsuite/tests/translprim/Makefile
View File

@ -1,4 +1,28 @@
newdefault: array_spec.ml.reference module_coercion.ml.reference
$(MAKE) default
BASEDIR=../..
TOPFLAGS+=-dlambda
include $(BASEDIR)/makefiles/Makefile.dlambda
include $(BASEDIR)/makefiles/Makefile.common
GENERATED_SOURCES = array_spec.ml.reference module_coercion.ml.reference \
*.flat-float
ifeq "$(FLAT_FLOAT_ARRAY)" "true"
suffix = -flat
else
suffix = -noflat
endif
array_spec.ml.reference: array_spec.ml.reference$(suffix) \
$(FLAT_FLOAT_ARRAY).flat-float
cp $< $@
module_coercion.ml.reference: module_coercion.ml.reference$(suffix) \
$(FLAT_FLOAT_ARRAY).flat-float
cp $< $@
%.flat-float:
@rm -f $(GENERATED_SOURCES)
@touch $@

0
testsuite/tests/translprim/array_spec.ml.reference → testsuite/tests/translprim/array_spec.ml.reference-flat
View File

88
testsuite/tests/translprim/array_spec.ml.reference-noflat Normal file
View File

@ -0,0 +1,88 @@
(setglobal Array_spec!
(let
(int_a = (makearray[int] 1 2 3)
float_a = (makearray[addr] 1. 2. 3.)
addr_a = (makearray[addr] "a" "b" "c"))
(seq (array.length[int] int_a) (array.length[addr] float_a)
(array.length[addr] addr_a)
(function a (array.length[addr] a))
(array.get[int] int_a 0) (array.get[addr] float_a 0)
(array.get[addr] addr_a 0)
(function a (array.get[addr] a 0))
(array.unsafe_get[int] int_a 0)
(array.unsafe_get[addr] float_a 0)
(array.unsafe_get[addr] addr_a 0)
(function a (array.unsafe_get[addr] a 0))
(array.set[int] int_a 0 1) (array.set[addr] float_a 0 1.)
(array.set[addr] addr_a 0 "a")
(function a x (array.set[addr] a 0 x))
(array.unsafe_set[int] int_a 0 1)
(array.unsafe_set[addr] float_a 0 1.)
(array.unsafe_set[addr] addr_a 0 "a")
(function a x (array.unsafe_set[addr] a 0 x))
(let
(eta_gen_len =
(function prim stub (array.length[addr] prim))
eta_gen_safe_get =
(function prim prim stub
(array.get[addr] prim prim))
eta_gen_unsafe_get =
(function prim prim stub
(array.unsafe_get[addr] prim prim))
eta_gen_safe_set =
(function prim prim prim stub
(array.set[addr] prim prim prim))
eta_gen_unsafe_set =
(function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
eta_int_len =
(function prim stub (array.length[int] prim))
eta_int_safe_get =
(function prim prim stub
(array.get[int] prim prim))
eta_int_unsafe_get =
(function prim prim stub
(array.unsafe_get[int] prim prim))
eta_int_safe_set =
(function prim prim prim stub
(array.set[int] prim prim prim))
eta_int_unsafe_set =
(function prim prim prim stub
(array.unsafe_set[int] prim prim prim))
eta_float_len =
(function prim stub (array.length[addr] prim))
eta_float_safe_get =
(function prim prim stub
(array.get[addr] prim prim))
eta_float_unsafe_get =
(function prim prim stub
(array.unsafe_get[addr] prim prim))
eta_float_safe_set =
(function prim prim prim stub
(array.set[addr] prim prim prim))
eta_float_unsafe_set =
(function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
eta_addr_len =
(function prim stub (array.length[addr] prim))
eta_addr_safe_get =
(function prim prim stub
(array.get[addr] prim prim))
eta_addr_unsafe_get =
(function prim prim stub
(array.unsafe_get[addr] prim prim))
eta_addr_safe_set =
(function prim prim prim stub
(array.set[addr] prim prim prim))
eta_addr_unsafe_set =
(function prim prim prim stub
(array.unsafe_set[addr] prim prim prim)))
(makeblock 0 int_a float_a addr_a eta_gen_len
eta_gen_safe_get eta_gen_unsafe_get eta_gen_safe_set
eta_gen_unsafe_set eta_int_len eta_int_safe_get
eta_int_unsafe_get eta_int_safe_set
eta_int_unsafe_set eta_float_len eta_float_safe_get
eta_float_unsafe_get eta_float_safe_set
eta_float_unsafe_set eta_addr_len eta_addr_safe_get
eta_addr_unsafe_get eta_addr_safe_set
eta_addr_unsafe_set)))))

0
testsuite/tests/translprim/module_coercion.ml.reference → testsuite/tests/translprim/module_coercion.ml.reference-flat
View File

124
testsuite/tests/translprim/module_coercion.ml.reference-noflat Normal file
View File

@ -0,0 +1,124 @@
(setglobal Module_coercion!
(let
(M = (module-defn(M) module_coercion.ml(1):0-699 (makeblock 0)))
(makeblock 0 M
(module-defn(M_int) module_coercion.ml(32):1116-1155
(makeblock 0 (function prim stub (array.length[int] prim))
(function prim prim stub
(array.get[int] prim prim))
(function prim prim stub
(array.unsafe_get[int] prim prim))
(function prim prim prim stub
(array.set[int] prim prim prim))
(function prim prim prim stub
(array.unsafe_set[int] prim prim prim))
(function prim prim stub
(caml_int_compare prim prim))
(function prim prim stub (== prim prim))
(function prim prim stub (!= prim prim))
(function prim prim stub (< prim prim))
(function prim prim stub (> prim prim))
(function prim prim stub (<= prim prim))
(function prim prim stub (>= prim prim))))
(module-defn(M_float) module_coercion.ml(33):1158-1201
(makeblock 0 (function prim stub (array.length[addr] prim))
(function prim prim stub
(array.get[addr] prim prim))
(function prim prim stub
(array.unsafe_get[addr] prim prim))
(function prim prim prim stub
(array.set[addr] prim prim prim))
(function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
(function prim prim stub
(caml_float_compare prim prim))
(function prim prim stub (==. prim prim))
(function prim prim stub (!=. prim prim))
(function prim prim stub (<. prim prim))
(function prim prim stub (>. prim prim))
(function prim prim stub (<=. prim prim))
(function prim prim stub (>=. prim prim))))
(module-defn(M_string) module_coercion.ml(34):1204-1249
(makeblock 0 (function prim stub (array.length[addr] prim))
(function prim prim stub
(array.get[addr] prim prim))
(function prim prim stub
(array.unsafe_get[addr] prim prim))
(function prim prim prim stub
(array.set[addr] prim prim prim))
(function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
(function prim prim stub
(caml_string_compare prim prim))
(function prim prim stub
(caml_string_equal prim prim))
(function prim prim stub
(caml_string_notequal prim prim))
(function prim prim stub
(caml_string_lessthan prim prim))
(function prim prim stub
(caml_string_greaterthan prim prim))
(function prim prim stub
(caml_string_lessequal prim prim))
(function prim prim stub
(caml_string_greaterequal prim prim))))
(module-defn(M_int32/1104) module_coercion.ml(35):1252-1295
(makeblock 0 (function prim stub (array.length[addr] prim))
(function prim prim stub
(array.get[addr] prim prim))
(function prim prim stub
(array.unsafe_get[addr] prim prim))
(function prim prim prim stub
(array.set[addr] prim prim prim))
(function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
(function prim prim stub
(caml_int32_compare prim prim))
(function prim prim stub (Int32.== prim prim))
(function prim prim stub (Int32.!= prim prim))
(function prim prim stub (Int32.< prim prim))
(function prim prim stub (Int32.> prim prim))
(function prim prim stub (Int32.<= prim prim))
(function prim prim stub (Int32.>= prim prim))))
(module-defn(M_int64/1129) module_coercion.ml(36):1298-1341
(makeblock 0 (function prim stub (array.length[addr] prim))
(function prim prim stub
(array.get[addr] prim prim))
(function prim prim stub
(array.unsafe_get[addr] prim prim))
(function prim prim prim stub
(array.set[addr] prim prim prim))
(function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
(function prim prim stub
(caml_int64_compare prim prim))
(function prim prim stub (Int64.== prim prim))
(function prim prim stub (Int64.!= prim prim))
(function prim prim stub (Int64.< prim prim))
(function prim prim stub (Int64.> prim prim))
(function prim prim stub (Int64.<= prim prim))
(function prim prim stub (Int64.>= prim prim))))
(module-defn(M_nativeint) module_coercion.ml(37):1344-1395
(makeblock 0 (function prim stub (array.length[addr] prim))
(function prim prim stub
(array.get[addr] prim prim))
(function prim prim stub
(array.unsafe_get[addr] prim prim))
(function prim prim prim stub
(array.set[addr] prim prim prim))
(function prim prim prim stub
(array.unsafe_set[addr] prim prim prim))
(function prim prim stub
(caml_nativeint_compare prim prim))
(function prim prim stub
(Nativeint.== prim prim))
(function prim prim stub
(Nativeint.!= prim prim))
(function prim prim stub
(Nativeint.< prim prim))
(function prim prim stub
(Nativeint.> prim prim))
(function prim prim stub
(Nativeint.<= prim prim))
(function prim prim stub
(Nativeint.>= prim prim)))))))

18
testsuite/tests/typing-misc/Makefile
View File

@ -13,6 +13,24 @@
#* *
#**************************************************************************
all: pr6939.ml
$(MAKE) default
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.expect
include $(BASEDIR)/makefiles/Makefile.common
GENERATED_SOURCES = pr6939.ml *.flat-float
ifeq "$(FLAT_FLOAT_ARRAY)" "true"
suffix = -flat
else
suffix = -noflat
endif
pr6939.ml: pr6939.ml$(suffix) $(FLAT_FLOAT_ARRAY).flat-float
cp $< $@
%.flat-float:
@rm -f $(GENERATED_SOURCES)
@touch $@

0
testsuite/tests/typing-misc/pr6939.ml → testsuite/tests/typing-misc/pr6939.ml-flat Executable file → Normal file
View File

14
testsuite/tests/typing-misc/pr6939.ml-noflat Normal file
View File

@ -0,0 +1,14 @@
let rec x = [| x |]; 1.;;
[%%expect{|
Line _, characters 12-19:
Warning 10: this expression should have type unit.
val x : float = 1.
|}];;
let rec x = let u = [|y|] in 10. and y = 1.;;
[%%expect{|
Line _, characters 16-17:
Warning 26: unused variable u.
val x : float = 10.
val y : float = 1.
|}];;

18
testsuite/tests/typing-unboxed-types/Makefile
View File

@ -1,3 +1,21 @@
newdefault: test.ml.reference
@$(MAKE) default
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
GENERATED_SOURCES = test.ml.reference *.flat-float
ifeq "$(FLAT_FLOAT_ARRAY)" "true"
suffix = -flat
else
suffix = -noflat
endif
test.ml.reference: test.ml.reference$(suffix) $(FLAT_FLOAT_ARRAY).flat-float
@cp $< $@
%.flat-float:
@rm -f $(GENERATED_SOURCES)
@touch $@

0
testsuite/tests/typing-unboxed-types/test.ml.reference → testsuite/tests/typing-unboxed-types/test.ml.reference-flat
View File

169
testsuite/tests/typing-unboxed-types/test.ml.reference-noflat Normal file
View File

@ -0,0 +1,169 @@
# type t1 = A of string [@@unboxed]
# - : bool = true
# type t2 = { f : string; } [@@unboxed]
# - : bool = true
# type t3 = B of { g : string; } [@@unboxed]
# - : bool = true
# Characters 29-58:
type t4 = C [@@ocaml.unboxed];; (* no argument *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because its constructor has no argument.
# Characters 0-45:
type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
its constructor has more than one argument.
# Characters 0-33:
type t5 = E | F [@@ocaml.unboxed];; (* more than one constructor *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one constructor.
# Characters 0-40:
type t6 = G of int | H [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one constructor.
# Characters 0-51:
type t7 = I of string | J of bool [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one constructor.
# Characters 1-50:
type t8 = { h : bool; i : int } [@@ocaml.unboxed];; (* more than one field *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because it has more than one field.
# Characters 0-56:
type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This type cannot be unboxed because
its constructor has more than one argument.
# type t10 = A of t10 [@@unboxed]
# Characters 12-15:
let rec x = A x;;
^^^
Error: This kind of expression is not allowed as right-hand side of `let rec'
# Characters 121-172:
......struct
type t = A of string [@@ocaml.unboxed]
end..
Error: Signature mismatch:
Modules do not match:
sig type t = A of string [@@unboxed] end
is not included in
sig type t = A of string end
Type declarations do not match:
type t = A of string [@@unboxed]
is not included in
type t = A of string
Their internal representations differ:
the first declaration uses unboxed representation.
# Characters 63-96:
......struct
type t = A of string
end..
Error: Signature mismatch:
Modules do not match:
sig type t = A of string end
is not included in
sig type t = A of string [@@unboxed] end
Type declarations do not match:
type t = A of string
is not included in
type t = A of string [@@unboxed]
Their internal representations differ:
the second declaration uses unboxed representation.
# Characters 48-102:
......struct
type t = { f : string } [@@ocaml.unboxed]
end..
Error: Signature mismatch:
Modules do not match:
sig type t = { f : string; } [@@unboxed] end
is not included in
sig type t = { f : string; } end
Type declarations do not match:
type t = { f : string; } [@@unboxed]
is not included in
type t = { f : string; }
Their internal representations differ:
the first declaration uses unboxed representation.
# Characters 66-102:
......struct
type t = { f : string }
end..
Error: Signature mismatch:
Modules do not match:
sig type t = { f : string; } end
is not included in
sig type t = { f : string; } [@@unboxed] end
Type declarations do not match:
type t = { f : string; }
is not included in
type t = { f : string; } [@@unboxed]
Their internal representations differ:
the second declaration uses unboxed representation.
# Characters 53-112:
......struct
type t = A of { f : string } [@@ocaml.unboxed]
end..
Error: Signature mismatch:
Modules do not match:
sig type t = A of { f : string; } [@@unboxed] end
is not included in
sig type t = A of { f : string; } end
Type declarations do not match:
type t = A of { f : string; } [@@unboxed]
is not included in
type t = A of { f : string; }
Their internal representations differ:
the first declaration uses unboxed representation.
# Characters 71-112:
......struct
type t = A of { f : string }
end..
Error: Signature mismatch:
Modules do not match:
sig type t = A of { f : string; } end
is not included in
sig type t = A of { f : string; } [@@unboxed] end
Type declarations do not match:
type t = A of { f : string; }
is not included in
type t = A of { f : string; } [@@unboxed]
Their internal representations differ:
the second declaration uses unboxed representation.
# type t11 = L of float [@@unboxed]
# - : unit = ()
# type 'a t12 = M of 'a t12 [@@unboxed]
# val f : int t12 array -> int t12 = <fun>
# type t13 = A : 'a t12 -> t13 [@@unboxed]
# type t14
# type t15 = A of t14 [@@unboxed]
# type 'a abs
# type t16 = A : 'a abs -> t16 [@@unboxed]
# type t18 = A : 'a list abs -> t18 [@@unboxed]
# * Characters 176-256:
......struct
type t = A of float [@@ocaml.unboxed]
type u = { f1 : t; f2 : t }
end..
Error: Signature mismatch:
...
Type declarations do not match:
type u = { f1 : t; f2 : t; }
is not included in
type u = { f1 : t; f2 : t; }
Their internal representations differ:
the first declaration uses unboxed float representation.
# * * module T : sig type t [@@immediate] end
# * type 'a s = S : 'a -> 'a s [@@unboxed]
# type t = T : 'a s -> t [@@unboxed]
# type 'a s = S : 'a -> 'a option s [@@unboxed]
# type t = T : 'a s -> t [@@unboxed]
# module M :
sig type 'a r constraint 'a = unit -> 'b val inj : 'b -> (unit -> 'b) r end
# type t = T : (unit -> 'a) M.r -> t [@@unboxed]
# type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed]
# type t = T : 'a s -> t [@@unboxed]
# type 'a t = T : 'a s -> 'a t [@@unboxed]
# type _ s = S : 'a t -> 'b s [@@unboxed]
and _ t = T : 'a -> 'a s t
#

6
tools/dumpobj.ml
View File

@ -122,11 +122,11 @@ let rec print_obj x =
else if tag = Obj.double_tag then
printf "%.12g" (Obj.magic x : float)
else if tag = Obj.double_array_tag then begin
let a = (Obj.magic x : float array) in
let a = (Obj.magic x : floatarray) in
printf "[|";
for i = 0 to Array.length a - 1 do
for i = 0 to Array.Floatarray.length a - 1 do
if i > 0 then printf ", ";
printf "%.12g" a.(i)
printf "%.12g" (Array.Floatarray.get a i)
done;
printf "|]"
end else if tag = Obj.custom_tag && same_custom x 0l then

17
toplevel/genprintval.ml
View File

@ -25,11 +25,14 @@ open Outcometree
module type OBJ =
sig
type t
val repr : 'a -> t
val obj : t -> 'a
val is_block : t -> bool
val tag : t -> int
val size : t -> int
val field : t -> int -> t
val double_array_tag : int
val double_field : t -> int -> float
end
module type EVALPATH =
@ -493,9 +496,17 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
if pos = 0 then tree_of_label env path name
else Oide_ident name
and v =
if unboxed
then tree_of_val (depth - 1) obj ty_arg
else nest tree_of_val (depth - 1) (O.field obj pos) ty_arg
if unboxed then
tree_of_val (depth - 1) obj ty_arg
else begin
let fld =
if O.tag obj = O.double_array_tag then
O.repr (O.double_field obj pos)
else
O.field obj pos
in
nest tree_of_val (depth - 1) fld ty_arg
end
in
(lid, v) :: tree_of_fields (pos + 1) remainder
in

3
toplevel/genprintval.mli
View File

@ -21,11 +21,14 @@ open Format
module type OBJ =
sig
type t
val repr : 'a -> t
val obj : t -> 'a
val is_block : t -> bool
val tag : t -> int
val size : t -> int
val field : t -> int -> t
val double_array_tag : int
val double_field : t -> int -> float
end
module type EVALPATH =

2
typing/typedecl.ml
View File

@ -448,7 +448,7 @@ let transl_declaration env sdecl id =
make_constructor env (Path.Pident id) params
scstr.pcd_args scstr.pcd_res
in
if unbox then begin
if Config.flat_float_array && unbox then begin
(* Cannot unbox a type when the argument can be both float and
non-float because it interferes with the dynamic float array
optimization. This can only happen when the type is a GADT

3
utils/config.mli
View File

@ -165,5 +165,8 @@ val libunwind_link_flags : string
val safe_string: bool
(* Whether the compiler was configured with -safe-string *)
val flat_float_array : bool
(* Whether the compiler and runtime automagically flatten float
arrays *)
val afl_instrument : bool
(* Whether afl-fuzz instrumentation is generated by default *)

3
utils/config.mlp
View File

@ -64,6 +64,8 @@ let profiling = %%PROFILING%%
let flambda = %%FLAMBDA%%
let safe_string = %%SAFE_STRING%%
let flat_float_array = %%FLAT_FLOAT_ARRAY%%
let afl_instrument = %%AFL_INSTRUMENT%%
let exec_magic_number = "Caml1999X011"
@ -171,6 +173,7 @@ let print_config oc =
p_bool "flambda" flambda;
p_bool "spacetime" spacetime;
p_bool "safe_string" safe_string;
p_bool "flat_float_array" flat_float_array;
(* print the magic number *)
p "exec_magic_number" exec_magic_number;