The unpac monorepo manager self-hosting as a monorepo using unpac
Merge commit 'cdc32182aed4ab327084aeb3090e529f6cec4b46' into 5.00
+204
-70
+10
Changes
+10
Changes
···
7
7
8
8
### Runtime system:
9
9
10
+
* #9391, #9424: Fix failed assertion in runtime due to ephemerons *set_* and
11
+
*blit_* function during Mark phase
12
+
(François Bobot, reported by Stephen Dolan, reviewed by Damien Doligez)
13
+
10
14
### Code generation and optimizations:
11
15
12
16
### Standard library:
···
20
24
are now provided by the camlp-streams library.
21
25
(Xavier Leroy, review by Nicolás Ojeda Bär)
22
26
27
+
- #10526: add Random.bits32, Random.bits64, Random.nativebits
28
+
(Xavier Leroy, review by Gabriel Scherer and François Bobot)
29
+
23
30
### Other libraries:
24
31
25
32
- #10192: Add support for Unix domain sockets on Windows and use them
···
31
38
- #3959, #7202, #10476: ocaml, in script mode, directive errors
32
39
(`#use "missing_file";;`) use stderr and exit with an error.
33
40
(Florian Angeletti, review by Gabriel Scherer)
41
+
42
+
- #10524: Directive argument type error now shows expected and received type.
43
+
(Wiktor Kuchta, review by Gabriel Scherer)
34
44
35
45
### Manual and documentation:
36
46
+1
-2
lambda/lambda.ml
+1
-2
lambda/lambda.ml
···
375
375
For that reason, they should not include cycles.
376
376
*)
377
377
378
-
exception Not_simple
379
-
380
378
let max_raw = 32
381
379
382
380
let make_key e =
381
+
let exception Not_simple in
383
382
let count = ref 0 (* Used for controlling size *)
384
383
and make_key = Ident.make_key_generator () in
385
384
(* make_key is used for normalizing let-bound variables *)
-2
lambda/switch.ml
-2
lambda/switch.ml
-2
lambda/switch.mli
-2
lambda/switch.mli
+19
-2
lambda/translcore.ml
+19
-2
lambda/translcore.ml
···
1086
1086
let x, y, z = List.fold_left rewrite_case ([], [], []) pat_expr_list in
1087
1087
List.rev x, List.rev y, List.rev z
1088
1088
in
1089
-
let static_catch body val_ids handler =
1089
+
(* In presence of exception patterns, the code we generate for
1090
+
1091
+
match <scrutinees> with
1092
+
| <val-patterns> -> <val-actions>
1093
+
| <exn-patterns> -> <exn-actions>
1094
+
1095
+
looks like
1096
+
1097
+
staticcatch
1098
+
(try (exit <val-exit> <scrutinees>)
1099
+
with <exn-patterns> -> <exn-actions>)
1100
+
with <val-exit> <val-ids> ->
1101
+
match <val-ids> with <val-patterns> -> <val-actions>
1102
+
1103
+
In particular, the 'exit' in the value case ensures that the
1104
+
value actions run outside the try..with exception handler.
1105
+
*)
1106
+
let static_catch scrutinees val_ids handler =
1090
1107
let id = Typecore.name_pattern "exn" (List.map fst exn_cases) in
1091
1108
let static_exception_id = next_raise_count () in
1092
1109
Lstaticcatch
1093
-
(Ltrywith (Lstaticraise (static_exception_id, body), id,
1110
+
(Ltrywith (Lstaticraise (static_exception_id, scrutinees), id,
1094
1111
Matching.for_trywith ~scopes e.exp_loc (Lvar id) exn_cases),
1095
1112
(static_exception_id, val_ids),
1096
1113
handler)
+1
manual/src/macros.hva
+1
manual/src/macros.hva
+6
-2
manual/src/manual.tex
+6
-2
manual/src/manual.tex
···
1
1
\documentclass[11pt]{book}
2
-
\usepackage{ae}
2
+
\usepackage{lmodern}% for T1 encoding and support of bold ttfamily
3
3
4
4
\usepackage[utf8]{inputenc}
5
5
\usepackage[T1]{fontenc}
6
+
\usepackage{microtype}
6
7
% HEVEA\@def@charset{UTF-8}%
7
8
% Unicode character declarations
8
9
\DeclareUnicodeCharacter{207A}{{}^{+}}
···
20
21
% Package for code examples:
21
22
\usepackage{listings}
22
23
\usepackage{alltt}
23
-
\usepackage{lmodern}% for supporting bold ttfamily in code examples
24
24
\usepackage[normalem]{ulem}% for underlining errors in code examples
25
25
\input{ifocamldoc}
26
26
\ifocamldoc\else
27
27
\usepackage{changepage}
28
28
\fi
29
29
\input{macros.tex}
30
+
31
+
% No ligatures in typewriter font
32
+
\DisableLigatures{encoding = T1, family = tt* }
33
+
30
34
% Listing environments
31
35
\lstnewenvironment{camloutput}{
32
36
\lstset{
+19
stdlib/random.ml
+19
stdlib/random.ml
···
176
176
177
177
let bool s = (bits s land 1 = 0)
178
178
179
+
let bits32 s =
180
+
let b1 = Int32.(shift_right_logical (of_int (bits s)) 14) in (* 16 bits *)
181
+
let b2 = Int32.(shift_right_logical (of_int (bits s)) 14) in (* 16 bits *)
182
+
Int32.(logor b1 (shift_left b2 16))
183
+
184
+
let bits64 s =
185
+
let b1 = Int64.(shift_right_logical (of_int (bits s)) 9) in (* 21 bits *)
186
+
let b2 = Int64.(shift_right_logical (of_int (bits s)) 9) in (* 21 bits *)
187
+
let b3 = Int64.(shift_right_logical (of_int (bits s)) 8) in (* 22 bits *)
188
+
Int64.(logor b1 (logor (shift_left b2 21) (shift_left b3 42)))
189
+
190
+
let nativebits =
191
+
if Nativeint.size = 32
192
+
then fun s -> Nativeint.of_int32 (bits32 s)
193
+
else fun s -> Int64.to_nativeint (bits64 s)
194
+
179
195
end
180
196
181
197
(* This is the state you get with [init 27182818] and then applying
···
206
222
let int64 bound = State.int64 (Domain.DLS.get random_key) bound
207
223
let float scale = State.float (Domain.DLS.get random_key) scale
208
224
let bool () = State.bool (Domain.DLS.get random_key)
225
+
let bits32 () = State.bits32 (Domain.DLS.get random_key)
226
+
let bits64 () = State.bits64 (Domain.DLS.get random_key)
227
+
let nativebits () = State.nativebits (Domain.DLS.get random_key)
209
228
210
229
let full_init seed = State.full_init (Domain.DLS.get random_key) seed
211
230
let init seed = State.full_init (Domain.DLS.get random_key) [| seed |]
+18
stdlib/random.mli
+18
stdlib/random.mli
···
82
82
val bool : unit -> bool
83
83
(** [Random.bool ()] returns [true] or [false] with probability 0.5 each. *)
84
84
85
+
val bits32 : unit -> Int32.t
86
+
(** [Random.bits32 ()] returns 32 random bits as an integer between
87
+
{!Int32.min_int} and {!Int32.max_int}.
88
+
@since 4.14.0 *)
89
+
90
+
val bits64 : unit -> Int64.t
91
+
(** [Random.bits64 ()] returns 64 random bits as an integer between
92
+
{!Int64.min_int} and {!Int64.max_int}.
93
+
@since 4.14.0 *)
94
+
95
+
val nativebits : unit -> Nativeint.t
96
+
(** [Random.nativebits ()] returns 32 or 64 random bits (depending on
97
+
the bit width of the platform) as an integer between
98
+
{!Nativeint.min_int} and {!Nativeint.max_int}.
99
+
@since 4.14.0 *)
85
100
86
101
(** {1 Advanced functions} *)
87
102
···
114
129
val int64 : t -> Int64.t -> Int64.t
115
130
val float : t -> float -> float
116
131
val bool : t -> bool
132
+
val bits32 : t -> Int32.t
133
+
val bits64 : t -> Int64.t
134
+
val nativebits : t -> Nativeint.t
117
135
(** These functions are the same as the basic functions, except that they
118
136
use (and update) the given PRNG state instead of the default one.
119
137
*)
+10
testsuite/tests/lib-random/chi2.ml
+10
testsuite/tests/lib-random/chi2.ml
···
48
48
(fun () -> int_of_float (Random.float 1.0 *. 256.0));
49
49
test "Random.float 1.0 (next 8 bits)"
50
50
(fun () -> int_of_float (Random.float 1.0 *. 65536.0));
51
+
test "Random.bits32 (bits 0-7)"
52
+
(fun () -> Int32.to_int (Random.bits32()));
53
+
test "Random.bits32 (bits 20-27)"
54
+
(fun () -> Int32.(to_int (shift_right (Random.bits32()) 20)));
51
55
test "Random.int32 2^30 (bits 0-7)"
52
56
(fun () -> Int32.to_int (Random.int32 0x40000000l));
53
57
test "Random.int32 2^30 (bits 20-27)"
···
55
59
test "Random.int32 (256 * p) / p"
56
60
(let p = 7048673l in
57
61
fun () -> Int32.(to_int (div (Random.int32 (mul 256l p)) p)));
62
+
test "Random.bits64 (bits 0-7)"
63
+
(fun () -> Int64.to_int (Random.bits64()));
64
+
test "Random.bits64 (bits 30-37)"
65
+
(fun () -> Int64.(to_int (shift_right (Random.bits64()) 30)));
66
+
test "Random.bits64 (bits 52-59)"
67
+
(fun () -> Int64.(to_int (shift_right (Random.bits64()) 52)));
58
68
test "Random.int64 2^60 (bits 0-7)"
59
69
(fun () -> Int64.to_int (Random.int64 0x1000000000000000L));
60
70
test "Random.int64 2^60 (bits 30-37)"
+67
testsuite/tests/misc/ephe_issue9391.ml
+67
testsuite/tests/misc/ephe_issue9391.ml
···
1
+
(* TEST
2
+
*)
3
+
4
+
let debug = false
5
+
6
+
open Printf
7
+
open Ephemeron
8
+
9
+
let empty = ref 0
10
+
let make_ra ~size = Array.init size (fun _ -> ref 1) [@@inline never]
11
+
let make_ephes ~size = Array.init size (fun _ -> Ephemeron.K1.create ()) [@@inline never]
12
+
13
+
let test ~size ~slice =
14
+
let keys1 = make_ra ~size in
15
+
let keys2 = make_ra ~size in
16
+
let datas1 = make_ra ~size in
17
+
let datas2 = make_ra ~size in
18
+
let ephe1 = make_ephes ~size in
19
+
let ephe2 = make_ephes ~size in
20
+
if debug then Gc.set { (Gc.get ()) with Gc.verbose = 0x3 };
21
+
(** Fill ephe.(i )from key.(i) to data.(i) *)
22
+
for i=0 to size-1 do Ephemeron.K1.set_key ephe1.(i) keys1.(i); done;
23
+
for i=0 to size-1 do Ephemeron.K1.set_data ephe1.(i) datas1.(i); done;
24
+
for i=0 to size-1 do Ephemeron.K1.set_key ephe2.(i) keys2.(i); done;
25
+
for i=0 to size-1 do Ephemeron.K1.set_data ephe2.(i) datas2.(i); done;
26
+
(** Push everything in the major heap *)
27
+
if debug then Printf.eprintf "Start minor major\n%!";
28
+
Gc.minor ();
29
+
Gc.major ();
30
+
if debug then Printf.eprintf "start emptying\n%!";
31
+
for i=0 to size-1 do keys1.(i) <- empty; done;
32
+
for i=0 to size-1 do datas1.(i) <- empty; done;
33
+
(** The emptying is done during a major so keys and data are kept alive by the
34
+
assignments. Restart a new major *)
35
+
Gc.major ();
36
+
if debug then Printf.eprintf "Start checking state\n%!";
37
+
(** Fill the ephemeron with an alive key *)
38
+
if debug then Printf.eprintf "Start replacing dead key into alive one\n%!";
39
+
(* Printf.eprintf "put in set (2) %i\n%!" (Gc.major_slice (10*4*slice*6)); *)
40
+
for i=0 to size-1 do
41
+
ignore (Gc.major_slice (4));
42
+
if debug then Printf.eprintf "@%!";
43
+
Ephemeron.K1.blit_data ephe1.(i) ephe2.(i);
44
+
if debug && 0 = i mod (size / 10) then Printf.eprintf "done %5i/%i\n%!" i size;
45
+
done;
46
+
if debug then Printf.eprintf "end\n%!";
47
+
(** Finish all, assertion in clean phase should not find a dangling data *)
48
+
Gc.full_major ();
49
+
let r = ref 0 in
50
+
if debug then
51
+
for i=0 to size-1 do
52
+
if Ephemeron.K1.check_data ephe2.(size-1-i) then incr r;
53
+
if 0 = i mod (size / 10) then Printf.eprintf "done %5i/%i %i\n%!" i size !r;
54
+
done;
55
+
(* keep the arrays alive *)
56
+
assert (Array.length keys1 = size);
57
+
assert (Array.length keys2 = size);
58
+
assert (Array.length datas1 = size);
59
+
assert (Array.length datas2 = size);
60
+
assert (Array.length ephe1 = size);
61
+
assert (Array.length ephe2 = size)
62
+
[@@inline never]
63
+
64
+
let () =
65
+
test ~size:1000 ~slice:5;
66
+
test ~size:1000 ~slice:10;
67
+
test ~size:1000 ~slice:15
+1
-32
toplevel/byte/topeval.ml
+1
-32
toplevel/byte/topeval.ml
···
176
176
toplevel_env := oldenv; raise x
177
177
end
178
178
| Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } ->
179
-
begin match Topcommon.get_directive dir_name with
180
-
| None ->
181
-
fprintf ppf "Unknown directive `%s'." dir_name;
182
-
let directives = Topcommon.all_directive_names () in
183
-
Misc.did_you_mean ppf
184
-
(fun () -> Misc.spellcheck directives dir_name);
185
-
fprintf ppf "@.";
186
-
false
187
-
| Some d ->
188
-
match d, pdir_arg with
189
-
| Directive_none f, None -> f (); true
190
-
| Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true
191
-
| Directive_int f, Some {pdira_desc = Pdir_int (n,None) } ->
192
-
begin match Int_literal_converter.int n with
193
-
| n -> f n; true
194
-
| exception _ ->
195
-
fprintf ppf "Integer literal exceeds the range of \
196
-
representable integers for directive `%s'.@."
197
-
dir_name;
198
-
false
199
-
end
200
-
| Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
201
-
fprintf ppf "Wrong integer literal for directive `%s'.@."
202
-
dir_name;
203
-
false
204
-
| Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
205
-
| Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
206
-
| _ ->
207
-
fprintf ppf "Wrong type of argument for directive `%s'.@."
208
-
dir_name;
209
-
false
210
-
end
179
+
try_run_directive ppf dir_name pdir_arg
211
180
212
181
let execute_phrase print_outcome ppf phr =
213
182
try execute_phrase print_outcome ppf phr
+1
-28
toplevel/native/topeval.ml
+1
-28
toplevel/native/topeval.ml
···
279
279
toplevel_env := oldenv; raise x
280
280
end
281
281
| Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } ->
282
-
begin match get_directive dir_name with
283
-
| None ->
284
-
fprintf ppf "Unknown directive `%s'.@." dir_name;
285
-
false
286
-
| Some d ->
287
-
match d, pdir_arg with
288
-
| Directive_none f, None -> f (); true
289
-
| Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true
290
-
| Directive_int f, Some {pdira_desc = Pdir_int (n,None)} ->
291
-
begin match Int_literal_converter.int n with
292
-
| n -> f n; true
293
-
| exception _ ->
294
-
fprintf ppf "Integer literal exceeds the range of \
295
-
representable integers for directive `%s'.@."
296
-
dir_name;
297
-
false
298
-
end
299
-
| Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
300
-
fprintf ppf "Wrong integer literal for directive `%s'.@."
301
-
dir_name;
302
-
false
303
-
| Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
304
-
| Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
305
-
| _ ->
306
-
fprintf ppf "Wrong type of argument for directive `%s'.@."
307
-
dir_name;
308
-
false
309
-
end
282
+
try_run_directive ppf dir_name pdir_arg
310
283
311
284
312
285
(* API compat *)
+48
toplevel/topcommon.ml
+48
toplevel/topcommon.ml
···
308
308
309
309
let all_directive_names () =
310
310
Hashtbl.fold (fun dir _ acc -> dir::acc) directive_table []
311
+
312
+
let try_run_directive ppf dir_name pdir_arg =
313
+
begin match get_directive dir_name with
314
+
| None ->
315
+
fprintf ppf "Unknown directive `%s'." dir_name;
316
+
let directives = all_directive_names () in
317
+
Misc.did_you_mean ppf
318
+
(fun () -> Misc.spellcheck directives dir_name);
319
+
fprintf ppf "@.";
320
+
false
321
+
| Some d ->
322
+
match d, pdir_arg with
323
+
| Directive_none f, None -> f (); true
324
+
| Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true
325
+
| Directive_int f, Some {pdira_desc = Pdir_int (n,None) } ->
326
+
begin match Misc.Int_literal_converter.int n with
327
+
| n -> f n; true
328
+
| exception _ ->
329
+
fprintf ppf "Integer literal exceeds the range of \
330
+
representable integers for directive `%s'.@."
331
+
dir_name;
332
+
false
333
+
end
334
+
| Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
335
+
fprintf ppf "Wrong integer literal for directive `%s'.@."
336
+
dir_name;
337
+
false
338
+
| Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
339
+
| Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
340
+
| _ ->
341
+
let dir_type = match d with
342
+
| Directive_none _ -> "no argument"
343
+
| Directive_string _ -> "a `string' literal"
344
+
| Directive_int _ -> "an `int' literal"
345
+
| Directive_ident _ -> "an identifier"
346
+
| Directive_bool _ -> "a `bool' literal"
347
+
in
348
+
let arg_type = match pdir_arg with
349
+
| None -> "no argument"
350
+
| Some {pdira_desc = Pdir_string _} -> "a `string' literal"
351
+
| Some {pdira_desc = Pdir_int _} -> "an `int' literal"
352
+
| Some {pdira_desc = Pdir_ident _} -> "an identifier"
353
+
| Some {pdira_desc = Pdir_bool _} -> "a `bool' literal"
354
+
in
355
+
fprintf ppf "Directive `%s' expects %s, got %s.@."
356
+
dir_name dir_type arg_type;
357
+
false
358
+
end
+3
toplevel/topcommon.mli
+3
toplevel/topcommon.mli
···
143
143
144
144
val all_directive_names : unit -> string list
145
145
146
+
val try_run_directive :
147
+
formatter -> string -> Parsetree.directive_argument option -> bool
148
+
146
149
val[@deprecated] directive_table : (string, directive_fun) Hashtbl.t
147
150
(* @deprecated please use [add_directive] instead of inserting
148
151
in this table directly. *)