Skip to content

Commit a40f9a0

Browse files
OlivierNicolevouillonhhugo
committed
Compiler: Document non-trivial function Code.constant_equal, and fix related bugs (#1659)
* Document non-trivial function Code.constant_equal Co-authored-by: Jérome Vouillon <[email protected]> * Fix bugs related to constant equality See #1659. * More static evaluation of equalities in eval * Statically evaluate caml_js_strict_equals too * Compiler: small refactoring in eval --------- Co-authored-by: Jérome Vouillon <[email protected]> Co-authored-by: Hugo Heuzard <[email protected]>
1 parent 4174f52 commit a40f9a0

File tree

12 files changed

+256
-102
lines changed

12 files changed

+256
-102
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: 45 additions & 10 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)
@@ -254,16 +255,51 @@ 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+
| Tuple _, _
276+
| _, Tuple _ -> None
277+
257278
let eval_instr ~target info ((x, loc) as i) =
258279
match x with
259-
| Let (x, Prim (Extern ("caml_js_equals" | "caml_equal"), [ y; z ])) -> (
280+
| Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> (
281+
match the_const_of info y, the_const_of info z with
282+
| Some e1, Some e2 -> (
283+
match Code.Constant.ocaml_equal e1 e2 with
284+
| None -> [ i ]
285+
| Some c ->
286+
let c =
287+
match prim with
288+
| "caml_equal" -> c
289+
| "caml_notequal" -> not c
290+
| _ -> assert false
291+
in
292+
let c = Constant (bool' c) in
293+
Flow.update_def info x c;
294+
[ Let (x, c), loc ])
295+
| _ -> [ i ])
296+
| Let (x, Prim (Extern ("caml_js_equals" | "caml_js_strict_equals"), [ y; z ])) -> (
260297
match the_const_of info y, the_const_of info z with
261298
| Some e1, Some e2 -> (
262-
match constant_equal e1 e2 with
299+
match constant_js_equal e1 e2 with
263300
| None -> [ i ]
264301
| Some c ->
265-
let c = if c then 1l else 0l in
266-
let c = Constant (Int c) in
302+
let c = Constant (bool' c) in
267303
Flow.update_def info x c;
268304
[ Let (x, c), loc ])
269305
| _ -> [ i ])
@@ -299,8 +335,7 @@ let eval_instr ~target info ((x, loc) as i) =
299335
match is_int ~target info y with
300336
| Unknown -> [ i ]
301337
| (Y | N) as b ->
302-
let b = if Poly.(b = N) then 0l else 1l in
303-
let c = Constant (Int b) in
338+
let c = Constant (bool' Poly.(b = Y)) in
304339
Flow.update_def info x c;
305340
[ Let (x, c), loc ])
306341
| Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> (

‎compiler/lib/flow.ml‎

Lines changed: 23 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -322,6 +322,28 @@ let the_def_of info x =
322322
x
323323
| Pc c -> Some (Constant c)
324324

325+
(* If [constant_identical a b = true], then the two values cannot be
326+
distinguished, i.e., they are not different objects (and [caml_js_equals a b
327+
= true]) and if both are floats, they are bitwise equal. *)
328+
let constant_identical a b =
329+
match a, b with
330+
| Int i, Int j -> Int32.equal i j
331+
| Float a, Float b -> Float.bitwise_equal a b
332+
| NativeString a, NativeString b -> Native_string.equal a b
333+
| String a, String b -> Config.Flag.use_js_string () && String.equal a b
334+
| Int _, Float _ | Float _, Int _ -> false
335+
(* All other values may be distinct objects and thus different by [caml_js_equals]. *)
336+
| String _, _
337+
| _, String _
338+
| NativeString _, _
339+
| _, NativeString _
340+
| Float_array _, _
341+
| _, Float_array _
342+
| Int64 _, _
343+
| _, Int64 _
344+
| Tuple _, _
345+
| _, Tuple _ -> false
346+
325347
let the_const_of info x =
326348
match x with
327349
| Pv x ->
@@ -337,7 +359,7 @@ let the_const_of info x =
337359
None
338360
(fun u v ->
339361
match u, v with
340-
| Some i, Some j when Poly.(Code.constant_equal i j = Some true) -> u
362+
| Some i, Some j when constant_identical i j -> u
341363
| _ -> None)
342364
x
343365
| Pc c -> Some c

0 commit comments

Comments
 (0)