anil.recoil.org
My working unpac repository
1(**************************************************************************)
2(* *)
3(* OCaml *)
4(* *)
5(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6(* Nicolas Ojeda Bar, LexiFi *)
7(* *)
8(* Copyright 2018 Institut National de Recherche en Informatique et *)
9(* en Automatique. *)
10(* *)
11(* All rights reserved. This file is distributed under the terms of *)
12(* the GNU Lesser General Public License version 2.1, with the *)
13(* special exception on linking described in the file LICENSE. *)
14(* *)
15(**************************************************************************)
16
17external neg : float -> float = "%negfloat"
18external add : float -> float -> float = "%addfloat"
19external sub : float -> float -> float = "%subfloat"
20external mul : float -> float -> float = "%mulfloat"
21external div : float -> float -> float = "%divfloat"
22external rem : float -> float -> float = "caml_fmod_float" "fmod"
23 [@@unboxed] [@@noalloc]
24external fma : float -> float -> float -> float = "caml_fma_float" "caml_fma"
25 [@@unboxed] [@@noalloc]
26external abs : float -> float = "%absfloat"
27
28let zero = 0.
29let one = 1.
30let minus_one = -1.
31let infinity = Stdlib.infinity
32let neg_infinity = Stdlib.neg_infinity
33let nan = Stdlib.nan
34let quiet_nan = nan
35external float_of_bits : int64 -> float
36 = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
37 [@@unboxed] [@@noalloc]
38let signaling_nan = float_of_bits 0x7F_F0_00_00_00_00_00_01L
39let is_finite (x: float) = x -. x = 0.
40let is_infinite (x: float) = 1. /. x = 0.
41let is_nan (x: float) = x <> x
42
43let pi = 0x1.921fb54442d18p+1
44let max_float = Stdlib.max_float
45let min_float = Stdlib.min_float
46let epsilon = Stdlib.epsilon_float
47external of_int : int -> float = "%floatofint"
48external to_int : float -> int = "%intoffloat"
49external of_string : string -> float = "caml_float_of_string"
50let of_string_opt = Stdlib.float_of_string_opt
51let to_string = Stdlib.string_of_float
52type fpclass = Stdlib.fpclass =
53 FP_normal
54 | FP_subnormal
55 | FP_zero
56 | FP_infinite
57 | FP_nan
58external classify_float : (float [@unboxed]) -> fpclass =
59 "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
60external pow : float -> float -> float = "caml_power_float" "pow"
61 [@@unboxed] [@@noalloc]
62external sqrt : float -> float = "caml_sqrt_float" "sqrt"
63 [@@unboxed] [@@noalloc]
64external cbrt : float -> float = "caml_cbrt_float" "caml_cbrt"
65 [@@unboxed] [@@noalloc]
66external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
67external exp2 : float -> float = "caml_exp2_float" "caml_exp2"
68 [@@unboxed] [@@noalloc]
69external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
70external log10 : float -> float = "caml_log10_float" "log10"
71 [@@unboxed] [@@noalloc]
72external log2 : float -> float = "caml_log2_float" "caml_log2"
73 [@@unboxed] [@@noalloc]
74external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
75 [@@unboxed] [@@noalloc]
76external log1p : float -> float = "caml_log1p_float" "caml_log1p"
77 [@@unboxed] [@@noalloc]
78external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
79external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
80external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
81external acos : float -> float = "caml_acos_float" "acos"
82 [@@unboxed] [@@noalloc]
83external asin : float -> float = "caml_asin_float" "asin"
84 [@@unboxed] [@@noalloc]
85external atan : float -> float = "caml_atan_float" "atan"
86 [@@unboxed] [@@noalloc]
87external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
88 [@@unboxed] [@@noalloc]
89external hypot : float -> float -> float
90 = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc]
91external cosh : float -> float = "caml_cosh_float" "cosh"
92 [@@unboxed] [@@noalloc]
93external sinh : float -> float = "caml_sinh_float" "sinh"
94 [@@unboxed] [@@noalloc]
95external tanh : float -> float = "caml_tanh_float" "tanh"
96 [@@unboxed] [@@noalloc]
97external acosh : float -> float = "caml_acosh_float" "caml_acosh"
98 [@@unboxed] [@@noalloc]
99external asinh : float -> float = "caml_asinh_float" "caml_asinh"
100 [@@unboxed] [@@noalloc]
101external atanh : float -> float = "caml_atanh_float" "caml_atanh"
102 [@@unboxed] [@@noalloc]
103external erf : float -> float = "caml_erf_float" "caml_erf"
104 [@@unboxed] [@@noalloc]
105external erfc : float -> float = "caml_erfc_float" "caml_erfc"
106 [@@unboxed] [@@noalloc]
107external trunc : float -> float = "caml_trunc_float" "caml_trunc"
108 [@@unboxed] [@@noalloc]
109external round : float -> float = "caml_round_float" "caml_round"
110 [@@unboxed] [@@noalloc]
111external ceil : float -> float = "caml_ceil_float" "ceil"
112 [@@unboxed] [@@noalloc]
113external floor : float -> float = "caml_floor_float" "floor"
114[@@unboxed] [@@noalloc]
115
116let is_integer x = x = trunc x && is_finite x
117
118external next_after : float -> float -> float
119 = "caml_nextafter_float" "caml_nextafter" [@@unboxed] [@@noalloc]
120
121let succ x = next_after x infinity
122let pred x = next_after x neg_infinity
123
124external copy_sign : float -> float -> float
125 = "caml_copysign_float" "caml_copysign"
126 [@@unboxed] [@@noalloc]
127external sign_bit : (float [@unboxed]) -> bool
128 = "caml_signbit_float" "caml_signbit" [@@noalloc]
129
130external frexp : float -> float * int = "caml_frexp_float"
131external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
132 "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
133external modf : float -> float * float = "caml_modf_float"
134type t = float
135external compare : float -> float -> int = "%compare"
136let equal x y = compare x y = 0
137
138let[@inline] min (x: float) (y: float) =
139 if y > x || (not(sign_bit y) && sign_bit x) then
140 if is_nan y then y else x
141 else if is_nan x then x else y
142
143let[@inline] max (x: float) (y: float) =
144 if y > x || (not(sign_bit y) && sign_bit x) then
145 if is_nan x then x else y
146 else if is_nan y then y else x
147
148let[@inline] min_max (x: float) (y: float) =
149 if is_nan x || is_nan y then (nan, nan)
150 else if y > x || (not(sign_bit y) && sign_bit x) then (x, y) else (y, x)
151
152let[@inline] min_num (x: float) (y: float) =
153 if y > x || (not(sign_bit y) && sign_bit x) then
154 if is_nan x then y else x
155 else if is_nan y then x else y
156
157let[@inline] max_num (x: float) (y: float) =
158 if y > x || (not(sign_bit y) && sign_bit x) then
159 if is_nan y then x else y
160 else if is_nan x then y else x
161
162let[@inline] min_max_num (x: float) (y: float) =
163 if is_nan x then (y,y)
164 else if is_nan y then (x,x)
165 else if y > x || (not(sign_bit y) && sign_bit x) then (x,y) else (y,x)
166
167external seeded_hash_param :
168 int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
169let seeded_hash seed x = seeded_hash_param 10 100 seed x
170let hash x = seeded_hash_param 10 100 0 x
171
172module Array = struct
173
174 type t = floatarray
175
176 external length : t -> int = "%floatarray_length"
177 external get : t -> int -> float = "%floatarray_safe_get"
178 external set : t -> int -> float -> unit = "%floatarray_safe_set"
179 external create : int -> t = "caml_floatarray_create"
180 external unsafe_get : t -> int -> float = "%floatarray_unsafe_get"
181 external unsafe_set : t -> int -> float -> unit = "%floatarray_unsafe_set"
182
183 external make : (int[@untagged]) -> (float[@unboxed]) -> t =
184 "caml_floatarray_make" "caml_floatarray_make_unboxed"
185
186 external unsafe_fill
187 : t -> (int[@untagged]) -> (int[@untagged]) -> (float[@unboxed]) -> unit
188 = "caml_floatarray_fill" "caml_floatarray_fill_unboxed" [@@noalloc]
189
190 external unsafe_blit: t -> int -> t -> int -> int -> unit =
191 "caml_floatarray_blit" [@@noalloc]
192
193 external unsafe_sub : t -> int -> int -> t = "caml_floatarray_sub"
194 external append_prim : t -> t -> t = "caml_floatarray_append"
195 external concat : t list -> t = "caml_floatarray_concat"
196
197 let check a ofs len msg =
198 if ofs < 0 || len < 0 || ofs + len < 0 || ofs + len > length a then
199 invalid_arg msg
200
201 let empty = create 0
202
203 let init l f =
204 if l < 0 then invalid_arg "Float.Array.init"
205 else
206 let res = create l in
207 for i = 0 to l - 1 do
208 unsafe_set res i (f i)
209 done;
210 res
211
212 let make_matrix sx sy v =
213 (* We raise even if [sx = 0 && sy < 0]: *)
214 if sy < 0 then invalid_arg "Float.Array.make_matrix";
215 let res = Array.make sx (create 0) in
216 if sy > 0 then begin
217 for x = 0 to sx - 1 do
218 Array.unsafe_set res x (make sy v)
219 done;
220 end;
221 res
222
223 let init_matrix sx sy f =
224 (* We raise even if [sx = 0 && sy < 0]: *)
225 if sy < 0 then invalid_arg "Float.Array.init_matrix";
226 let res = Array.make sx (create 0) in
227 if sy > 0 then begin
228 for x = 0 to sx - 1 do
229 let row = create sy in
230 for y = 0 to sy - 1 do
231 unsafe_set row y (f x y)
232 done;
233 Array.unsafe_set res x row
234 done;
235 end;
236 res
237
238 let sub a ofs len =
239 check a ofs len "Float.Array.sub";
240 unsafe_sub a ofs len
241
242 let copy a =
243 let l = length a in
244 if l = 0 then empty
245 else unsafe_sub a 0 l
246
247 let append a1 a2 =
248 let l1 = length a1 in
249 if l1 = 0 then copy a2
250 else if length a2 = 0 then unsafe_sub a1 0 l1
251 else append_prim a1 a2
252
253 (* inlining exposes a float-unboxing opportunity for [v] *)
254 let[@inline] fill a ofs len v =
255 check a ofs len "Float.Array.fill";
256 unsafe_fill a ofs len v
257
258 let blit src sofs dst dofs len =
259 check src sofs len "Float.array.blit";
260 check dst dofs len "Float.array.blit";
261 unsafe_blit src sofs dst dofs len
262
263 let to_list a =
264 List.init (length a) (unsafe_get a)
265
266 let of_list l =
267 let result = create (List.length l) in
268 let rec fill i l =
269 match l with
270 | [] -> result
271 | h :: t -> unsafe_set result i h; fill (i + 1) t
272 in
273 fill 0 l
274
275 (* duplicated from array.ml *)
276 let equal eq a b =
277 if length a <> length b then false else
278 let i = ref 0 in
279 let len = length a in
280 while !i < len && eq (unsafe_get a !i) (unsafe_get b !i) do incr i done;
281 !i = len
282
283 let float_compare = compare
284 (* duplicated from array.ml *)
285 let compare cmp a b =
286 let len_a = length a and len_b = length b in
287 let diff = len_a - len_b in
288 if diff <> 0 then (if diff < 0 then -1 else 1) else
289 let i = ref 0 and c = ref 0 in
290 while !i < len_a && !c = 0
291 do c := cmp (unsafe_get a !i) (unsafe_get b !i); incr i done;
292 !c
293
294 (* duplicated from array.ml *)
295 let iter f a =
296 for i = 0 to length a - 1 do f (unsafe_get a i) done
297
298 (* duplicated from array.ml *)
299 let iter2 f a b =
300 if length a <> length b then
301 invalid_arg "Float.Array.iter2: arrays must have the same length"
302 else
303 for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done
304
305 let map f a =
306 let l = length a in
307 let r = create l in
308 for i = 0 to l - 1 do
309 unsafe_set r i (f (unsafe_get a i))
310 done;
311 r
312
313 (* duplicated from array.ml *)
314 let map_inplace f a =
315 for i = 0 to length a - 1 do
316 unsafe_set a i (f (unsafe_get a i))
317 done
318
319 let map2 f a b =
320 let la = length a in
321 let lb = length b in
322 if la <> lb then
323 invalid_arg "Float.Array.map2: arrays must have the same length"
324 else begin
325 let r = create la in
326 for i = 0 to la - 1 do
327 unsafe_set r i (f (unsafe_get a i) (unsafe_get b i))
328 done;
329 r
330 end
331
332 (* duplicated from array.ml *)
333 let iteri f a =
334 for i = 0 to length a - 1 do f i (unsafe_get a i) done
335
336 let mapi f a =
337 let l = length a in
338 let r = create l in
339 for i = 0 to l - 1 do
340 unsafe_set r i (f i (unsafe_get a i))
341 done;
342 r
343
344 (* duplicated from array.ml *)
345 let mapi_inplace f a =
346 for i = 0 to length a - 1 do
347 unsafe_set a i (f i (unsafe_get a i))
348 done
349
350 (* duplicated from array.ml *)
351 let fold_left f x a =
352 let r = ref x in
353 for i = 0 to length a - 1 do
354 r := f !r (unsafe_get a i)
355 done;
356 !r
357
358 (* duplicated from array.ml *)
359 let fold_right f a x =
360 let r = ref x in
361 for i = length a - 1 downto 0 do
362 r := f (unsafe_get a i) !r
363 done;
364 !r
365
366 (* duplicated from array.ml *)
367 let exists p a =
368 let n = length a in
369 let rec loop i =
370 if i = n then false
371 else if p (unsafe_get a i) then true
372 else loop (i + 1) in
373 loop 0
374
375 (* duplicated from array.ml *)
376 let for_all p a =
377 let n = length a in
378 let rec loop i =
379 if i = n then true
380 else if p (unsafe_get a i) then loop (i + 1)
381 else false in
382 loop 0
383
384 (* duplicated from array.ml *)
385 let mem x a =
386 let n = length a in
387 let rec loop i =
388 if i = n then false
389 else if float_compare (unsafe_get a i) x = 0 then true
390 else loop (i + 1)
391 in
392 loop 0
393
394 (* mostly duplicated from array.ml, but slightly different *)
395 let mem_ieee x a =
396 let n = length a in
397 let rec loop i =
398 if i = n then false
399 else if x = (unsafe_get a i) then true
400 else loop (i + 1)
401 in
402 loop 0
403
404 (* duplicated from array.ml *)
405 let find_opt p a =
406 let n = length a in
407 let rec loop i =
408 if i = n then None
409 else
410 let x = unsafe_get a i in
411 if p x then Some x
412 else loop (i + 1)
413 in
414 loop 0
415
416 (* duplicated from array.ml *)
417 let find_index p a =
418 let n = length a in
419 let rec loop i =
420 if i = n then None
421 else if p (unsafe_get a i) then Some i
422 else loop (i + 1) in
423 loop 0
424
425 (* duplicated from array.ml *)
426 let find_map f a =
427 let n = length a in
428 let rec loop i =
429 if i = n then None
430 else
431 match f (unsafe_get a i) with
432 | None -> loop (i + 1)
433 | Some _ as r -> r
434 in
435 loop 0
436
437 (* duplicated from array.ml *)
438 let find_mapi f a =
439 let n = length a in
440 let rec loop i =
441 if i = n then None
442 else
443 match f i (unsafe_get a i) with
444 | None -> loop (i + 1)
445 | Some _ as r -> r
446 in
447 loop 0
448
449 (* duplicated from array.ml *)
450 exception Bottom of int
451 let sort cmp a =
452 let maxson l i =
453 let i31 = i+i+i+1 in
454 let x = ref i31 in
455 if i31+2 < l then begin
456 if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1;
457 if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2;
458 !x
459 end else
460 if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0
461 then i31+1
462 else if i31 < l then i31 else raise (Bottom i)
463 in
464 let rec trickledown l i e =
465 let j = maxson l i in
466 if cmp (get a j) e > 0 then begin
467 set a i (get a j);
468 trickledown l j e;
469 end else begin
470 set a i e;
471 end;
472 in
473 let trickle l i e = try trickledown l i e with Bottom i -> set a i e in
474 let rec bubbledown l i =
475 let j = maxson l i in
476 set a i (get a j);
477 bubbledown l j
478 in
479 let bubble l i = try bubbledown l i with Bottom i -> i in
480 let rec trickleup i e =
481 let father = (i - 1) / 3 in
482 assert (i <> father);
483 if cmp (get a father) e < 0 then begin
484 set a i (get a father);
485 if father > 0 then trickleup father e else set a 0 e;
486 end else begin
487 set a i e;
488 end;
489 in
490 let l = length a in
491 for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done;
492 for i = l - 1 downto 2 do
493 let e = (get a i) in
494 set a i (get a 0);
495 trickleup (bubble i 0) e;
496 done;
497 if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e)
498
499 (* duplicated from array.ml, except for the call to [create] *)
500 let cutoff = 5
501 let stable_sort cmp a =
502 let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
503 let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
504 let rec loop i1 s1 i2 s2 d =
505 if cmp s1 s2 <= 0 then begin
506 set dst d s1;
507 let i1 = i1 + 1 in
508 if i1 < src1r then
509 loop i1 (get a i1) i2 s2 (d + 1)
510 else
511 blit src2 i2 dst (d + 1) (src2r - i2)
512 end else begin
513 set dst d s2;
514 let i2 = i2 + 1 in
515 if i2 < src2r then
516 loop i1 s1 i2 (get src2 i2) (d + 1)
517 else
518 blit a i1 dst (d + 1) (src1r - i1)
519 end
520 in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs;
521 in
522 let isortto srcofs dst dstofs len =
523 for i = 0 to len - 1 do
524 let e = (get a (srcofs + i)) in
525 let j = ref (dstofs + i - 1) in
526 while (!j >= dstofs && cmp (get dst !j) e > 0) do
527 set dst (!j + 1) (get dst !j);
528 decr j;
529 done;
530 set dst (!j + 1) e;
531 done;
532 in
533 let rec sortto srcofs dst dstofs len =
534 if len <= cutoff then isortto srcofs dst dstofs len else begin
535 let l1 = len / 2 in
536 let l2 = len - l1 in
537 sortto (srcofs + l1) dst (dstofs + l1) l2;
538 sortto srcofs a (srcofs + l2) l1;
539 merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
540 end;
541 in
542 let l = length a in
543 if l <= cutoff then isortto 0 a 0 l else begin
544 let l1 = l / 2 in
545 let l2 = l - l1 in
546 let t = create l2 in
547 sortto l1 t 0 l2;
548 sortto 0 a l2 l1;
549 merge l2 l1 t 0 l2 a 0;
550 end
551
552 let fast_sort = stable_sort
553
554 (* duplicated from array.ml *)
555 let shuffle ~rand a = (* Fisher-Yates *)
556 for i = length a - 1 downto 1 do
557 let j = rand (i + 1) in
558 let v = unsafe_get a i in
559 unsafe_set a i (get a j);
560 unsafe_set a j v
561 done
562
563 (* duplicated from array.ml *)
564 let to_seq a =
565 let rec aux i () =
566 if i < length a
567 then
568 let x = unsafe_get a i in
569 Seq.Cons (x, aux (i+1))
570 else Seq.Nil
571 in
572 aux 0
573
574 (* duplicated from array.ml *)
575 let to_seqi a =
576 let rec aux i () =
577 if i < length a
578 then
579 let x = unsafe_get a i in
580 Seq.Cons ((i,x), aux (i+1))
581 else Seq.Nil
582 in
583 aux 0
584
585 (* mostly duplicated from array.ml *)
586 let of_rev_list l =
587 let len = List.length l in
588 let a = create len in
589 let rec fill i = function
590 [] -> a
591 | hd::tl -> unsafe_set a i hd; fill (i-1) tl
592 in
593 fill (len-1) l
594
595 (* duplicated from array.ml *)
596 let of_seq i =
597 let l = Seq.fold_left (fun acc x -> x::acc) [] i in
598 of_rev_list l
599
600
601 let map_to_array f a =
602 let l = length a in
603 if l = 0 then [| |] else begin
604 let r = Array.make l (f (unsafe_get a 0)) in
605 for i = 1 to l - 1 do
606 Array.unsafe_set r i (f (unsafe_get a i))
607 done;
608 r
609 end
610
611 let map_from_array f a =
612 let l = Array.length a in
613 let r = create l in
614 for i = 0 to l - 1 do
615 unsafe_set r i (f (Array.unsafe_get a i))
616 done;
617 r
618
619end
620
621module ArrayLabels = Array