Skip to content

Commit

Permalink
Compiler: Document non-trivial function Code.constant_equal, and fix …
Browse files Browse the repository at this point in the history 
…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]>
  • Loading branch information
@OlivierNicole @vouillon @hhugo
3 people committed Sep 9, 2024
1 parent 034ad82 commit 10aaa3b
Show file tree
Hide file tree
Showing 12 changed files with 256 additions and 102 deletions.
142 changes: 73 additions & 69 deletions compiler/lib/code.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -290,75 +290,79 @@ type constant =
| NativeInt of nativeint
| Tuple of int * constant array * array_or_not

let rec constant_equal a b =
match a, b with
| String a, String b -> Some (String.equal a b)
| NativeString a, NativeString b -> Some (Native_string.equal a b)
| Tuple (ta, a, _), Tuple (tb, b, _) ->
if ta <> tb || Array.length a <> Array.length b
then Some false
else
let same = ref (Some true) in
for i = 0 to Array.length a - 1 do
match !same, constant_equal a.(i) b.(i) with
| None, _ -> ()
| _, None -> same := None
| Some s, Some c -> same := Some (s && c)
done;
!same
| Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b)
| Int64 a, Int64 b -> Some (Int64.equal a b)
| NativeInt a, NativeInt b -> Some (Nativeint.equal a b)
| Float_array a, Float_array b -> Some (Array.equal Float.equal a b)
| Float a, Float b -> Some (Float.equal a b)
| String _, NativeString _ | NativeString _, String _ -> None
| Int _, Float _ | Float _, Int _ -> None
| Tuple ((0 | 254), _, _), Float_array _ -> None
| Float_array _, Tuple ((0 | 254), _, _) -> None
| ( Tuple _
, ( String _
| NativeString _
| Int64 _
| Int _
| Int32 _
| NativeInt _
| Float _
| Float_array _ ) ) -> Some false
| ( Float_array _
, ( String _
| NativeString _
| Int64 _
| Int _
| Int32 _
| NativeInt _
| Float _
| Tuple _ ) ) -> Some false
| ( String _
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
Some false
| ( NativeString _
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
Some false
| ( Int64 _
, ( String _
| NativeString _
| Int _
| Int32 _
| NativeInt _
| Float _
| Tuple _
| Float_array _ ) ) -> Some false
| Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
Some false
| ( (Int _ | Int32 _ | NativeInt _)
, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) ->
Some false
(* Note: the following cases should not occur when compiling to Javascript *)
| Int _, (Int32 _ | NativeInt _)
| Int32 _, (Int _ | NativeInt _)
| NativeInt _, (Int _ | Int32 _)
| (Int32 _ | NativeInt _), Float _
| Float _, (Int32 _ | NativeInt _) -> None
module Constant = struct
type t = constant

let rec ocaml_equal a b =
match a, b with
| String a, String b -> Some (String.equal a b)
| NativeString a, NativeString b -> Some (Native_string.equal a b)
| Tuple (ta, a, _), Tuple (tb, b, _) ->
if ta <> tb || Array.length a <> Array.length b
then Some false
else
let same = ref (Some true) in
for i = 0 to Array.length a - 1 do
match !same, ocaml_equal a.(i) b.(i) with
| None, _ -> ()
| _, None -> same := None
| Some s, Some c -> same := Some (s && c)
done;
!same
| Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b)
| Int64 a, Int64 b -> Some (Int64.equal a b)
| NativeInt a, NativeInt b -> Some (Nativeint.equal a b)
| Float_array a, Float_array b -> Some (Array.equal Float.ieee_equal a b)
| Float a, Float b -> Some (Float.ieee_equal a b)
| String _, NativeString _ | NativeString _, String _ -> None
| Int _, Float _ | Float _, Int _ -> None
| Tuple ((0 | 254), _, _), Float_array _ -> None
| Float_array _, Tuple ((0 | 254), _, _) -> None
| ( Tuple _
, ( String _
| NativeString _
| Int64 _
| Int _
| Int32 _
| NativeInt _
| Float _
| Float_array _ ) ) -> Some false
| ( Float_array _
, ( String _
| NativeString _
| Int64 _
| Int _
| Int32 _
| NativeInt _
| Float _
| Tuple _ ) ) -> Some false
| ( String _
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
Some false
| ( NativeString _
, (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
Some false
| ( Int64 _
, ( String _
| NativeString _
| Int _
| Int32 _
| NativeInt _
| Float _
| Tuple _
| Float_array _ ) ) -> Some false
| Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
Some false
| ( (Int _ | Int32 _ | NativeInt _)
, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) ->
Some false
(* Note: the following cases should not occur when compiling to Javascript *)
| Int _, (Int32 _ | NativeInt _)
| Int32 _, (Int _ | NativeInt _)
| NativeInt _, (Int _ | Int32 _)
| (Int32 _ | NativeInt _), Float _
| Float _, (Int32 _ | NativeInt _) -> None
end

type loc =
| No
Expand Down
10 changes: 9 additions & 1 deletion compiler/lib/code.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -150,6 +150,8 @@ module Native_string : sig
val of_string : string -> t

val of_bytestring : string -> t

val equal : t -> t -> bool
end

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

val constant_equal : constant -> constant -> bool option
module Constant : sig
type t = constant

val ocaml_equal : t -> t -> bool option
(** Guaranteed equality in terms of OCaml [(=)]: if [constant_equal a b =
Some v], then [Poly.(=) a b = v]. This is used for optimization purposes. *)
end

type loc =
| No
Expand Down
30 changes: 17 additions & 13 deletions compiler/lib/driver.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -241,9 +241,9 @@ let gen_missing js missing =
, ( ECond
( EBin
( NotEqEq
, dot (EVar (ident Constant.global_object_)) prim
, dot (EVar (ident Global_constant.global_object_)) prim
, EVar (ident_s "undefined") )
, dot (EVar (ident Constant.global_object_)) prim
, dot (EVar (ident Global_constant.global_object_)) prim
, EFun
( None
, fun_
Expand Down Expand Up @@ -364,7 +364,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) :
(EBin
( Eq
, dot
(EVar (ident Constant.global_object_))
(EVar (ident Global_constant.global_object_))
(Utf8_string.of_string_exn "jsoo_runtime")
, EObj all ))
, N )
Expand All @@ -375,7 +375,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) :
(EVar (ident (Utf8_string.of_string_exn "Object")))
(Utf8_string.of_string_exn "assign"))
[ dot
(EVar (ident Constant.global_object_))
(EVar (ident Global_constant.global_object_))
(Utf8_string.of_string_exn "jsoo_runtime")
; EObj all
]
Expand Down Expand Up @@ -404,7 +404,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) :
; rest = None
}
, ( dot
(EVar (ident Constant.global_object_))
(EVar (ident Global_constant.global_object_))
(Utf8_string.of_string_exn "jsoo_runtime")
, N ) )
] )
Expand Down Expand Up @@ -510,27 +510,30 @@ let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_
o#get_free
in
let export_shim js =
if J.IdentSet.mem (J.ident Constant.exports_) freenames
if J.IdentSet.mem (J.ident Global_constant.exports_) freenames
then
if should_export wrap_with_fun
then var Constant.exports_ (J.EObj []) :: js
then var Global_constant.exports_ (J.EObj []) :: js
else
let export_node =
let s =
Printf.sprintf
{|((typeof module === 'object' && module.exports) || %s)|}
Constant.global_object
Global_constant.global_object
in
let lex = Parse_js.Lexer.of_string s in
Parse_js.parse_expr lex
in
var Constant.exports_ export_node :: js
var Global_constant.exports_ export_node :: js
else js
in
let old_global_object_shim js =
if J.IdentSet.mem (J.ident Constant.old_global_object_) freenames
if J.IdentSet.mem (J.ident Global_constant.old_global_object_) freenames
then
var Constant.old_global_object_ (J.EVar (J.ident Constant.global_object_)) :: js
var
Global_constant.old_global_object_
(J.EVar (J.ident Global_constant.global_object_))
:: js
else js
in

Expand All @@ -544,14 +547,15 @@ let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_
then expr (J.EStr (Utf8_string.of_string_exn "use strict")) :: js
else js
in
f [ J.ident Constant.global_object_ ] js
f [ J.ident Global_constant.global_object_ ] js
in
match wrap_with_fun with
| `Anonymous -> expr (mk efun)
| `Named name ->
let name = Utf8_string.of_string_exn name in
mk (sfun (J.ident name))
| `Iife -> expr (J.call (mk efun) [ J.EVar (J.ident Constant.global_object_) ] J.N)
| `Iife ->
expr (J.call (mk efun) [ J.EVar (J.ident Global_constant.global_object_) ] J.N)
in
let always_required_js =
(* consider adding a comments in the generated file with original
Expand Down
55 changes: 45 additions & 10 deletions compiler/lib/eval.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -66,14 +66,15 @@ let float_unop (l : constant list) (f : float -> float) : constant option =
| [ Int i ] -> Some (Float (f (Int32.to_float i)))
| _ -> None

let bool' b = Int (if b then 1l else 0l)

let bool b = Some (bool' b)

let float_binop_bool l f =
match float_binop_aux l f with
| Some true -> Some (Int 1l)
| Some false -> Some (Int 0l)
| Some b -> bool b
| None -> None

let bool b = Some (Int (if b then 1l else 0l))

let eval_prim ~target x =
match x with
| Not, [ Int i ] -> bool Int32.(i = 0l)
Expand Down Expand Up @@ -255,16 +256,51 @@ let the_cont_of info x (a : cont array) =
| _ -> None)
x

(* If [constant_js_equal a b = Some v], then [caml_js_equals a b = v]). *)
let constant_js_equal a b =
match a, b with
| Int i, Int j -> Some (Int32.equal i j)
| Float a, Float b -> Some (Float.ieee_equal a b)
| NativeString a, NativeString b -> Some (Native_string.equal a b)
| String a, String b when Config.Flag.use_js_string () -> Some (String.equal a b)
| Int _, Float _ | Float _, Int _ -> None
(* All other values may be distinct objects and thus different by [caml_js_equals]. *)
| String _, _
| _, String _
| NativeString _, _
| _, NativeString _
| Float_array _, _
| _, Float_array _
| Int64 _, _
| _, Int64 _
| Tuple _, _
| _, Tuple _ -> None

let eval_instr ~target info ((x, loc) as i) =
match x with
| Let (x, Prim (Extern ("caml_js_equals" | "caml_equal"), [ y; z ])) -> (
| Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> (
match the_const_of info y, the_const_of info z with
| Some e1, Some e2 -> (
match Code.Constant.ocaml_equal e1 e2 with
| None -> [ i ]
| Some c ->
let c =
match prim with
| "caml_equal" -> c
| "caml_notequal" -> not c
| _ -> assert false
in
let c = Constant (bool' c) in
Flow.update_def info x c;
[ Let (x, c), loc ])
| _ -> [ i ])
| Let (x, Prim (Extern ("caml_js_equals" | "caml_js_strict_equals"), [ y; z ])) -> (
match the_const_of info y, the_const_of info z with
| Some e1, Some e2 -> (
match constant_equal e1 e2 with
match constant_js_equal e1 e2 with
| None -> [ i ]
| Some c ->
let c = if c then 1l else 0l in
let c = Constant (Int c) in
let c = Constant (bool' c) in
Flow.update_def info x c;
[ Let (x, c), loc ])
| _ -> [ i ])
Expand Down Expand Up @@ -300,8 +336,7 @@ let eval_instr ~target info ((x, loc) as i) =
match is_int ~target info y with
| Unknown -> [ i ]
| (Y | N) as b ->
let b = if Poly.(b = N) then 0l else 1l in
let c = Constant (Int b) in
let c = Constant (bool' Poly.(b = Y)) in
Flow.update_def info x c;
[ Let (x, c), loc ])
| Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> (
Expand Down
24 changes: 23 additions & 1 deletion compiler/lib/flow.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -322,6 +322,28 @@ let the_def_of info x =
x
| Pc c -> Some (Constant c)

(* If [constant_identical a b = true], then the two values cannot be
distinguished, i.e., they are not different objects (and [caml_js_equals a b
= true]) and if both are floats, they are bitwise equal. *)
let constant_identical a b =
match a, b with
| Int i, Int j -> Int32.equal i j
| Float a, Float b -> Float.bitwise_equal a b
| NativeString a, NativeString b -> Native_string.equal a b
| String a, String b -> Config.Flag.use_js_string () && String.equal a b
| Int _, Float _ | Float _, Int _ -> false
(* All other values may be distinct objects and thus different by [caml_js_equals]. *)
| String _, _
| _, String _
| NativeString _, _
| _, NativeString _
| Float_array _, _
| _, Float_array _
| Int64 _, _
| _, Int64 _
| Tuple _, _
| _, Tuple _ -> false

let the_const_of info x =
match x with
| Pv x ->
Expand All @@ -337,7 +359,7 @@ let the_const_of info x =
None
(fun u v ->
match u, v with
| Some i, Some j when Poly.(Code.constant_equal i j = Some true) -> u
| Some i, Some j when constant_identical i j -> u
| _ -> None)
x
| Pc c -> Some c
Expand Down
Loading

0 comments on commit 10aaa3b

Please sign in to comment.