Skip to content

Commit cfc3028

Browse files
vouillonvouillon
authored
Merge pull request #71 from OlivierNicole/converge-jsoo-merge-07
Integrate changes to Document.constant_equal
2 parents 4174f52 + 26864d1 commit cfc3028

File tree

15 files changed

+305
-142
lines changed

15 files changed

+305
-142
lines changed

‎compiler/lib/code.ml‎

Lines changed: 73 additions & 69 deletions
Original file line numberDiff line numberDiff line change
@@ -290,75 +290,79 @@ type constant =
290290
| NativeInt of nativeint
291291
| Tuple of int * constant array * array_or_not
292292

293-
let rec constant_equal a b =
294-
match a, b with
295-
| String a, String b -> Some (String.equal a b)
296-
| NativeString a, NativeString b -> Some (Native_string.equal a b)
297-
| Tuple (ta, a, _), Tuple (tb, b, _) ->
298-
if ta <> tb || Array.length a <> Array.length b
299-
then Some false
300-
else
301-
let same = ref (Some true) in
302-
for i = 0 to Array.length a - 1 do
303-
match !same, constant_equal a.(i) b.(i) with
304-
| None, _ -> ()
305-
| _, None -> same := None
306-
| Some s, Some c -> same := Some (s && c)
307-
done;
308-
!same
309-
| Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b)
310-
| Int64 a, Int64 b -> Some (Int64.equal a b)
311-
| NativeInt a, NativeInt b -> Some (Nativeint.equal a b)
312-
| Float_array a, Float_array b -> Some (Array.equal Float.equal a b)
313-
| Float a, Float b -> Some (Float.equal a b)
314-
| String _, NativeString _ | NativeString _, String _ -> None
315-
| Int _, Float _ | Float _, Int _ -> None
316-
| Tuple ((0 | 254), _, _), Float_array _ -> None
317-
| Float_array _, Tuple ((0 | 254), _, _) -> None
318-
| ( Tuple _
319-
, ( String _
320-
| NativeString _
321-
| Int64 _
322-
| Int _
323-
| Int32 _
324-
| NativeInt _
325-
| Float _
326-
| Float_array _ ) ) -> Some false
327-
| ( Float_array _
328-
, ( String _
329-
| NativeString _
330-
| Int64 _
331-
| Int _
332-
| Int32 _
333-
| NativeInt _
334-
| Float _
335-
| Tuple _ ) ) -> Some false
336-
| ( String _
337-
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
338-
Some false
339-
| ( NativeString _
340-
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
341-
Some false
342-
| ( Int64 _
343-
, ( String _
344-
| NativeString _
345-
| Int _
346-
| Int32 _
347-
| NativeInt _
348-
| Float _
349-
| Tuple _
350-
| Float_array _ ) ) -> Some false
351-
| Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
352-
Some false
353-
| ( (Int _ | Int32 _ | NativeInt _)
354-
, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) ->
355-
Some false
356-
(* Note: the following cases should not occur when compiling to Javascript *)
357-
| Int _, (Int32 _ | NativeInt _)
358-
| Int32 _, (Int _ | NativeInt _)
359-
| NativeInt _, (Int _ | Int32 _)
360-
| (Int32 _ | NativeInt _), Float _
361-
| Float _, (Int32 _ | NativeInt _) -> None
293+
module Constant = struct
294+
type t = constant
295+
296+
let rec ocaml_equal a b =
297+
match a, b with
298+
| String a, String b -> Some (String.equal a b)
299+
| NativeString a, NativeString b -> Some (Native_string.equal a b)
300+
| Tuple (ta, a, _), Tuple (tb, b, _) ->
301+
if ta <> tb || Array.length a <> Array.length b
302+
then Some false
303+
else
304+
let same = ref (Some true) in
305+
for i = 0 to Array.length a - 1 do
306+
match !same, ocaml_equal a.(i) b.(i) with
307+
| None, _ -> ()
308+
| _, None -> same := None
309+
| Some s, Some c -> same := Some (s && c)
310+
done;
311+
!same
312+
| Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b)
313+
| Int64 a, Int64 b -> Some (Int64.equal a b)
314+
| NativeInt a, NativeInt b -> Some (Nativeint.equal a b)
315+
| Float_array a, Float_array b -> Some (Array.equal Float.ieee_equal a b)
316+
| Float a, Float b -> Some (Float.ieee_equal a b)
317+
| String _, NativeString _ | NativeString _, String _ -> None
318+
| Int _, Float _ | Float _, Int _ -> None
319+
| Tuple ((0 | 254), _, _), Float_array _ -> None
320+
| Float_array _, Tuple ((0 | 254), _, _) -> None
321+
| ( Tuple _
322+
, ( String _
323+
| NativeString _
324+
| Int64 _
325+
| Int _
326+
| Int32 _
327+
| NativeInt _
328+
| Float _
329+
| Float_array _ ) ) -> Some false
330+
| ( Float_array _
331+
, ( String _
332+
| NativeString _
333+
| Int64 _
334+
| Int _
335+
| Int32 _
336+
| NativeInt _
337+
| Float _
338+
| Tuple _ ) ) -> Some false
339+
| ( String _
340+
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
341+
Some false
342+
| ( NativeString _
343+
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
344+
Some false
345+
| ( Int64 _
346+
, ( String _
347+
| NativeString _
348+
| Int _
349+
| Int32 _
350+
| NativeInt _
351+
| Float _
352+
| Tuple _
353+
| Float_array _ ) ) -> Some false
354+
| Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
355+
Some false
356+
| ( (Int _ | Int32 _ | NativeInt _)
357+
, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) ->
358+
Some false
359+
(* Note: the following cases should not occur when compiling to Javascript *)
360+
| Int _, (Int32 _ | NativeInt _)
361+
| Int32 _, (Int _ | NativeInt _)
362+
| NativeInt _, (Int _ | Int32 _)
363+
| (Int32 _ | NativeInt _), Float _
364+
| Float _, (Int32 _ | NativeInt _) -> None
365+
end
362366

363367
type loc =
364368
| No

‎compiler/lib/code.mli‎

Lines changed: 9 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -150,6 +150,8 @@ module Native_string : sig
150150
val of_string : string -> t
151151

152152
val of_bytestring : string -> t
153+
154+
val equal : t -> t -> bool
153155
end
154156

155157
type int_kind =
@@ -168,7 +170,13 @@ type constant =
168170
| NativeInt of nativeint (** Only produced when compiling to WebAssembly. *)
169171
| Tuple of int * constant array * array_or_not
170172

171-
val constant_equal : constant -> constant -> bool option
173+
module Constant : sig
174+
type t = constant
175+
176+
val ocaml_equal : t -> t -> bool option
177+
(** Guaranteed equality in terms of OCaml [(=)]: if [constant_equal a b =
178+
Some v], then [Poly.(=) a b = v]. This is used for optimization purposes. *)
179+
end
172180

173181
type loc =
174182
| No

‎compiler/lib/driver.ml‎

Lines changed: 17 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -241,9 +241,9 @@ let gen_missing js missing =
241241
, ( ECond
242242
( EBin
243243
( NotEqEq
244-
, dot (EVar (ident Constant.global_object_)) prim
244+
, dot (EVar (ident Global_constant.global_object_)) prim
245245
, EVar (ident_s "undefined") )
246-
, dot (EVar (ident Constant.global_object_)) prim
246+
, dot (EVar (ident Global_constant.global_object_)) prim
247247
, EFun
248248
( None
249249
, fun_
@@ -364,7 +364,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) :
364364
(EBin
365365
( Eq
366366
, dot
367-
(EVar (ident Constant.global_object_))
367+
(EVar (ident Global_constant.global_object_))
368368
(Utf8_string.of_string_exn "jsoo_runtime")
369369
, EObj all ))
370370
, N )
@@ -375,7 +375,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) :
375375
(EVar (ident (Utf8_string.of_string_exn "Object")))
376376
(Utf8_string.of_string_exn "assign"))
377377
[ dot
378-
(EVar (ident Constant.global_object_))
378+
(EVar (ident Global_constant.global_object_))
379379
(Utf8_string.of_string_exn "jsoo_runtime")
380380
; EObj all
381381
]
@@ -404,7 +404,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) :
404404
; rest = None
405405
}
406406
, ( dot
407-
(EVar (ident Constant.global_object_))
407+
(EVar (ident Global_constant.global_object_))
408408
(Utf8_string.of_string_exn "jsoo_runtime")
409409
, N ) )
410410
] )
@@ -510,27 +510,30 @@ let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_
510510
o#get_free
511511
in
512512
let export_shim js =
513-
if J.IdentSet.mem (J.ident Constant.exports_) freenames
513+
if J.IdentSet.mem (J.ident Global_constant.exports_) freenames
514514
then
515515
if should_export wrap_with_fun
516-
then var Constant.exports_ (J.EObj []) :: js
516+
then var Global_constant.exports_ (J.EObj []) :: js
517517
else
518518
let export_node =
519519
let s =
520520
Printf.sprintf
521521
{|((typeof module === 'object' && module.exports) || %s)|}
522-
Constant.global_object
522+
Global_constant.global_object
523523
in
524524
let lex = Parse_js.Lexer.of_string s in
525525
Parse_js.parse_expr lex
526526
in
527-
var Constant.exports_ export_node :: js
527+
var Global_constant.exports_ export_node :: js
528528
else js
529529
in
530530
let old_global_object_shim js =
531-
if J.IdentSet.mem (J.ident Constant.old_global_object_) freenames
531+
if J.IdentSet.mem (J.ident Global_constant.old_global_object_) freenames
532532
then
533-
var Constant.old_global_object_ (J.EVar (J.ident Constant.global_object_)) :: js
533+
var
534+
Global_constant.old_global_object_
535+
(J.EVar (J.ident Global_constant.global_object_))
536+
:: js
534537
else js
535538
in
536539

@@ -544,14 +547,15 @@ let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_
544547
then expr (J.EStr (Utf8_string.of_string_exn "use strict")) :: js
545548
else js
546549
in
547-
f [ J.ident Constant.global_object_ ] js
550+
f [ J.ident Global_constant.global_object_ ] js
548551
in
549552
match wrap_with_fun with
550553
| `Anonymous -> expr (mk efun)
551554
| `Named name ->
552555
let name = Utf8_string.of_string_exn name in
553556
mk (sfun (J.ident name))
554-
| `Iife -> expr (J.call (mk efun) [ J.EVar (J.ident Constant.global_object_) ] J.N)
557+
| `Iife ->
558+
expr (J.call (mk efun) [ J.EVar (J.ident Global_constant.global_object_) ] J.N)
555559
in
556560
let always_required_js =
557561
(* consider adding a comments in the generated file with original

‎compiler/lib/eval.ml‎

Lines changed: 54 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -65,14 +65,15 @@ let float_unop (l : constant list) (f : float -> float) : constant option =
6565
| [ Int i ] -> Some (Float (f (Int32.to_float i)))
6666
| _ -> None
6767

68+
let bool' b = Int (if b then 1l else 0l)
69+
70+
let bool b = Some (bool' b)
71+
6872
let float_binop_bool l f =
6973
match float_binop_aux l f with
70-
| Some true -> Some (Int 1l)
71-
| Some false -> Some (Int 0l)
74+
| Some b -> bool b
7275
| None -> None
7376

74-
let bool b = Some (Int (if b then 1l else 0l))
75-
7677
let eval_prim ~target x =
7778
match x with
7879
| Not, [ Int i ] -> bool Int32.(i = 0l)
@@ -165,14 +166,14 @@ let eval_prim ~target x =
165166
| _ -> None)
166167
| _ -> None
167168

168-
let the_length_of info x =
169+
let the_length_of ~target info x =
169170
get_approx
170171
info
171172
(fun x ->
172173
match info.info_defs.(Var.idx x) with
173174
| Expr (Constant (String s)) -> Some (Int32.of_int (String.length s))
174175
| Expr (Prim (Extern "caml_create_string", [ arg ]))
175-
| Expr (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int info arg
176+
| Expr (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int ~target info arg
176177
| _ -> None)
177178
None
178179
(fun u v ->
@@ -254,24 +255,63 @@ let the_cont_of info x (a : cont array) =
254255
| _ -> None)
255256
x
256257

258+
(* If [constant_js_equal a b = Some v], then [caml_js_equals a b = v]). *)
259+
let constant_js_equal a b =
260+
match a, b with
261+
| Int i, Int j -> Some (Int32.equal i j)
262+
| Float a, Float b -> Some (Float.ieee_equal a b)
263+
| NativeString a, NativeString b -> Some (Native_string.equal a b)
264+
| String a, String b when Config.Flag.use_js_string () -> Some (String.equal a b)
265+
| Int _, Float _ | Float _, Int _ -> None
266+
(* All other values may be distinct objects and thus different by [caml_js_equals]. *)
267+
| String _, _
268+
| _, String _
269+
| NativeString _, _
270+
| _, NativeString _
271+
| Float_array _, _
272+
| _, Float_array _
273+
| Int64 _, _
274+
| _, Int64 _
275+
| Int32 _, _
276+
| _, Int32 _
277+
| NativeInt _, _
278+
| _, NativeInt _
279+
| Tuple _, _
280+
| _, Tuple _ -> None
281+
257282
let eval_instr ~target info ((x, loc) as i) =
258283
match x with
259-
| Let (x, Prim (Extern ("caml_js_equals" | "caml_equal"), [ y; z ])) -> (
260-
match the_const_of info y, the_const_of info z with
284+
| Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> (
285+
match the_const_of ~target info y, the_const_of ~target info z with
286+
| Some e1, Some e2 -> (
287+
match Code.Constant.ocaml_equal e1 e2 with
288+
| None -> [ i ]
289+
| Some c ->
290+
let c =
291+
match prim with
292+
| "caml_equal" -> c
293+
| "caml_notequal" -> not c
294+
| _ -> assert false
295+
in
296+
let c = Constant (bool' c) in
297+
Flow.update_def info x c;
298+
[ Let (x, c), loc ])
299+
| _ -> [ i ])
300+
| Let (x, Prim (Extern ("caml_js_equals" | "caml_js_strict_equals"), [ y; z ])) -> (
301+
match the_const_of ~target info y, the_const_of ~target info z with
261302
| Some e1, Some e2 -> (
262-
match constant_equal e1 e2 with
303+
match constant_js_equal e1 e2 with
263304
| None -> [ i ]
264305
| Some c ->
265-
let c = if c then 1l else 0l in
266-
let c = Constant (Int c) in
306+
let c = Constant (bool' c) in
267307
Flow.update_def info x c;
268308
[ Let (x, c), loc ])
269309
| _ -> [ i ])
270310
| Let (x, Prim (Extern "caml_ml_string_length", [ s ])) -> (
271311
let c =
272312
match s with
273313
| Pc (String s) -> Some (Int32.of_int (String.length s))
274-
| Pv v -> the_length_of info v
314+
| Pv v -> the_length_of ~target info v
275315
| _ -> None
276316
in
277317
match c with
@@ -299,8 +339,7 @@ let eval_instr ~target info ((x, loc) as i) =
299339
match is_int ~target info y with
300340
| Unknown -> [ i ]
301341
| (Y | N) as b ->
302-
let b = if Poly.(b = N) then 0l else 1l in
303-
let c = Constant (Int b) in
342+
let c = Constant (bool' Poly.(b = Y)) in
304343
Flow.update_def info x c;
305344
[ Let (x, c), loc ])
306345
| Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> (
@@ -325,7 +364,7 @@ let eval_instr ~target info ((x, loc) as i) =
325364
| Let (_, Prim (Extern ("%resume" | "%perform" | "%reperform"), _)) ->
326365
[ i ] (* We need that the arguments to this primitives remain variables *)
327366
| Let (x, Prim (prim, prim_args)) -> (
328-
let prim_args' = List.map prim_args ~f:(fun x -> the_const_of info x) in
367+
let prim_args' = List.map prim_args ~f:(fun x -> the_const_of ~target info x) in
329368
let res =
330369
if List.for_all prim_args' ~f:(function
331370
| Some _ -> true

0 commit comments

Comments
 (0)